Create a UTF8 file without BOM with Inno Setup (Unicode version) - utf-8

I have to read and modify some JSON files. The file encoding must be UTF8 without BOM or the JSON file will be not accepted.
I tried the following Code:
const
Utf8Bom = #$EF#$BB#$BF;
Utf16BomLE = #$FF#$FE; // little endian //
Utf16BomBE = #$FE#$FF; // big endian //
Utf16Bom = Utf16BomBE;
CP_UTF16 = 1200;
CP_UTF8 = 65001;
function WideStringToString (const wStr: string; codePage: Word): string;
var
len: Integer;
begin
len := WideCharToMultiByte (codePage, 0, wStr, -1, '', 0, 0, 0);
if len > 0 then
begin
SetLength (Result, len-1);
WideCharToMultiByte (codePage, 0, wStr, -1, Result, Length (Result), 0, 0);
end;
end;
function ClearBom(const s, sig: string): string;
var
i, n, len: Integer;
begin
Result := s;
len := Length (sig);
n := 0;
if (len> 0) and (Length (Result)> len) then
repeat
for i := 1 to len do
if Result [1] = sig [i] then
begin
Delete (Result, 1, 1);
Break;
end;
n := n + 1;
until (n = len) or (Result = '');
end;
function ConvertUtf16(const SourceStr: string; codePage: Word): string;
var
wStr: string;
begin
try
wStr := ClearBom(SourceStr, Utf16Bom);
Result := WideStringToString(wStr, codePage);
finally
SetLength(wStr, 0);
end;
end;
function Utf16ToUtf8(const SourceStr: string): string;
begin
Result := ConvertUtf16(SourceStr, CP_UTF8);
end;
function JSONSaveFile(const Filename: String; s: String): Boolean;
var
fs: TFileStream;
i, len : Integer;
begin
i := 1;
len := Length(s)
If len > 0 then
begin
try
try
fs := TFileStream.Create(Filename, fmCreate or f mShareExclusive);
fs.Seek(0, 0);
while (s[i] <> #0) and (i < len) do
begin
fs.WriteBuffer(s[i],CharLength(s,i));
i := i + CharLength(s,i);
end;
Result := True;
except
Log('EXCEPTION RAISED in JSONSaveFile: '+Filename);
end;
finally
fs.free;
end;
end;
end;
I get only a ANSI coded files. Build-in functions like SaveStringsToUTF8File() function will not work, cause the BOM is added by default.
Or is the a better way to save/create this text file with SaveStringToFile()?
How to solve it?

Use the WideCharToMultiByte function to convert the string to UTF-8 and just save it:
const
CP_UTF8 = 65001;
function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD;
lpWideCharStr: string; cchWideChar: Integer; lpMultiByteStr: AnsiString;
cchMultiByte: Integer; lpDefaultCharFake: Integer;
lpUsedDefaultCharFake: Integer): Integer;
external 'WideCharToMultiByte#kernel32.dll stdcall';
function GetStringAsUtf8(S: string): AnsiString;
var
Len: Integer;
begin
Len := WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, 0, 0, 0);
SetLength(Result, Len);
WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, Len, 0, 0);
end;
function SaveStringToUTF8FileWithoutBOM(FileName: string; S: string): Boolean;
var
Utf8: AnsiString;
begin
Utf8 := GetStringAsUtf8(S);
Result := SaveStringToFile(FileName, Utf8, False);
end;
You have to use Unicode version of Inno Setup (the only version as of Inno Setup 6).
See also:
LoadStringFromFileInCP and LoadStringsFromFileInCP functions in:
Inno Setup - Convert array of string to Unicode and back to ANSI
Inno Setup replace a string in a UTF-8 file without BOM

Related

Project of the license car plate (Pascal)

I am studying Pascal and have a problem.
My code needs to make combinations of four numbers, from left to right but I want to prevent those combinations from repeating the same thing being the numbers in positions, but worth the same thing from right to left.
Does anyone have any idea how to do that?
program mistureba;
type
placa = array [1..4] of integer;
var
a4num : array [1..24] of placa; // a4num : array [1..24,1..4] of integer
linha : integer;
const
MAXDIG = 4;
procedure mistura(input : placa; index : integer);
// input tem a série de digitos da placa
// index indica a posição que inicia o arranjo
var
output : placa;
p, i : integer;
begin
if index = MAXDIG then
begin // mostra / insere a sequencia que está em input
//for i := 1 to MAXDIG do
//write(input);
//writeln;
a4num[linha] := input;
linha := linha + 1;
end
else
begin
output := input;
for p := index to MAXDIG do
begin
output[index] := input[p];
for i := index to p - 1 do
output[i + 1] := input;
for i := p + 1 to MAXDIG do
output := input;
mistura(output,index + 1);
end;
end;
end;
var
//a4num : placa;
p, i : integer;
begin
linha := 1;
for i := 1 to MAXDIG do
readln(a4num[linha, i]);
mistura(a4num[linha], 1);
// vou mostrar o conteúdo do meu conjunto de placas
for linha := 1 to 24 do
if [i, 1] = [i, 4] then
begin
for i := 1 to MAXDIG do
write(a4num[linha, i]);
writeln;
end
else
begin
writeln('0');
end;
if [i,2] = [i,3] then
begin
for i := 1 to MAXDIG do
write(a4num[linha, i]);
writeln;
end
else
begin
writeln('0');
end;
end.
It was still not very clear what you wanted, so here are four solutions. You can choose the one you like:
program license;
uses
classes;
type
tIntegers = array of integer;
procedure BuildPermutation(aInput : string; aUsedCharacters : tIntegers; aBuild : string; var aOutput : tStringList);
var
i, j : integer;
Used : boolean;
begin
for i := 1 to length(aInput) do
begin
Used := false;
for j := 0 to length(aBuild) -1 do
if aUsedCharacters[j] = i then
begin
Used := true;
break;
end;
if not Used then
begin
aUsedCharacters[length(aBuild)] := i;
aBuild := aBuild + aInput[i];
if length(aBuild) = length(aInput) then
aOutput.Add(aBuild)
else
BuildPermutation(aInput, aUsedCharacters, aBuild, aOutput);
SetLength(aBuild, length(aBuild) - 1);
end;
end;
end;
function AllPermutations(aInput : string) : tStringList;
var
UsedCharacters : tIntegers = nil;
i : integer;
begin
result := tStringList.Create;
SetLength(UsedCharacters, length(aInput));
for i := 0 to length(UsedCharacters) - 1 do
UsedCharacters[i] := 0;
BuildPermutation(aInput, UsedCharacters, '', result);
end;
function WithoutDuplicatesSorted(aInput : tStringList) : tStringList;
// very easy using a built in feature of tStringList
var
OnePlate : string;
begin
result := tStringList.Create;
result.Sorted := true;
result.Duplicates := dupIgnore;
for OnePlate in aInput do
result.Add(OnePlate);
end;
function WithoutDuplicatesUnsorted(aInput : tStringList) : tStringList;
var
OnePlate : string;
begin
result := tStringList.Create;
for OnePlate in aInput do
if result.IndexOf(OnePlate) = -1 then
result.Add(OnePlate);
end;
function WithoutMirrors(aInput : tStringList) : tStringList;
var
OnePlate : string;
Mirror : string;
i : integer;
begin
result := tStringList.Create;
for OnePlate in aInput do
begin
Mirror := '';
for i := 1 to length(OnePlate) do
Mirror := OnePlate[i] + Mirror;
if result.IndexOf(Mirror) = -1 then
result.Add(OnePlate);
end;
end;
function WithoutMirrorsAndDuplicates(aInput : tStringList) : tStringList;
var
OnePlate : string;
Mirror : string;
i : integer;
begin
result := tStringList.Create;
for OnePlate in aInput do
if result.IndexOf(OnePlate) = -1 then
begin
Mirror := '';
for i := 1 to length(OnePlate) do
Mirror := OnePlate[i] + Mirror;
if result.IndexOf(Mirror) = -1 then
result.Add(OnePlate);
end;
end;
procedure PrintResult(aTitle : string; aInput : tStringList);
var
OnePlate : string;
begin
writeln(aTitle);
for OnePlate in aInput do
writeln(OnePlate);
end;
procedure Solve;
var
Input : string = '';
Intermediate : tStringList = nil;
FinalResult : tStringList = nil;
begin
// get one version of the license plate
// please note that it allows non-numeric characters
// if you want, you can insert a filtering, or any other mechanism to ensure only numeric license plates
writeln('Input one version of the license plate:');
readln(Input);
// make all possible permutations and print them
Intermediate := AllPermutations(Input);
PrintResult('All permutations', Intermediate);
// option 1 - filter identical ones (and also sorting them to make it easy)
FinalResult := WithoutDuplicatesSorted(Intermediate);
PrintResult('Without duplicates sorted', FinalResult);
FinalResult.Free;
// option 2 - filter identical ones (without sorting them, i.e. more complicated)
FinalResult := WithoutDuplicatesUnsorted(Intermediate);
PrintResult('Without duplicates unsorted', FinalResult);
FinalResult.Free;
// option 3 - filter mirrors (be careful, it is not defined which one of 123 and 321 will be shown!!!)
FinalResult := WithoutMirrors(Intermediate);
PrintResult('Without mirrors', FinalResult);
FinalResult.Free;
// option 3 - filter mirrors and duplicates
FinalResult := WithoutMirrorsAndDuplicates(Intermediate);
PrintResult('Without mirrors and duplicates', FinalResult);
FinalResult.Free;
Intermediate.Free;
end;
begin
Solve;
end.

Wrong number of parameters specified for call to "f1"

When creating a procedural data type, Free Pascal throws a strange error. But I'm passing one parameter, why is the number of parameters incorrect?
Type
Func = Function (x:Real):Real;
Function middlfunc(a, b:Real; n:Integer; f:Func): Real;
Var
x,s,d: Real; k:Integer;
Begin
d:=(b-a)/n;
s:=0;
For k:=0 To n Do
Begin
x:=a+k*d;
s:=s+f(x);
End;
middlfunc:=s/(n+1);
End;
Function f1(x:Real):Real; {There is the error}
Begin
f1:=x*x;
End;
Var
mf1:Real;
a, b: real;
n: integer;
Begin
a := 0;
b := 3.1415;
n := 100;
mf1 := middlfunc(a,b,n,f1); {ERROR :((((((((}
WriteLn(mf1)
End.
USE PASCAL PROCEDURE INSTEAD OF FUNCTION for suitability
If you want to use a Function as a parameter to another function, then you have to do it like this:
Type
TFunctionParameter = function(x: Real): Real;
Function middlfunc(a, b:Real; n:Integer; f:TFunctionParameter): Real;
Var
x,s,d: Real; k:Integer;
Begin
d:=(b-a)/n;
s:=0;
For k:=0 To n Do
Begin
x:=a+k*d;
s:=s+f(x);
End;
middlfunc:=s/(n+1);
End;
function RaiseToSecondPower(x: Real): Real;
begin
result := x*x;
end;
Var
mf1:Real;
a, b: real;
n: integer;
Begin
a := 0;
b := 3.1415;
n := 100;
mf1 := middlfunc(a,b,n,RaiseToSecondPower);
WriteLn(mf1)
End.

Sorting numeric data in Tstringlist numerically in Delphi

Huge amount of numeric data (from a database) is stored in a Tstringlist variable. the Data may look like:
4
4 1/2
12.006
13 3/8
1.05
13.25
5 1/2
2.25
13 5/8
By setting the sort property of the Tstringlist to true, they are sorted as texts and as a result, 13.25 shows up before 4.
How can these data be sorted numerically (and efficiently)?
(Delphi, Rad Studio 10.4)
Here is a solution:
// Conversion accepting input like '4', '4.003', '4 1/2' or '1/4'
// No leading or trailing space allowed (use trim if required).
function MyStrToFloat(const S : String) : Double;
var
I, J : Integer;
FS : TFormatSettings;
begin
I := Pos('/', S);
if I > 0 then begin
// We have a fractional part
J := Pos(' ', S);
if J > 0 then
// Both integer and fractional parts
Result := StrToInt(Trim(Copy(S, 1, J - 1)))
else
Result := 0;
Result := Result + StrToInt(Trim(Copy(S, J + 1, I - J - 1))) /
StrToInt(Trim(Copy(S, I + 1)));
end
else begin
FS.DecimalSeparator := '.';
Result := StrToFloat(S, FS);
end;
end;
function StringListSortProc(
List : TStringList;
Index1 : Integer;
Index2 : Integer): Integer;
var
N1, N2: Double;
begin
N1 := MyStrToFloat(List[Index1]);
N2 := MyStrToFloat(List[Index2]);
if N1 > N2 then
Result := 1
else if N1 < N2 then
Result := -1
else
Result := 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
SL : TStringList;
S : String;
begin
SL := TStringList.Create;
try
SL.Add('4');
SL.Add('1/2');
SL.Add('4 1/2');
SL.Add('12.006');
SL.Add('13 3/8');
SL.Add('1.05');
SL.Add('13.25');
SL.Add('5 1/2');
SL.Add('2.25');
SL.Add('13 5/8');
Memo1.Lines.Add('Raw:');
for S in SL do
Memo1.Lines.Add(S);
SL.CustomSort(StringListSortProc);
Memo1.Lines.Add('Sorted:');
for S in SL do
Memo1.Lines.Add(S);
finally
SL.Free;
end;
end;
The conversion is done in the sorting which is not very efficient. It is probably better to create a new list with converted values and then sort it. Or convert when loading the list from database. You've got the idea...
Two components solve your problem:
StrCmpLogical is your friend. It uses Natural sorting - Digits in the strings are considered as numerical content rather than text.
And this SO post How do I enter fractions in Delphi?
I put it together below:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
ButtonSort: TButton;
Memo2: TMemo;
procedure ButtonSortClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
//Natural sorting - Digits in the strings are considered as numerical content rather than text. This test is not case-sensitive.
function StrCmpLogicalW(P1, P2: PWideChar): Integer; stdcall; external 'Shlwapi.dll';
function StrCmpLogical(const S1, S2: string): Integer;
var
Form1: TForm1;
implementation
{$R *.dfm}
function StrCmpLogical(const S1, S2: string): Integer;
begin
result := StrCmpLogicalW(PChar(S1), PChar(S2));
end;
function CustomNbrSort(List: TStringList; Index1, Index2: Integer): Integer;
begin
result := StrCmpLogical(List[index1], List[index2]);
end;
procedure DoCustomSort(const List : TStringList);
begin
List.CustomSort(CustomNbrSort);
end;
// https://stackoverflow.com/questions/18082644/how-do-i-enter-fractions-in-delphi
function FractionToFloat(const S: string): real;
var
BarPos: integer;
numStr, denomStr: string;
num, denom: real;
begin
BarPos := Pos('/', S);
if BarPos = 0 then
Exit(StrToFloat(S));
numStr := Trim(Copy(S, 1, BarPos - 1));
denomStr := Trim(Copy(S, BarPos + 1, Length(S)));
num := StrToFloat(numStr);
denom := StrToFloat(denomStr);
result := num/denom;
end;
function FullFractionToFloat(S: string): real;
var
SpPos: integer;
intStr: string;
frStr: string;
int: real;
fr: real;
begin
S := Trim(S);
SpPos := Pos(' ', S);
if SpPos = 0 then
Exit(FractionToFloat(S));
intStr := Trim(Copy(S, 1, SpPos - 1));
frStr := Trim(Copy(S, SpPos + 1, Length(S)));
int := StrToFloat(intStr);
fr := FractionToFloat(frStr);
result := int + fr;
end;
procedure TForm1.ButtonSortClick(Sender: TObject);
begin
var MyList : TStrings := TStringList.Create;
try
//MyList.Assign(Memo1.Lines);
var MyFormatSettings : TFormatSettings := FormatSettings; //Make a copy of the global variable;
MyFormatSettings.DecimalSeparator := '.'; //The system's seporator may be a comma ','
for var i : integer := 0 to Memo1.Lines.Count - 1 do begin
var s : string := Memo1.Lines[i];
if not s.Contains('.') then
s := FloatToStr(FullFractionToFloat(s), MyFormatSettings);
MyList.AddObject(s, TObject(i));
end;
TStringList(MyList).CustomSort(CustomNbrSort);
Memo2.Lines.Clear;
for var i : integer := 0 to Memo1.Lines.Count - 1 do
Memo2.Lines.Add(Memo1.Lines[Integer(MyList.Objects[i])]);
finally
MyList.Free;
end;
end;
end.

Program behaving differently in FPC and ObjFPC

Following is a program in lazarus to perform RC4 encryption and decryption when given a string. When the compiler directive {$mode fpc} is used and the string 123 is entered it crashes with External: SIGSEGV. However there is no crash when inputting the same string in {$mode objfpc}. Another inconsistency is that in {$mode objfpc} the program raises the exception External: SIGSEGV again with the input of hellow.
//{$mode fpc}
{$mode objfpc}
program project1;
uses
sysutils, strutils;
type
myArray = array[0..255] of integer;
dynamicArray = array of integer;
dynamicArrayString = array of string;
const
key = 'qwertyui';
var
plaintext : string;
function KSA(const key: string): myArray;
var
i, j, key_length, temp: integer;
S : myArray;
begin
key_length := length(key);
j := 0;
for i := Low(S) to High(S) do
S[i] := i;
for i := Low(S) to High(S) do
begin
j := ((j + S[i] + ord(key[i mod key_length + 1])) mod 256);
temp := S[i];
S[i] := S[j];
S[j] := temp;
end;
KSA := S;
end;
function PRGA(S : myArray; n : integer) : dynamicArray;
var
i, j, K, temp, sizeOfArray : integer;
key : dynamicArray;
begin
i := 0;
j := 0;
K := 0;
temp := 0;
sizeOfArray := n - 1;
SetLength(key, sizeOfArray);
while n > 0 do
begin
n := n - 1;
i := (i + 1) mod 256;
j := (j + S[i]) mod 256;
temp := S[i];
S[i] := S[j];
S[j] := temp;
K := S[(S[i] + S[j]) mod 256];
key[i-1] := K;
end;
PRGA := key;
end;
procedure getPlaintext;
begin
readln(plaintext);
end;
function encrypt : string;
var
sizeOfArray, i : integer;
cipherString : string;
cipher, keystream: dynamicArray;
S : myArray;
begin
S := KSA(key);
keystream := PRGA(S, length(plaintext));
sizeOfArray := 0;
for i := 0 to (length(plaintext) - 1) do
begin
sizeOfArray := sizeOfArray + 1;
SetLength(cipher, sizeOfArray);
cipher[i] := (keystream[i]) xor (ord(plaintext[i + 1]));
end;
cipherString := '';
for i := 0 to High(cipher) do
cipherString := cipherString + IntToHex(cipher[I], 2);
encrypt := cipherString;
end;
function stringToHex(cipherString : string) : dynamicArrayString;
var
sizeOfArray, i: integer;
DecryptArrayString : dynamicArrayString;
begin
sizeOfArray := 0;
i := 0;
// Turn the string into an array of hex
while length(cipherString) > 0 do
begin
sizeOfArray := sizeOfArray + 1;
SetLength(DecryptArrayString, sizeOfArray);
DecryptArrayString[i] := cipherString[1] + cipherString[2];
i := i + 1;
cipherString := rightstr(cipherString, length(cipherString) - 2);
end;
stringToHex := DecryptArrayString;
end;
function hexToDecimal(DecryptArrayString : dynamicArrayString) : dynamicArray;
var
sizeOfDecryptArrayInt, i : integer;
DecryptArrayInt : dynamicArray;
begin
sizeOfDecryptArrayInt := 0;
// Hex to decimal
for i := 0 to high(DecryptArrayString) do
begin
sizeOfDecryptArrayInt := sizeOfDecryptArrayInt + 1;
SetLength(DecryptArrayInt, sizeOfDecryptArrayInt);
DecryptArrayInt[i] := Hex2Dec(DecryptArrayString[i]);
end;
hexToDecimal := DecryptArrayInt;
end;
function decrypt(DecryptArrayInt : dynamicArray) : string;
var
DecryptedString : string;
S : myArray;
keystream, Decrypted : dynamicArray;
sizeOfArray, i : integer;
begin
sizeOfArray := 0;
for i := 0 to high(DecryptArrayInt) do
begin
sizeOfArray := sizeOfArray + 1;
SetLength(Decrypted, sizeOfArray);
S := KSA(key);
keystream := PRGA(S, length(plaintext));
Decrypted[i] := (keystream[i] xor DecryptArrayInt[i]);
end;
decryptedString := '';
// Turn array to string
for i := 0 to high(Decrypted) do
decryptedString := decryptedString + chr(Decrypted[i]);
decrypt := decryptedString;
end;
procedure encryptDecrypt;
var
cipherString, DecryptedString : string;
DecryptArrayString : dynamicArrayString;
DecryptArrayInt : dynamicArray;
begin
cipherString := encrypt;
writeln(cipherString);
DecryptArrayString := stringToHex(cipherString);
DecryptArrayInt := hexToDecimal(DecryptArrayString);
DecryptedString := decrypt(DecryptArrayInt);
writeln(DecryptedString);
end;
begin
getPlaintext;
encryptDecrypt;
readln;
end.
I've not been able to find the many specific cases that makes the program crash apart from a string of any three characters will always crash in {$mode fpc} but not in {$mode objfpc}
You should debug (and watch) your code so any error can be traced more easily. Use the FP IDE, it helps a lot.
Meanwhile, watch this line:
keystream := PRGA(S, length(plaintext));
And inside the PRGA function watch these lines:
sizeOfArray := n - 1;
SetLength(key, sizeOfArray);
What's wrong here? Well, suppose "plaintext" has only 1 character. So, "Length(plaintext)"=1, right? In PRGA you do "sizeOfArray:= n-1;", so sizeOfArray = 0. When you do SetLength, "Key" will be NIL because you're indicating a zero indexes length. Later, on loop, you have:
key[i-1] := K;
the program will fail because you are accessing at index 0 and the Key variable is NIL.
Careful: On "SetLength(key, sizeOfArray);" valid indexes for key are in range [0..sizeOfArray-1], but sizeOfArray must be at least 1 to be valid (sizeOfArray >= 1).
So, you should check your PRGA function. It's up to you to find the definitive solution. Don't give up. Good luck!

Correct way to do non overlapped communication via serial port (COM)

I am using Delphi XE2 and I try to communicate with some device via serial port. Communication should be straight forward, but I have some problems. The device communication protocol is as follows:
I (master) send frame starting with ":" and ending with CRLF.
The device (slave) sends response in the same format (starting with ":" and ending with CRLF).
I am using WinAPI and non overlapped IO. The problem I have is that, very often I receive #0 chars as response from the device. I am sure the problem is on my side, because I can use device provider application, and I can see that communication goes fine.
Here is how I setup my COM port:
Result := False;
FFileHandle := CreateFile('COM3', GENERIC_READ OR GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
if FFileHandle = INVALID_HANDLE_VALUE then
Exit;
if not GetCommState(FFileHandle, DCB) then
Exit;
DCB.BaudRate := ASettings.BaudRate;
DCB.Flags := 1 OR // BINARY
(DTR_CONTROL_ENABLE shl 4) OR
(RTS_CONTROL_ENABLE shl 12);
DCB.XonLim := 100; // transmit XON threshold
DCB.XoffLim := 100; // transmit XOFF threshold
DCB.ByteSize := 8; // number of bits/byte, 4-8
DCB.Parity := 0; // 0-4=no,odd,even,mark,space
DCB.StopBits := ONESTOPBIT; // 0,1,2 = 1, 1.5, 2
DCB.XonChar := #1; // Tx and Rx XON character
DCB.XoffChar := #2; // Tx and Rx XOFF character
DCB.ErrorChar := #$FF; // error replacement character
DCB.EofChar := #$0A; // end of input character
DCB.EvtChar := #$0A; // received event character
if not SetCommState(FFileHandle, DCB) then
Exit;
if not SetCommMask(FFileHandle, EV_RXCHAR OR EV_TXEMPTY OR EV_RXFLAG) then
Exit;
Timeouts.ReadIntervalTimeout := 1200;
Timeouts.ReadTotalTimeoutMultiplier := 1;
Timeouts.ReadTotalTimeoutConstant := 1200;
Timeouts.WriteTotalTimeoutMultiplier := 0;
Timeouts.WriteTotalTimeoutConstant := 0;
if not SetCommTimeouts(FFileHandle, Timeouts) then
Exit;
if not PurgeComm(FFileHandle, PURGE_TXABORT OR PURGE_RXABORT OR PURGE_TXCLEAR OR PURGE_RXCLEAR) then
Exit;
if not ClearCommError(FFileHandle, Errors, #ComStat) then
Exit;
if not SetupComm(FFileHandle, 1024, 1024) then
Exit;
Result := True;
Here is how I do write:
function TCOMPortWrapper.Write(const AFrame: AnsiString): TComPortWriteRes;
var
Written: Cardinal;
Err: Cardinal;
Stat: TComStat;
Mask: Cardinal;
begin
Result := CPW_ERROR;
ClearCommError(FFileHandle, Err, #Stat);
if not IsOpened then
Exit;
if not WriteFile(FFileHandle, AFrame[1], Length(AFrame), Written, nil) then
Exit;
Mask := EV_TXEMPTY;
if not WaitCommEvent(FFileHandle, Mask, nil) then
Exit;
ClearCommError(FFileHandle, Err, #Stat);
Result := CPW_OK;
end;
And finally here it is how I do reads:
function TCOMPortWrapper.Read(out Frame: AnsiString): TComPortReadRes;
var
S: AnsiString;
BytesRead: Cardinal;
Mask: Cardinal;
begin
Result := CPR_ERROR;
if not IsOpened then
Exit;
SetLength(S, 4096);
Mask := EV_RXFLAG;
if not WaitCommEvent(FFileHandle, Mask, nil) then
Exit;
if not ReadFile(FFileHandle, S[1], Length(S), BytesRead, nil) then
Exit;
SetLength(S, BytesRead);
Frame := S;
Result := CPR_OK;
end;
As I mentioned above, in reads instead of getting actual frame I do get string of #0 chars. I think, that my mistake might be with WaitCommEvent API calls, as I am very new to serial communication.
Thanks for help!
Maybe you forgot the "#": ReadFile(FFileHandle, # S[1], Length(S), BytesRead, nil)
I'm doing like this to read string from COM:
constructor TSerialPort.Create(const APortName: String);
begin
inherited Create;
FPortHandle := INVALID_HANDLE_VALUE;
FPortName := APortName;
FDCB.DCBlength := SizeOf(DCB);
FDCB.BaudRate := CBR_19200;
FDCB.Flags := MakeCommFlags(True, False, True, True, DTR_CONTROL_DISABLE,
False, False, False, False, False, False, RTS_CONTROL_DISABLE, False);
FDCB.wReserved := 0;
FDCB.XonLim := 2048;
FDCB.XoffLim := 512;
FDCB.ByteSize := 8;
FDCB.Parity := NOPARITY;
FDCB.StopBits := ONESTOPBIT;
FDCB.XonChar := #0;
FDCB.XoffChar := #0;
FDCB.ErrorChar := #0;
FDCB.EofChar := #255;
FDCB.EvtChar := #0;
FDCB.wReserved1 := 0;
FCTO.ReadIntervalTimeout := 0;
FCTO.ReadTotalTimeoutMultiplier := 20;
FCTO.ReadTotalTimeoutConstant := 500;
FCTO.WriteTotalTimeoutMultiplier := 10;
FCTO.WriteTotalTimeoutConstant := 200;
FEOSChar := #13;
end;
function TSerialPort.Open: Boolean;
begin
Result := False;
if FPortHandle <> INVALID_HANDLE_VALUE then
Close;
FPortHandle := CreateFile(PChar('\\.\'+FPortName), GENERIC_READ or GENERIC_WRITE, 0,
nil, OPEN_EXISTING, 0, 0);
if FPortHandle <> INVALID_HANDLE_VALUE then
begin
// setup device buffers
SetupComm(FPortHandle, 2048, 2048);
Flush; // purge any information in the buffer
Result := True;
end;
end;
function TSerialPort.ReadString(var S: SysUtils.TBytes): Boolean;
const
MAX_BUF = 255;
var
B: Byte;
iCounter: Integer;
begin
Result := True;
B := 0;
SetLength(S, MAX_BUF);
ZeroMemory(#S[0], Length(S));
iCounter := 0;
while (B <> Ord(FEOSChar)) and Result and (iCounter < MAX_BUF) do
begin
Result := Read(B, 1);
if (B <> Ord(FEOSChar)) and Result then
begin
S[iCounter] := B;
Inc(iCounter);
end;
end;
if Result then
begin // delete leading zeros
while (Length(S) > 0) and (S[0] = 0) do
begin
for iCounter := 0 to Length(S)-2 do
S[iCounter] := S[iCounter+1];
SetLength(S,Length(S)-1);
end;
end
else
SetLength(S, 0);
end;
function TSerialPort.Read(var inbuf; inlen: DWORD): Boolean;
var
dwBytesRead: DWORD;
begin
Result := False;
if FPortHandle = INVALID_HANDLE_VALUE then
Exit;
dwBytesRead := 0;
Result := ReadFile(FPortHandle, inbuf, inlen, dwBytesRead, nil);
end;
FEOSChar end of string byte/char. To get string from TBytes you can use SysUtils.StringOf() function
upd:
function MakeCommFlags(fBinary, fParity, fOutxCtsFlow, fOutxDsrFlow: Boolean;
fDtrControl: Byte; fDsrSensitivity, fTXContinueOnXoff, fOutX, fInX,
fErrorChar, fNull: Boolean; fRtsControl: Byte;
fAbortOnError: Boolean): DWORD;
begin
Result := 0;
fDtrControl := fDtrControl and $03;
fRtsControl := fRtsControl and $03;
Result := Result or (Byte(fBinary) shl 0);
Result := Result or (Byte(fParity) shl 1);
Result := Result or (Byte(fOutxCtsFlow) shl 2);
Result := Result or (Byte(fOutxDsrFlow) shl 3);
Result := Result or (Byte(fDtrControl) shl 4);
Result := Result or (Byte(fDsrSensitivity) shl 6);
Result := Result or (Byte(fTXContinueOnXoff) shl 7);
Result := Result or (Byte(fOutX) shl 8);
Result := Result or (Byte(fInX) shl 9);
Result := Result or (Byte(fErrorChar) shl 10);
Result := Result or (Byte(fNull) shl 11);
Result := Result or (Byte(fRtsControl) shl 12);
Result := Result or (Byte(fAbortOnError) shl 14);
end;

Resources