Delphi UDP Hole Punching: on internet not always works - delphi

I'm trying to implement UDP Hole Punching with Delphi with Indy and Firemonkey technology.
I have tried to follow this document: https://www.researchgate.net/publication/1959162_Peer-to-Peer_Communication_Across_Network_Address_Translators
The program seems to work but is NOT stable.
If I work on a system on the local intranet no problem.
If I work on an internet, it doesn't always work and I don't know why.
I have created two applications.
The first is server side.
Everytime all clients connect correctly to server.
The server registers the Local IP and Internet IP pairs in a variable (fPeers).
I created an IdUDPServer instance.
This is the “Connect push button” code:
procedure TForm1.B_ConnectClick(Sender: TObject);
var
vIdSocketHandle: TIdSocketHandle;
begin
if IdUDPServer.Active then
begin
IdUDPServer.Active := False;
B_Connect.Text := 'Connect';
end
else
begin
IdUDPServer.Bindings.Clear;
vIdSocketHandle := IdUDPServer.Bindings.Add;
vIdSocketHandle.IP := GStack.LocalAddress;
vIdSocketHandle.Port := E_POrt.Text.ToInteger;
IdUDPServer.Active := True;
B_Connect.Text := 'Disconnect';
end;
end;
During the IdUDPServerUDPRead event I capture the Local and Internet IP addresses of the clients that connect.
In the TStringLIST called fPeerIP I add the list of addresses.
procedure TForm1.IdUDPServerUDPRead(AThread: TIdUDPListenerThread;
const AData: TIdBytes; ABinding: TIdSocketHandle);
var vPair: string;
vData: string;
vString: string;
vLog: string;
begin
vPair := ABinding.PeerIP + ':'+ABinding.PeerPort.ToString;
vData := BytesToString(AData);
vLog := '';
if leftstr(vdata,7) = 'LOCALIP' then
begin
vString := vPair+#9+lsExtract(vData,2,',');
if fPeerIP.IndexOfName(vString) = -1 then
begin
fPeerIP.Add(vString);
M_Peers.Lines.Add(vString);
vLog := vLog + vString + #13#10;
IdUDPServer.Send(ABinding.PeerIP, ABinding.PeerPort, 'Peer aggiunto alla lista');
end;
end
else vLog := vData;
end;
On the client side, I created an IdUDPServer instance which, upon connection, sends a string to the server.
procedure TForm2.B_ConnectClick(Sender: TObject);
var vIdSocketHandle: TIdSocketHandle;
vLocalAddressList: TIdStackLocalAddressList;
vI: Integer;
vSendLIST: TStringLIST;
begin
if IdUDPServer.Active then
begin
Timer.Enabled := False;
IdUDPServer.Active := False;
B_Connect.Text := 'Connect';
M_Networks.Lines.Clear;
M_Debug.Lines.Clear;
LB_Peers.Items.Clear;
end
else
begin
try
vSendLIST := TStringLIST.Create;
IdUDPServer.Bindings.Clear;
vLocalAddressList := TIdStackLocalAddressList.Create;
GStack.GetLocalAddressList(vLocalAddressList);
M_Networks.Lines.Clear;
for vI := 0 to vLocalAddressList.Count-1 do
begin
if vLocalAddressList.Addresses[vI].IPVersion = id_IPV4 then
begin
M_Networks.Lines.Add(vLocalAddressList.Addresses[vI].IPAddress);
vSendLIST.Add(Format('LOCALIP,%s:%d',[vLocalAddressList.Addresses[vI].IPAddress,E_ClientPort.Text.ToInteger]));
end;
end;
vIdSocketHandle := IdUDPServer.Bindings.Add;
vIdSocketHandle.Port := E_ClientPort.Text.ToInteger;
vIdSocketHandle.IP := '0.0.0.0';
IdUDPServer.Active := True;
for vI := 0 to vSendLIST.Count-1 do
IdUDPServer.Send(E_Server.Text, E_Port.Text.ToInteger, vSendLIST[vI]);
B_Connect.Text := 'Disconnect';
if Assigned(vSendLIST) then FreeAndNil(vSendLIST);
finally
if Assigned(vLocalAddressList) then FreeAndnil(vLocalAddressList);
end;
end;
end;
Also on the client side, in the IdUDPServerUDPRead event I detect the list of Peers (function sent by the server) and send a "PING" to each connected peer.
I realize maybe I have given little information.
I'd like to know your opinion and possibly indicate to me if I made a mistake in the process that activates the Hole Punching.
Thanks in advance
LS

Your code is theoretically right and may work on some NAT routers but it will not work on the rest
I have been trying to achieve UDP Hole Punching for many years but it's really complicated,
you need to combine many NAT Traversal mechanisms together to make it work in the most cases
Reading about STUN, TURN and ICE mechanisms may help

Related

TSendMail.Execute Returns True Without Sending

If I understand correctly, TSendMail is supposed to use my installed email client. If I execute it on my virtual machine, it returns "true" and gives me the expected message that I need to install an email program.
However, if I run the program on my regular machine (on which Thunderbird is installed) TSendMail.execute returns "True", but Thunderbird doesn't get called. Here's my code:
procedure TfSendEmail.btnSendClick(Sender: TObject);
var
aNode: PVirtualNode;
Data: PRecipients;
i: integer;
begin
aNode := vstRecipients.GetFirst;
i := 0;
while (aNode <> nil) do
begin
Data := vstRecipients.GetNodeData(aNode);
Mail.Recipients.Add;
Mail.Recipients[i].DisplayName := Data.Name;
Mail.Recipients[i].Address := Data.Email;
inc(i);
aNode := vstRecipients.GetNext(aNode);
end;
Mail.Attachments.Assign(lbAttachments.Items);
Mail.Subject := edtSubject.Text;
Mail.Text.Assign(mmoMsgText.Lines);
if Mail.Execute then
begin
ShowMessage('Succeeded');
//ModalResult := mrOk;
end
else
MessageDlg('Sorry!. Could not send email.', mtError, [mbOK], 0);
end;
Using Delphi 10.2.3 on fully updated Win10 machines. Maybe my recipient assignment is faulty. Anyway, I can't find any complete usage examples, only the incomplete example on attachments from Embarcadero's wiki.

Delphi TCPClient read string from TCPServer

I need to write a simple chat program that will be used by some customers. Basically, there are a lot of clients connected to a server and they chat together. The server works:
Here the code if needed:
//CONNECT TO THE SERVER
procedure TFormServer.ButtonStartClick(Sender: TObject);
begin
if not TCPServer.Active then
begin
try
TCPServer.DefaultPort := 8002;
TCPServer.Bindings[0].IP := LIP.Text;
TCPServer.Bindings[0].Port := StrToInt(LPort.Text);
TCPServer.MaxConnections := 5;
TCPServer.Active := true;
Memo1.Lines.Add(TimeNow + 'Server started.');
except
on E: Exception do
Memo1.Lines.Add(sLineBreak + ' ====== INTERNAL ERROR ====== ' +
sLineBreak + ' > ' + E.Message + sLineBreak);
end;
end;
end;
//DISCONNECT
procedure TFormServer.ButtonStopClick(Sender: TObject);
begin
if TCPServer.Active then
begin
TCPServer.Active := false;
Memo1.Lines.Add(TimeNow + 'Server stopped.');
end;
end;
//IF CLOSE THE APP DONT FORGET TO CLOSE SERVER!!
procedure TFormServer.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ButtonStopClick(Self);
end;
procedure TFormServer.FormCreate(Sender: TObject);
begin
FClients := 0;
end;
//When a client connects I write a log
procedure TFormServer.TCPServerConnect(AContext: TIdContext);
begin
Inc(FClients);
TThread.Synchronize(nil, procedure
begin
LabelCount.Text := 'Connected sockets: ' + FClients.ToString;
Memo1.Lines.Add(TimeNow + ' Client connected # ' + AContext.Binding.IP + ':' + AContext.Binding.Port.ToString);
end);
end;
//Same, when a client disconnects I log it
procedure TFormServer.TCPServerDisconnect(AContext: TIdContext);
begin
Dec(FClients);
TThread.Synchronize(nil, procedure
begin
LabelCount.Text := 'Connected sockets: ' + FClients.ToString;
Memo1.Lines.Add(TimeNow + ' Client disconnected');
end);
end;
//WHAT I DO HERE:
//I receive a message from the client and then I send this message to EVERYONE that is connected here. It is a global chat
procedure TFormServer.TCPServerExecute(AContext: TIdContext);
var
txt: string;
begin
txt := AContext.Connection.IOHandler.ReadLn();
AContext.Connection.IOHandler.WriteLn(txt);
TThread.Synchronize(nil, procedure
begin
Memo1.Lines.Add(TimeNow + txt);
end);
end;
The sever code is very easy and minimal but it does what I need. This is the client instead:
Here there is the code, very simple:
//CONNECT TO THE SERVER
procedure TFormClient.ConnectClick(Sender: TObject);
begin
if Length(Username.Text) < 4 then
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('ERROR: Username must contain at least 4 characters');
Exit;
end;
if not TCPClient.Connected then
begin
try
Username.Enabled := false;
Memo1.Lines.Clear;
TCPClient.Host := '127.0.0.1';
TCPClient.Port := 8002;
TCPClient.ConnectTimeout := 5000;
TCPClient.Connect;
Connect.Text := 'Disconnect';
except
on E: Exception do
Memo1.Lines.Add(' ====== ERROR ======' + sLineBreak +
' > ' + E.Message + sLineBreak);
end;
end
else
begin
TCPClient.Disconnect;
Username.Enabled := true;
Connect.Text := 'Connect';
end;
end;
//IF YOU FORGET TO DISCONNECT WHEN APP IS CLOSED
procedure TFormClient.FormDestroy(Sender: TObject);
begin
if TCPClient.Connected then
TCPClient.Disconnect;
end;
//Here I send a string to the server and it's good
procedure TFormClient.SendClick(Sender: TObject);
begin
if TCPClient.Connected then
begin
TCPClient.IOHandler.WriteLn(Username.Text + ': ' + EditMessage.Text);
EditMessage.Text := '';
end
else
begin
Memo1.Lines.Add('ERROR: You aren''t connected!');
end;
end;
//Problems here
procedure TFormClient.Timer1Timer(Sender: TObject);
begin
Memo1.Lines.Add(TCPClient.IOHandler.ReadLn());
end;
The problems start in the last procedure Timer1Timer. I have found that TCPServer uses a thread and this is why I call Synchronize to update the UI. Instead TCPClient does not use a thread and I manually have to check the server. Please see this code:
procedure TFormServer.TCPServerExecute(AContext: TIdContext);
var
txt: string;
begin
txt := AContext.Connection.IOHandler.ReadLn();
AContext.Connection.IOHandler.WriteLn(txt);
TThread.Synchronize(nil, procedure
begin
Memo1.Lines.Add(TimeNow + txt);
end);
end;
As you can see, when the server receives a string he immediatly sends it back to all the clients. I try to get the string here:
procedure TFormClient.Timer1Timer(Sender: TObject);
begin
Memo1.Lines.Add(TCPClient.IOHandler.ReadLn());
end;
What is wrong? I have seen a similar question here and answers said that I have to use a timer and IOHandler.ReadLn(), which is what I am doing. I think that the problem is here. How to fix?
Also timer has an interval of 200, is it too short?
I have read what Remy Lebeau said in the answer and I've produced this simple code:
procedure TFormClient.Timer1Timer(Sender: TObject);
begin
if not(TCPClient.Connected) then
Exit;
if TCPClient.IOHandler.InputBufferIsEmpty then
Exit;
Memo1.Lines.Add(TCPClient.IOHandler.InputBufferAsString());
end;
There is a Timer1 component in the form. This works as I expect but it still could lock the UI or not?
The server works
Just an FYI, you don't need the FClients variable at all, especially since you are not really accessing it safely. At the very least, use TInterlocked to access it safely. Or switch to TIdThreadSafeInteger. Though really, the only place you use it is in LabelCount, and you can get the current client count from the TIdTCPServers.Contexts property instead.
This is the client instead:
...
The problems start in the last procedure Timer1Timer.
That is because you are using a UI-based TTimer, and (like most things in Indy) the IOHandler.ReadLn() method blocks until completed. You are calling it within the context of the UI thread, so it blocks the UI message loop until a full line has arrived from the socket.
One way to work around blocking the UI is to place an Indy TIdAntiFreeze component onto your Form. Then the UI will remain responsive while ReadLn() blocks. However, this would be kind of dangerous to use with a TTimer, as you would end up with OnTimer reentry issues that could corrupt the IOHandler's data.
Really, the best solution is to simply not call the IOHandler.ReadLn() in the UI thread at all. Call it in a worker thread instead. Start the thread after you successfully Connect() to the server, and terminate the thread when disconnected. Or even move the Connect() itself into the thread. Either way, you can use Indy's TIdThreadComponent, or write your own T(Id)Thread-derived class.
Instead TCPClient does not use a thread and I manually have to check the server.
Correct, but the way you are doing it is wrong.
If you don't want to use a worker thread (which you should), then at least change your OnTimer event handler so it does not block the UI anymore, like this:
Or:
procedure TFormClient.Timer1Timer(Sender: TObject);
begin
if TCPClient.IOHandler.InputBufferIsEmpty then
begin
TCPClient.IOHandler.CheckForDataOnSource(0);
TCPClient.IOHandler.CheckForDisconnect(False);
if TCPClient.IOHandler.InputBufferIsEmpty then Exit;
end;
// may still block if the EOL hasn't been received yet...
Memo1.Lines.Add(TCPClient.IOHandler.ReadLn);
end;
Alternatively:
procedure TFormClient.Timer1Timer(Sender: TObject);
begin
// Connected() performs a read operation and will buffer
// any pending bytes that happen to be received...
if not TCPClient.Connected then Exit;
while TCPClient.IOHandler.InputBuffer.IndexOf(Byte($0A)) <> -1 do
Memo1.Lines.Add(TCPClient.IOHandler.ReadLn());
end;
I have seen a similar question here and answers said that I have to use a timer and IOHandler.ReadLn(), which is what I am doing.
Whoever said that is wrong, or you misunderstood what was required. Using a timer in the UI is a possible solution, if used correctly, but it is not a very good solution.
Create a thread for your tcpclient and sync messages back to the UI.

Seeing Indy Traffic in Fiddler

I think this is an easy question for someone familiar with Indy. I'm using Delphi 2010 and Indy 10. I am trying to get off the ground accessing an SSL web service. I think it will be a lot easier if I can get Fiddler to see my HTTP traffic. I have seen posts on StackOverflow that indicate it's no big thing to get Fiddler to see your Indy traffic, that you just have to configure the port to make it work. My question is how do you do that?
Here is my code so far:
procedure TForm1.Button1Click(Sender: TObject);
var slRequest: TStringList;
sResponse,
sFileName: String;
lHTTP: TIdHTTP;
lIOHandler: TIdSSLIOHandlerSocketOpenSSL;
begin
sFileName := 'Ping.xml';
slRequest := TStringList.Create;
try
slRequest.LoadFromFile(sFileName);
lHTTP := TIdHTTP.Create(nil);
lHTTP.Intercept := IdLogDebug1;
lIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
try
lHTTP.IOHandler := lIOHandler;
sResponse := lHTTP.Post('https://FSETTESTPROD.EDD.CA.GOV/fsetservice', slRequest);
Memo1.Lines.Text := sResponse;
finally
lIOHandler.Free;
end;
finally
slRequest.Free;
end;
end;
Edit: If I don't use the proxy for Fiddler and click the button while Wireshark is running, I get this traffic in Wireshark.
You can set Indy to use the proxy fiddler provides easily by setting the ProxyParams:
try
lHTTP.IOHandler := lIOHandler;
lHTTP.ProxyParams.ProxyServer := '127.0.0.1';
lHTTP.ProxyParams.ProxyPort := 8888;
sResponse := lHTTP.Post('<URL>', slRequest);
Memo1.Lines.Text := sResponse;
finally
lIOHandler.Free;
end;
You should be able to see all traffic in Fiddler then.
Edit: If that does not work you can add a TIdLogDebug component and add it as interceptor (like you did in your question).
The OnReceive and OnSend events contain the complete headers sent and received aswell as the reply data:
procedure TForm10.captureTraffic(ASender: TIdConnectionIntercept;
var ABuffer: TArray<Byte>);
var
i: Integer;
s: String;
begin
s := '';
for i := Low(ABuffer) to High(ABuffer) do
s := s + chr(ABuffer[i]);
Memo1.Lines.Add(s);
end;

WM_COPYDATA string not appearing in target application

I'm trying to pass information between two of my applications in Delphi 2010.
I'm using a simplified version of code that I've used successfully in the past (simplified because I don't need the sender to know that the send has been successful) I've boiled down the send received to a pair of example applications, which in essence are as follows
Send
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
s := ebFirm.Text;
copyDataStruct.cbData := 1 + length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: THandle;
res: integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application
ShellExecute(Handle, 'open', GetPhone, nil, nil, SW_SHOWNORMAL);
// Give time for the application to launch
Sleep(3000);
SendData(copyDataStruct); // RECURSION!
end;
SendMessage(rh, WM_COPYDATA, Integer(Handle), Integer(#copyDataStruct));
end;
Receive Application
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
s := PAnsiChar(Msg.CopyDataStruct.lpData) ;
jobstatus.Panels[1].Text := s;
end;
The major difference between the working test applications and the application I am adding the code to is that there is a lot of extra activity going on in target application. Especially on startup.
Any suggestions on why the WMCopyData procedure seems not to be firing at all?
CHeers
Dan
There are a few problems with your code.
One, you are not assigning a unique ID to the message. The VCL, and various third-party components, also use WM_COPYDATA, so you have to make sure you are actually processing YOUR message and not SOMEONE ELSE'S message.
Two, you may not be waiting long enough for the second app to start. Instead of Sleep(), use ShellExecuteEx() with the SEE_MASK_WAITFORINPUTIDLE flag (or use CreateProcess() and WaitForInputIdle()).
Third, when starting the second app, your recursive logic is attempting to send the message a second time. If that happened to fail, you would launch a third app, and so on. You should take out the recursion altogether, you don't need it.
Try this:
var
GetPhoneMsg: DWORD = 0;
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
if GetPhoneMsg = 0 then Exit;
s := ebFirm.Text;
copyDataStruct.dwData := GetPhoneMsg;
copyDataStruct.cbData := Length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: HWND;
si: TShellExecuteInfo;
res: Integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application and give time to start
ZeroMemory(#si, SizeOf(si));
si.cbSize := SizeOf(si);
si.fMask := SEE_MASK_WAITFORINPUTIDLE;
si.hwnd := Handle;
si.lpVerb := 'open';
si.lpFile := GetPhone;
si.nShow := SW_SHOWNORMAL;
if not ShellExecuteEx(#si) then Exit;
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then Exit;
end;
SendMessage(rh, WM_COPYDATA, WParam(Handle), LParam(#copyDataStruct));
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
Receive Application
var
GetPhoneMsg: DWORD = 0;
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
if (GetPhoneMsg <> 0) and (Msg.CopyDataStruct.dwData = GetPhoneMsg) then
begin
SetString(s, PAnsiChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData);
jobstatus.Panels[1].Text := s;
end else
inherited;
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
I think it is a good habit to add
copyDataStruct.dwData := Handle;
in procedure TMF.SendString; - if you don't have a custom identifier, putting the source HWND value will help debugging on the destination (you can check for this value in the other side, and therefore avoid misunderstand of broadcasted WMCOPY_DATA e.g. - yes, there should not be, but I've seen some!).
And
procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
in TMF client class definition, right?
There should be a missing exit or else after the nested SendData call:
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
(...)
Sleep(3000);
SendData(copyDataStruct);
end else
SendMessage(rh, WM_COPYDATA, NativeInt(Handle), NativeInt(#copyDataStruct));
end;
But this won't change much.
Check the rh := FindWindow() returned handle: is it the Handle of the TMF client form, or the Application.Handle?
It doesn't work anymore if you are using Windows 7.
If you are using it, check this page to see how to add an exception: http://msdn.microsoft.com/en-us/library/ms649011%28v=vs.85%29.aspx
I thought there was a problem with the (rh) handle being 0 when you call it, if the app needed to be started. But now I see that SendData calls itself recursively. I added a comment in the code for that, as it was non-obvious. But now there's another problem. The 2nd instance of SendData will have the right handle. But then you're going to pop out of that, back into the first instance where the handle is still 0, and then you WILL call SendMessage again, this time with a 0 handle. This probably is not the cause of your trouble, but it's unintended, unnecessary, and altogether bad. IMO, this is a case complicating things by trying to be too clever.

How to check if a TCP port is available with Delphi?

Is there a more elegant way of checking if a TCP port is available with Delphi other than catching a netstat call?
I guess you can use Indy's components to do that. For instance a TIdHTTPServer will raise an exception if a port is in use when it is being opened.
So basically you could create such component, bind it to localhost:<yourport> and if an exception is raised ( catch it and check it ) then the port is probably in use, else it is free.
I guess other indy components can tell if a port is open or not, but I can't look at it right now.
This was just to give you an approach.
#Mattl, if Available means open for you, you can use this code.
program CheckTCP_PortOpen;
{$APPTYPE CONSOLE}
uses
Winsock; //Windows Sockets API Unit
function PortTCPIsOpen(dwPort : Word; ipAddressStr:string) : boolean;
var
client : sockaddr_in;//sockaddr_in is used by Windows Sockets to specify a local or remote endpoint address
sock : Integer;
begin
client.sin_family := AF_INET;
client.sin_port := htons(dwPort);//htons converts a u_short from host to TCP/IP network byte order.
client.sin_addr.s_addr := inet_addr(PChar(ipAddressStr)); //the inet_addr function converts a string containing an IPv4 dotted-decimal address into a proper address for the IN_ADDR structure.
sock :=socket(AF_INET, SOCK_STREAM, 0);//The socket function creates a socket
Result:=connect(sock,client,SizeOf(client))=0;//establishes a connection to a specified socket.
end;
var
ret : Integer;
wsdata : WSAData;
begin
Writeln('Init WinSock');
ret := WSAStartup($0002, wsdata);//initiates use of the Winsock
if ret<>0 then exit;
try
Writeln('Description : '+wsData.szDescription);
Writeln('Status : '+wsData.szSystemStatus);
if PortTCPIsOpen(80,'127.0.0.1') then
Writeln('Open')
else
Writeln('Close');
finally
WSACleanup; //terminates use of the Winsock
end;
Readln;
end.
netstat information can be retrieved by calling the GetTcpTable and GetUdpTable functions in the IP Helper API, or IPHLPAPI.DLL. For more information on calling the IPHLPAPI.DLL from Delphi, check out this Network traffic monitor. There are some wrappers for it too, and it is part of JEDI API Library.
I wrote a Delphi version of NetStat long ago, but have since lost the source code. Those resources should get you started though.
The following code from Synapse works very well:
uses
blcksock;
function PortAvailable(Port:STring):boolean;
var
svr : TTCPBlockSocket;
begin
svr := TTCPBlockSocket.Create;
try
svr.Bind('0.0.0.0',Port);
svr.Listen;
result := svr.LastError = 0;
Svr.CloseSocket;
finally
svr.Free;
end;
end;
Using an Indy.Sockets v10 TIdTCPServer component:
function TExample.IsTCPPortAvailable(const APort: Word): Boolean;
var
LTCPServer: TIdTCPServer;
LBinding: TIdSocketHandle;
begin
Result := True;
LTCPServer := TIdTCPServer.Create;
try
try
with LTCPServer do
begin
DefaultPort := APort;
LBinding := Bindings.Add;
LBinding.IP := '127.0.0.1';
LBinding.Port := APort;
OnExecute := TCPServerExecute;
Active := True;
end;
finally
LTCPServer.Free;
end;
except on EIdCouldNotBindSocket do
Result := False;
end;
end;
procedure TExample.TCPServerExecute(AContext: TIdContext);
begin
end;
Based on Silver's example above, and since in many cases you want to find an available port rather than just verifying that a given port is in use:
uses
//Indy V10
IdContext,
IdSocketHandle,
IdTcpServer;
type
//our port-checking tool
TPortChk = class(TIdTCPServer)
procedure OnExec(AContext: TIdContext);
end;
procedure TPortChk.OnExec(AContext: TIdContext);
begin
//does nothing, but must exist and be hooked
end;
//check a TCP port to see if it's already in use.
//normally used before opening a listener.
function PortAvailable(APort: Word): Boolean;
var
svr: TPortChk;
bnd: TIdSocketHandle;
begin
//assume our port is available
Result := True;
//create our checking object
svr := TPortChk.Create;
try
//set the execute event
svr.OnExecute := svr.OnExec;
//loop looking for an available port
try
//set up the binding for our local system and the
//port in question
bnd := svr.Bindings.Add;
bnd.IP := '127.0.0.1';
bnd.Port := APort;
//try to bind. This will throw an EIdCouldNotBindSocket
//exception if the port is already in use.
svr.Active := True;
//if we get here, the port is *currently* available.
//close the server and bail
svr.Active := False;
Exit;
except
//whoops, port's in use (or some related failure)
Result := False;
end;
finally
svr.Free;
end;
end;
//search a range of ports for the first available
function FindAvailablePort(First, Count: Word): Word;
var
svr: TPortChk;
bnd: TIdSocketHandle;
begin
//assume our initial port is available
Result := First;
//create our checking object
svr := TPortChk.Create;
try
//set the execute event
svr.OnExecute := svr.OnExec;
//loop looking for an available port
while (Result - First) < Count do begin
try
//set up the binding for our local system and the
//port in question
bnd := svr.Bindings.Add;
bnd.IP := '127.0.0.1';
bnd.Port := Result;
//try to bind. This will throw an EIdCouldNotBindSocket
//exception if the port is already in use.
svr.Active := True;
//if we get here, we found our available port, so kill the
//server and bail
svr.Active := False;
Exit;
except
Inc(Result);
svr.Bindings.Clear;
end;
end;
//if we get here, all of our possible ports are in use,
//so return $FFFF to indicate that no port is available
Result := $FFFF;
finally
svr.Free;
end;
end;

Resources