TmemoryStream Server Out Of Memory On receiving stream - delphi

All I'm trying to do is send a stream with TSockets, but I'm having an "out of memory" error. I managed to send files, just not images. In the server Form's OnCreate event, I'm creating the stream. For the client, in the Form's OnCreate I'm creating the stream, also a bmp.
I've tried to see if it's not sending, but it's sending something, only I can't tell what. On the server side, I've tested sending commands to the client, and I know they send, also I've tested with booleans, but still get a memory error.
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
BytesReceived: Longint;
CopyBuffer: Pointer;
ChunkSize: Integer;
TempSize: Integer;
FSize: Integer;
writing: Boolean;
bmp: tbitmap;
const
MaxChunkSize: Longint = 8192;
begin
If FSize = 0 then
begin
If Socket.ReceiveLength > SizeOf(TempSize) then
begin
Socket.ReceiveBuf(TempSize, SizeOf(TempSize));
stream.SetSize(TempSize);
FSize := TempSize;
End;
End;
If (FSize > 0) and (writing) then //receiving the image
begin
GetMem(CopyBuffer, MaxChunkSize);
writing := true;
While Socket.ReceiveLength > 0 do
Begin
ChunkSize := Socket.ReceiveLength;
If ChunkSize > MaxChunkSize then
ChunkSize := MaxChunkSize;
BytesReceived := Socket.ReceiveBuf(CopyBuffer^, ChunkSize);
stream.Write(CopyBuffer^, BytesReceived);
Dec(FSize, BytesReceived);
End;
If FSize = 0 then
begin
bmp.LoadFromStream(stream);
self.Image1.Picture.Bitmap.LoadFromStream(stream);
stream.SetSize(0);
FSize := 0;
End;
FreeMem(CopyBuffer, MaxChunkSize);
writing := false;
stream.Free;
exit;
End;
end;
procedure TForm1.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
var
size: Integer;
Data: string;
begin
try
CaptureImage(bmp); //i have a procedure for this & know it works
bmp.SaveToStream(stream);
size := stream.size; //sending the tbitmap image
stream.Position := 0;
Socket.SendBuf(size, sizeof(size));
Socket.SendStream(stream);
except
stream.Free;
end;

You are not taking FSize into account when reading data from the client. You are reading as much as the client sends, and not stopping when the stream size has been reached. And you are not taking into account that it may (and likely will) take multiple OnRead events to receive the entire image, so you may end up freeing your stream prematurely.
Also, TCustomWinSocket.SendStream() is not very stable, especially if you are using the socket in non-blocking mode. You should instead use TCustomWinSocket.SendBuf() directly in a loop and handle any socket errors as needed.
Try something more like this:
uses
..., System.Math;
procedure TForm1.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := nil;
end;
procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
if Socket.Data <> nil then
TMemoryStream(Socket.Data).Free;
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
Stream: TMemoryStream;
BytesReceived: Integer;
StreamSize, TempSize: Int32;
BytesRemaining: Int64;
P: PByte;
ChunkSize: Integer;
bmp: TBitmap;
const
MaxChunkSize: Int64 = 8192;
begin
Stream := TMemoryStream(Socket.Data);
// receiving the image size
if Stream = nil then
begin
if Socket.ReceiveLength < SizeOf(TempSize) then Exit;
BytesReceived := Socket.ReceiveBuf(TempSize, SizeOf(TempSize));
if BytesReceived <= 0 then Exit;
StreamSize := ntohl(TempSize);
Stream := TMemoryStream.Create;
Socket.Data := Stream;
Stream.Size := StreamSize;
BytesRemaining := StreamSize;
end else
BytesRemaining := Stream.Size - Stream.Position;
// receiving the image
if BytesRemaining > 0 then
begin
P := PByte(Stream.Memory);
if Stream.Position > 0 then
Inc(P, Stream.Position);
repeat
ChunkSize := Integer(Math.Min(BytesRemaining, MaxChunkSize));
BytesReceived := Socket.ReceiveBuf(P^, ChunkSize);
if BytesReceived <= 0 then Exit;
Inc(P, BytesReceived);
Dec(BytesRemaining, BytesReceived);
Stream.Seek(soCurrent, BytesReceived);
until BytesRemaining = 0;
end;
// loading the image
try
bmp := TBitmap.Create;
try
Stream.Position := 0;
bmp.LoadFromStream(Stream);
Image1.Picture.Bitmap.Assign(bmp);
finally
bmp.Free;
end;
finally
Socket.Data := nil;
Stream.Free;
end;
end;
uses
..., System.Math, Winapi.WinSock;
function SendRaw(Sckt: TSocket; const Data; Size: Integer);
var
P: PByte;
BytesSent: Integer;
begin
Result := 0;
P := PByte(#Data);
while Size > 0 do
begin
BytesSent := send(Sckt, P^, Size, 0);
if BytesSent = -1 then Exit;
Inc(P, BytesSent);
Dec(Size, BytesSent);
Inc(Result, BytesSent);
end;
end;
procedure WriteToSocket(Socket: TCustomWinSocket; const Data; Size: Integer);
var
Stream: TMemoryStream;
P: PByte;
BytesSent: Integer;
begin
if Size <= 0 then Exit;
Stream := TMemoryStream(Socket.Data);
P := PByte(#Data);
if not ((Stream <> nil) and (Stream.Size > 0)) then
begin
BytesSent := SendRaw(Socket.SocketHandle, P^, Size);
if BytesSent > 0 then
begin
Dec(Size, BytesSent);
if Size = 0 then Exit;
Inc(P, BytesSent);
end;
end;
if Stream = nil then
begin
Stream := TMemoryStream.Create;
Socket.Data := Stream;
end else
Stream.Seek(soEnd, 0);
Stream.WriteBuffer(P^, Size);
end;
procedure TForm1.ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := nil;
end;
procedure TForm1.ClientSocket1Disconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
if Socket.Data <> nil then
TMemoryStream(Socket.Data).Free;
end;
procedure TForm1.ClientSocket1Write(Sender: TObject; Socket: TCustomWinSocket);
var
Stream: TMemoryStream;
BytesRemaining: Int64;
ChunkSize: Integer;
P: PByte;
begin
Stream := TMemoryStream(Socket.Data);
if Stream = nil then Exit;
BytesRemaining := Stream.Size;
if BytesRemaining = 0 then Exit;
P := PByte(Stream.Memory);
repeat
ChunkSize := Integer(Math.Min(BytesRemaining, MaxInt));
BytesSent := SendRaw(Socket.SocketHandle, P^, ChunkSize);
if BytesSent > 0 then
begin
Inc(P, BytesSent);
Dec(BytesRemaining, BytesSent);
end;
until (BytesSent < ChunkSize) or (BytesRemaining = 0);
if BytesRemaining = 0 then
Stream.Clear
else if P > Stream.Memory then
begin
MoveMemory(Stream.Memory, P, BytesRemaining);
Stream.Size := BytesRemaining;
end;
end;
procedure TForm1.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
var
Stream: TMemoryStream;
bmp: TBitmap;
StreamSize, TempSize: Int32;
begin
...
Stream := TMemoryStream.Create;
try
// saving the bitmap image
bmp := TBitmap.Create;
try
CaptureImage(bmp);
bmp.SaveToStream(Stream);
finally
bmp.Free;
end;
// sending the TBitmap image
StreamSize := Stream.Size;
TempSize := htonl(StreamSize);
WriteToSocket(Socket, TempSize, sizeof(TempSize));
WriteToSocket(Socket, Stream.Memory^, StreamSize);
finally
Stream.Free;
end;
end;

Related

TCP communication between localhost client and server has corrupted data

I am trying to stream raw h264 video packets from a (IcsOverbyte) Server (TWSocketServer) to a Client(TWSocket) however I've been having some trouble trying to properly assemble the messages.
Before going into my question I just wanted to say that I've confirmed that the .h264 data is valid, after I serialize my message I deserialize it and save the video-packet data part into a file and play it with VLC, the file is playable with no issues. That way I also confirmed that my Serialize/Deserialize routine is correct (both server and client have the same source for the types and ser/des routine).
My message is like so ->
TMessageHeader = packed record
MessageID: UInt32;
TotalSize: UInt32; {Meaning HeaderSize + Payload}
end;
TMediaDataMessage = record
Header: TMessageHeader;
Channel: UInt32;
Stream: UInt32;
MediaType: Byte; {0 - Video, 1 - Audio}
Data: TArray<Byte>;
function FromBytes(pBytes: TArray<Byte>): Boolean;
function ToBytes: TArray<Byte>;
function GetSize: UInt32;
end;
On the client-side I have a message assembly routine like this...
procedure TfrmMain.HandleDataAvailable(pSender: TObject; ErrCode: Word);
var
vRcvdCount: Integer;
vBytes: TBytes;
vMessageTotalSize: UInt32;
vOffset: UInt32;
begin
{$POINTERMATH ON}
if ErrCode <> 0 then
Exit;
if pSender = nil then
Exit;
SetLength(vBytes, 65536);
vRcvdCount := fTCPClient.Receive(#vBytes[0], 65536);
vOffset := 0;
try
if fRemainingDataSize > 0 then
begin
if vRcvdCount >= fRemainingDataSize then
begin
fCurrentBuf.Write(vBytes[vOffset], fRemainingDataSize);
Inc(vOffset, fRemainingDataSize);
Dec(vRcvdCount, fRemainingDataSize);
fRemainingDataSize := 0;
SetHandleMessage(fIdx.ToString + 'Sync');
end
else
begin
fCurrentBuf.Write(vBytes[vOffset], vRcvdCount);
Dec(fRemainingDataSize, vRcvdCount);
end;
end;
except
reLog.Lines.Add('Error sync');
end;
try
while (vRcvdCount > 0) do
begin
vMessageTotalSize := PUInt32(#vBytes[vOffset + 4])^;
if vRcvdCount >= vMessageTotalSize then
begin
fCurrentBuf.Write(vBytes[vOffset], vMessageTotalSize);
Inc(vOffset, vMessageTotalSize);
Dec(vRcvdCount, vMessageTotalSize);
SetHandleMessage('Loop');
end
else
begin
fCurrentBuf.Write(vBytes[vOffset], vRcvdCount);
fRemainingDataSize := vMessageTotalSize - vRcvdCount;
vRcvdCount := 0;
end;
end;
except
reLog.Lines.Add('Loop');
end;
//fTcpClient.Flush;
end;
FYI the exceptions never occur.
And this is the SetHandleMessage procedure
procedure TfrmMain.SetHandleMessage(pSort: string);
var
vMsgBytes: TArray<Byte>;
vMessageID: UInt32;
begin
fCurrentBuf.Position := 0;
SetLength(vMsgBytes, fCurrentBuf.Size);
fCurrentBuf.Read(vMsgBytes[0], fCurrentBuf.Size);
fCurrentBuf.Clear;
vMessageID := PUInt32(#vMsgBytes[0])^;
HandleMessage(vMessageID, vMsgBytes, pSort);
end;
I've been chasing my own tail for a while now I can't seem to pinpoint what is the issue.
I've also tried just streaming the raw .h264 to the client and save it to file and it works as well...
It seems the only thing that could be wrong is the message assembly routine.
Edit:. Decided to add the serialization functions.
function TMediaDataMessage.FromBytes(pBytes: TArray<Byte>): Boolean;
var
vLen: Integer;
vOffset: Integer;
vArrSize: UInt32;
begin
vOffset := 0;
Move(pBytes[vOffset], PByte(#Header.MessageId)[0], Sizeof(Header.MessageID));
Inc(vOffset, Sizeof(Header.MessageID));
Move(pBytes[vOffset], PByte(#Header.TotalSize)[0], Sizeof(Header.TotalSize));
Inc(vOffset, Sizeof(Header.TotalSize));
Move(pBytes[vOffset], PByte(#Channel)[0], Sizeof(Channel));
Inc(vOffset, Sizeof(Channel));
Move(pBytes[vOffset], PByte(#Stream)[0], Sizeof(Stream));
Inc(vOffset, Sizeof(Stream));
Move(pBytes[vOffset], PByte(#MediaType)[0], Sizeof(MediaType));
Inc(vOffset, Sizeof(MediaType));
Move(pBytes[vOffset], PByte(#vArrSize)[0], Sizeof(vArrSize));
Inc(vOffset, Sizeof(vArrSize));
if vArrSize <> 0 then
begin
SetLength(Data, vArrSize);
Move(pBytes[vOffset], Data[0], vArrSize);
end;
Exit(True);
end;
function TMediaDataMessage.GetSize: UInt32;
begin
Result := (Sizeof(uInt32) *2) + Sizeof(Channel) + Sizeof(Stream) +
Sizeof(MediaType) + Sizeof(UInt32) + Length(Data);
end;
function TMediaDataMessage.ToBytes: TArray<Byte>;
var
vSize: UInt32;
vOffset: UInt32;
vLen: UInt32;
begin
vSize := Self.GetSize;
SetLength(Result, vSize);
vOffset := 0;
Move(Self.Header.MessageID, Result[vOffset], Sizeof(Self.Header.MessageID));
Inc(vOffset, Sizeof(Self.Header.MessageID));
Move(Self.Header.TotalSize, Result[vOffset], Sizeof(Self.Header.TotalSize));
Inc(vOffset, Sizeof(Self.Header.TotalSize));
Move(Self.Channel, Result[vOffset], Sizeof(Self.Channel));
Inc(vOffset, Sizeof(Self.Channel));
Move(Self.Stream, Result[vOffset], Sizeof(Self.Stream));
Inc(vOffset, Sizeof(Self.Stream));
Move(Self.MediaType, Result[vOffset], Sizeof(Self.MediaType));
Inc(vOffset, Sizeof(Self.MediaType));
vLen := Length(Self.Data);
Move(vLen, Result[vOffset], Sizeof(UInt32));
Inc(vOffset, Sizeof(UInt32));
if vLen > 0 then
Move(Self.Data[0], Result[vOffset], vLen);
end;
I figured it out...
I had to set vRcvdCount to 0 in the first else statement.
Looks like this now ->
procedure TfrmMain.HandleDataAvailable(pSender: TObject; ErrCode: Word);
var
vRcvdCount: Integer;
vBytes: TBytes;
vMessageTotalSize: UInt32;
vOffset: UInt32;
begin
{$POINTERMATH ON}
if ErrCode <> 0 then
Exit;
if pSender = nil then
Exit;
SetLength(vBytes, 65536);
vRcvdCount := fTCPClient.Receive(#vBytes[0], 65536);
vOffset := 0;
try
if fRemainingDataSize > 0 then
begin
if vRcvdCount >= fRemainingDataSize then
begin
fCurrentBuf.Write(vBytes[vOffset], fRemainingDataSize);
Inc(vOffset, fRemainingDataSize);
Dec(vRcvdCount, fRemainingDataSize);
fRemainingDataSize := 0;
SetHandleMessage(fIdx.ToString + 'Sync');
end
else
begin
fCurrentBuf.Write(vBytes[vOffset], vRcvdCount);
Dec(fRemainingDataSize, vRcvdCount);
vRcvdCount := 0; \\ Add this here!!!
end;
end;
except
reLog.Lines.Add('Error sync');
end;
try
while (vRcvdCount > 0) do
begin
vMessageTotalSize := PUInt32(#vBytes[vOffset + 4])^;
if vRcvdCount >= vMessageTotalSize then
begin
fCurrentBuf.Write(vBytes[vOffset], vMessageTotalSize);
Inc(vOffset, vMessageTotalSize);
Dec(vRcvdCount, vMessageTotalSize);
SetHandleMessage('Loop');
end
else
begin
fCurrentBuf.Write(vBytes[vOffset], vRcvdCount);
fRemainingDataSize := vMessageTotalSize - vRcvdCount;
vRcvdCount := 0;
end;
end;
except
reLog.Lines.Add('Loop');
end;
//fTcpClient.Flush;
end;

delphi THashSHA2 return a wrong SHA256 on huge file

Data.Cloud.CloudAPI.pas has class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string; that return wrong SHA 256 on some file.
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
LBytes : TBytes;
Hash: THashSHA2;
begin
LBytes := TBytesStream(Content).Bytes;
//Hash bytes
Hash := THashSHA2.Create;
Hash.Update(LBytes);
Result := Hash.HashAsString;
end;
AWS S3 return error:
The provided x-amz-content-sha256 header does not match what was computed
GetStreamToHashSHA256Hex seems produce a different sha256 from amazon:
<ClientComputedContentSHA256>f43ee89e2b7758057bb1f33eb8546d4c2c118f2ab932de89dbd74aabc0651053</ClientComputedContentSHA256>
<S3ComputedContentSHA256>3bbf5f864cc139cf6392b4623bd782a69d16929db713bffaa68035f8a5c3c0ce</S3ComputedContentSHA256>
I have made some tests wit a myfile.zip (600 MB) ...
TIdHashSHA256 an alternative from Indy return the right SHA256 (same of aws s3), eg.:
var
aFileStream: TFileStream;
aHash: TIdHashSHA256;
begin
aFileStream := TFileStream.Create('C:\myfile.zip', fmOpenRead or fmShareDenyWrite);
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStreamAsHex(aFileStream).ToLower;
finally
aFileStream.Free;
aHash.Free;
end;
end;
hash_file() from PHP return the right SHA256 (same of aws s3), eg.:
hash_file('sha256', 'C:\myfile.zip');
but THashSHA2 return a wrong sha256, eg.:
var
LBytes : TBytes;
Hash: THashSHA2;
begin
LBytes := TFile.ReadAllBytes('C:\myfile.zip');
Hash := THashSHA2.Create;
Hash.Update(LBytes);
Result := Hash.HashAsString;
end;
why?
UPDATE
this is my bug fix. Import Data.Cloud.CloudAPI.pas into the project and rewrite these function:
uses IdHash, IdHashSHA, IdSSLOpenSSL;
class function TCloudSHA256Authentication.GetHashSHA256Hex( HashString: string): string;
var
aHash: TIdHashSHA256;
begin
LoadOpenSSLLibrary;
try
if not(TIdHashSHA256.IsAvailable) then
raise Exception.Create('HashSHA256 Isn''t available!');
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStringAsHex(HashString).ToLower;
finally
aHash.Free;
end;
finally
UnLoadOpenSSLLibrary;
end;
end;
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
aHash: TIdHashSHA256;
begin
LoadOpenSSLLibrary;
try
if not(TIdHashSHA256.IsAvailable) then
raise Exception.Create('HashSHA256 Isn''t available!');
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStreamAsHex(Content).ToLower;
finally
aHash.Free;
end;
finally
UnLoadOpenSSLLibrary;
end;
end;
UPDATE 2
i have also try to implement the FredS suggestion, it works:
class function TCloudSHA256Authentication.GetHashSHA256Hex( HashString: string): string;
var
Content: TStringStream;
Hash: THashSHA2;
LBytes: TArray<Byte>;
Buffer: PByte;
BufLen: Integer;
Readed: Integer;
begin
BufLen := 16 * 1024;
Buffer := AllocMem(BufLen);
Hash := THashSHA2.Create;
Content := TStringStream.Create(HashString);
try
while Content.Position < Content.Size do
begin
Readed := Content.Read(Buffer^, BufLen);
if Readed > 0 then
Hash.update(Buffer^, Readed);
end;
finally
Content.Free;
FreeMem(Buffer);
end;
Result := Hash.HashAsString;
end;
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
LBytes : TBytes;
Hash: THashSHA2;
Buffer: PByte;
BufLen: Integer;
Readed: Integer;
begin
BufLen := 16 * 1024;
Buffer := AllocMem(BufLen);
Hash := THashSHA2.Create;
try
Content.Seek(0, soFromBeginning);
while Content.Position < Content.Size do
begin
Readed := Content.Read(Buffer^, BufLen);
if Readed > 0 then
Hash.update(Buffer^, Readed);
end;
Content.Seek(0, soFromBeginning);
finally
FreeMem(Buffer);
end;
Result := Hash.HashAsString;
end;
I just tested a +1.5 GB file using MS Cyrpto and THashSHA2 on Berlin, they both returned the same hash but MS Crypto like OpenSSL is much faster.
The problem is that the file is too large to hold in TBytes in one chunk.
My record helper has TBytes.MaxLen = $F000; {61440} so you need to use a TFileStream and read the file in chunks into HashSHA2.Update instead.
Update:
As per David Heffernan's comment I retested TBytes.MaxLen and it appears to be only limited by available memory.
Practical Example and Speed comparison between MS Crypto and Delphi HashSha2
Note: Requires Jedi API
program SHA2SpeedTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
JwaWindows, Winapi.Windows, System.SysUtils, System.Classes, System.Diagnostics, System.Hash;
const
SHA256_LEN = 256 div 8;
ChunkSize = $F000;
type
TBytesHelper = record helper for TBytes
public
function BinToHex: string;
end;
function TBytesHelper.BinToHex: string;
var
Len : Integer;
begin
Len := Length(Self);
SetLength(Result, Len * 2));
System.Classes.BinToHex(Self, PChar(Result), Len);
end;
procedure DelphiHash256(const AStream: TStream; out Bytes: TBytes);
var
HashSHA2: THashSHA2;
BytesRead: Integer;
begin
HashSHA2 := THashSHA2.create;
SetLength(Bytes, ChunkSize);
AStream.Position := 0;
repeat
BytesRead := AStream.Read(Bytes, ChunkSize);
if (BytesRead = 0) then Break; // Done
HashSHA2.Update(Bytes, BytesRead);
until False;
Bytes := HashSHA2.HashAsBytes;
end;
function CryptoHash256(const AStream: TStream; out Bytes: TBytes): Boolean;
var
SigLen : Cardinal;
hHash : HCRYPTHASH;
hProv : HCRYPTPROV;
BytesRead: Integer;
begin
hProv := 0; hHash := 0;
Result := False;
If not CryptAcquireContext(hProv, nil, nil, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) then Exit;
try
if not CryptCreateHash(hProv, CALG_SHA_256, 0, 0, hHash) then Exit;
try
SetLength(Bytes, ChunkSize);
AStream.Position := 0;
repeat
BytesRead := AStream.Read(Bytes, ChunkSize);
if (BytesRead = 0) then Break; // Done
if not CryptHashData(hHash, #Bytes[0], BytesRead, 0) then Exit;
until False;
SigLen := SHA256_LEN;
SetLength(Bytes, SigLen);
Result := CryptGetHashParam(hHash, HP_HASHVAL, #Bytes[0], SigLen, 0);
finally
CryptDestroyHash(hHash);
end;
finally
CryptReleaseContext(hProv, 0);
end;
end;
var
Stream: TStream;
Bytes : TBytes;
sw : TStopwatch;
CryptoTicks : int64;
FileName : string;
{* CheckFileName *}
function CheckFileName: boolean;
begin
if (FileName='') then FileName := ParamStr(0);
Result := FileExists(FileName);
if not Result then Writeln('Invalid File name');
end;
begin
repeat
Writeln('Please Enter a valid File name, empty for this Executable');
Readln(FileName);
until CheckFileName;
try
Stream := TFileStream.Create(FileName, fmOpenRead + fmShareDenyNone);
try
WriteLn('Crypto - Calculating Checksum');
sw.Start;
if not CryptoHash256(Stream, Bytes) then raise Exception.Create('Something Happened :)');
sw.Stop;
Writeln(Bytes.BinToHex);
WriteLn('Elapsed: ' + sw.Elapsed.ToString);
CryptoTicks := sw.ElapsedTicks;
WriteLn('Delphi - Calculating Checksum');
sw.Reset; sw.Start;
DelphiHash256(Stream, Bytes);
sw.Stop;
Writeln(Bytes.BinToHex);
WriteLn('Elapsed: ' + sw.Elapsed.ToString);
Writeln(Format('MS Crypto is %d%% faster', [(sw.ElapsedTicks-CryptoTicks) * 100 div CryptoTicks]));
finally
Stream.Free;
end;
Writeln('Hit <Enter> to exit');
Readln;
except
on E: Exception do Writeln(E.ClassName, ': ', E.Message);
end;
end.

Error message: "Bitmap Image is not valid" on received from Socket

I'm trying to get a screenshot and send it over the web using ClientSocket and ServerSocket components.
I'm having problems when I try to turn the stream received at ServerSocket into a picture again. Error message "Bitmap Image is not valid!" when performing:
DesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
I do not know if the problem is in the way sending the image or get in the way.
My server code:
unit UntThreadDesktop;
interface
uses
System.Classes,
System.SysUtils,
System.Win.ScktComp,
WinApi.Windows,
WinApi.ActiveX,
Vcl.Graphics,
Vcl.Imaging.Jpeg,
UntDesktopForm;
type
TThreadDesktop = class(TThread)
private
FSocket: TCustomWinSocket;
FDesktopForm: TDesktopForm;
public
constructor Create(ASocket: TCustomWinSocket);
destructor Destroy; override;
procedure Execute; override;
end;
implementation
uses
UntLibraries;
{ TThreadDesktop }
constructor TThreadDesktop.Create(ASocket: TCustomWinSocket);
begin
inherited Create(true);
FreeOnTerminate := true;
FSocket := ASocket;
end;
destructor TThreadDesktop.Destroy;
begin
inherited;
end;
procedure TThreadDesktop.Execute;
var
text: string;
fileSize: integer;
ms: TMemoryStream;
buf: Pointer;
nBytes: integer;
jpg: TJPEGImage;
begin
inherited;
CoInitialize(nil);
try
// Init DesktopForm
Synchronize(procedure begin
FDesktopForm := TDesktopForm.Create;
FDesktopForm.Show;
end);
ms := TMemoryStream.Create;
try
FSocket.SendText('<|GetScreen|>');
while FSocket.Connected and (not Self.Terminated) and (FDesktopForm <> nil) do
begin
if FSocket.ReceiveLength > 0 then
begin
ms.Clear;
text := string(FSocket.ReceiveText);
text := Copy(text,1, Pos(#0,text)-1);
fileSize := StrToInt(text);
// Receiving file
while FSocket.Connected and (not Self.Terminated) and (FDesktopForm <> nil) do
begin
Synchronize(procedure begin
if FDesktopForm <> nil then
FDesktopForm.panInfo.Caption := 'Total: ' + IntToStr(ms.Size) +
' de ' + IntToStr(fileSize);
end);
try
text := '';
GetMem(buf, FSocket.ReceiveLength);
try
nBytes := FSocket.ReceiveBuf(buf^, FSocket.ReceiveLength);
if nBytes > 0 then
ms.Write(buf^, nBytes);
if (ms.Size = fileSize) or (nBytes <= 0) then
begin
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
//jpg := TJPEGImage.Create;
//jpg.LoadFromStream(ms);
// Carrega a imagem
Synchronize(procedure begin
if FDesktopForm <> nil then
//FDesktopForm.imgScreen.Picture.Assign(jpg);
FDesktopForm.imgScreen.Picture.Graphic.LoadFromStream(ms);
end);
end;
finally
FreeMem(buf);
end;
except
end;
end;
end;
TThread.Sleep(10);
end;
finally
ms.Free;
// Close DesktopForm
Synchronize(procedure begin
if FDesktopForm <> nil then
FDesktopForm.Close;
end);
end;
finally
CoUninitialize;
end;
end;
end.
It´s a thread used to receive the image in background.
In the main form of my application server I own a TServerSocket component working with the ServerType property to stThreadBlocking.
In my client application I have TClientSocket component using the property ClientType as ctNonBlocking.
My thread code:
unit UntThreadDesktopClient;
interface
uses
System.Classes,
System.SysUtils,
System.Win.ScktComp,
WinApi.Windows,
WinApi.ActiveX,
Vcl.Imaging.Jpeg,
Vcl.Graphics,
Vcl.Forms;
type
TThreadDesktopClient = class(TThread)
private
FSocket: TClientSocket;
FStream: TMemoryStream;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
procedure Execute; override;
private
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure GetScreen(stream: TMemoryStream);
end;
implementation
{ TThreadDesktopClient }
constructor TThreadDesktopClient.Create(AHostname: string; APort: integer);
begin
inherited Create(true);
FreeOnTerminate := true;
FStream := TMemoryStream.Create;
FSocket := TClientSocket.Create(nil);
FSocket.ClientType := ctNonBlocking;
FSocket.Host := AHostname;
FSocket.Port := APort;
FSocket.OnConnect := OnConnect;
FSocket.Open;
end;
destructor TThreadDesktopClient.Destroy;
begin
FStream.Free;
if FSocket.Active then
FSocket.Close;
FSocket.Free;
inherited;
end;
procedure TThreadDesktopClient.Execute;
var
cmd: AnsiString;
begin
inherited;
CoInitialize(nil);
try
while FSocket.Active and not Self.Terminated do
begin
if FSocket.Socket.ReceiveLength > 0 then
begin
cmd := FSocket.Socket.ReceiveText;
if cmd = '<|GetScreen|>' then
begin
FStream.Clear;
GetScreen(FStream);
FStream.Position := 0;
FSocket.Socket.SendText(AnsiString(IntToStr(FStream.Size)) + #0);
FSocket.Socket.SendStream(FStream);
end
else
if cmd = '<|TYPE|>' then
begin
FSocket.Socket.SendText('<|TYPE-DESKTOP|>');
end;
end;
end;
finally
CoUninitialize;
end;
end;
procedure TThreadDesktopClient.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Start;
end;
procedure TThreadDesktopClient.GetScreen(stream: TMemoryStream);
var
DC: HDC;
bmp: TBitmap;
jpg: TJPEGImage;
begin
DC := GetDC(GetDesktopWindow);
try
bmp := TBitmap.Create;
jpg := TJPEGImage.Create;
try
//bmp.PixelFormat := pf8bit;
bmp.Width := GetDeviceCaps(DC, HORZRES);
bmp.Height := GetDeviceCaps(DC, VERTRES);
//bmp.Width := Screen.Width;
//bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, DC, 0, 0, SRCCOPY);
bmp.Modified := True;
//jpg.Assign(bmp);
//jpg.Compress;
stream.Clear;
//jpg.SaveToStream(stream);
bmp.SaveToStream(stream);
finally
bmp.Free;
jpg.Free;
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
end;
end.
For further clarification, I will also post my main thread of the client application and how it is called in the main form from my client application.
unit UntThreadMain;
interface
uses
System.Classes,
System.Win.ScktComp,
WinApi.ActiveX;
type
TThreadMain = class(TThread)
private
FClientSocket: TClientSocket;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
procedure Execute; override;
public
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
private
procedure SendInfo;
procedure OpenDesktopChannel;
end;
implementation
uses
UntClientMainForm,
UntThreadDesktopClient;
{ TThreadMain }
constructor TThreadMain.Create(AHostname: string; APort: integer);
begin
inherited Create(true);
FreeOnTerminate := false;
FClientSocket := TClientSocket.Create(nil);
FClientSocket.ClientType := ctNonBlocking;
FClientSocket.Host := AHostname;
FClientSocket.Port := APort;
FClientSocket.OnConnect := OnConnect;
FClientSocket.OnDisconnect := OnDisconnect;
FClientSocket.Open;
end;
destructor TThreadMain.Destroy;
begin
if FClientSocket.Active then
FClientSocket.Close;
FClientSocket.Free;
inherited;
end;
procedure TThreadMain.Execute;
var
cmd: AnsiString;
begin
inherited;
CoInitialize(nil);
try
while FClientSocket.Socket.Connected and not Self.Terminated do
begin
if FClientSocket.Socket.ReceiveLength > 0 then
begin
cmd := FClientSocket.Socket.ReceiveText;
if cmd = '<|TYPE|>' then
FClientSocket.Socket.SendText('<|TYPE-COMMAND|>')
else
if cmd = '<|INFO|>' then
SendInfo
else
if cmd = '<|REQUEST-DESKTOP|>' then
TThreadDesktopClient.Create(FClientSocket.Host, FClientSocket.Port);
end;
end;
finally
CoUninitialize;
end;
end;
procedure TThreadMain.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Start;
Synchronize(procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Conectado';
ClientMainForm.btnConectar.Caption := 'Desconectar';
end);
end;
procedure TThreadMain.OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Desconectado';
ClientMainForm.btnConectar.Caption := 'Conectar';
end);
end;
procedure TThreadMain.OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
end;
procedure TThreadMain.SendInfo;
var
cmd: AnsiString;
begin
cmd := '<|INFO|>;NomePC=Tiago-PC;SO=Windows Seven Professiona 64-bit;' +
'CPU=Intel Core i7 3ª Geração';
FClientSocket.Socket.SendText(cmd);
end;
end.
Note that this thread calls the TThreadDesktopClient.
In the main form of the application server, where the TServerSocket, got OnGetThread TServerSocket the method this way:
procedure TMainForm.ServerSocketGetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TThreadController.Create(false, ClientSocket);
end;
When an image is requested:
procedure TMainForm.pmiAcessarClick(Sender: TObject);
var
nI: integer;
begin
for nI := 0 to Pred(ServerSocket.Socket.ActiveConnections) do
begin
if ServerSocket.Socket.Connections[nI].SocketHandle = cdsClientesId.AsInteger then
ServerSocket.Socket.Connections[nI].SendText('<|REQUEST-DESKTOP|>');
end;
end;
Returning to my client application, this code is used to connect in server (TServerSocket).
procedure TClientMainForm.btnConectarClick(Sender: TObject);
begin
if FThreadMain = nil then
begin
FThreadMain := TThreadMain.Create('localhost', 6550);
end
else
begin
FThreadMain.Terminate;
FThreadMain.Free;
FThreadMain := nil;
end;
end;
So, this is all my code.
When an image is received, I try to load it on TImage get the error message: "Bitmap Image is not valid."
I've tried a few different ways to treat the stream sent by the client application. But it still fails.
Usually got the same error: "Bitmap Image is not valid."
There are a LOT of problems with the code you showed - ranging from a fundamental lack of understanding of how TClientSocket and TServerSocket actually work in general, to a lack of understanding of how to send/receive/parse over TCP/IP. I see very few things in your code that are correct.
You are creating multiple connections on the client side, making each one identify its type (command vs desktop), but your server code is not querying that type or even caring what the type is. It assumes every client is a desktop client and asks for its screen. So you can simplify your code on both sides by simply eliminating that second connection. It is not really needed anyway. You would keep your connections to a minimum to reduce overhead.
I would strongly suggest a re-write of your code.
Try something more like this instead:
Common:
unit UntSocketCommon;
uses
System.Classes,
System.Win.ScktComp;
interface
procedure ReadRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
function ReadLineFromSocket(Socket: TWinSocketStream): String;
function ReadIntegerFromSocket(Socket: TWinSocketStream): Integer;
procedure ReadStreamFromSocket(Socket: TWinSocketStream; Stream: TStream);
procedure WriteRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
procedure WriteLineToSocket(Socket: TWinSocketStream; const Value: String);
procedure WriteIntegerToSocket(Socket: TWinSocketStream; Value: Integer);
procedure WriteStreamToSocket(Socket: TWinSocketStream; Stream: TStream);
implementation
procedure ReadRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
var
PBuf: PByte;
nBytesRead: Integer;
begin
PBuf := PByte(Buf);
while BufLen > 0 do
begin
nBytesRead := Socket.Read(PBuf^, BufLen);
if nBytesRead < 1 then raise Exception.Create('Unable to read from socket');
Inc(PBuf, nBytesRead);
Dec(BufLen, nBytesRead);
end;
end;
function ReadLineFromSocket(Socket: TWinSocketStream): String;
var
Ch: AnsiChar;
Buf: array[0..255] of AnsiChar;
BufLen: Integer;
S: UTF8String;
procedure AppendBuf;
var
OldLen: Integer;
begin
OldLen := Length(S);
SetLength(S, OldLen + BufLen);
Move(Buf[0], S[OldLen], BufLen);
end;
begin
Result := '';
BufLen := 0;
repeat
ReadRawFromSocket(Socket, #Ch, SizeOf(Ch));
if Ch = #10 then Break;
if BufLen = Length(Buf) then
begin
AppendBuf;
BufLen := 0;
end;
Buf[BufLen] := Ch;
Inc(BufLen);
until False;
if BufLen > 0 then AppendBuf;
BufLen := Length(S);
if BufLen > 0 then
begin
if S[BufLen] = #13 then
SetLength(S, BufLen-1);
end;
Result := String(S);
end;
function ReadIntegerFromSocket(Socket: TWinSocketStream): Integer;
begin
ReadRawFromSocket(Socket, #Result, SizeOf(Result));
Result := ntohl(Result);
end;
procedure ReadStreamFromSocket(Socket: TWinSocketStream; Stream: TStream);
var
Size: Integer;
Buf: array[0..1023] of Byte;
nBytes: Integer;
begin
Size := ReadIntegerFromSocket(Socket);
while Size > 0 do
begin
nBytes := Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
ReadRawFromSocket(Socket, Buf[0], nBytes);
Stream.WriteBuffer(Buf[0], nBytes);
Dec(Size, nBytes);
end;
end;
procedure WriteRawToSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
var
PBuf: PByte;
nBytesWritten: Integer;
begin
PBuf := PByte(Buf);
while BufLen > 0 do
begin
nBytesWritten := Socket.Write(PBuf^, BufLen);
if nBytesWritten < 1 then raise Exception.Create('Unable to write to socket');
Inc(PBuf, nBytesWritten);
Dec(BufLen, nBytesWritten);
end;
end;
procedure WriteLineToSocket(Socket: TWinSocketStream; const Value: String);
var
S: UTF8String;
begin
S := UTF8String(Value + #13#10);
WriteRawToSocket(Socket, PAnsiChar(S), Length(S));
end;
procedure WriteIntegerToSocket(Socket: TWinSocketStream; Value: Integer);
begin
Value := htonl(Value);
WriteRawToSocket(Socket, #Value, SizeOf(Value));
end;
procedure WriteStreamToSocket(Socket: TWinSocketStream; Stream: TStream);
var
Size: Integer;
Buf: array[0..1023] of Byte;
nBytes: Integer;
begin
Size := Stream.Size - Stream.Position;
WriteIntegerToSocket(Socket, Size);
while Size > 0 do
begin
nBytes := Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
Stream.ReadBuffer(Buf[0], nBytes);
WriteRawToSocket(Socket, Buf[0], nBytes);
Dec(Size, nBytes);
end;
end;
end.
Server:
unit UntThreadDesktop;
interface
uses
System.Classes,
System.Win.ScktComp,
UntDesktopForm;
type
TThreadController = class(TServerClientThread)
private
FDesktopForm: TDesktopForm;
protected
procedure ClientExecute; override;
end;
implementation
uses
System.SysUtils,
WinApi.Windows,
Vcl.Graphics,
UntLibraries,
UntSocketCommon;
{ TThreadDesktop }
procedure TThreadController.ClientExecute;
var
fileSize: Integer;
ms: TMemoryStream;
buf: array[0..1023] of Byte;
nBytes: Integer;
SocketStrm: TWinSocketStream;
begin
SocketStrm := TWinSocketStream.Create(ClientSocket, 5000);
try
// Init DesktopForm
Synchronize(
procedure
begin
FDesktopForm := TDesktopForm.Create;
FDesktopForm.Show;
end
);
try
ms := TMemoryStream.Create;
try
while ClientSocket.Connected and (not Terminated) and (FDesktopForm <> nil) do
begin
ms.Clear;
WriteLineToSocket(SocketStrm, '<|GetScreen|>');
{
ReadStreamFromSocket(SocketStrm, ms);
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
end
);
}
fileSize := ReadIntegerFromSocket(SocketStrm);
while (ms.Size < fileSize) and ClientSocket.Connected and (not Terminated) and (FDesktopForm <> nil) do
begin
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.panInfo.Caption := 'Total: ' + IntToStr(ms.Size) + ' de ' + IntToStr(fileSize);
end
);
nBytes := fileSize - ms.Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
ReadRawFromSocket(SocketStrm, buf[0], nBytes);
ms.WriteBuffer(buf[0], nBytes);
if ms.Size = fileSize then
begin
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
end
);
end;
end;
end;
finally
ms.Free;
end;
finally
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.Close;
end
);
end;
finally
SocketStrm.Free;
end;
end;
end.
procedure TMainForm.ServerSocketGetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TThreadController.Create(false, ClientSocket);
end;
Client:
unit UntThreadMain;
interface
uses
System.Classes,
System.Win.ScktComp;
type
TThreadMain = class(TThread)
private
FClientSocket: TClientSocket;
FSocketStrm: TWinSocketStream;
procedure SendInfo;
procedure SendScreen;
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
protected
procedure Execute; override;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
end;
implementation
uses
System.SysUtils,
WinApi.Windows,
Vcl.Graphics,
UntClientMainForm,
UntSocketCommon;
{ TThreadMain }
constructor TThreadMain.Create(AHostname: string; APort: integer);
begin
inherited Create(false);
FreeOnTerminate := false;
FClientSocket := TClientSocket.Create(nil);
FClientSocket.ClientType := ctBlocking;
FClientSocket.Host := AHostname;
FClientSocket.Port := APort;
FClientSocket.OnConnect := OnConnect;
FClientSocket.OnDisconnect := OnDisconnect;
FClientSocket.OnError := OnError;
end;
destructor TThreadMain.Destroy;
begin
FClientSocket.Free;
inherited;
end;
procedure TThreadMain.Execute;
var
SocketStrm: TWinSocketStream;
cmd: String;
begin
FClientSocket.Open;
try
FSocketStrm := TWinSocketStream.Create(FClientSocket.Socket, 5000);
try
while FClientSocket.Socket.Connected and (not Terminated) do
begin
if SocketStrm.WaitForData(1000) then
begin
cmd := ReadLineFromSocket(SocketStrm);
if cmd = '<|INFO|>' then
begin
SendInfo
end
else if cmd = '<|GetScreen|>' then
begin
SendScreen;
end
end;
end;
finally
FSocketStrm.Free;
end;
finally
FClientSocket.Close;
end;
end;
procedure TThreadMain.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(
procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Conectado';
ClientMainForm.btnConectar.Caption := 'Desconectar';
end
);
end;
procedure TThreadMain.OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(
procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Desconectado';
ClientMainForm.btnConectar.Caption := 'Conectar';
end
);
end;
procedure TThreadMain.OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
Socket.Close;
end;
procedure TThreadMain.SendInfo;
var
cmd: string;
begin
cmd := '<|INFO|>;NomePC=Tiago-PC;SO=Windows Seven Professiona 64-bit;CPU=Intel Core i7 3ª Geração';
WriteLineToSocket(FSocketStrm, cmd);
end;
procedure TThreadMain.SendScreen;
var
DC: HDC;
bmp: TBitmap;
ms: TMemoryStream;
begin
ms := TMemoryStream.Create;
try
bmp := TBitmap.Create;
try
DC := GetDC(0);
try
//bmp.PixelFormat := pf8bit;
bmp.Width := GetDeviceCaps(DC, HORZRES);
bmp.Height := GetDeviceCaps(DC, VERTRES);
//bmp.Width := Screen.Width;
//bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, DC, 0, 0, SRCCOPY);
finally
ReleaseDC(0, DC);
end;
bmp.SaveToStream(ms);
finally
bmp.Free;
end;
ms.Position := 0;
WriteStreamToSocket(FSocketStrm, ms);
finally
ms.Free;
end;
end;
end.
procedure TClientMainForm.btnConectarClick(Sender: TObject);
begin
if FThreadMain = nil then
begin
FThreadMain := TThreadMain.Create('localhost', 6550);
end else
begin
FThreadMain.Terminate;
FThreadMain.WaitFor;
FThreadMain.Free;
FThreadMain := nil;
end;
end;

Sending a Dynamic array (Inside a record) through Socket?

i'm trying to transfer a record from server to client, directly using .SendBuf().
however, this record has a member which is a dynamic array, and i have read somewhere (here in SOF) that when sending records, the members must be STATIC (fixed-length), but the problem is... i cannot determine how many arguments i would send (in the future).
how can i solve this problem ?
procedure TServerClass.SendBufToSocket(const vmName: TVMNames; const vmArgs: Array of TValue);
var
// this record is sent to client
// vmName = method to be called [in]
// vmArgs = Argument for the method [in, optional]
BufRec: packed record
vmName: array[0..49] of char;
vmArgs: Array of TValue;
end;
s: string;
i: integer;
begin
// convert enum method name to string
s:= GetEnumName(TypeInfo(TVMNames), Integer(vmName));
// copy method name to record
lstrcpy(BufRec.vmName, pChar(s));
// copy arg array to record
SetLength(BufRec.vmArgs, length(vmArgs));
for i:=0 to high(vmArgs)
do BufRec.vmArgs[i] := vmArgs[i];
// send record
ServerSocket.Socket.Connections[idxSocket].SendBuf(PByte(#BufRec)^, SizeOf(BufRec));
end;
I found out from where i've read it, here:
ReceiveBuf from TCustomWinSocket won't work with dynamic arrays for the buffer
You will not be able to send the record as-is, so in fact you don't even need to use a record at all. You must serialize your data into a flat format that is suitable for transmission over a network. For example, when sending a string, send the string length before sending the string data. Likewise, when sending an array, send the array length before sending the array items. As for the items themselves, since TValue is dynamic, you have to serialize it into a flat format as well.
Try something like this on the sending side:
procedure TServerClass.SendBufToSocket(const vmName: TVMNames; const vmArgs: Array of TValue);
var
I: integer;
procedure SendRaw(Data: Pointer; DataLen: Integer);
var
DataPtr: PByte;
Socket: TCustomWinSocket;
Sent, Err: Integer;
begin
DataPtr := PByte(Data);
Socket := ServerSocket.Socket.Connections[idxSocket];
while DataLen > 0 do
begin
Sent := Socket.SendBuf(DataPtr^, DataLen);
if Sent > 0 then
begin
Inc(DataPtr, Sent);
Dec(DataLen, Sent)
end else
begin
Err := WSAGetLastError();
if Err <> WSAEWOULDBLOCK then
raise Exception.CreateFmt('Unable to sent data. Error: %d', [Err]);
Sleep(10);
end;
end;
end;
procedure SendInteger(Value: Integer);
begin
Value := htonl(Value);
SendRaw(#Value, SizeOf(Value));
end;
procedure SendString(const Value: String);
var
S: UTF8string;
Len: Integer;
begin
S := Value;
Len := Length(S);
SendInteger(Len);
SendRaw(PAnsiChar(S), Len);
end;
begin
SendString(GetEnumName(TypeInfo(TVMNames), Integer(vmName)));
SendInteger(Length(vmArgs));
for I := Low(vmArgs) to High(vmArgs) do
SendString(vmArgs[I].ToString);
end;
And then on the receiving side:
type
TValueArray := array of TValue;
procedure TServerClass.ReadBufFromSocket(var vmName: TVMNames; var vmArgs: TValueArray);
var
Cnt, I: integer;
Tmp: String;
procedure ReadRaw(Data: Pointer; DataLen: Integer);
var
DataPtr: PByte;
Socket: TCustomWinSocket;
Read, Err: Integer;
begin
DataPtr := PByte(Data);
Socket := ClientSocket.Socket;
while DataLen > 0 do
begin
Read := Socket.ReceiveBuf(DataPtr^, DataLen);
if Read > 0 then
begin
Inc(DataPtr, Read);
Dec(DataLen, Read);
end
else if Read = 0 then
begin
raise Exception.Create('Disconnected');
end else
begin
Err := WSAGetLastError();
if Err <> WSAEWOULDBLOCK then
raise Exception.CreateFmt('Unable to read data. Error: %d', [Err]);
Sleep(10);
end;
end;
end;
function ReadInteger: Integer;
begin
ReadRaw(#Result, SizeOf(Result));
Result := ntohl(Result);
end;
function ReadString: String;
var
S: UTF8String;
Len: Integer;
begin
Len := ReadInteger;
SetLength(S, Len);
ReadRaw(PAnsiChar(S), Len);
Result := S;
end;
begin
vmName := TVMNames(GetEnumValue(TypeInfo(TVMNames), ReadString));
Cnt := ReadInteger;
SetLength(vmArgs, Cnt);
for I := 0 to Cnt-1 do
begin
Tmp := ReadString;
// convert to TValue as needed...
vmArgs[I] := ...;
end;
end;
With that said, note that socket programming is more complex than this simple example shows. You have to do proper error handling. You have to account for partial data sends and receives. And if you are using non-blocking sockets, if the socket enters a blocking state then you have to wait for it to enter a readable/writable state again before you can attempt to read/write data that is still pending. You are not doing any of that yet. You need to get yourself a good book on effective socket programming.
Update: if you are trying to utilize the OnRead and OnWrite events of the socket components, you have to take a different approach:
procedure TServerClass.ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TMemoryStream.Create;
end;
procedure TServerClass.ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TMemoryStream(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TServerClass.ClientWrite(Sender: TObject; Socket: TCustomWinSocket);
var
OutBuffer: TMemoryStream;
Ptr: PByte;
Sent, Len: Integer;
begin
OutBufer := TMemoryStream(Socket.Data);
if OutBuffer.Size = 0 then Exit;
OutBuffer.Position := 0;
Ptr := PByte(OutBuffer.Memory);
Len := OutBuffer.Size - OutBuffer.Position;
while Len > 0 do
begin
Sent := Socket.SendBuf(Ptr^, Len);
if Sent <= 0 then Break;
Inc(Ptr, Sent);
Dec(Len, Sent)
end;
if OutBuffer.Position > 0 then
begin
if OutBuffer.Position >= OutBuffer.Size then
OutBuffer.Clear
else
begin
Move(Ptr^, OutBuffer.Memory^, Len);
OutBuffer.Size := Len;
end;
end;
end;
procedure TServerClass.SendBufToSocket(const vmName: TVMNames; const vmArgs: Array of TValue);
var
I: integer;
Socket: TCustomWinSocket;
OutBuffer: TMemoryStream;
procedure SendRaw(Data: Pointer; DataLen: Integer);
var
DataPtr: PByte;
Sent: Integer;
begin
if DataLen < 1 then Exit;
DataPtr := PByte(Data);
if OutBuffer.Size = 0 then
begin
repeat
Sent := Socket.SendBuf(DataPtr^, DataLen);
if Sent < 1 then Break;
Inc(DataPtr, Sent);
Dec(DataLen, Sent)
until DataLen < 1;
end;
if DataLen > 0 then
begin
OutBuffer.Seek(0, soEnd);
OutBuffer.WriteBuffer(DataPtr^, DataLen);
end;
end;
procedure SendInteger(Value: Integer);
begin
Value := htonl(Value);
SendRaw(#Value, SizeOf(Value));
end;
procedure SendString(const Value: String);
var
S: UTF8string;
Len: Integer;
begin
S := Value;
Len := Length(S);
SendInteger(Len);
SendRaw(PAnsiChar(S), Len);
end;
begin
Socket := ServerSocket.Socket.Connections[idxSocket];
OutBuffer := TMemoryStream(Socket.Data);
SendString(GetEnumName(TypeInfo(TVMNames), Integer(vmName)));
SendInteger(Length(vmArgs));
for I := Low(vmArgs) to High(vmArgs) do
SendString(vmArgs[I].ToString);
end;
And then on the receiving side:
procedure TServerClass.ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TMemoryStream.Create;
end;
procedure TServerClass.ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TMemoryStream(Socket.Data).Free;
Socket.Data := nil;
end;
procedure TServerClass.ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
InBuffer: TMemoryStream;
Ptr: PByte;
OldSize, Pos, Read: Integer;
function HasAvailable(DataLen: Integer): Boolean;
being
Result := (InBuffer.Size - InBuffer.Position) >= DataLen;
end;
function ReadInteger(var Value: Integer);
begin
Result := False;
if HasAvailable(SizeOf(Integer)) then
begin
InBuffer.ReadBuffer(Value, SizeOf(Integer));
Value := ntohl(Value);
Result := True;
end;
end;
function ReadString(var Value: String);
var
S: UTF8String;
Len: Integer;
begin
Result := False;
if not ReadInteger(Len) then Exit;
if not HasAvailable(Len) then Exit;
SetLength(S, Len);
InBuffer.ReadBuffer(PAnsiChar(S)^, Len);
Value := S;
Result := True;
end;
function ReadNames: Boolean;
var
S: String;
vmName: TVMNames;
vmArgs: TValueArray;
begin
Result := False;
if not ReadString(S) then Exit;
vmName := TVMNames(GetEnumValue(TypeInfo(TVMNames), S));
if not ReadInteger(Cnt) then Exit;
SetLength(vmArgs, Cnt);
for I := 0 to Cnt-1 do
begin
if not ReadString(S) then Exit;
// convert to TValue as needed...
vmArgs[I] := ...;
end;
// use vmArgs as needed...
Result := True;
end;
begin
InBuffer := TMemoryStream(Socket.Data);
Read := Socket.ReceiveLength;
if Read <= 0 then Exit;
OldSize := InBuffer.Size;
InBuffer.Size := OldSize + Read;
try
Ptr := PByte(InBuffer.Memory);
Inc(Ptr, OldSize);
Read := Socket.ReceiveBuf(Ptr^, Read);
except
Read := -1;
end;
if Read < 0 then Read := 0;
InBuffer.Size := OldSize + Read;
if Read = 0 then Exit;
InBuffer.Position := 0;
repeat
Pos := InBuffer.Position;
until not ReadNames;
InBuffer.Position := Pos;
Read := InBuffer.Size - InBuffer.Position;
if Read < 1 then
InBuffer.Clear
else
begin
Ptr := PByte(InBuffer.Memory);
Inc(Ptr, InBuffer.Position);
Move(Ptr^, InBuffer.Memory^, Read);
InBuffer.Size := Read;
end;
end;
As mentioned in some comments, serialize your record to a stream and then send the stream contents over the wire. I use kbLib in some of my projects and it works really good.
You can use any dynamic type like strings, arrays in your record.
Small example:
type
TMyRecord = record
str : string;
end;
procedure Test;
var
FStream : TMemoryStream;
MYrecord : TMyRecord;
MYrecord1 : TMyRecord;
begin
FStream := TMemoryStream.Create;
try
MyRecord.Str := 'hello world';
// save record to stream
TKBDynamic.WriteTo(FStream, MyRecord, TypeInfo(TMyRecord));
FStream.Position := 0;
// read record from stream
TKBDynamic.ReadFrom(FStream, MyRecord1, TypeInfo(TMyRecord));
If MyRecord1.Str <> MyRecord.Str then
ShowMessage('this should not happen!');
finally
FStream.Free;
end;
end;

File not received if I free the instance of filestream anywhere?

I am trying to send a file using TServerSocket/TClientSocket. The file is sent completely as long as I do not free the filestream anywhere and by anywhere I mean form.OnCreate event too. If I do free anywhere only 1 or 2 percent is sent.
I also have to put the TFileStream.Create line of code on the server side OnCreate event. If I create a stream in TForm2.ServerSocket1ClientRead then I get an EFcreateerror: 'the process cannot access file because it is being used by another process''.
procedure TForm2.FormCreate(Sender: TObject);
begin
FStream := TFileStream.Create('c:\temp\log.txt', fmCreate or
fmShareDenyWrite);
end;
procedure TForm2.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
var
fs: TFileStream;
begin
fs := TFileStream.Create('c:\log.txt', fmOpenRead);
socket.SendStream(fs);
end;
procedure TForm2.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
iLen: Integer;
Bfr: Pointer;
begin
iLen := Socket.ReceiveLength;
GetMem(Bfr, iLen);
Socket.ReceiveBuf(Bfr^, iLen);
FStream.Write(Bfr^, iLen);
FreeMem(bfr);
//fstream.free
end;
Even if I put my code this way:
if fstream.Size = fstream.position then
fstream.free
Even then it gives me problem.
What is this strange phenomena? Is it a bug in Delphi? If yes is there a
work-around? If it matters: I am using Delphi 2010.
Update: sorry I meant if I put my code this way:
if fileSize = fstream.position then
fstream.free
Sorry, not fstream.size but filesize. I have already initialised file size as 300000 (size of file to be received).
Solved: Solved by replacing
FStream := TFileStream.Create('c:\temp\log.txt',
fmCreate or fmShareDenyWrite);
with
if not FileExists('c:\temp\log.txt') then
FStream := TFileStream.Create('c:\temp\log.txt',
fmCreate or fmShareDenyWrite);
You are trying to free your FStream object as soon as you receive the first block of data. Do not do that. That block will usually be smaller than the full file, especially if you are sending a large file. Also, checking for Position = Size on the receiving end is useless as well, as it will always evaluate be true since the current Position will always be at the end of the stream. As I already told you in the other discussion, you are not using the SendStream() and ReceiveBuf() methods effectively, and the sender needs to send the file size before sending the file data (or alternatively disconnect at the end of the file) so the receiver knows exactly when to stop its reading.
Edit:
Try something like this:
type
TSocketBuffer = class
public
Stream: TStream;
ExpectedSize: Int64;
Data: array[0..1023] of Byte;
DataOffset, DataSize: Integer;
destructor Destroy; override;
end;
TServerSocketBuffer = class(TSocketBuffer)
public
FileName: String;
destructor Destroy; override;
end;
destructor TSocketBuffer.Destroy;
begin
if Stream <> nil then Stream.Free;
inherited;
end;
destructor TServerSocketBuffer.Destroy;
begin
if Stream <> nil then FreeAndNil(Stream);
if FileName <> '' then DeleteFile(FileName);
inherited;
end;
procedure TForm2.ClientSocket1Connect(Sender: TObject; Socket: TCustomWinSocket);
var
Buffer: TSocketBuffer;
begin
Buffer := TSocketBuffer.Create;
Socket.Data := Buffer;
// open the file to send...
Buffer.Stream := TFileStream.Create('c:\log.txt', fmOpenRead or fmShareDenyWrite);
Buffer.ExpectedSize := Buffer.Stream.Size;
// buffer the stream size...
Move(Buffer.Data[0], Buffer.ExpectedSize, Sizeof(Int64));
Buffer.DataOffset := 0;
Buffer.DataSize := SizeOf(Int64);
// begin sending...
ClientSocket1Write(Sender, Socket);
end;
procedure TForm2.ClientSocket1Disconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketBuffer(Socket.Data).Free;
end;
procedure TForm2.ClientSocket1Write(Sender: TObject; Socket: TCustomWinSocket);
var
Buffer: TSocketBuffer;
NumBytes: Integer;
begin
// in case OnWrite is fired before OnConnect...
if Socket.Data = nil then Exit;
Buffer := TSocketBuffer(Socket.Data);
if Buffer.Stream = nil then Exit;
// keep sending until EOF is reached, or until the socket blocks/errors...
repeat
// if there is pending data buffered, send it now...
while Buffer.DataOffset < Buffer.DataSize do
begin
NumBytes := Socket.SendBuf(Buffer.Data[Buffer.DataOffset], Buffer.DataSize-Buffer.DataOffset);
if NumBytes <= 0 then Exit; // wait for next event...
Inc(Buffer.DataOffset, NumBytes);
end;
// has EOF been reached?
if Buffer.ExpectedSize <= 0 then Break;
// read the next block of data from the stream...
Buffer.DataOffset := 0;
Buffer.DataSize := 0;
NumBytes := Buffer.Stream.Read(Buffer.Data[0], Min(Buffer.ExpectedSize, SizeOf(Buffer.Data)));
if NumBytes <= 0 then Break; // stream error, stop sending...
Buffer.DataSize := NumBytes;
Dec(Buffer.ExpectedSize, NumBytes);
// the next loop iteration will start sending it...
until False;
// all done...
FreeAndNil(Buffer.Stream);
Socket.Close;
end;
procedure TForm2.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TServerSocketBuffer.Create;
end;
procedure TForm2.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TServerSocketBuffer(Socket.Data).Free;
end;
procedure TForm2.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
Buffer: TServerSocketBuffer;
FileName: String;
NumBytes: Integer;
begin
Buffer := TServerSocketBuffer(Socket.Data);
if Buffer.Stream = nil then
begin
// keep reading until stream size has been received in full...
while Buffer.DataSize < SizeOf(Int64) do
begin
NumBytes := Socket.ReceiveBuf(Buffer.Data[Buffer.DataOffset], SizeOf(Int64)-Buffer.DataOffset);
if NumBytes <= 0 then Exit; // wait for next event...
Inc(Buffer.DataSize, NumBytes);
Inc(Buffer.DataOffset, NumBytes);
end;
Move(Buffer.ExpectedSize, Buffer.Data[0], SizeOf(Int64));
// create the file to store in...
FileName := 'c:\temp\log.txt';
Buffer.Stream := TFileStream.Create(FileName, fmCreate);
Buffer.FileName := FileName;
// (optional) pre-size the file...
Buffer.Stream.Size := Buffer.ExpectedSize;
end;
// keep reading until EOF is reached, or until the socket blocks/errors...
while Buffer.ExpectedSize > 0 do
begin
// read the next block of data from the socket...
Buffer.DataOffset := 0;
Buffer.DataSize := 0;
NumBytes := Socket.ReceiveBuf(Buffer.Data[0], Min(Buffer.ExpectedSize, SizeOf(Buffer.Data)));
if NumBytes <= 0 then Exit; // wait for next event...
Buffer.DataSize := NumBytes;
// save the data to the stream....
repeat
NumBytes := Buffer.Stream.Write(Buffer.Data[Buffer.DataOffset], Buffer.DataSize-Buffer.DataOffset);
if NumBytes <= 0 then
// stream error, stop reading...
Socket.Close;
Exit;
end;
Inc(Buffer.DataOffset, NumBytes);
Dec(Buffer.ExpectedSize, NumBytes);
until Buffer.DataOffset >= Buffer.DataSize;
end;
// all done...
FreeAndNil(Buffer.Stream);
Buffer.FileName := '';
end;

Resources