delphpi tcp service and client examples

//服务器端
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,Winapi.WinSock;

type
  clients = record
    soc :TSocket;
    add :sockaddr_in;
  end;
  pclients = ^clients;

  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    procedure btn1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    s :TSocket;
    acThreadID :DWORD;
  end;

  procedure ServerAccept(s :TSocket);stdcall;
  procedure SocketWorkThread(ns :TSocket);stdcall;
const
  buflen=100;
var
  Form1: TForm1;

   clientslist :TList;

implementation

{$R *.dfm}


procedure  SocketWorkThread(ns :TSocket);stdcall;
var
   recvbuf :array[0..buflen -1] of Char;
   rtn,k :Integer;
   rs :string[buflen];
   rs2:string;
   error :string;
begin
   try
     while true do
     begin
       rtn := recv(ns,recvbuf,buflen,0);
       if rtn < 1 then
       begin
         for k := 0 to clientslist.Count -1 do
         begin
           if ns = pclients(clientslist.Items[k]).soc then
           begin
               FreeMem (clientslist.Items [k]); // ZL myself increasing feeling to be released under 
               clientslist.Delete (k); 
               Break; 
           End 
           the else 
             the Continue; 
         End ; 
         closesocket (ns); 
         error: = inttohex (ns, 2 ) + ' exit ' ; 
         Form1.mmo1.Lines.Add (error); 
         the ExitThread ( 0 );
        End ;
        // RS: = the PChar (@recvbuf); 
       RS2: = StrPas (recvbuf);
        // the ShowMessage ( 'RS = = '+ RS); 
       Form1.mmo1.Lines.Add (RS2);
     end;
   except
   end;
end;

procedure  ServerAccept(s :TSocket);stdcall;
var
   ra :sockaddr_in;
   ra_len :integer;
   recev :TSocket;
   ThreadID :DWORD;
   ip :string;
   newclient :pclients;
begin
   ra_len := SizeOf(ra);
   try
     while True do
     begin
       recev := accept(s,@ra,@ra_len);
       if recev = -1 then
       begin
         ExitThread(0);
       end;
       ip := IntToHex(recev,2)+'-'+ IntToStr(Ord(ra.sin_addr.S_un_b.s_b1))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b2))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b3))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b4));
       Form1.mmo1.Lines.Add(ip);
       GetMem(newclient,SizeOf(clients));
       newclient.soc := recev;
       newclient.add := ra;
       clientslist.Add(newclient);
       CreateThread(nil,0,@SocketWorkThread,Pointer(recev),0,ThreadID);
     end;
   except
   end;
end;


procedure TForm1.btn1Click(Sender: TObject);
var
 wsa:TWSAData;
 wsstatus:Integer;
  sa:sockaddr_in;
begin
  wsstatus := WSAStartup($0202,wsa);
  if wsstatus<> 0 then
   begin
     ShowMessage('初始化socket出错！');
     Exit;
   end;

   s := Socket(AF_INET,SOCK_STREAM,0);
   if s < 0 then
   begin
     ShowMessage('创建socket出错！');
     WSACleanup;
     Exit;
   end;

   sa.sin_port := htons(StrToInt('2002'));
   sa.sin_family := AF_INET;
   sa.sin_addr.S_addr := INADDR_ANY;
   wsstatus := bind(s,sa,SizeOf(sa));
   if wsstatus <> 0 then
   begin
     ShowMessage('绑定socket出错');
     WSACleanup;
     Exit;
   end;

   wsstatus := listen(s,5);
   if   wsstatus <> 0 then
   begin
     ShowMessage('监听出错！');
     WSACleanup;
     Exit;
   end;

   clientslist := TList.Create;
   CreateThread(nil,0,@ServerAccept,Pointer(s),0,acThreadID);
   btn1.Enabled := False;
   Form1.Caption: = ' server is started ' ;
 End ; 



Procedure TForm1.FormClose (Sender: TObject; var Action: TCloseAction);
 the begin 
  clientslist.Free; // ZL myself increasing feeling to be released 
End ; 

End . 


/ / client 

Unit Unit1; 

interface 

uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.WinSock, Vcl. StdCtrls; 

type 
  TForm1 = class (a TForm) 
    btnCon: the TButton; 
    btnSend: the TButton;
    btnDis: TButton;
    mmo1: TMemo;
    edtSend: TEdit;
    procedure btnConClick(Sender: TObject);
    procedure btnDisClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
  private
    { Private declarations }
  public
    s:TSocket;
  end;
procedure Receive(server :TSocket);stdcall;
const buflen = 100;
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure Receive(server :TSocket);stdcall;
var
   recbuf:array[0..buflen -1] of Char;
   rtn :Integer;
   rs :string;
begin
   while True do
   begin
       rtn := recv(server,recbuf,buflen,0);
       if rtn < 1 then
       begin
           closesocket(server);
           ExitThread(0);
       end;
           rs := pchar(@recbuf);
       Form1.mmo1.Lines.Add(rs);
   end;
end;


procedure TForm1.btnConClick(Sender: TObject);
var
   sa :TWSAData;
   wstates :Integer;
   ad :sockaddr_in;
   threadid :DWORD;
begin
     wstates := WSAStartup($0202,sa);
     if   wstates <> 0 then
     begin
         ShowMessage('socket初始化出错！');
         Exit;
     end;

     s := socket(PF_INET,SOCK_STREAM,IPPROTO_IP);
     if s = INVALID_SOCKET then
     begin
         ShowMessage ( ' establish socket error! ' ); 
         WSACleanup; 
         Exit; 
     End ; 

     ad.sin_family: = PF_INET; 
     ad.sin_port: = htons (StrToInt ( ' 2002 ' )); 
     ad.sin_addr.S_addr: = inet_addr (PAnsiChar ( ' 127.0.0.1 ' )); 
     wstates: = connect (S, AD, the SizeOf (AD));
      IF wstates <> 0  the then 
     the begin 
       the ShowMessage ( ' connection error ' ); 
       WSACleanup; 
       btnCon.Enabled: = to false; 
       the Exit; 
     End;

   CreateThread(nil,0,@Receive,Pointer(s),0,threadid);
end;


procedure TForm1.btnDisClick(Sender: TObject);
begin
  try
    closesocket(s);
    WSACleanup;
  finally
    btnCon.Enabled := True;
  end;
end;

procedure TForm1.btnSendClick(Sender: TObject);
var
   sendbuf :array[0..buflen -1] ofChar; 
   sendLen: Integer; 
   I: Integer; 
the begin
   if edtSend.Text <> ''  the then 
   the begin 
     FillChar (the sendbuf, 100 , 0 ); // important here: the receiving terminal or an individual prone to distortion phenomenon 

       for I: = 0  to the Length (edtSend.Text) - . 1  do 
           the sendbuf [I]: = (edtSend.Text) [I + . 1 ]; 
       sendLen: = send (S, the sendbuf, buflen,, 0 ); 

       IF sendLen < 0  the then 
       the begin 
           the ShowMessage ( ' transmission errors ' ); 
           WSACleanup; 
           btnCon.Enabled: = False; 
           the Exit;
       over ;
   over ;
over ; 


than .