ServerSocket only receive one time - delphi

I'm trying send a record over clientsocket and receive on serversocket, everything works well but only on first time, after send one time i need disconnect clientsocket, connect again to send it again.
If somebody can help me.
here is the server side code how i receive the informations:
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
LBuffer: TBytes;
LMessageBuffer: TBytes;
LDataSize: Integer;
LProtocol: TProtocol;
begin
LDataSize := Socket.ReceiveLength;
if LDataSize >= szProtocol then begin
try
Socket.ReceiveBuf(LBuffer, SizeOf(LBuffer));
LProtocol := BytesToProtocol(LBuffer);
// check client command and act accordingly
case LProtocol.Command of
cmdConnect: begin
Memo1.Lines.Add(Format('[%s][%s][%s]', ['Connect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end; // cmdConnect: begin
cmdDisconnect: begin
Memo1.Lines.Add(Format('[%s][%s][%s]', ['Disconnect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end; // cmdDisconnect: begin
end;
finally
ClearBuffer(LBuffer);
end;
end;
end;
and here the client side:
var
LBuffer: TBytes;
LProtocol: TProtocol;
x : Integer;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
ClientData.UserName := Edit1.Text;
ClientData.ID := Now;
LProtocol.Sender := ClientData;
LBuffer := ProtocolToBytes(LProtocol);
try
ClientSocket1.Socket.SendBuf(LBuffer, Length(LBuffer));
finally
ClearBuffer(LBuffer);
end;
record declaration:
type
TCommand = (
cmdConnect,
cmdDisconnect,
cmdMessageBroadcast,
cmdMessagePrivate,
cmdScreenShotGet,
cmdScreenShotData);
// client information structure, you can extend this based on your needs
type
TClient = record
UserName: string[50];
ID: TDateTime;
end; // TClient = record
// size of the client information structure
const
szClient = SizeOf(TClient);
Thanks :)

TBytes is a dynamic array, but you are treating it as if it were a static array.
In your client code, you are not sending LBuffer correctly. Being a dynamic array, LBuffer is just a pointer to data that is stored elsewhere in memory. So, you need to dereference LBuffer to pass the correct memory address to SendBuf().
In your server code, you are not even allocating any memory for LBuffer at all before reading bytes into it. And, like in the client, you need to dereference LBuffer when passing it to ReceiveBuf(). You also need to use the correct byte size when telling ReceiveBuf() how many bytes to read (SizeOf(TBytes) is the wrong value to use).
Lastly, you need to pay attention to the return values of SendBuf() and ReceiveBuf(), as they CAN return that fewer bytes than requested were processed! So, you should be calling SendBuf() and ReceiveBuf() in a loop.
Try this:
var
LBuffer: TBytes;
LProtocol: TProtocol;
LBufferPtr: PByte;
LBufferLen: Integer;
LNumSent: Integer;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
ClientData.UserName := Edit1.Text;
ClientData.ID := Now;
LProtocol.Sender := ClientData;
LBuffer := ProtocolToBytes(LProtocol);
LBufferPtr := PByte(LBuffer);
LBufferLen := Length(LBuffer);
repeat
LNumSent := ClientSocket1.Socket.SendBuf(LBufferPtr^, LBufferLen);
if LNumSent = -1 then
begin
// if ClientSocket1.ClientType is set to ctNonBlocking,
// uncomment this check ...
{
if WSAGetLastError() = WSAEWOULDBLOCK then
begin
// optionally call the Winsock select() function to wait
// until the socket can accept more data before calling
// SendBuf() again...
Continue;
end;
}
// ERROR!
ClientSocket1.Close;
Break;
end;
Inc(LBufferPtr, LNumSent);
Dec(LBufferLen, LNumSent);
until LBufferLen = 0;
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
LBuffer: TBytes;
LDataSize: Integer;
LProtocol: TProtocol;
LBufferPtr: PByte;
LBufferLen: Integer;
LNumRecvd: Integer;
begin
LDataSize := Socket.ReceiveLength;
if LDataSize < szProtocol then Exit;
SetLength(LBuffer, szProtocol);
repeat
// since you are validating ReceiveLength beforehand, ReceiveBuf()
// *should not* return fewer bytes than requested, but it doesn't
// hurt to be careful...
LBufferPtr := PByte(LBuffer);
LBufferLen := szProtocol;
repeat
LNumRecvd := Socket.ReceiveBuf(LBufferPtr^, LBufferLen);
if LNumRecvd <= 0 then Exit;
Inc(LBufferPtr, LNumRecvd);
Dec(LBufferLen, LNumRecvd);
Dec(LDataSize, LNumRecvd);
until LBufferLen = 0;
LProtocol := BytesToProtocol(LBuffer);
// check client command and act accordingly
case LProtocol.Command of
cmdConnect: begin
Memo1.Lines.Add(Format('[%s][%s][%s]', ['Connect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end;
cmdDisconnect: begin
Memo1.Lines.Add(Format('[%s][%s][%s]', ['Disconnect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end;
end;
until LDataSize < szProtocol;
end;
That being said, TClientSocket and TServerSocket have been deprecated for a LONG time. They are not even installed by default anymore (but are still available if you need to install them). You should really consider switching to another socket library that handles these kind of details for you, such as Indy's TIdTCPClient and TIdTCPServer (Indy is preinstalled in Delphi), eg:
type
PTIdBytes = ^TIdBytes;
var
LBuffer: TBytes;
LProtocol: TProtocol;
begin
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
ClientData.UserName := Edit1.Text;
ClientData.ID := Now;
LProtocol.Sender := ClientData;
LBuffer := ProtocolToBytes(LProtocol);
// TBytes and TIdBytes are technically the same thing under the hood,
// but they are still distinct types and not assignment-compatible,
// so using a dirty hack to pass a TBytes as a TIdBytes without having
// to make a copy of the bytes...
IdTCPClient1.IOHandler.Write(PTIdBytes(#LBuffer)^);
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
type
PTBytes = ^TBytes;
var
LBuffer: TIdBytes;
LProtocol: TProtocol;
// note: TIdTCPServer is a multi-threaded component, so you must
// sync with the main thread when accessing the UI...
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(AStr);
end
);
end;
begin
// ReadBytes() can allocate the buffer for you...
AContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol);
// using a similar dirty hack to pass a TIdBytes as a TBytes
// without making a copy of the bytes ...
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
// check client command and act accordingly
case LProtocol.Command of
cmdConnect: begin
AddToMemo(Format('[%s][%s][%s]', ['Connect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end;
cmdDisconnect: begin
AddToMemo(Format('[%s][%s][%s]', ['Disconnect', LProtocol.Sender.UserName, TimeToStr(LProtocol.Sender.ID)]));
end;
end;
end;

Related

Delphi - udp works in local but not works over network

I made a simple file transfer program with indy udp socket but there was a problem.
Since UDP does not guarantee the order of data, so I tried making udp reliable manually.
At first, I made a TPacket record which includes Serial Number,Next Number,
Index Number and array of byte(data).
Serial Number is the ID of the packet.
Next Number is the Serial Number of which the receiver needs to receive packet next.
Index Number is the index of the packet, which is used for sorting the packets when the sender sends many packets at once.
The sender divides the data into packets in the fixed length, and sends the total count of packets.
After that the sender tries sending the packets gradually: sends the count of packets, sends the packets, receives the index of error packets, re-sends the error packets.
(The receiver receives the packets and sorts the packets with index and if the missed packets exist the receiver sends the indexes of the missed packets.)
I tried sending a large file.
It works good in local(localhost, hotspot), but it sometimes stops when connected over network.(through AP,internet)
I debugged my app and I found there was a mismatch of Sending-Receiving(in the source, "SendAck" and "RecvAck")(e.g. the sender sends the count of packet and the receiver sends the indexes of error packets... the receiver should have received the count of packet.)
My Source(omitted some parts) :
unit UUDPHelper;
interface
uses
System.Classes, System.Generics.Collections, IdUDPClient, IdUDPServer, System.SysUtils,
System.Math, IdGlobal, IdSocketHandle, UCode, IdExceptionCore, IdStack,
System.Generics.Defaults, System.DateUtils;
type
TPacket = record
Serial:Int64;
Next:Int64;
Index:Int64;
data:TBytes;
end;
TIdAck = (IA_OK = 1,IA_FAIL);
EReadTimeout = class(Exception) end;
TUDPClient = class(TIdUDPClient)
private
RNum:Int64;
SNum:Int64;
function ReceiveBuffer:TBytes; overload;
function StreamToPackets(Stream:TMemoryStream):TList<TPacket>;
procedure SendAck(Ack:Int64);
function RecvAck(Timeout:Int64 = -1):Int64;
public
constructor Create(AOwner:TComponent);
procedure AtConnected(Sender:TObject);
procedure AtDisconnected(Sender:TObject);
procedure Signal; overload;
procedure Signal(Code:TCode); overload;
procedure DisconnectSignal;
procedure ConnectSignal;
procedure WriteInt64(value:Int64);
procedure WriteString(str:string);
procedure WriteStream(Stream:TMemoryStream);
function ReadInt64():Int64;
function ReadString():string;
procedure ReadStream(var Stream:TMemoryStream);
end;
TIPNum = record
IP:string;
RNum:Int64;
SNum:Int64;
end;
TUDPRead = reference to procedure(const AData:TBytes; ABinding:TIdSocketHandle);
TUDPServer = class(TIdUDPServer)
private
IPNumList:TList<TIPNum>;
function ReceiveBuffer(ABinding:TIdSocketHandle):TBytes;
procedure SetRNum(RNum:Int64; Idx:Integer);
procedure SetSNum(SNum:Int64; Idx:Integer);
procedure SendAck(Ack:Int64; ABinding:TIdSocketHandle);
function RecvAck(ABinding:TIdSocketHandle; Timeout:Int64 = -1):Int64;
public
AtUDPRead:TUDPRead;
constructor Create(AOwner:TComponent);
destructor Destroy;
procedure InUDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle);
function FindIPNum(IP:string):Integer;
function GetIPNum(IP:string):TIPNum;
procedure ClearIPNum;
function StreamToPackets(Stream:TMemoryStream; IP:string):TList<TPacket>;
procedure WriteInt64(value:Int64; ABinding:TIdSocketHandle);
procedure WriteString(str:string; ABinding:TIdSocketHandle);
procedure WriteStream(Stream:TMemoryStream; ABinding:TIdSocketHandle);
function ReadInt64(ABinding:TIdSocketHandle):Int64;
function ReadString(ABinding:TIdSocketHandle):string;
procedure ReadStream(var Stream:TMemoryStream; ABinding:TIdSocketHandle);
end;
procedure TUDPClient.ReadStream(var Stream: TMemoryStream);
var
count:Int64;
ack,ack2:TIdAck;
pList:TList<TPacket>;
buffer:TBytes;
packet:TPacket;
I,J,K:Int64;
T:Int64;
Amount:Integer;
Idxs,Temp:array of Int64;
nIdx,TempLen,pn:Integer;
IsFound:Boolean;
begin
count:=RecvAck(); // receive the total count of packets.
pList:=TList<TPacket>.Create();
I:=0;
T:=0;
nIdx:=0;
SetLength(Idxs,MAX_AMOUNT);
SetLength(Temp,MAX_AMOUNT);
while I<count do
begin
Amount:=RecvAck(); // receive the count of packets.
J:=0;
pn:=nIdx;
while nIdx<Amount do
begin
if T+J>=count then break;
Idxs[nIdx]:=T+J;
inc(nIdx);
inc(J);
end;
{Idxs is the array of indexes of packets which will be received soon.}
for J:=1 to Amount do
begin
try
buffer:=ReceiveBuffer();
except
buffer:=nil;
end;
if (buffer=nil) or (Length(buffer)=0) then break;
packet:=BytesToPacket(buffer);
if Length(packet.data)=0 then break;
IsFound:=False;
K:=0;
while K<pList.Count do
begin
if pList[K].Index=packet.Index then
begin
IsFound:=True;
break;
end;
inc(K);
end;
if IsFound then
pList.Delete(K);
pList.Add(packet);
Finalize(buffer);
end;
pList.Sort(TComparer<TPacket>.Construct(function(const Left,Right:TPacket):Integer
begin
Result:=Left.Index-Right.Index;
end));
//Finds the missed packets with Idxs array.
TempLen:=0;
for J:=0 to nIdx-1 do
begin
IsFound:=False;
for K:=I to pList.Count-1 do
if pList[K].Index=Idxs[J] then
begin
IsFound:=True;
break;
end;
if not IsFound then
begin
Temp[TempLen]:=Idxs[J];
inc(TempLen);
end;
end;
// counts the packets which is sent normally.
J:=I;
while J < pList.Count do
begin
if pList[J].Index <> J then
break;
inc(J);
end;
I:=J;
T := T + Amount - pn;
Move(Temp[0],Idxs[0],sizeof(Int64)*TempLen);
nIdx:=TempLen;
// if there is no missed packet, sends OK sign.
// else, sends FAIL and error indexes.
if nIdx=0 then
SendAck(Int64(IA_OK))
else
begin
SendAck(Int64(IA_FAIL));
SendAck(Int64(nIdx));
for J:=0 to nIdx-1 do
SendAck(Idxs[J]);
end;
end;
Finalize(Idxs);
Finalize(Temp);
Stream:=PacketsToStream(pList);
Stream.Position:=0;
for I:=0 to pList.Count-1 do
if Length(pList[I].data)>0 then
begin
buffer:=pList[I].data;
Finalize(buffer);
end;
pList.Free;
end;
procedure TUDPClient.WriteStream(Stream: TMemoryStream);
var
pList:TList<TPacket>;
buffer:TBytes;
ack,ack2:TIdAck;
Amount:Integer;
I,T:Int64;
ldt,dt,ot:TDateTime;
J:Integer;
Idxs:array of Int64;
nIdx,pn:Integer;
ncount:Integer;
Index:Int64;
IsFound:Boolean;
IsExcept:Boolean;
m:Int64;
begin
Stream.Position:=0;
pList:=StreamToPackets(Stream);
SendAck(Int64(pList.Count)); // sends the total count of packets
Amount:=30;
I:=0;
T:=0;
SetLength(Idxs,MAX_AMOUNT);
nIdx:=0;
ncount:=0;
ldt:=-1;
while I<pList.Count do
begin
// Fill Idxs array.
// Idxs array contains the indexes of packets to be sent soon.
J:=0;
while nIdx<Amount do
begin
if T+J>=pList.Count then break;
Idxs[nIdx]:=T+J;
inc(nIdx);
inc(J);
end;
pn:=nIdx;
SendAck(Int64(nIdx)); // sends the count of packets.
ot:=Date()+Time();
for J:=0 to nIdx-1 do
begin
buffer:=PacketToBytes( pList[Idxs[J]] );
SendBuffer(TIdBytes(buffer));
Finalize(buffer);
end;
ack:=TIdAck(RecvAck(10000)); // receives the ack of the receiver.
dt:=Date()+Time();
T:=T+nIdx-ncount;
if ack=IA_FAIL then // if failed, fill the idxs array with error indexs.
begin
nIdx:=RecvAck();
for J:=0 to nIdx-1 do
Idxs[J]:=RecvAck();
ncount:=nIdx;
end
else // if succeeded, clear the idxs array.
begin
ncount:=0;
nIdx:=0;
end;
I:=I+pn-nIdx;
// send-amount controlling //
if ldt<>-1 then
begin
if SecondsBetween(ot,ldt)>SecondsBetween(ot,dt) then
Amount:=Min(Amount+10,MAX_AMOUNT);
if SecondsBetween(ot,ldt)<SecondsBetween(ot,dt) then
Amount:=Max(Amount-10,Max(nIdx,30));
end;
ldt:=dt;
end;
Finalize(Idxs);
for I:=0 to pList.Count-1 do
if Length(pList[I].data)>0 then
begin
buffer:=pList[I].data;
Finalize(buffer);
end;
pList.Free;
end;
procedure TUDPClient.SendAck(Ack: Int64);
var
p:TPacket;
p2:TPacket;
o,t:TDateTime;
buffer:TBytes;
begin
p.Serial:=SNum;
p.Next:=Rand();
SNum:=p.Next;
p.Index:=Ack;
p2.Index:=Int64(IA_FAIL);
p2.Serial:=RNum;
o:=Date()+Time();
while not ((p2.Serial=RNum) and (p2.Index=Int64(IA_OK))) do
begin
if p2.Serial=RNum then
SendBuffer(TIdBytes(PacketToBytes(p)));
try
try
buffer:=ReceiveBuffer();
if Length(buffer)>24 then continue;
p2:=BytesToPacket(buffer);
except
end;
finally
Finalize(buffer);
t:=Date()+Time();
if SecondsBetween(o,t)>=5 then
begin
SNum:=p.Serial;
raise EReadTimeout.Create('Read Timeout');
end;
end;
end;
SendBuffer(TIdBytes(PacketToBytes(p)));
RNum:=p2.Next;
end;
function TUDPClient.RecvAck(Timeout:Int64): Int64;
var
p,p2,ap:TPacket;
buffer:TBytes;
o,t:TDateTime;
begin
if Timeout=-1 then
Timeout:=5000;
p.Serial:=RNum+1;
o := Date() + Time();
while p.Serial<>RNum do
begin
try
try
buffer:=ReceiveBuffer();
if Length(buffer)>24 then continue;
p := BytesToPacket(buffer);
except
end;
finally
T := Date() + Time();
if SecondsBetween(o,T) >= Timeout / 1000 then
raise EReadTimeout.Create('Read Timeout');
end;
end;
p2.Serial:=SNum;
p2.Next:=Rand();
SNum:=p2.Next;
p2.Index:=Int64(IA_OK);
o:=Date()+Time();
t:=o;
ap.Serial:=RNum+1;
while True do
begin
if SecondsBetween(o,t)>=2 then break;
SendBuffer(TIdBytes(PacketToBytes(p2)));
try
try
buffer:=ReceiveBuffer();
ap:=BytesToPacket(buffer);
except
continue;
end;
finally
t:=Date()+Time();
end;
if ap.Serial=RNum then
break;
end;
RNum:=p.Next;
Result:=p.Index;
end;
procedure TUDPServer.ReadStream(var Stream: TMemoryStream; ABinding:TIdSocketHandle);
var
count:Int64;
ack:TIdAck;
pList:TList<TPacket>;
buffer:TBytes;
packet:TPacket;
I,J,K:Int64;
T:Int64;
Amount:Integer;
Idxs,Temp:array of Int64;
nIdx,TempLen,pn:Integer;
IsFound:Boolean;
IPIdx:Integer;
IPNum:TIPNum;
begin
IPIdx:=FindIPNum(ABinding.PeerIP);
if IPIdx=-1 then Exit;
count:=RecvAck(ABinding);
pList:=TList<TPacket>.Create();
I:=0;
T:=0;
nIdx:=0;
SetLength(Idxs,MAX_AMOUNT);
SetLength(Temp,MAX_AMOUNT);
while I<count do
begin
Amount:=RecvAck(ABinding);
J:=0;
pn:=nIdx;
while nIdx<Amount do
begin
if T+J>=count then break;
Idxs[nIdx]:=T+J;
inc(nIdx);
inc(J);
end;
for J:=1 to Amount do
begin
try
buffer:=ReceiveBuffer(ABinding);
except
buffer:=nil;
end;
if (buffer=nil) or (Length(buffer)=0) then break;
packet:=BytesToPacket(buffer);
if Length(packet.data)=0 then break;
IsFound:=False;
K:=0;
while K<pList.Count do
begin
if pList[K].Index=packet.Index then
begin
IsFound:=True;
break;
end;
inc(K);
end;
if IsFound then
pList.Delete(K);
pList.Add(packet);
Finalize(buffer);
end;
pList.Sort(TComparer<TPacket>.Construct(function(const Left,Right:TPacket):Integer
begin
Result:=Left.Index-Right.Index;
end));
TempLen:=0;
for J:=0 to nIdx-1 do
begin
IsFound:=False;
for K:=I to pList.Count-1 do
if pList[K].Index=Idxs[J] then
begin
IsFound:=True;
break;
end;
if not IsFound then
begin
Temp[TempLen]:=Idxs[J];
inc(TempLen);
end;
end;
J:=I;
while J < pList.Count do
begin
if pList[J].Index <> J then
break;
inc(J);
end;
I:=J;
T:=T+Amount-pn;
Move(Temp[0],Idxs[0],sizeof(Int64)*TempLen);
nIdx:=TempLen;
if nIdx=0 then
SendAck(Int64(IA_OK),ABinding)
else
begin
SendAck(Int64(IA_FAIL),ABinding);
SendAck(Int64(nIdx),ABinding);
for J:=0 to nIdx-1 do
SendAck(Int64(Idxs[J]),ABinding);
end;
end;
Finalize(Idxs);
Finalize(Temp);
Stream:=PacketsToStream(pList);
Stream.Position:=0;
for I:=0 to pList.Count-1 do
if Length(pList[I].data)>0 then
begin
buffer:=pList[I].data;
Finalize(buffer);
end;
pList.Free;
end;
procedure TUDPServer.WriteStream(Stream: TMemoryStream; ABinding:TIdSocketHandle);
var
pList:TList<TPacket>;
packet:TPacket;
buffer:TBytes;
ack,ack2:TIdAck;
Amount:Integer;
I,T:Int64;
ldt,dt,ot:TDateTime;
J:Integer;
Idxs:array of Int64;
nIdx,pn:Integer;
ncount:Integer;
Index:Int64;
IsFound:Boolean;
IsExcept:Boolean;
m:Int64;
IPIdx:Integer;
begin
IPIdx:=FindIPNum(ABinding.PeerIP);
if IPIdx=-1 then Exit;
Stream.Position:=0;
pList:=StreamToPackets(Stream,ABinding.PeerIP);
SendAck(Int64(pList.Count),ABinding);
Amount:=Min(pList.Count,30);
I:=0;
T:=0;
SetLength(Idxs,MAX_AMOUNT);
nIdx:=0;
ncount:=0;
ldt:=-1;
while I<pList.Count do
begin
J:=0;
while nIdx<Amount do
begin
if T+J>=pList.Count then break;
Idxs[nIdx]:=T+J;
inc(nIdx);
inc(J);
end;
pn:=nIdx;
SendAck(Int64(nIdx),ABinding);
ot:=Date()+Time();
for J:=0 to nIdx-1 do
begin
buffer:=PacketToBytes( pList[Idxs[J]] );
SendBuffer(ABinding.PeerIP,ABinding.PeerPort,TIdBytes(buffer));
Finalize(buffer);
end;
ack:=TIdAck(RecvAck(ABinding,10000));
dt:=Date()+Time()-ot;
T:=T+nIdx-ncount;
if ack=IA_FAIL then
begin
nIdx:=RecvAck(ABinding);
for J:=0 to nIdx-1 do
Idxs[J]:=RecvAck(ABinding);
ncount:=nIdx;
end
else
begin
ncount:=0;
nIdx:=0;
end;
I:=I+pn-nIdx;
if ldt<>-1 then
begin
if SecondsBetween(ot,ldt)>SecondsBetween(ot,dt) then
Amount:=Min(Amount+10,MAX_AMOUNT);
if SecondsBetween(ot,ldt)<SecondsBetween(ot,dt) then
Amount:=Max(Amount-10,Max(nIdx,30));
end;
ldt:=dt;
end;
Finalize(Idxs);
for I:=0 to pList.Count-1 do
if Length(pList[I].data)>0 then
begin
buffer:=pList[I].data;
Finalize(buffer);
end;
pList.Free;
end;
procedure TUDPServer.SendAck(Ack: Int64; ABinding: TIdSocketHandle);
var
p:TPacket;
p2:TPacket;
IPIdx:Integer;
o,t:TDateTime;
buffer:TBytes;
begin
IPIdx:=FindIPNum(ABinding.PeerIP);
if IPIdx=-1 then Exit;
p.Serial:=IPNumList[IPIdx].SNum;
p.Next:=Rand();
SetSNum(p.Next,IPIdx);
p.Index:=Ack;
p2.Index:=Int64(IA_FAIL);
p2.Serial:=IPNumList[IPIdx].RNum;
o:=Date()+Time();
while not ((p2.Serial=IPNumList[IPIdx].RNum) and (p2.Index=Int64(IA_OK))) do
begin
if p2.Serial=IPNumList[IPIdx].RNum then
SendBuffer(ABinding.PeerIP,ABinding.PeerPort,TIdBytes(PacketToBytes(p)));
try
try
buffer:=ReceiveBuffer(ABinding);
if Length(buffer)>24 then continue;
p2:=BytesToPacket(buffer);
except
end;
finally
Finalize(buffer);
t:=Date()+Time();
if SecondsBetween(o,t)>=5 then
begin
SetSNum(p.Serial,IPIdx);
raise EReadTimeout.Create('Read Timeout');
end;
end;
end;
SendBuffer(ABinding.PeerIP,ABinding.PeerPort,TIdBytes(PacketToBytes(p)));
SetRNum(p2.Next,IPIdx);
end;
function TUDPServer.RecvAck(ABinding: TIdSocketHandle; Timeout:Int64): Int64;
var
p,p2,ap:TPacket;
buffer:TBytes;
IPIdx:Integer;
o,t:TDateTime;
begin
IPIdx:=FindIPNum(ABinding.PeerIP);
if IPIdx=-1 then Exit;
if Timeout=-1 then
Timeout:=5000;
p.Serial:=IPNumList[IPIdx].RNum+1;
o := Date() + Time();
while p.Serial<>IPNumList[IPIdx].RNum do
begin
try
try
buffer:=ReceiveBuffer(ABinding);
if Length(buffer)>24 then continue;
p := BytesToPacket(buffer);
except
end;
finally
T := Date() + Time();
if SecondsBetween(o,T) >= Timeout / 1000 then
raise EReadTimeout.Create('Read Timeout');
end;
end;
p2.Serial:=IPNumList[IPIdx].SNum;
p2.Next:=Rand();
SetSNum(p2.Next,IPIdx);
p2.Index:=Int64(IA_OK);
o:=Date()+Time();
t:=o;
ap.Serial:=IPNumList[IPIdx].RNum+1;
while True do
begin
if SecondsBetween(o,t)>=2 then break;
SendBuffer(ABinding.PeerIP,ABinding.PeerPort,TIdBytes(PacketToBytes(p2)));
try
try
buffer:=ReceiveBuffer(ABinding);
ap:=BytesToPacket(buffer);
except
continue;
end;
finally
t:=Date()+Time();
end;
if ap.Serial=IPNumList[IPIdx].RNum then
break;
end;
SetRNum(p.Next,IPIdx);
Result:=p.Index;
end;
What do you think is the problem?
There is no connection problem. But it sometimes raises EReadTimeout Exception when connected over network while downloading a file.
Environment
OS:Windows 10
Compiler : Delphi 10 tokyo
AP: TP-LINK TL-WR940N PLUS
Tested with My Laptop,PC, Android Phone
My Laptop <-> My Laptop = worked
My Laptop <-> My PC = not worked
My Laptop <-> My Phone (in AP) = not worked
My Laptop <-> My Phone (in laptop's hotspot) = worked

How to determine the size of a buffer for a DLL call when the result comes from the DLL

Using both Delphi 10.2 Tokyo and Delphi XE2.
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
The call to the DLL comes from a Delphi XE2 EXE, but I don't believe that is relevant, but I am noting it nonetheless.
The call to post data to a site will often return text data. Sometimes very large amounts of text data. Greater than 150K characters.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
My DLL code where I get the error:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
vcl.Dialogs,
IdSSLOpenSSL, IdHTTP, IdIOHandlerStack, IdURI,
IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall
var HTTPReq : TIdHTTP;
var Response: TStringStream;
var SendStream : TStringStream;
var IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
var Uri : TIdURI;
var s : string;
begin
Result := -1;
try
HTTPReq := TIdHTTP.Create(nil);
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1_2, sslvTLSv1_1];
if Assigned(HTTPReq) then begin
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.Request.ContentType := 'text/xml;charset=UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
HTTPReq.HTTPOptions := [];
end;
SendStream := TStringStream.Create(Body);
Response := TStringStream.Create(EmptyStr);
try
HTTPReq.Request.ContentLength := Length(Body);
Uri := TiDUri.Create(url);
try
HTTPReq.Request.Host := Uri.Host;
finally
Uri.Free;
end;
HTTPReq.Post(url + 'admin.asmx', SendStream,Response);
if Response.Size > 0 then begin
if assigned(OutData) then begin
s := Response.DataString;// Redundant? Probably can just use Response.DataString?
StrPLCopy(OutData, s, OutLen);// <- ACCESS VIOLATION HERE
//StrPLCopy(OutData, s, Response.Size);// <- ACCESS VIOLATION HERE
Result := 0;
end;
end
else begin
Result := -2;
end;
finally
Response.Free;
SendStream.Free;
IdSSLIOHandler.Free;
HTTPReq.Free;
end;
except
on E:Exception do begin
ShowMessage(E.Message);
Result := 1;
end;
end;
end;
exports
PostAdminDataViaDll;
begin
end.
My Calling method code:
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall;
var Handle : THandle;
var MyPost : TMyPost;
var dataString : string;
var returnData : string;
begin
if not (FileExists(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL')) then begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
Exit;
end;
dataString := EmptyStr;
returnData := '';
Handle := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if Handle <> 0 then begin
try
try
MyPost := GetProcAddress(Handle, 'PostAdminDataViaDll');
if #MyPost <> nil then begin
// NOTE 32767 is not big enough for the returned data! Help!
if MyPost(PChar(body), PChar(method), PChar(url), PChar(returnData), 32767) = 0 then begin
dataString := returnData;
end;
end;
except
end;
finally
FreeLibrary(Handle);
end;
end
else begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
end;
if not sametext(dataString, EmptyStr) then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
Why not simply update Indy in XE2 to a newer version that supports TLS 1.2? Then you don't need the DLL at all.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
It is not a "big no-no", especially if the response data is dynamic in nature. Returning a pointer to dynamically allocated data is perfectly fine. You would simply have to export an extra function to free the data when the caller is done using it, that's all. The "big no-no" is that this does introduce a potential memory leak, if the caller forgets to call the 2nd function. But that is what try..finally is good for.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
That is not a lot of memory. Any failure you were getting with it was likely due to you simply misusing the memory.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
That is because you are not filling in the memory correctly.
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
You can't, when using POST. You would have to cache the response data somewhere off to the side, and then expose ways to let the caller query that cache for its size and data afterwards.
My DLL code where I get the error:
My Calling method code:
I see a number of logic mistakes in that code.
But, the most important reason for the Access Violation error is that your EXE is simply not allocating any memory for its returnData variable.
Casting a string to a PChar never produces a nil pointer. If the input string is not empty, a pointer to the string's first Char is returned. Otherwise, a pointer to a static #0 Char is returned instead. This ensures that a string casted to PChar always results in a non-nil, null-terminated, C style character string.
Your EXE is telling the DLL that returnData can hold up to 32767 chars, but in reality it can't hold any chars at all! In the DLL, OutData is not nil, and OutLen is wrong.
Also, StrPLCopy() always null-terminates the output, but the MaxLen parameter does not include the null-terminator, so the caller must allocate room for MaxLen+1 characters. This is stated in the StrPLCopy() documentation.
With all of this said, try something more like this:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
Vcl.Dialogs,
IdIOHandlerStack, IdSSLOpenSSL, IdHTTP, IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar;
var OutData : PChar): integer; stdcall;
var
HTTPReq : TIdHTTP;
SendStream : TStringStream;
IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
s : string;
begin
OutData := nil;
try
HTTPReq := TIdHTTP.Create(nil);
try
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(HTTPReq);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.HTTPOptions := [];
HTTPReq.Request.ContentType := 'text/xml';
HTTPReq.Request.Charset := 'UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
SendStream := TStringStream.Create(Body, TEncoding.UTF8);
try
s := HTTPReq.Post(string(url) + 'admin.asmx', SendStream);
finally
SendStream.Free;
end;
Result := Length(s);
if Result > 0 then begin
GetMem(OutData, (Result + 1) * Sizeof(Char));
Move(PChar(s)^, OutData^, (Result + 1) * Sizeof(Char));
end;
finally
HTTPReq.Free;
end;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
function FreeDataViaDll(Data : Pointer): integer; stdcall;
begin
try
FreeMem(Data);
Result := 0;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
exports
PostAdminDataToCenPosViaDll,
FreeDataViaDll;
begin
end.
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; var OutData : PChar): integer; stdcall;
TMyFree = function (Data Pointer): integer; stdcall;
var
hDll : THandle;
MyPost : TMyPost;
MyFree : TMyFree;
dataString : string;
returnData : PChar;
returnLen : Integer;
begin
hDll := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if hDll = 0 then begin
Application.MessageBox('Unable to load TestDLL.DLL.', 'Error posting', MB_ICONERROR or MB_OK);
Exit;
end;
try
try
MyPost := GetProcAddress(hDll, 'PostAdminDataViaDll');
MyFree := GetProcAddress(hDll, 'FreeDataViaDll');
if Assigned(MyPost) and Assigned(MyFree) then begin
returnLen := MyPost(PChar(body), PChar(method), PChar(url), returnData);
if returnLen > 0 then begin
try
SetString(dataString, returnData, returnLen);
finally
MyFree(returnData);
end;
end;
end;
finally
FreeLibrary(hDll);
end;
except
end;
if dataString <> '' then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;

SendMessage(WM_COPYDATA) + Record + String

I want to send a record, that right now have only a string on it, but I will add more variables. Is the first time I work with records, so this maybe is a silly question. But, why this works:
type
TDataPipe = record
WindowTitle: String[255];
end;
var
Data: TDataPipe;
copyDataStruct : TCopyDataStruct;
begin
Data.WindowTitle:= String(PChar(HookedMessage.lParam));
copyDataStruct.dwData := 0;
copyDataStruct.cbData := SizeOf(Data);
copyDataStruct.lpData := #Data;
SendMessage(FindWindow('TForm1', nil), WM_COPYDATA, Integer(hInstance), Integer(#copyDataStruct));
end;
Receiving side:
type
TDataPipe = record
WindowTitle: String[255];
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sampleRecord : TDataPipe;
begin
sampleRecord.WindowTitle:= TDataPipe(Msg.CopyDataStruct.lpData^).WindowTitle;
Memo1.Lines.Add(sampleRecord.WindowTitle);
end;
Why if on the record, I use:
WindowTitle: String; //removed the fixed size
and on the sending side I use:
Data.WindowTitle:= PChar(HookedMessage.lParam); //removed String()
it simply doesn't go?
I get access violations / app freeze...
The scenario is: sending side is a DLL hooked using SetWindowsHookEx, receiving side a simple exe that loaded / called SetWindowsHookEx...
A String[255] is a fixed 256-byte block of memory, where the character data is stored directly in that memory. As such, it is safe to pass as-is across process boundaries without serialization.
A String, on the other hand, is a dynamic type. It just contains a pointer to character data that is stored elsewhere in memory. As such, you can't pass a String as-is across process boundaries, all you would be passing is the pointer value, which has no meaning to the receiving process. You have to serialize String data into a flat format that can safely by passed to, and deserialized by, the receiving process. For example:
Sending side:
type
PDataPipe = ^TDataPipe;
TDataPipe = record
WindowTitleLen: Integer;
WindowTitleData: array[0..0] of Char;
//WindowTitleData: array[0..WindowTitleLen-1] of Char;
end;
var
Wnd: HWND;
s: String;
Data: PDataPipe;
DataLen: Integer;
copyDataStruct : TCopyDataStruct;
begin
Wnd := FindWindow('TForm1', nil);
if Wnd = 0 then Exit;
s := PChar(HookedMessage.lParam);
DataLen := SizeOf(Integer) + (SizeOf(Char) * Length(s));
GetMem(Data, DataLen);
try
Data.WindowTitleLen := Length(s);
StrMove(Data.WindowTitleData, PChar(s), Length(s));
copyDataStruct.dwData := ...; // see notes further below
copyDataStruct.cbData := DataLen;
copyDataStruct.lpData := Data;
SendMessage(Wnd, WM_COPYDATA, 0, LPARAM(#copyDataStruct));
finally
FreeMem(Data);
end;
end;
Receiving side:
type
PDataPipe = ^TDataPipe;
TDataPipe = record
WindowTitleLen: Integer;
WindowTitleData: array[0..0] of Char;
//WindowTitleData: array[0..WindowTitleLen-1] of Char;
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
Data: PDataPipe;
s: string;
begin
Data := PDataPipe(Msg.CopyDataStruct.lpData);
SetString(s, Data.WindowTitleData, Data.WindowTitleLen);
Memo1.Lines.Add(s);
end;
That being said, in either situation, you really should be assigning your own custom ID number to the copyDataStruct.dwData field. The VCL itself uses WM_COPYDATA internally, so you don't want to get those messages confused with yours, and vice versa. You can use RegisterWindowMessage() to create a unique ID to avoid conflicts with IDs used by other WM_COPYDATA users:
var
dwMyCopyDataID: DWORD;
...
var
...
copyDataStruct : TCopyDataStruct;
begin
...
copyDataStruct.dwData := dwMyCopyDataID;
...
end;
...
initialization
dwMyCopyDataID := RegisterWindowMessage('MyCopyDataID');
var
dwMyCopyDataID: DWORD;
...
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
...
begin
if Msg.CopyDataStruct.dwData = dwMyCopyDataID then
begin
...
end else
inherited;
end;
...
initialization
dwMyCopyDataID := RegisterWindowMessage('MyCopyDataID');
Lastly, the WPARAM parameter of WM_COPYDATA is an HWND, not an HINSTANCE. If the sender does not have its own HWND, just pass 0. Do not pass your sender's HInstance variable.
Preparation:
procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited;
StrCopy(Params.WinClassName, PChar(SingleInstClassName)); // Copies a null-terminated string. StrCopy is designed to copy up to 255 characters from the source buffer into the destination buffer. If the source buffer contains more than 255 characters, the procedure will copy only the first 255 characters.
end;
Sender:
procedure TAppData.ResurectInstance(Arg: string);
VAR
Window: HWND;
DataToSend: TCopyDataStruct;
begin
Arg:= Trim(Arg);
{ Prepare the data you want to send }
DataToSend.dwData := CopyDataID; // CopyDataID = Unique ID for my apps
DataToSend.cbData := Length(Arg) * SizeOf(Char);
DataToSend.lpData := PChar(Arg);
{ We should never use PostMessage() with the WM_COPYDATA message because the data that is passed to the receiving application is only valid during the call. Finally, be aware that the call to SendMessage will not return until the message is processed.}
Window:= WinApi.Windows.FindWindow(PWideChar(SingleInstClassName), NIL); // This is a copy of cmWindow.FindTopWindowByClass
SendMessage(Window, WM_COPYDATA, 0, LPARAM(#DataToSend));
end;
Receiver:
procedure TMainForm.WMCopyData(var Msg: TWMCopyData);
VAR
FileName: string;
begin
{ Receives filename from another instance of this program }
if (Msg.CopyDataStruct.dwData = AppData.CopyDataID) { Only react on this specific message }
AND (Msg.CopyDataStruct.cbData > 0) { Do I receive an empty string? }
then
begin
SetString(FileName, PChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData div SizeOf(Char));
msg.Result:= 2006; { Send something back as positive answer }
AppData.Restore;
...
end
else
inherited;
end;

how send data record using SendMessage(..) in separate process

i use to send a data on two separate process but it fails. it works only under same process... this is concept.
//-----------------------------------------------------------------------------------
MainApps
//-----------------------------------------------------------------------------------
Type
PMyrec = ^TMyrec;
TMyrec = Record
name : string;
add : string;
age : integer;
end;
:OnButtonSend
var aData : PMyrec;
begin
new(aData);
aData.Name := 'MyName';
aData.Add := 'My Address';
aData.Age : 18;
SendMessage(FindWindow('SubApps'),WM_MyMessage,0,Integer(#aData));
end;
//-----------------------------------------------------------------------------------
SubApps
//-----------------------------------------------------------------------------------
Type
PMyrec = ^TMyrec;
TMyrec = Record
name : string;
add : string;
age : integer;
end;
:OnCaptureMessage
var
aData : PMyrec;
begin
aData := PMyrec(Msg.LParam);
showmessage(aData^.Name);
end;
You're right. Addresses only have meaning within a single process. The PMyRec value you create in the first process is just a garbage address in the target process.
To send an arbitrary block of memory to another process via a window message, you should use the wm_CopyData message. You give that message the address of the data and the size, and the OS takes care of copying it into the target process's address space.
Since your data includes a string, which is represented internally as a another pointer, it won't be enough to just copy the 12 bytes of your record. You'll need to allocate additional memory to hold the record and the string data in a single block of memory so wm_CopyData can copy it and the target process can read it.
Here's one way to do it, using a stream to collect the data into a single block of memory.
procedure SendRecord(Source, Target: HWnd; const Rec: TMyRec);
var
Buffer: TMemoryStream;
Len: Integer;
CopyData: TCopyDataStruct;
begin
Buffer := TMemoryStream.Create;
try
Len := Length(Rec.name);
Buffer.Write(Len, SizeOf(Len));
if Len > 0 then
Buffer.Write(Rec.name[1], Len * SizeOf(Char));
Len := Length(Rec.add);
Buffer.Write(Len, SizeOf(Len));
if Len > 0 then
Buffer.Write(Rec.add[1], Len * SizeOf(Char));
Buffer.Write(Rec.age, SizeOf(Rec.age));
CopyData.dwData := 0;
CopyData.cbData := Buffer.Size;
CopyData.lpData := Buffer.Memory;
SendMessage(Target, wm_CopyData, Source, LParam(#CopyData));
finally
Buffer.free;
end;
end;
We write the lengths of the strings in addition to the strings' characters so that the recipient knows how many characters belong to each one. The recipient's code will look like this:
procedure TBasicForm.WMCopyData(var Message: TWMCopyData);
var
Rec: TMyRec;
Len: Integer;
Buffer: TStream;
begin
Buffer := TReadOnlyMemoryStream.Create(
Message.CopyDataStruct.lpData, Message.CopyDataStruct.cbData);
try
if Message.CopyDataStruct.dwData = 0 then begin
Buffer.Read(Len, SizeOf(Len));
SetLength(Rec.name, Len);
if Len > 0 then
Buffer.Read(Rec.name[1], Len * SizeOf(Char));
Buffer.Read(Len, SizeOf(Len));
SetLength(Rec.add, Len);
if Len > 0 then
Buffer.Read(Rec.add[1], Len * SizeOf(Len));
Buffer.Read(Rec.age, SizeOf(Rec.age));
// TODO: Do stuff with Rec here.
Message.Result := 1;
end else
inherited;
finally
Buffer.Free;
end;
end;
I've used the non-standard TReadOnlyMemoryStream since it makes everything easier. Here's a simple implementation for it:
type
TReadOnlyMemoryStream = class(TCustomMemoryStream)
public
constructor Create(Mem: Pointer; Size: LongInt);
function Write(const Buffer; Count: LongInt): LongInt; override;
end;
constructor TReadOnlyMemoryStream.Create;
begin
inherited Create;
SetPointer(Mem, Size);
end;
function TReadOnlyMemoryStream.Write;
begin
Result := 0;
end;

Enumerate running processes in Delphi

How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.

Resources