Split up serial data in delphi - delphi

I am a newbie in Delphi programming and I need some help. I have a problem with spliting my serial data. This is my code:
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x, i: integer;
save_data : TStringList;
begin
save_data := TStringList.create;
for x := 0 to Count-1 do begin
ComPort1.ReadStr(DataByte,1);
if DataByte = 'n' then
begin
memo1.Text := '';
end
else
begin
memo1.Text := memo1.Text + DataByte;
Split(' ', DataByte, save_data);
end;
end;
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
save_data.Free;
end;
My Split(' ', DataByte, save_data); doesn't work. I don't understand because I just split String data which is taken from the serial port. This is my Split() procedure:
procedure TForm1.Split(const Delimiter: Char; Input: string; const Strings: TStrings) ;
begin
Assert(Assigned(Strings));
Strings.Clear;
Strings.Delimiter := Delimiter;
Strings.DelimitedText := Input;
end;
I do not know why my program is giving me a EStringListError error.

You are calling ReadStr() to read individual bytes, and calling Split() on every byte (except for 'n'). So the TStringList will only ever hold 1 string at a time. Like MBo said, you need to fix your loop to avoid that, eg:
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x: integer;
save_data : TStringList;
begin
ComPort1.ReadStr(DataByte, Count);
for x := 1 to Length(DataByte) do
begin
if DataByte[x] = 'n' then
begin
Memo1.Text := '';
end
else
begin
Memo1.Text := Memo1.Text + DataByte[x];
end;
end;
save_data := TStringList.create;
try
Split(' ', DataByte, save_data);
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
finally
save_data.Free;
end;
end;
That being said, you are not taking into account that the number of bytes you receive for any given OnRxChar event call is arbitrary. It is whatever raw bytes have been read at that exact moment. You are assuming a full string with at least 6 delimited substrings, and that is simply not guaranteed. You need to buffer the raw data as you receive it, and then parse and remove only completed strings from the buffer as needed.
Try something more like this:
var
DataBuffer: string;
// consider using the OnRxBuf event instead...
procedure TForm1.ComPort1RxChar(Sender: TObject; Count: Integer);
var
DataByte : string;
x: integer;
save_data : TStringList;
begin
ComPort1.ReadStr(DataByte, Count);
DataBuffer := DataBuffer + DataByte;
x := Pos('n', DataBuffer);
if x = 0 then Exit;
save_data := TStringList.Create;
try
repeat
DataByte := Copy(DataBuffer, 1, x-1);
Delete(DataBuffer, 1, x);
Memo1.Text := DataByte;
Split(' ', DataByte, save_data);
if save_data.Count >= 6 then
begin
save_gyroX := save_data[0];
save_gyroY := save_data[1];
save_gyroZ := save_data[2];
save_accelX := save_data[3];
save_accelY := save_data[4];
save_accelZ := save_data[5];
SerialProcess();
end;
x := Pos('n', DataBuffer);
until x = 0;
finally
save_data.Free;
end;
end;

if Comport is Dejan Crnila CPort class, then this line
ComPort1.ReadStr(DataByte,1);
replaces Databyte contents every time, and this string always is 1-byte length.
Just read all bytes from buffer with single call
ComPort1.ReadStr(DataByte, Count);
and do work with string

Related

How get size of a Jpeg? [duplicate]

I want to know the width and height of an image file before opening that file.
So, how can I do that?
This refers to JPEG, BMP, PNG and GIF types of image files.
If by 'image file' you mean those raster image files recognised by the VCL's graphics system, and by 'before opening' you mean 'before the user is likely to notice that the file is opened', then you can do this very easily:
var
pict: TPicture;
begin
with TOpenDialog.Create(nil) do
try
if Execute then
begin
pict := TPicture.Create;
try
pict.LoadFromFile(FileName);
Caption := Format('%d×%d', [pict.Width, pict.Height])
finally
pict.Free;
end;
end;
finally
Free;
end;
Of course, the file is opened, and this requires a lot of memory if the image is big. However, if you need to obtain metatada (like dimensions) without loading the file, I believe you need a more 'complicated' solution.
You can try this page. I have not tested it, but it seems pretty reasonable that it will work.
Also, different file types have different ways of getting the width and height.
One of the page answers:
unit ImgSize;
interface
uses Classes;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
implementation
uses SysUtils;
function ReadMWord(f: TFileStream): word;
type
TMotorolaWord = record
case byte of
0: (Value: word);
1: (Byte1, Byte2: byte);
end;
var
MW: TMotorolaWord;
begin
// It would probably be better to just read these two bytes in normally and
// then do a small ASM routine to swap them. But we aren't talking about
// reading entire files, so I doubt the performance gain would be worth the trouble.
f.Read(MW.Byte2, SizeOf(Byte));
f.Read(MW.Byte1, SizeOf(Byte));
Result := MW.Value;
end;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
const
ValidSig : array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
Sig: array[0..1] of byte;
f: TFileStream;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
Len: word;
ReadLen: LongInt;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
ReadLen := f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
ReadLen := 0;
if ReadLen > 0 then
begin
ReadLen := f.Read(Seg, 1);
while (Seg = $FF) and (ReadLen > 0) do
begin
ReadLen := f.Read(Seg, 1);
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) then
begin
ReadLen := f.Read(Dummy[0], 3); // don't need these bytes
wHeight := ReadMWord(f);
wWidth := ReadMWord(f);
end
else
begin
if not (Seg in Parameterless) then
begin
Len := ReadMWord(f);
f.Seek(Len - 2, 1);
f.Read(Seg, 1);
end
else
Seg := $FF; // Fake it to keep looping.
end;
end;
end;
end;
finally
f.Free;
end;
end;
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
type
TPNGSig = array[0..7] of byte;
const
ValidSig: TPNGSig = (137, 80, 78, 71, 13, 10, 26, 10);
var
Sig: TPNGSig;
f: tFileStream;
x: integer;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
exit;
f.Seek(18, 0);
wWidth := ReadMWord(f);
f.Seek(22, 0);
wHeight := ReadMWord(f);
finally
f.Free;
end;
end;
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
type
TGIFHeader = record
Sig: array[0..5] of char;
ScreenWidth, ScreenHeight: word;
Flags, Background, Aspect: byte;
end;
TGIFImageBlock = record
Left, Top, Width, Height: word;
Flags: byte;
end;
var
f: file;
Header: TGifHeader;
ImageBlock: TGifImageBlock;
nResult: integer;
x: integer;
c: char;
DimensionsFound: boolean;
begin
wWidth := 0;
wHeight := 0;
if sGifFile = '' then
exit;
{$I-}
FileMode := 0; // read-only
AssignFile(f, sGifFile);
reset(f, 1);
if IOResult <> 0 then
// Could not open file
exit;
// Read header and ensure valid file
BlockRead(f, Header, SizeOf(TGifHeader), nResult);
if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0)
or (StrLComp('GIF', Header.Sig, 3) <> 0) then
begin
// Image file invalid
close(f);
exit;
end;
// Skip color map, if there is one
if (Header.Flags and $80) > 0 then
begin
x := 3 * (1 SHL ((Header.Flags and 7) + 1));
Seek(f, x);
if IOResult <> 0 then
begin
// Color map thrashed
close(f);
exit;
end;
end;
DimensionsFound := False;
FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
// Step through blocks
BlockRead(f, c, 1, nResult);
while (not EOF(f)) and (not DimensionsFound) do
begin
case c of
',': // Found image
begin
BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
if nResult <> SizeOf(TGIFImageBlock) then
begin
// Invalid image block encountered
close(f);
exit;
end;
wWidth := ImageBlock.Width;
wHeight := ImageBlock.Height;
DimensionsFound := True;
end;
',' : // Skip
begin
// NOP
end;
// nothing else, just ignore
end;
BlockRead(f, c, 1, nResult);
end;
close(f);
{$I+}
end;
end.
And for BMP (also found at the page I mentioned):
function FetchBitmapHeader(PictFileName: String; Var wd, ht: Word): Boolean;
// similar routine is in "BitmapRegion" routine
label ErrExit;
const
ValidSig: array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
BmpSig = $4d42;
var
// Err : Boolean;
fh: HFile;
// tof : TOFSTRUCT;
bf: TBITMAPFILEHEADER;
bh: TBITMAPINFOHEADER;
// JpgImg : TJPEGImage;
Itype: Smallint;
Sig: array[0..1] of byte;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
skipLen: word;
OkBmp, Readgood: Boolean;
begin
// Open the file and get a handle to it's BITMAPINFO
OkBmp := False;
Itype := ImageType(PictFileName);
fh := CreateFile(PChar(PictFileName), GENERIC_READ, FILE_SHARE_READ, Nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (fh = INVALID_HANDLE_VALUE) then
goto ErrExit;
if Itype = 1 then
begin
// read the BITMAPFILEHEADER
if not GoodFileRead(fh, #bf, sizeof(bf)) then
goto ErrExit;
if (bf.bfType <> BmpSig) then // 'BM'
goto ErrExit;
if not GoodFileRead(fh, #bh, sizeof(bh)) then
goto ErrExit;
// for now, don't even deal with CORE headers
if (bh.biSize = sizeof(TBITMAPCOREHEADER)) then
goto ErrExit;
wd := bh.biWidth;
ht := bh.biheight;
OkBmp := True;
end
else
if (Itype = 2) then
begin
FillChar(Sig, SizeOf(Sig), #0);
if not GoodFileRead(fh, #Sig[0], sizeof(Sig)) then
goto ErrExit;
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
goto ErrExit;
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
while (Seg = $FF) and Readgood do
begin
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) or (Seg = $C2) then
begin
Readgood := GoodFileRead(fh, #Dummy[0],3); // don't need these bytes
if ReadMWord(fh, ht) and ReadMWord(fh, wd) then
OkBmp := True;
end
else
begin
if not (Seg in Parameterless) then
begin
ReadMWord(fh,skipLen);
SetFilePointer(fh, skipLen - 2, nil, FILE_CURRENT);
GoodFileRead(fh, #Seg, sizeof(Seg));
end
else
Seg := $FF; // Fake it to keep looping
end;
end;
end;
end;
ErrExit: CloseHandle(fh);
Result := OkBmp;
end;
As a complement to Rafael's answer, I believe that this much shorter procedure can detect BMP dimensions:
function GetBitmapDimensions(const FileName: string; out Width,
Height: integer): boolean;
const
BMP_MAGIC_WORD = ord('M') shl 8 or ord('B');
var
f: TFileStream;
header: TBitmapFileHeader;
info: TBitmapInfoHeader;
begin
result := false;
f := TFileStream.Create(FileName, fmOpenRead);
try
if f.Read(header, sizeof(header)) <> sizeof(header) then Exit;
if header.bfType <> BMP_MAGIC_WORD then Exit;
if f.Read(info, sizeof(info)) <> sizeof(info) then Exit;
Width := info.biWidth;
Height := abs(info.biHeight);
result := true;
finally
f.Free;
end;
end;
If anyone yet interested in retrieving TIFF image dimensions without loading the graphic, there is a proven method that works perfectly for me in all environments. I also found another solution for that, but it returned wrong values from Illustrator-generated TIFFs. But there is a fantastic graphic library, called GraphicEx by Mike Lischke (TVirtualStringTree's very talented developer). There are implementations of many popular image formats and all of them descend from the base class TGraphicExGraphic, that implements ReadImageProperties virtual method. It is stream-based and only reads the fileheader in all implementations. So it is lightning-fast... :-)
So, here is a sample code, that retrieves a TIFF's dimensions (the method is the same for all graphic implementation, PNG,PCD,TGA,GIF,PCX,etc):
Uses ..., GraphicEx,...,...;
Procedure ReadTifSize (FN:String; Var iWidth,iHeight:Integer);
Var FS:TFileStream;
TIFF:TTIFFGraphic;
Begin
iWidth:=0;iHeight:=0;
TIFF:=TTIFFGraphic.Create;
FS:=TFileStream.Create(FN,OF_READ);
Try
TIFF.ReadImageProperties(FS,0);
iWidth:=TIFF.ImageProperties.Width;
iHeight:=TIFF.ImageProperties.Height;
Finally
TIFF.Destroy;
FS.Free;
End;
End;
That's all... :-) And this is the same for all the graphic implementations in the unit.
I don't like Rafael's solution for JPEG files too much because his algorithm parses every single byte until it hits FFC0. It doesn't make use of the fact that almost all markers (except FFD8, FFD9 and FFFE) are followed by two length bytes, allowing to skip from marker to marker. So I suggest the following procedure (which I condensed even a little more by stuffing checking for a marker and retrieving a value into the same function):
procedure GetJPGSize(const Filename: string; var ImgWidth, ImgHeight: word);
const
SigJPG : TBytes = [$FF, $D8];
SigC01 : TBytes = [$FF, $C0];
SigC02 : TBytes = [$FF, $C1];
var
FStream: TFileStream;
Buf: array[0..1] of Byte;
Offset,CheckMarker : Word;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function SameValue(Sig:TBytes):Boolean;
begin
Result := CompareMem(#Sig[0], #Buf[0], Length(Sig));
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function CheckMarkerOrVal(var Value:Word):Boolean;
begin
FStream.ReadData(Buf, Length(Buf));
Value := Swap(PWord(#Buf[0])^);
Result := (Buf[0] = $FF);
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
begin
FStream := TFileStream.Create(Filename, fmOpenRead);
Try
// First two bytes in a JPG file MUST be $FFD8, followed by the next marker
If not (CheckMarkerOrVal(CheckMarker) and SameValue(SigJPG))
then exit;
Repeat
If not CheckMarkerOrVal(CheckMarker)
then exit;
If SameValue(SigC01) or SameValue(SigC02) then begin
FStream.Position := FStream.Position + 3;
CheckMarkerOrVal(ImgHeight);
CheckMarkerOrVal(ImgWidth);
exit;
end;
CheckMarkerOrVal(Offset);
FStream.Position := FStream.Position + Offset - 2;
until FStream.Position > FStream.Size div 2;
Finally
FStream.Free;
end;
end;
Since GetGIFSize in Rafael's answer is broken and utterly complicated, here is my personal version of it:
function GetGifSize(var Stream: TMemoryStream; var Width: Word; var Height: Word): Boolean;
var
HeaderStr: AnsiString;
begin
Result := False;
Width := 0;
Height := 0;
//GIF header is 13 bytes in length
if Stream.Size > 13 then
begin
SetString(HeaderStr, PAnsiChar(Stream.Memory), 6);
if (HeaderStr = 'GIF89a') or (HeaderStr = 'GIF87a') then
begin
Stream.Seek(6, soFromBeginning);
Stream.Read(Width, 2); //Width is located at bytes 7-8
Stream.Read(Height, 2); //Height is located at bytes 9-10
Result := True;
end;
end;
end;
I found it by reading the RFC.

Delphi Inconsistent data coming from a hardware using Cport

I am having trouble getting the serial port data from an equipment.
Below is the image of the expected result:
Desire result:
Unwanted result:
I use Ttimer so I can automatically get the data and put it to the Memo.
I need the data to be placed line by line in the memo.
This is the source code:
procedure TForm3.Timer1Timer(Sender: TObject);
var
k: Integer;
InBuffer: array[1..500] of char;
begin
for k:=1 to 500 do
InBuffer[k]:=' ';
Trim(InBuffer);
if cport.Connected = true then
begin
ComLed1.Kind := lkGreenLight;
cport.ReadStr(str,k);
Trim(str);
S:=str;
if str = '' then
begin
end
else
begin
memo1.lines.Add(str);
end;
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Connected';
end;
end;
My question is what is the problem? And what is the solution for this.
TMemo.Lines.Add() adds a line. The text you add will have a line break inserted at the end of it. It is clear that you are receiving the hardware data in pieces, and you are adding each piece separately as its own line in the Memo.
To do what you are attempting, you need to either:
Read the pieces from the hardware and cache them until you detect the end of a complete message, and then Add() only complete messages to the Memo. How you do this depends on the particular protocol the hardware is using to send data to you. Does it wrap the data in STX/ETX markers? Does it delimit messages? We don't know, you have not provided any information about that. And your code is trying (unsuccessfully) to trim a lot of data away that it probably shouldn't be throwing away at all.
Don't use Add() at all. You can use the SelText property instead to avoid inserting any line breaks you don't want.
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
That being said, your timer code is doing some odd things. InBuffer is filled with spaces, then (unsuccessfully) trimmed, and then completely ignored. You are passing an uninitialized k value to ReadStr(). The str value you do read is unsuccessfully trimmed before added to the Memo. You are assigning str to S and then ignoring S.
Try this instead:
procedure TForm3.Timer1Timer(Sender: TObject);
var
str: AnsiString;
begin
if cport.Connected then
begin
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
cport.ReadStr(str, 256);
str := Trim(str);
if str <> '' then
begin
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
end;
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
Alternatively (assuming you are using TComPort that has an OnRxChar event):
procedure TForm3.Timer1Timer(Sender: TObject);
begin
if cport.Connected then
begin
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
procedure TForm3.cportRxChar(Sender: TObject; Count: Integer);
var
str: AnsiString;
begin
cport.ReadStr(str, Count);
str := Trim(str);
if str <> '' then
begin
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
end;
end;
Edit based on new information provided in comments, try something like this:
private
buffer: AnsiString;
portConnected: boolean;
procedure TForm3.Timer1Timer(Sender: TObject);
begin
if cport.Connected then
begin
if not portConnected then
begin
portConnected := true;
buffer := '';
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
end;
end
else
begin
if portConnected then
begin
portConnected := false;
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
end;
procedure TForm3.cportRxChar(Sender: TObject; Count: Integer);
var
str: AnsiString;
i: integer;
begin
cport.ReadStr(str, Count);
buffer := buffer + str;
repeat
i := Pos(#10, buffer);
if i = 0 then Exit;
str := Copy(buffer, 1, i-1);
Delete(buffer, 1, i);
memo1.Lines.Add(str);
until buffer = '';
end;

Multi-Byte Character Support over TServerSocket Delphi

While working on a multi-user chat application I've got stuck around getting the multi-byte chars to work over TServerSocket / TClientSocket.
This is the part where the client sends the message to the server:
procedure TChatForm.SendBtnClick(Sender: TObject);
var str : string;
begin
str := MsgLabel.Text;
ClientSocket.Socket.SendText('message' + separator + nickname + separator + str);
MsgLabel.Text := '';
add_text(MsgBox,MsgLabel,nickname+': '+str,'none');
end;
This is how the server parses the received data:
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
i,hnd : Integer;
recv : string;
arr : TStringArray; // type TStringArray = array of string;
begin
recv := Socket.ReceiveText;
hnd := Socket.Handle; //using this to avoid sending received data back to the client
arr := SplitStr(recv,separator);
//SplitStr is a function i use because TStringList.DelimitedText uses only a char as delimiter
// sending the data to the others users / but the expeditor - async error workaround
for i:=0 to ServerSocket.Socket.ActiveConnections-1 do begin
if ServerSocket.Socket.Connections[i].Handle <> hnd then
ServerSocket.Socket.Connections[i].SendText(recv);
end;
if arr[0] = 'connect' then begin
// adding the connected user to the tlistbox
Contacts.Items.Add(arr[1]);
// adding the connected message in the trichedit
add_text(MsgBox,SendMsg,arr[1]+' has connected !','green');
end else if arr[0] = 'disconnect' then begin
// removing the user from the online user list
Contacts.Items.Delete(Contacts.Items.IndexOf(arr[1]));
// adding the disconnected message in trichedit
add_text(MsgBox,SendMsg,arr[1]+' has disconnected !','red');
end else if arr[0] = 'message' then begin
// finally adding the message that user send in the TRichEdit
add_text(MsgBox,SendMsg,arr[1]+': '+arr[2],'none');
end;
end;
An example of how the Socket.ReceiveText looks like:
- when user connects he sends the next message - connect^SEPARATOR^username
- when a user sends a message - message^SEPARATOR^username^SEPARATOR^message_body
The structure is ACTION + SEPARATOR + USERNAME + EXTRA_DATA, thas my way of "keeping" the online users list updated. I'm new to delphi, if there's any easier way of doing that, let me know.
The problem is now, if I'm sending multibyte characters over to the users and back, those multibyte chars are received as question marks "?".
- "ț or ș" becomes "? or ?"
Printscreen here:
EDIT2: Ok, after all the changes have been made, thanks to your answers, I bumped into a problem while trying to send the data received by the server from the client back to the other clients. Well this problem has 2 little bumps:
This is how the server sends a "global" message to the users.
procedure TServerForm.SendBtnClick(Sender: TObject);
var
i : Integer;
str : String;
begin
str := SendMsg.Text;
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
SendString(Connections[i], TSocketBuffers(Connections[i].Data).OutBuffer, 'global' + separator + str);
end;
add_text(MsgBox,SendMsg,str,'none');
SendMsg.Text := '';
end;
This is how server sends back to other active connections the data received from one client:
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
Buffers: TSocketBuffers;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
Buffers := TSocketBuffers(Socket.Data);
if not Buffers.ReadInData(Socket) then Exit;
Buffers.InBuffer.Position := 0;
try
while ReadString(Buffers.InBuffer, RecvStr) do
begin
arr := SplitStr(RecvStr, separator);
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
begin
if Connections[i] <> Socket then
SendString(Connections[i], TSocketBuffers(Connections[i].Data).OutBuffer, arr[0]);
end;
end;
// [ .. some string processing stuff .. ]
end;
finally
CompactBuffer(Buffers.InBuffer);
end;
end;
Now, if these 2 methods are correct, then the problem is the reading data on the client side, and this is how the data is parsed on the client side following the same principle as ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
procedure TChatForm.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
Buffers: TSocketBuffers;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
Buffers := TSocketBuffers(Socket.Data);
if not Buffers.ReadInData(Socket) then Exit;
Buffers.InBuffer.Position := 0;
try
while ReadString(Buffers.InBuffer, RecvStr) do begin
ShowMessage(RecvStr); // testing if anything is received
// [[.. some string processing code ..]]
end;
finally
CompactBuffer(Buffers.InBuffer);
end;
end;
Trying to send data from client to server works flawlessly as you can see in the image (above) string is interpreted as it should be. The problem is either trying to send the data back to the clients in ServerSocketClientRead method, either in the ClientSocketRead method.
UPDATE 3: So I had launched the client on another pc and the problem seems to be at the ClientSocketRead method (if the ServerSocketClientRead -> SendString and the global SendBtn -> SendString are correct); I'll keep updating if any new details are found.
You need to stay away from the SendText() and ReceiveText() methods, especially if you are using non-blocking sockets. They do not handle the conditions that data may have to be sent in multiple packets, and that packets can arrive in smaller pieces or even multiple packets merged together. These are very common conditions that you have to handle in TCP programming.
SendText() simply passes the string as-is to SendBuf(). If it cannot send the entire string in a single send, it does not attempt to re-send the remaining characters. So you can (and likely will) send incomplete strings. It does return how many bytes were actually sent, so you can call SendText() in a loop until there are no more characters to send.
ReceiveText() has no way of knowing the length of the string being received. It merely reads whatever is currently in the socket buffer and returns it as a string. So this also runs the risk of reading incomplete strings, or even reading multiple (even partial) strings together.
The best way to send a string is to use SendBuf() and ReceiveBuf() directly instead. When sending a string, either send the string length (in bytes) before sending the string data, or else send a unique delimiter after the string data that does not appear in the string itself. The receiver can then read the length value and then read the specified number of bytes, or read until the delimiter is encountered. Also, when dealing with non-ASCII string data, especially with D2009+'s UnicodeString string type, you should encode the string data to a universal format during transmission, such as UTF-8.
If you are using non-blocking sockets, this gets more complicated. If a socket would enter a blocking state during a send/read operation, the operation fails with an WSAEWOULDBLOCK error code and you have to repeat the operation when the socket is out of the blocking state.
If a send operation fails with WSAEWOULDBLOCK then buffer your remaining data somewhere (and append any future outbound data to the end of that buffer if it is not empty) until the OnWrite event fires, then send whatever is in your buffer, removing successfully sent bytes, until it is emptied or the socket blocks again (in which case, you have to wait for another OnWrite event before sending the remaining buffer data).
Likewise, when a read operation fails with WSAEWOULDBLOCK but you are still expecting data, you have to wait for another OnRead event to fire before you can attempt to read again, buffering any intermediate data that has been received, until you have received all of the data that you are expecting before you can then process it.
For example:
Common code:
type
TSocketData = class
private
Socket: TCustomSocketSocket;
InBuffer: TMemoryStream;
OutBuffer: TMemoryStream;
function SendRawToSocket(Data: Pointer; DataLen: Integer): Integer;
procedure Compact(Buffer: TMemoryStream);
public
constructor Create(ASocket: TCustomSocketSocket);
destructor Destroy; override;
function BufferInboundData: Boolean;
procedure FlushOutboundData;
procedure BeginReading;
procedure EndReading;
function SendRaw(Data: Pointer; DataLen: Integer): Boolean;
function ReadRaw(Data: Pointer; DataLen: Integer): Boolean;
function SendInteger(Value: Integer): Boolean;
function ReadInteger(var Value: Integer): Boolean;
function SendInt64(Value: Int64): Boolean;
function ReadInt64(var Value: Int64): Boolean;
function SendString(const Str: String): Boolean;
function ReadString(var Str: String): Boolean;
function SendStream(Stream: TStream): Boolean;
function ReadStream(Stream: TStream): Boolean;
end;
constructor TSocketData.Create(ASocket: TCustomWinSocket);
begin
inherited;
Socket := ASocket;
InBuffer := TMemoryStream.Create;
OutBuffer := TMemoryStream.Create;
end;
destructor TSocketData.Destroy;
begin
InBuffer.Free;
OutBuffer.Free;
inherited;
end;
function TSocketData.SendRawToSocket(Data: Pointer; DataLen: Integer): Integer;
var
Bytes: PByte;
Ret: Integer;
begin
Result := 0;
Bytes := PByte(Data);
while DataLen > 0 do
begin
Ret := Socket.SendBuf(Bytes^, DataLen);
if Ret < 1 then
begin
if WSAGetLastError = WSAEWOULDBLOCK then Break;
Result := -1;
Exit;
end;
Inc(Bytes, Ret);
Dec(DataLen, Ret);
Inc(Result, Ret);
end;
end;
function TSocketData.BufferInboundData: Boolean;
var
RecvLen, OldSize: Integer;
begin
Result := False;
RecvLen := Socket.ReceiveLength;
if RecvLen < 1 then Exit;
OldSize := InBuffer.Size;
InBuffer.Size := OldSize + RecvLen;
try
RecvLen := Socket.ReceiveBuf((PByte(InBuffer.Memory)+OldSize)^, RecvLen);
if RecvLen < 1 then RecvLen := 0;
except
RecvLen := 0;
end;
InBuffer.Size := OldSize + RecvLen;
if RecvLen = 0 then Exit;
Result := True;
end;
procedure TSocketData.FlushOutboundData;
var
Ret: Integer;
begin
if OutBuffer.Size = 0 then Exit;
Ret := SendRawToSocket(OutBuffer.Memory, OutBuffer.Size);
if Ret < 1 then Exit;
OutBuffer.Position := Ret;
Compact(OutBuffer);
end;
procedure TSocketData.Compact(Buffer: TMemoryStream);
var
Remaining: Integer;
begin
if Buffer.Position = 0 then Exit;
Remaining := Buffer.Size - Buffer.Position;
if Remaining > 0 then
Move((PByte(Buffer.Memory) + Buffer.Position)^, Buffer.Memory^, Remaining);
Buffer.Size := Remaining;
end;
procedure TSocketData.BeginReading;
begin
InBuffer.Position := 0;
end;
procedure TSocketData.EndReading;
begin
Compact(InBuffer);
end;
function TSocketData.SendRaw(Data: Pointer; DataLen: Integer): Boolean;
var
Bytes: PByte;
Ret: Integer;
begin
Bytes := PByte(Data);
if OutBuffer.Size = 0 then
begin
Ret := SendRawToSocket(Bytes, DataLen);
if Ret = -1 then
begin
Result := False;
Exit;
end;
Inc(Bytes, Ret);
Dec(DataLen, Ret);
end;
if DataLen > 0 then
begin
OutBuffer.Seek(0, soEnd);
OutBuffer.WriteBuffer(Bytes^, DataLen);
end;
Result := True;
end;
function TSocketData.ReadRaw(Data: Pointer; DataLen: Integer): Boolean;
begin
Result := False;
if (InBuffer.Size - InBuffer.Position) < DataLen then Exit;
InBuffer.ReadBuffer(Data^, DataLen);
Result := True;
end;
function TSocketData.SendInteger(Value: Integer): Boolean;
begin
Value := htonl(Value);
Result := SendRaw(#Value, SizeOf(Value));
end;
function TSocketData.ReadInteger(var Value: Integer): Boolean;
begin
Result := ReadRaw(#Value, SizeOf(Value));
if Result then Value := ntohl(Value);
end;
type
TInt64Parts = packed record
case Integer of
0: (
LowPart: LongWord;
HighPart: LongWord);
1: (
QuadPart: Int64);
end;
function hton64(AValue: Int64): Int64;
var
LParts: TInt64Parts;
L: LongWord;
begin
LParts.QuadPart := AValue;
L := htonl(LParts.HighPart);
LParts.HighPart := htonl(LParts.LowPart);
LParts.LowPart := L;
Result := LParts.QuadPart;
end;
function ntoh64(AValue: Int64): Int64;
var
LParts: TInt64Parts;
L: LongWord;
begin
LParts.QuadPart := AValue;
L := ntohl(LParts.HighPart);
LParts.HighPart := ntohl(LParts.LowPart);
LParts.LowPart := L;
Result := LParts.QuadPart;
end;
function TSocketData.SendInt64(Value: Int64): Boolean;
begin
Value := hton64(Value);
Result := SendRaw(#Value, SizeOf(Value));
end;
function TSocketData.ReadInt64(var Value: Int64): Boolean;
begin
Result := ReadRaw(#Value, SizeOf(Value));
if Result then Value := ntoh64(Value);
end;
function TSocketData.SendString(const Str: String): Boolean;
var
S: UTF8String;
Len: Integer;
begin
S := UTF8String(Str);
Len := Length(S);
Result := SendInteger(Len);
if Result and (Len > 0) then
Result := SendRaw(PAnsiChar(S), Len);
end;
function TSocketData.ReadString(var Str: String): Boolean;
var
S: UTF8String;
Len: Integer;
begin
Result := False;
Str := '';
if not ReadInteger(Len) then Exit;
if (InBuffer.Size - InBuffer.Position) < Len then
begin
InBuffer.Seek(-SizeOf(Len), soCurrent);
Exit;
end;
if Len > 0 then
begin
SetLength(S, Len);
ReadRaw(PAnsiChar(S), Len);
Str := String(S);
end;
Result := True;
end;
function TSocketData.SendStream(Stream: TStream): Boolean;
var
Buf: array[0..1023] of Byte;
Len: Int64;
NumToSend: Integer;
begin
Len := Stream.Size - Stream.Position;
Result := SendInt64(Len);
if Result and (Len > 0) then
begin
repeat
if Len > SizeOf(Buf) then
NumToSend := SizeOf(Buf)
else
NumToSend := Integer(Len);
Stream.ReadBuffer(Buf[0], NumToSend);
Dec(Len, NumToSend);
Result := SendRaw(#Buf[0], NumToSend);
until (Len = 0) or (not Result);
end;
end;
function TSocketData.ReadStream(Stream: TStream): Boolean;
var
Len: Int64;
begin
Result := False;
if not ReadInt64(Len) then Exit;
if (InBuffer.Size - InBuffer.Position) < Len then
begin
InBuffer.Seek(-SizeOf(Len), soCurrent);
Exit;
end;
if Len > 0 then
Stream.CopyFrom(InBuffer, Len);
Result := True;
end;
Client code:
procedure TChatForm.ClientSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketData.Create(Socket);
end;
procedure TChatForm.ClientSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TChatForm.ClientSocketWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).FlushOutboundData;
end;
procedure TChatForm.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
SocketData: TSocketData;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
SocketData := TSocketData(Socket.Data);
if not SocketData.BufferInboundData then Exit;
SocketData.BeginReading;
try
while SocketData.ReadString(RecvStr) do begin
ShowMessage(RecvStr); // testing if anything is received
// [[.. some string processing code ..]]
end;
finally
SocketData.EndReading;
end;
end;
procedure TChatForm.SendBtnClick(Sender: TObject);
var
SocketData: TSocketData;
begin
if ClientSocket1.Socket = nil then Exit;
SocketData := TSocketData(ClientSocket1.Socket.Data);
if SocketData = nil then Exit;
str := MsgLabel.Text;
if SocketData.SendString('message' + separator + nickname + separator + str) then
begin
MsgLabel.Text := '';
add_text(MsgBox, MsgLabel, nickname + ': ' + str, 'none');
end;
end;
Server code:
procedure TServerForm.ServerSocketClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketData.Create(Socket);
end;
procedure TServerForm.ServerSocketClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TServerForm.ServerSocketClientRead(Sender: TObject;Socket: TCustomWinSocket);
var
SocketData: TSocketData;
i: Integer;
RecvStr : String;
arr : TStringArray;
begin
SocketData := TSocketData(Socket.Data);
if not SocketData.BufferInboundData then Exit;
SocketData.BeginReading;
try
while SocketData.ReadString(RecvStr) do
begin
arr := SplitStr(RecvStr, separator);
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
begin
if Connections[i] <> Socket then
TSocketData(Connections[i].Data).SendString(RecvStr);
end;
end;
if arr[0] = 'connect' then
begin
Contacts.Items.Add(arr[1]);
add_text(MsgBox, SendMsg, arr[1] + ' has connected !', 'green');
end
else if arr[0] = 'disconnect' then
begin
Contacts.Items.Delete(Contacts.Items.IndexOf(arr[1]));
add_text(MsgBox, SendMsg, arr[1] + ' has disconnected !', 'red');
end
else if arr[0] = 'message' then
begin
add_text(MsgBox, SendMsg, arr[1] + ': ' + arr[2], 'none');
end;
end;
finally
SocketData.EndReading;
end;
end;
procedure TServerForm.ServerSocketClientWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketData(Socket.Data).FlushOutboundData;
end;
procedure TServerForm.SendBtnClick(Sender: TObject);
var
i : Integer;
str : String;
begin
str := SendMsg.Text;
with ServerSocket.Socket do
begin
for i := 0 to ActiveConnections-1 do
TSocketData(Connections[i].Data).SendString('global' + separator + str);
end;
add_text(MsgBox, SendMsg, str, 'none');
SendMsg.Text := '';
end;

How can I quickly convert an array of numeral characters into an integer?

Situation: a whole number saved as hex in a byte array(TBytes). Convert that number to type integer with less copying, if possible without any copying.
here's an example:
array = ($35, $36, $37);
This is '5', '6', '7' in ansi. How do I convert it to 567(=$273) with less trouble?
I did it by copying twice. Is it possible to be done faster? How?
You can use LookUp Table instead HexToInt...
This procedure works only with AnsiChars and of course no error checking is provided!
var
Table :array[byte]of byte;
procedure InitLookupTable;
var
n: integer;
begin
for n := 0 to Length(Table) do
case n of
ord('0')..ord('9'): Table[n] := n - ord('0');
ord('A')..ord('F'): Table[n] := n - ord('A') + 10;
ord('a')..ord('f'): Table[n] := n - ord('a') + 10;
else Table[n] := 0;
end;
end;
function HexToInt(var hex: TBytes): integer;
var
n: integer;
begin
result := 0;
for n := 0 to Length(hex) -1 do
result := result shl 4 + Table[ord(hex[n])];
end;
function BytesToInt(const bytes: TBytes): integer;
var
i: integer;
begin
result := 0;
for i := 0 to high(bytes) do
result := (result shl 4) + HexToInt(bytes[i]);
end;
As PA pointed out, this will overflow with enough digits, of course. The implementation of HexToInt is left as an exercise to the reader, as is error handling.
You can do
function CharArrToInteger(const Arr: TBytes): integer;
var
s: AnsiString;
begin
SetLength(s, length(Arr));
Move(Arr[0], s[1], length(s));
result := StrToInt(s);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37);
Caption := IntToStr(CharArrToInteger(a));
end;
If you know that the string is null-terminated, that is, if the final character in the array is 0, then you can just do
function CharArrToInteger(const Arr: TBytes): integer;
begin
result := StrToInt(PAnsiChar(#Arr[0]));
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37, 0);
Caption := IntToStr(CharArrToInteger(a));
end;
The most natural approach, however, is to use an array of characters instead of an array of bytes! Then the compiler can do some tricks for you:
procedure TForm1.FormCreate(Sender: TObject);
var
a: TCharArray;
begin
a := TCharArray.Create(#$35, #$36, #$37);
Caption := IntToStr(StrToInt(string(a)));
end;
It cannot be any faster than that ;-)
function HexToInt(num:pointer; size:Cardinal): UInt64;
var i: integer;
inp: Cardinal absolute num;
begin
if(size > SizeOf(Result)) then Exit;
result := 0;
for i := 0 to size-1 do begin
result := result shl 4;
case(PByte(inp+i)^) of
ord('0')..ord('9'): Inc(Result, PByte(inp+i)^ - ord('0'));
ord('A')..ord('F'): Inc(Result, PByte(inp+i)^ - ord('A') + 10);
ord('a')..ord('f'): Inc(Result, PByte(inp+i)^ - ord('a') + 10);
end;
end;
end;
function fHexToInt(b:TBytes): UInt64; inline;
begin
Result:=HexToInt(#b[0], Length(b));
end;
...
b:TBytes = ($35, $36, $37);
HexToInt(#b[0], 3);
fHexToInt(b);

Is there an inverse function of *SysUtils.Format* in Delphi

Has anyone written an 'UnFormat' routine for Delphi?
What I'm imagining is the inverse of SysUtils.Format and looks something like this
UnFormat('a number %n and another %n',[float1, float2]);
So you could unpack a string into a series of variables using format strings.
I've looked at the 'Format' routine in SysUtils, but I've never used assembly so it is meaningless to me.
This is called scanf in C, I've made a Delphi look-a-like for this :
function ScanFormat(const Input, Format: string; Args: array of Pointer): Integer;
var
InputOffset: Integer;
FormatOffset: Integer;
InputChar: Char;
FormatChar: Char;
function _GetInputChar: Char;
begin
if InputOffset <= Length(Input) then
begin
Result := Input[InputOffset];
Inc(InputOffset);
end
else
Result := #0;
end;
function _PeekFormatChar: Char;
begin
if FormatOffset <= Length(Format) then
Result := Format[FormatOffset]
else
Result := #0;
end;
function _GetFormatChar: Char;
begin
Result := _PeekFormatChar;
if Result <> #0 then
Inc(FormatOffset);
end;
function _ScanInputString(const Arg: Pointer = nil): string;
var
EndChar: Char;
begin
Result := '';
EndChar := _PeekFormatChar;
InputChar := _GetInputChar;
while (InputChar > ' ')
and (InputChar <> EndChar) do
begin
Result := Result + InputChar;
InputChar := _GetInputChar;
end;
if InputChar <> #0 then
Dec(InputOffset);
if Assigned(Arg) then
PString(Arg)^ := Result;
end;
function _ScanInputInteger(const Arg: Pointer): Boolean;
var
Value: string;
begin
Value := _ScanInputString;
Result := TryStrToInt(Value, {out} PInteger(Arg)^);
end;
procedure _Raise;
begin
raise EConvertError.CreateFmt('Unknown ScanFormat character : "%s"!', [FormatChar]);
end;
begin
Result := 0;
InputOffset := 1;
FormatOffset := 1;
FormatChar := _GetFormatChar;
while FormatChar <> #0 do
begin
if FormatChar <> '%' then
begin
InputChar := _GetInputChar;
if (InputChar = #0)
or (FormatChar <> InputChar) then
Exit;
end
else
begin
FormatChar := _GetFormatChar;
case FormatChar of
'%':
if _GetInputChar <> '%' then
Exit;
's':
begin
_ScanInputString(Args[Result]);
Inc(Result);
end;
'd', 'u':
begin
if not _ScanInputInteger(Args[Result]) then
Exit;
Inc(Result);
end;
else
_Raise;
end;
end;
FormatChar := _GetFormatChar;
end;
end;
I know it tends to scare people, but you could write a simple function to do this using regular expressions
'a number (.*?) and another (.*?)
If you are worried about reg expressions take a look at www.regexbuddy.com and you'll never look back.
I tend to take care of this using a simple parser. I have two functions, one is called NumStringParts which returns the number of "parts" in a string with a specific delimiter (in your case above the space) and GetStrPart returns the specific part from a string with a specific delimiter. Both of these routines have been used since my Turbo Pascal days in many a project.
function NumStringParts(SourceStr,Delimiter:String):Integer;
var
offset : integer;
curnum : integer;
begin
curnum := 1;
offset := 1;
while (offset <> 0) do
begin
Offset := Pos(Delimiter,SourceStr);
if Offset <> 0 then
begin
Inc(CurNum);
Delete(SourceStr,1,(Offset-1)+Length(Delimiter));
end;
end;
result := CurNum;
end;
function GetStringPart(SourceStr,Delimiter:String;Num:Integer):string;
var
offset : integer;
CurNum : integer;
CurPart : String;
begin
CurNum := 1;
Offset := 1;
While (CurNum <= Num) and (Offset <> 0) do
begin
Offset := Pos(Delimiter,SourceStr);
if Offset <> 0 then
begin
CurPart := Copy(SourceStr,1,Offset-1);
Delete(SourceStr,1,(Offset-1)+Length(Delimiter));
Inc(CurNum)
end
else
CurPart := SourceStr;
end;
if CurNum >= Num then
Result := CurPart
else
Result := '';
end;
Example of usage:
var
st : string;
f1,f2 : double;
begin
st := 'a number 12.35 and another 13.415';
ShowMessage('Total String parts = '+IntToStr(NumStringParts(st,#32)));
f1 := StrToFloatDef(GetStringPart(st,#32,3),0.0);
f2 := StrToFloatDef(GetStringPart(st,#32,6),0.0);
ShowMessage('Float 1 = '+FloatToStr(F1)+' and Float 2 = '+FloatToStr(F2));
end;
These routines work wonders for simple or strict comma delimited strings too. These routines work wonderfully in Delphi 2009/2010.

Resources