 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2007, <kouriakine@mail.ru>
 TCP Sockets, TCP/IP routines.
 Modifications:
  20070204 - Creation
  20070215 - first tested release
  20070228 - set SNDBUF, RCVBUF
  20070303 - use DuplicateHandle
 ****************************************************************************
 }

unit _tcp; // TCP/IP routines

{$I _sysdef}

interface

uses
 windows, winsock, sysutils, classes, math,
 _alloc, _fifo, _rtc, _str, _fio, _polling, _dynar;

 {
 *******************************************************************************
 Назначение.
  Этот модуль предназначен для работы с потоковыми TCP сокетами.
 *******************************************************************************
 Принцип работы.
  Всеми операциями I/O занимается отдельный поток, который общается с клиентским
  потоком через FIFO. Поток периодически сканирует канал, инициирует необходимые
  операции чтения/записи, беря данные из FIFO передатчика и помещая в FIFO буфер
  приемника, а также регистрируя ошибки при помощи процедуры пользователя Report
  При старте или при разрыве связи:
   - сервер закрывает канал и создает его снова
   - клиент периодически пытается открыть существующий канал
  Поэтому при разрыве связи она автоматически восстанавливается, когда возникают
  благоприятные условия. Это хорошо для случая, когда измерительная машина может
  работать автономно. Как только появилась связь с центральным сервером, канал
  тут же ее подхватывает. Удобно.
  Указанный метод не блещет изощренностью, но представляется наиболее устойчивым
  к возможным сбоям, а кроме того,  проще, чем работа по событиям или сообщениям,
  а потому кажется предпочтительнее для измерительных задач.
 *******************************************************************************
 Программирование.
  TTcpServer - сервер для входящих соединений, он не имеет функций чтения-записи
  но имеет Count дочерних каналов Pipes, которые служат и для ввода-вывода.
  При этом сервер может обслуживать Count входящих соединений.
  TTcpClient - клиент для исходящих соединений, он имеет функции чтения-записи, 
  при этом Count=1 и Self[0]=Self, то есть канал соединения всегда один.
  Поэтому код
   for i:=0 to pipe.Count-1 do
   if pipe[i].Connected>0 then begin
    write(pipe[i].RxFifo.GetText);      // Receive data...
    pipe[i].TxFifo.PutTex(GetUserData); // Transmit data ...
   end;
  будет работать всегда.
  Owner - родительский сокет, отличен от nil только для дочерних каналов сервера
  Count - число дочерних каналов сервера или 1 для клиента.
  Pipes - массив дочерних каналов сервера или Self для клиента.
  Connected - число активных соединений, равно 0/1 для потоковых сокетов,а также
  0..Count для сервера.
  Handle - дескриптор сокета или INVALID_SOCKET.
  Port - номер TCP порта.
  IsServer - равен True для сервера и его дочерних каналов.
  IsStream - равен True для клиента и дочерних каналов сервера,указывает наличие
  функций чтения-записи.
  Target - имя сервера, с которым хочет соединиться клиент.
  HostIP,PeerIP - IP адреса локальной и удаленной машины.
  HostName,PeerName - имена локальной и удаленной машины.
  RxFifo,TxFifo - буферы ввода-вывода, присутствуют только у IsStream сокетов.
  Для обмена данными используется FIFO RxFifo-приемник, TxFifo-передатчик.
  Для чтения данных из канала вызывается pipe.RxFifo.Get.
  Для записи данных в канал   вызывается pipe.TxFifo.Put.
  Polling - опрос канала организуется через поток Polling.
  Для приостановки опроса используйте pipe.Polling.Enable(..)
  Reporter - callback процедура для сообщений об ошибках. Еще надо анализировать
  RxFifo.Lost,TxFifo.Lost.
  Все каналы регистрируются в списке FullSocketList.
  На низком уровне используются только средства Win32 и функции Berkley sockets.
 *******************************************************************************
 Пример программирования.
  Server:
   pipe:=NewTcpServer(1234);
   while not Terminated do
   for i:=0 to pipe.Count-1 do
   if pipe[i].Connected>0 then begin
    write(pipe[i].RxFifo.GetText);      // Receive data...
    pipe[i].TxFifo.PutTex(GetUserData); // Transmit data ...
   end;
   Kill(pipe);
  Client:
   pipe:=NewTcpClient(1234,'localhost');
   while not Terminated do begin
    write(pipe.RxFifo.GetText);      // Receive data...
    pipe.TxFifo.PutTex(GetUserData); // Transmit data ...
   end;
   Kill(pipe);
 *******************************************************************************
 }
const
 DefSocketTimeOut  = 1000;                                                      // Default socket timeout
 DefSocketTxSize   = 1024*16;                                                   // Default socket Tx fifo size
 DefSocketRxSize   = DefSocketTxSize*2;                                         // Default socket Rx fifo size
 DefSocketSndBuff  = 1024*16;                                                   // Default socket SND buffer
 DefSocketRcvBuff  = 1024*16;                                                   // Default socket RCV buffer
 DefSocketDelay    = 1;                                                         // Default socket polling delay
 DefSocketPriority = tpTimeCritical;                                            // Default socket thread priority
 DefSocketOptions  = $08;                                                       // Default socket options
 so_CloseShutdown  = $00000001;                                                 // Socket shutdown before close
 so_CloseTxClean   = $00000002;                                                 // Clear TxFifo on close connection
 so_CloseRxClean   = $00000004;                                                 // Clear RxFifo on close connection
 so_TcpNoDelay     = $00000008;                                                 // Use TCP_NODELAY option
 so_UseLinger0     = $00000010;                                                 // Use LINGER with zero timeout
 so_SetSndBuff     = $00000020;                                                 // Set socket Tx = SND buffer size
 so_SetRcvBuff     = $00000040;                                                 // Set socket Rx = RCV buffer size

type
 //////////////
 // TSocketPipe
 //////////////
 TSocketPipe = class;                                                           // Forward declaration
 ESocketFail = class(ESoftException);                                           // Socket exception
 TSocketReporter = procedure(                                                   // Proc. to report errors
                           Pipe:TSocketPipe;                                    // Sender socket pipe
                           When:Double;                                         // When it happened
                           What:PChar;                                          // What is happened
                           Code:Integer);                                       // Error code
 TSocketPipe = class(TMasterObject)                                             // TCP/IP pipe class
 private
  myOwner     : TSocketPipe;                                                    // Owner socket or NIL
  myChilds    : TObjectStorage;                                                 // Child sockets
  myHandle    : TSocket;                                                        // Socket handle
  myPort      : Word;                                                           // TCP/IP port number
  myHostIP    : Cardinal;                                                       // Local host IP
  myPeerIP    : Cardinal;                                                       // Peer  host IP
  myTarget    : array[0..MAX_PATH] of Char;                                     // Remote server name
  myHostName  : array[0..MAX_PATH] of Char;                                     // Local host name
  myPeerName  : array[0..MAX_PATH] of Char;                                     // Peer  host name
  myConnected : Integer;                                                        // How many connections
  myOptions   : Cardinal;                                                       // Option flags
  myRxFifo    : TFifo;                                                          // Receiver FIFO
  myTxFifo    : TFifo;                                                          // Transmitter FIFO
  myPolling   : TPolling;                                                       // Polling thread
  myReporter  : TSocketReporter;                                                // Proc. to report errors
  myTimeOut   : Integer;                                                        // Timeout to check connection
  myRxBuff    : ShortString;                                                    // Uses as buffer to receive
  myTxBuff    : ShortString;                                                    // Uses as buffer to transmit
  myWSAData   : TWSAData;                                                       // Temporary
  myRxLost    : Int64;                                                          // Last value of RxFifo.Lost
  myTxLost    : Int64;                                                          // Last value of TxFifo.Lost
  myLastCheck : Cardinal;                                                       // Time when last check done
  function    Childs:TObjectStorage;
  function    GetOwner:TSocketPipe;
  function    GetCount:Integer;
  function    GetPipes(i:Integer):TSocketPipe;
  function    GetConnected:Integer;
  function    GetOptions:Cardinal;
  procedure   SetOptions(aOptions:Cardinal);
  function    GetHandle:TSocket;
  function    GetPort:Word;
  function    GetHostIP:Cardinal;
  function    GetPeerIP:Cardinal;
  function    GetTarget:LongString;
  function    GetHostName:LongString;
  function    GetPeerName:LongString;
  function    GetIsServer:Boolean;
  function    GetIsStream:Boolean;
  function    GetRxFifo:TFifo;
  function    GetTxFifo:TFifo;
  function    GetPolling:TPolling;
  procedure   Report(What:PChar; Code:Integer);
  procedure   SetReporter(aReporter:TSocketReporter);
  procedure   Close(aErrorCode:Integer=ERROR_SUCCESS; aRxLost:Integer=0; aTxLost:Integer=0);
  procedure   KillSocket(var aSocket:TSocket; aOptions:Cardinal);
  procedure   Poll;
 public
  constructor Create(aOwner:TSocketPipe; aMaxPipes:Integer; aName:LongString);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public // properties
  property    Owner              : TSocketPipe     read  GetOwner;              // Parent socket or nil
  property    Count              : Integer         read  GetCount;              // Number of childs
  property    Pipes[i:Integer]   : TSocketPipe     read  GetPipes; default;     // Child sockets
  property    Connected          : Integer         read  GetConnected;          // Number of connections
  property    Options            : Cardinal        read  GetOptions write SetOptions; // See so_XXX
  property    Handle             : TSocket         read  GetHandle;             // Socket handle or INVALID_SOCKET
  property    Port               : Word            read  GetPort;               // TCP/IP port number
  property    IsServer           : Boolean         read  GetIsServer;           // Server or client?
  property    IsStream           : Boolean         read  GetIsStream;           // Read/writable?
  property    Target             : LongString      read  GetTarget;             // Target server
  property    HostIP             : Cardinal        read  GetHostIP;             // Local  host IP
  property    PeerIP             : Cardinal        read  GetPeerIP;             // Remote host IP
  property    HostName           : LongString      read  GetHostName;           // Local  host name
  property    PeerName           : LongString      read  GetPeerName;           // Remote host name
  property    RxFifo             : TFifo           read  GetRxFifo;             // Receiver    FIFO
  property    TxFifo             : TFifo           read  GetTxFifo;             // Transmitter FIFO
  property    Polling            : TPolling        read  GetPolling;            // Polling thread
  property    Reporter           : TSocketReporter write SetReporter;           // Error report procedure
 end;
 /////////////
 // TTcpServer
 /////////////
 TTcpServer = class(TSocketPipe)
 public
  constructor Create(aPort       : Word;                                        // TCP/IP port
                     aMaxPipes   : Integer;                                     // Max connections
                     aReporter   : TSocketReporter;                             // Callback to report errors
                     aDelay      : Integer;                                     // Polling delay
                     aPriority   : TThreadPriority;                             // Thread priority
                     aRxFifoSize : Integer;                                     // Receiver fifo size
                     aTxFifoSize : Integer;                                     // Transmitter fifo size
                     aTimeOut    : Integer;                                     // Timeout for connections
                     aOptions    : Integer);                                    // Option flags
  destructor Destroy; override;
 end;
 /////////////
 // TTcpClient
 /////////////
 TTcpClient = class(TSocketPipe)
 public
  constructor Create(aPort       : Word;                                        // TCP/IP port
                     aTarget     : LongString;                                  // Targer server to connect to
                     aReporter   : TSocketReporter;                             // Callback to report errors
                     aDelay      : Integer;                                     // Polling delay
                     aPriority   : TThreadPriority;                             // Thread priority
                     aRxFifoSize : Integer;                                     // Receiver fifo size
                     aTxFifoSize : Integer;                                     // Transmitter fifo size
                     aTimeOut    : Integer;                                     // Timeout for connections
                     aOptions    : Integer);                                    // Option flags
  destructor  Destroy; override;
 end;

 ////////////////////
 // Utility functions
 ////////////////////

function  NewTcpServer(aPort       : Word;                                       // TCP/IP port
                       aMaxPipes   : Integer         = 1;                        // Max connections
                       aReporter   : TSocketReporter = nil;                      // Callback to report errors
                       aDelay      : Integer         = DefSocketDelay;           // Polling delay
                       aPriority   : TThreadPriority = DefSocketPriority;        // Thread priority
                       aRxFifoSize : Integer         = DefSocketRxSize;          // Receiver fifo size
                       aTxFifoSize : Integer         = DefSocketTxSize;          // Transmitter fifo size
                       aTimeOut    : Integer         = DefSocketTimeOut;         // Timeout for connections
                       aOptions    : Integer         = DefSocketOptions          // Option flags
                                  ): TTcpServer;
function  NewTcpClient(aPort       : Word;                                       // TCP/IP port
                       aTarget     : LongString;                                 // Targer server to connect to
                       aReporter   : TSocketReporter = nil;                      // Callback to report errors
                       aDelay      : Integer         = DefSocketDelay;           // Polling delay
                       aPriority   : TThreadPriority = DefSocketPriority;        // Thread priority
                       aRxFifoSize : Integer         = DefSocketRxSize;          // Receiver fifo size
                       aTxFifoSize : Integer         = DefSocketTxSize;          // Transmitter fifo size
                       aTimeOut    : Integer         = DefSocketTimeOut;         // Timeout for connections
                       aOptions    : Integer         = DefSocketOptions          // Option flags
                                  ): TTcpClient;

procedure Kill(var TheObject:TSocketPipe); overload;
procedure Kill(var TheObject:TTcpServer); overload;
procedure Kill(var TheObject:TTcpClient); overload;

function FullSocketList:TObjectStorage;

 ///////////////////
 // TCP/IP utilities
 ///////////////////
function IPToStr(IP:Cardinal):LongString;
function StrToIP(Host:LongString):Cardinal;
function SocketErrorMessage(ErrorCode:Integer):LongString;
function SocketErrorReport(Comment:LongString; ErrorCode:Integer):LongString;

procedure TestSocketPipes;

implementation

const // shutdown flags
 SD_RECEIVE = 0;
 SD_SEND    = 1;
 SD_BOTH    = 2;

 ///////////////////
 // TCP/IP utilities
 ///////////////////
function IPToStr(IP:Cardinal):LongString;
var Addr:TInAddr;
begin
 Addr.S_addr:=IP;
 Result:=WinSock.inet_ntoa(Addr);
end;

function StrToIP(Host:LongString):Cardinal;
begin
  Result:=WinSock.inet_addr(PChar(Host))  
end;

function SocketErrorMessage(ErrorCode:Integer):LongString;
begin
 Result:=SysErrorMessage(ErrorCode);
 if Length(Result)=0 then
 case ErrorCode of
  WSAEINTR:           Result := 'Interrupted system call';
  WSAEBADF:           Result := 'Bad file number';
  WSAEACCES:          Result := 'Permission denied';
  WSAEFAULT:          Result := 'Bad address';
  WSAEINVAL:          Result := 'Invalid argument';
  WSAEMFILE:          Result := 'Too many open files';
  WSAEWOULDBLOCK:     Result := 'Operation would block';
  WSAEINPROGRESS:     Result := 'Operation now in progress';
  WSAEALREADY:        Result := 'Operation already in progress';
  WSAENOTSOCK:        Result := 'Socket operation on non-socket';
  WSAEDESTADDRREQ:    Result := 'Destination address required';
  WSAEMSGSIZE:        Result := 'Message too long';
  WSAEPROTOTYPE:      Result := 'Protocol wrong type for socket';
  WSAENOPROTOOPT:     Result := 'Protocol not available';
  WSAEPROTONOSUPPORT: Result := 'Protocol not supported';
  WSAESOCKTNOSUPPORT: Result := 'Socket type not supported';
  WSAEOPNOTSUPP:      Result := 'Operation not supported on socket';
  WSAEPFNOSUPPORT:    Result := 'Protocol family not supported';
  WSAEAFNOSUPPORT:    Result := 'Address family not supported by protocol family';
  WSAEADDRINUSE:      Result := 'Address already in use';
  WSAEADDRNOTAVAIL:   Result := 'Can''t assign requested address';
  WSAENETDOWN:        Result := 'Network is down';
  WSAENETUNREACH:     Result := 'Network is unreachable';
  WSAENETRESET:       Result := 'Network dropped connection on reset';
  WSAECONNABORTED:    Result := 'Software caused connection abort';
  WSAECONNRESET:      Result := 'Connection reset by peer';
  WSAENOBUFS:         Result := 'No buffer space available';
  WSAEISCONN:         Result := 'Socket is already connected';
  WSAENOTCONN:        Result := 'Socket is not connected';
  WSAESHUTDOWN:       Result := 'Can''t send after socket shutdown';
  WSAETOOMANYREFS:    Result := 'Too many references: can''t splice';
  WSAETIMEDOUT:       Result := 'Connection timed out';
  WSAECONNREFUSED:    Result := 'Connection refused';
  WSAELOOP:           Result := 'Too many levels of symbolic links';
  WSAENAMETOOLONG:    Result := 'File name too long';
  WSAEHOSTDOWN:       Result := 'Host is down';
  WSAEHOSTUNREACH:    Result := 'No route to host';
  WSAENOTEMPTY:       Result := 'Directory not empty';
  WSAEPROCLIM:        Result := 'Too many processes';
  WSAEUSERS:          Result := 'Too many users';
  WSAEDQUOT:          Result := 'Disk quota exceeded';
  WSAESTALE:          Result := 'Stale NFS file handle';
  WSAEREMOTE:         Result := 'Too many levels of remote in path';
  WSASYSNOTREADY:     Result := 'Network sub-system is unusable';
  WSAVERNOTSUPPORTED: Result := 'WinSock DLL cannot support this application';
  WSANOTINITIALISED:  Result := 'WinSock not initialized';
  WSAHOST_NOT_FOUND:  Result := 'Host not found';
  WSATRY_AGAIN:       Result := 'Non-authoritative host not found';
  WSANO_RECOVERY:     Result := 'Non-recoverable error';
  WSANO_DATA:         Result := 'No Data';
 end;
end;

function SocketErrorReport(Comment:LongString; ErrorCode:Integer):LongString;
begin
 Result:=Format('%s: %d="%s".',[Comment,ErrorCode,SocketErrorMessage(ErrorCode)]);
end;

 /////////////////////////////
 // TSocketPipe implementation
 /////////////////////////////
procedure SocketPollAction(aPolling:TPolling; var Terminate:Boolean);
begin
 if aPolling.LinkObject is TSocketPipe
 then (aPolling.LinkObject as TSocketPipe).Poll
 else Terminate:=true;
end;

constructor TSocketPipe.Create(aOwner:TSocketPipe; aMaxPipes:Integer; aName:LongString);
var
 ErrorCode : Integer;
begin
 inherited Create;
 myOwner:=aOwner;
 myHandle:=INVALID_SOCKET;
 myOptions:=DefSocketOptions;
 if Assigned(myOwner) then begin
  myPort:=myOwner.myPort;
  myTimeOut:=myOwner.myTimeOut;
  myOptions:=myOwner.myOptions;
  myReporter:=myOwner.myReporter;
 end else begin
  myPolling:=NewPolling(SocketPollAction, DefSocketDelay, DefSocketPriority, false, aName);
  myPolling.Master:=myPolling;
  myPolling.LinkObject:=Self;
 end;
 if aMaxPipes>0 then begin
  myChilds:=NewObjectStorage(True,aMaxPipes,0);
  myChilds.Master:=myChilds;
 end else begin
  myRxFifo:=NewFifo(DefSocketRxSize);
  myRxFifo.Master:=myRxFifo;
  myTxFifo:=NewFifo(DefSocketTxSize);
  myTxFifo.Master:=myTxFifo;
 end;
 ErrorCode:=WinSock.WSAStartup($0101,myWSAData);
 Report('WSAStartup',ErrorCode);
end;

destructor TSocketPipe.Destroy;
var
 ErrorCode : Integer;
begin
 try
  Polling.Enable(false);
  Close(ERROR_SUCCESS);
  Kill(myPolling);
  Kill(myRxFifo);
  Kill(myTxFifo);
  Kill(myChilds);
  ErrorCode:=WinSock.WSACleanup;
  Report('WSACleanup',ErrorCode);
 except
  on E:Exception do BugReport(E,Self);
 end;
 inherited;
end;

procedure TSocketPipe.AfterConstruction;
begin
 inherited;
 FullSocketList.Add(Self);
 Owner.Childs.Add(Self);
 Polling.Enable(true);
end;

procedure TSocketPipe.BeforeDestruction;
var
 Owns  : Boolean;
 Index : Integer;
begin
 Polling.Enable(false);
 FullSocketList.Remove(Self);
 Owner.Childs.Lock;
 try
  Index:=Owner.Childs.IndexOf(Self);
  if Index>=0 then begin
   Owns:=Owner.Childs.OwnsObjects;
   Owner.Childs.OwnsObjects:=false;
   Owner.Childs.Delete(Index);
   Owner.Childs.OwnsObjects:=Owns;
  end;
 finally
  Owner.Childs.UnLock;
 end;
 inherited;
end;

procedure TSocketPipe.KillSocket(var aSocket:TSocket; aOptions:Cardinal);
begin
 if Assigned(Self) then
 if aSocket <> INVALID_SOCKET then begin               // If socket opened
  if aOptions and so_CloseShutdown <> 0 then
  if WinSock.Shutdown(aSocket,SD_BOTH)<>ERROR_SUCCESS  // Shutdown socket
  then Report('Shutdown',WinSock.WSAGetLastError)
  else Report('Shutdown',ERROR_SUCCESS);
  if WinSock.CloseSocket(aSocket)<>ERROR_SUCCESS       // Close socket
  then Report('CloseSocket',WinSock.WSAGetLastError)
  else Report('CloseSocket',ERROR_SUCCESS);
  aSocket:=INVALID_SOCKET;                             // Mark it closed
 end;
end;

procedure CloseChildPipe(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if aObject is TSocketPipe then (aObject as TSocketPipe).Close(LongInt(CustomData));
end;

procedure TSocketPipe.Close(aErrorCode:Integer; aRxLost:Integer; aTxLost:Integer);
var
 LostRx : Integer;
 LostTx : Integer;
begin
 if Assigned(Self) then
 try
  Report('Close',aErrorCode);
  Childs.ForEach(CloseChildPipe,Pointer(aErrorCode));               // Close child connections
  KillSocket(myHandle,myOptions);                                   // Close socket if one opened
  myHostIP:=0; myPeerIP:=0;                                         // Clear host and peer IP
  myRxBuff:='';  myTxBuff:='';                                      // Clear raw buffers
  if myOptions and so_CloseRxClean <> 0                             // If allow RxFifo clean
  then LostRx:=Length(myRxFifo.GetText)                             // Receiver data lost
  else LostRx:=0;                                                   // No FIFO clean
  if myOptions and so_CloseTxClean <> 0                             // If allow TxFifo clean
  then LostTx:=Length(myTxFifo.GetText)                             // Transmitter data lost
  else LostTx:=0;                                                   // No FIFO clean
  SafeFillChar(myHostName,SizeOf(myHostName),0);                    // Clear host name
  SafeFillChar(myPeerName,SizeOf(myPeerName),0);                    // Clear peer name
  if Assigned(myOwner)                                              // If have parent then
  then LockedSub(myOwner.myConnected,LockedExchange(myConnected,0)) // clear self&owner connections
  else LockedExchange(myConnected,0);                               // else self connections
  if (aErrorCode<>ERROR_SUCCESS) or (aRxLost+aTxLost<>0) then begin // If error occured
   myRxFifo.Lost:=myRxFifo.Lost+LostRx+aRxLost;                     // Receiver data lost
   myTxFifo.Lost:=myTxFifo.Lost+LostTx+aTxLost;                     // Transmitter data lost
  end;
  Report('Closed',ERROR_SUCCESS);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TSocketPipe.GetOwner:TSocketPipe;
begin
 if Assigned(Self) then Result:=myOwner else Result:=nil;
end;

function TSocketPipe.Childs:TObjectStorage;
begin
 if Assigned(Self) then Result:=myChilds else Result:=nil;
end;

function TSocketPipe.GetCount:Integer;
begin
 if IsStream then Result:=1 else Result:=Childs.Count;
end;

function TSocketPipe.GetPipes(i:Integer):TSocketPipe;
begin
 if IsStream then begin
  if i=0 then Result:=Self else Result:=nil;
 end else begin
  TObject(Result):=Childs[i];
  if not (TObject(Result) is TSocketPipe) then Result:=nil;
 end;
end;

function TSocketPipe.GetPort:Word;
begin
 if Assigned(Self) then Result:=myPort else Result:=0;
end;

function TSocketPipe.GetConnected:Integer;
begin
 if Assigned(Self) then Result:=myConnected else Result:=0;
end;

function TSocketPipe.GetOptions:Cardinal;
begin
 if Assigned(Self) then Result:=myOptions else Result:=0;
end;

procedure TSocketPipe.SetOptions(aOptions:Cardinal);
begin
 if Assigned(Self) then myOptions:=aOptions;
end;

function TSocketPipe.GetHandle:TSocket;
begin
 if Assigned(Self) then Result:=myHandle else Result:=INVALID_SOCKET;
end;

function TSocketPipe.GetHostIP:Cardinal;
begin
 if Assigned(Self) then Result:=myHostIP else Result:=0;
end;

function TSocketPipe.GetPeerIP:Cardinal;
begin
 if Assigned(Self) then Result:=myPeerIP else Result:=0;
end;

function TSocketPipe.GetHostName:LongString;
begin
 if Assigned(Self) then Result:=myHostName else Result:='';
end;

function TSocketPipe.GetPeerName:LongString;
begin
 if Assigned(Self) then Result:=myPeerName else Result:='';
end;

function TSocketPipe.GetIsServer:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myOwner) or Assigned(myChilds)
 else Result:=False;
end;

function TSocketPipe.GetIsStream:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myRxFifo) and Assigned(myTxFifo)
 else Result:=False;
end;

function TSocketPipe.GetTarget:LongString;
begin
 if Assigned(Self) then Result:=myTarget else Result:='';
end;

function TSocketPipe.GetRxFifo:TFifo;
begin
 if Assigned(Self) then Result:=myRxFifo else Result:=nil;
end;

function TSocketPipe.GetTxFifo:TFifo;
begin
 if Assigned(Self) then Result:=myTxFifo else Result:=nil;
end;

function TSocketPipe.GetPolling:TPolling;
begin
 if Assigned(Self) then Result:=myPolling else Result:=nil;
end;

procedure TSocketPipe.SetReporter(aReporter:TSocketReporter);
begin
 if Assigned(Self) then myReporter:=aReporter;
end;

procedure TSocketPipe.Report(What:PChar; Code:Integer);
var Rep:TSocketReporter;
begin
 if Assigned(Self) then
 try
  if Assigned(myReporter) then Rep:=myReporter else
  if Assigned(myOwner) then Rep:=myOwner.myReporter else Rep:=nil;
  if Assigned(Rep) then Rep(Self,msecnow,What,Code);
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure PollChildPipe(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if aObject is TSocketPipe then (aObject as TSocketPipe).Poll;
end;

procedure FindChildPipe(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if Assigned(CustomData) then
 if aObject is TSocketPipe then
 with aObject as TSocketPipe do
 if myHandle=INVALID_SOCKET then begin
  TObject(CustomData^):=aObject;
  Terminate:=True;
 end;
end;

procedure TSocketPipe.Poll;
var
 SndBuff       : u_long;
 RcvBuff       : u_long;
 ReuseAddr     : u_long;
 NoBlocking    : u_long;
 TcpNoDelay    : u_long;
 Linger        : TLinger;
 ErrorCode     : Integer;
 Leng,Size     : Integer;
 tmpSocket     : TSocket;
 tmpSizeOf     : Integer;
 tmpHostEnt    : PHostEnt;
 tmpSockAddrIn : TSockAddrIn;
 Item          : TSocketPipe;
 FDSetR        : TFDSet;
 FDSetW        : TFDSet;
 FDSetE        : TFDSet;
 TimeVal       : TTimeVal;
 TimerPulse    : Boolean;
 procedure Trouble(aComment:PChar; aErrorCode:Integer; Fatal:Boolean=TRUE);
 begin
  Report(aComment,aErrorCode);
  if Fatal then begin
   Close(aErrorCode,0,Length(myTxBuff));
   RAISE ESocketFail.Create(SocketErrorReport(aComment,aErrorCode));
  end;
 end;
 procedure Success(aComment:PChar);
 begin
  Report(aComment,ERROR_SUCCESS);
 end;
begin
 if Assigned(Self) then
 try
  //
  // Generate timer pulse every TimeOut.
  //
  TimerPulse:=false;
  if abs(GetTickCount-myLastCheck)>myTimeOut then begin
   myLastCheck:=GetTickCount;
   TimerPulse:=true;
  end;
  //
  // Check if FIFO data lost, report if so.
  //
  if TimerPulse and IsStream then begin
   if myRxFifo.Lost<>myRxLost then begin
    if myRxFifo.Lost>myRxLost then Report('RxLost',-1);
    myRxLost:=myRxFifo.Lost;
   end;
   if myTxFifo.Lost<>myTxLost then begin
    if myTxFifo.Lost>myTxLost then Report('TxLost',-1);
    myTxLost:=myTxFifo.Lost;
   end;
  end;
  //
  // Poll parent server or client: try to accept or connect.
  //
  if not Assigned(myOwner) then begin
   //
   // If socket handle is not created, try to create it periodically.
   //
   if TimerPulse then
   if myHandle=INVALID_SOCKET then begin
    //
    // Get local host name and IP for future.
    //
    myHostIP:=0;
    FillChar(myHostName,SizeOf(myHostName),0);
    if WinSock.GetHostName(myHostName,SizeOf(myHostName))<>ERROR_SUCCESS
    then Trouble('GetHostName',WinSock.WSAGetLastError)
    else Success('GetHostName');
    tmpHostEnt:=WinSock.GetHostByName(myHostName);
    if Assigned(tmpHostEnt) then begin
     myHostIP:=PLongInt(tmpHostEnt^.h_addr^)^;
     // If domain name is not in host name, hope to get it from HostEnt.
     if StrPos('.',myHostName)=nil then begin
      tmpHostEnt:=WinSock.GetHostByAddr(tmpHostEnt.h_addr^, SizeOf(LongInt), AF_INET);
      if Assigned(tmpHostEnt) then StrCopy(myHostName,tmpHostEnt.h_name);
     end;
    end;
    //
    // Create TCP stream socket.
    //
    myHandle:=WinSock.Socket(PF_INET,SOCK_STREAM,IPPROTO_TCP);
    if myHandle=INVALID_SOCKET
    then Trouble('Socket',WinSock.WSAGetLastError)
    else Success('Socket');
    //
    // Make socket private (non-inherited) for child processes.
    //
    if not Windows.DuplicateHandle(GetCurrentProcess,myHandle,
                                   GetCurrentProcess,@myHandle,
                                   GENERIC_READ or GENERIC_WRITE,
                                   FALSE,DUPLICATE_CLOSE_SOURCE)
    then Trouble('DuplicateHandle',GetLastError,FALSE)
    else Success('DuplicateHandle');
    //
    // Disables the Nagle algorithm for send coalescing.
    //
    if myOptions and so_TcpNoDelay<>0 then
    if myHandle<>INVALID_SOCKET then begin
     TcpNoDelay:=1;
     if WinSock.SetSockOpt(myHandle,IPPROTO_TCP,TCP_NODELAY,@TcpNoDelay,SizeOf(TcpNoDelay))<>ERROR_SUCCESS
     then Trouble('SetSockOpt_TcpNoDelay',WinSock.WSAGetLastError,FALSE)
     else Success('SetSockOpt_TcpNoDelay');
    end;
    //
    // Set Rx buffer size
    //
    if myOptions and so_SetRcvBuff<>0 then
    if myHandle<>INVALID_SOCKET then begin
     RcvBuff:=DefSocketRcvBuff;
     if WinSock.SetSockOpt(myHandle,SOL_SOCKET,SO_RCVBUF,@RcvBuff,SizeOf(RcvBuff))<>ERROR_SUCCESS
     then Trouble('SetSockOpt_RcvBuff',WinSock.WSAGetLastError,FALSE)
     else Success('SetSockOpt_RcvBuff');
    end;
    //
    // Set Tx buffer size
    //
    if myOptions and so_SetSndBuff<>0 then
    if myHandle<>INVALID_SOCKET then begin
     SndBuff:=DefSocketSndBuff;
     if WinSock.SetSockOpt(myHandle,SOL_SOCKET,SO_SNDBUF,@SndBuff,SizeOf(SndBuff))<>ERROR_SUCCESS
     then Trouble('SetSockOpt_SndBuff',WinSock.WSAGetLastError,FALSE)
     else Success('SetSockOpt_SndBuff');
    end;
    //
    // Use LINGER with zero timeout.
    //
    if myOptions and so_UseLinger0<>0 then
    if myHandle<>INVALID_SOCKET then begin
     Linger.l_onoff:=1;
     Linger.l_linger:=0;
     if WinSock.SetSockOpt(myHandle,SOL_SOCKET,SO_LINGER,@Linger,SizeOf(Linger))<>ERROR_SUCCESS
     then Trouble('SetSockOpt_Linger',WinSock.WSAGetLastError,FALSE)
     else Success('SetSockOpt_Linger');
    end;
    //
    // Set no-blocking mode.
    //
    if myHandle<>INVALID_SOCKET then begin
     NoBlocking:=1;
     if WinSock.IOCtlSocket(myHandle,FIONBIO,NoBlocking)<>ERROR_SUCCESS
     then Trouble('IOCtlSocket',WinSock.WSAGetLastError)
     else Success('IOCtlSocket');
    end;
    //
    // Bind server TCP port. Try reusing address.
    //
    if IsServer then
    if myHandle<>INVALID_SOCKET then begin
     FillChar(tmpSockAddrIn,SizeOf(tmpSockAddrIn),0);
     tmpSockAddrIn.sin_family:=AF_INET;
     tmpSockAddrIn.sin_addr.s_addr:=WinSock.htonl(INADDR_ANY);
     tmpSockAddrIn.sin_port:=WinSock.htons(Port);
     ReuseAddr:=1;
     if WinSock.SetSockOpt(myHandle,SOL_SOCKET,SO_REUSEADDR,@ReuseAddr,SizeOf(ReuseAddr))<>ERROR_SUCCESS
     then Trouble('SetSockOpt',WinSock.WSAGetLastError)
     else Success('SetSockOpt');
     if WinSock.Bind(myHandle,tmpSockAddrIn,SizeOf(tmpSockAddrIn))<>ERROR_SUCCESS
     then Trouble('Bind',WinSock.WSAGetLastError)
     else Success('Bind');
    end;
    //
    // Put server to listen mode.
    //
    if IsServer then
    if myHandle<>INVALID_SOCKET then begin
     if WinSock.Listen(myHandle,SOMAXCONN)<>ERROR_SUCCESS
     then Trouble('Listen',WinSock.WSAGetLastError)
     else Success('Listen');
    end;
    //
    // Connect client to target server.
    //
    if not IsServer then
    if myHandle<>INVALID_SOCKET then begin
     FillChar(tmpSockAddrIn,SizeOf(tmpSockAddrIn),0);
     tmpSockAddrIn.sin_family:=AF_INET;
     tmpSockAddrIn.sin_addr.s_addr:=WinSock.inet_addr(myTarget);
     if tmpSockAddrIn.sin_addr.s_addr=-1 then begin
      tmpHostEnt:=WinSock.GetHostByName(myTarget);
      if not Assigned(tmpHostEnt)
      then Trouble('GetHostByName',WSAEHOSTUNREACH)
      else Success('GetHostByName');
      tmpSockAddrIn.sin_addr.S_addr:=PLongInt(tmpHostEnt^.h_addr_list^)^;
     end;
     tmpSockAddrIn.sin_port:=WinSock.htons(Port);
     ErrorCode:=WinSock.Connect(myHandle,tmpSockAddrIn,SizeOf(tmpSockAddrIn));
     if ErrorCode<>ERROR_SUCCESS then begin
      if WinSock.WSAGetLastError<>WSAEWOULDBLOCK
      then Trouble('Connect',WinSock.WSAGetLastError)
      else ; // Should wait for connection...
     end else Success('Connect');
    end;
   end;
   //
   // Exit if socket handle still was not created.
   //
   if myHandle=INVALID_SOCKET then Exit;
   //
   // Try to accept income server connection.
   //
   if IsServer then
   if Connected<Count+1 then // +0/1=No/Disconnect if no free pipes?
   if myHandle<>INVALID_SOCKET then begin
    tmpSizeOf:=SizeOf(tmpSockAddrIn);
    tmpSocket:=WinSock.Accept(myHandle,@tmpSockAddrIn,@tmpSizeOf);
    if tmpSocket=INVALID_SOCKET then begin
     if WinSock.WSAGetLastError<>WSAEWOULDBLOCK
     then Trouble('Accept',WinSock.WSAGetLastError)
     else ; // Should wait for connection...
    end else begin
     //
     // New connection is accepted. Try to find free SocketPipe.
     //
     Item:=nil;
     Childs.ForEach(FindChildPipe,@Item);
     if Assigned(Item) then begin
      //
      // Free socket Item was found. Put this socket to polling list.
      //
      Item.myHandle:=tmpSocket;
      Item.myHostIP:=myHostIP;
      StrCopy(Item.myHostName,myHostName);
      Item.myPeerIP:=tmpSockAddrIn.sin_addr.S_addr;
      FillChar(Item.myPeerName,SizeOf(Item.myPeerName),0);
      StrCopy(Item.myPeerName,WinSock.inet_ntoa(tmpSockAddrIn.sin_addr));
      tmpHostEnt:=WinSock.GetHostByAddr(@Item.myPeerIP, SizeOf(LongInt), AF_INET);
      if Assigned(tmpHostEnt) then StrCopy(Item.myPeerName,tmpHostEnt.h_name);
      NoBlocking:=1;
      if WinSock.IOCtlSocket(Item.myHandle,FIONBIO,NoBlocking)<>ERROR_SUCCESS
      then Item.Report('IOCtlSocket',WinSock.WSAGetLastError)
      else Item.Report('IOCtlSocket',ERROR_SUCCESS);
      LockedInc(Item.myConnected);
      LockedInc(myConnected);
      Item.Report(PChar(Format('Accepted %s=%s',[IpToStr(Item.PeerIP),Item.PeerName])),ERROR_SUCCESS);
     end else KillSocket(tmpSocket,so_CloseShutdown); // Because no free socket Item was found.
    end;
   end;
   //
   // Poll child server sockets.
   //
   if IsServer then
   if myHandle<>INVALID_SOCKET then Childs.ForEach(PollChildPipe,nil);
   //
   // Check connection is eastablished or not.
   //
   if Connected<1 then
   if not IsServer then
   if myHandle<>INVALID_SOCKET then begin
    //
    // Read socket state.
    //
    TimeVal.tv_sec:=0;
    TimeVal.tv_usec:=0;
    FD_ZERO(FDSetR); FD_SET(myHandle,FDSetR);
    FD_ZERO(FDSetW); FD_SET(myHandle,FDSetW);
    FD_ZERO(FDSetE); FD_SET(myHandle,FDSetE);
    ErrorCode:=WinSock.Select(myHandle, @FDSetR, @FDSetW, @FDSetE, @TimeVal);
    if ErrorCode=SOCKET_ERROR then Trouble('Select',WinSock.WSAGetLastError);
    if FD_ISSET(myHandle,FDSetE) then Trouble('Select',WinSock.WSAGetLastError);
    //
    // If socket is writeable, it means connection eastablished.
    //
    if FD_ISSET(myHandle,FDSetW) then begin
     tmpSizeOf:=SizeOf(tmpSockAddrIn);
     if WinSock.GetPeerName(myHandle,tmpSockAddrIn,tmpSizeOf)=ERROR_SUCCESS then begin
      myPeerIP:=tmpSockAddrIn.sin_addr.S_addr;
      FillChar(myPeerName,SizeOf(myPeerName),0);
      StrCopy(myPeerName,WinSock.inet_ntoa(tmpSockAddrIn.sin_addr));
      tmpHostEnt:=WinSock.GetHostByAddr(@myPeerIP, SizeOf(LongInt), AF_INET);
      if Assigned(tmpHostEnt) then StrCopy(myPeerName,tmpHostEnt.h_name);
      LockedInc(myConnected);
      Success(PChar(Format('Connected %s=%s',[IpToStr(PeerIP),PeerName])));
     end else Trouble('GetPeerName',WinSock.WSAGetLastError);
    end;
   end;
  end;
  //
  // Read/writable socket polling.
  // If connection is opened, check state, then read/write.
  //
  if IsStream then
  if Connected>0 then
  if myHandle<>INVALID_SOCKET then begin
   //
   // Read socket state.
   //
   TimeVal.tv_sec:=0;
   TimeVal.tv_usec:=0;
   FD_ZERO(FDSetR); FD_SET(myHandle,FDSetR);
   FD_ZERO(FDSetW); FD_SET(myHandle,FDSetW);
   FD_ZERO(FDSetE); FD_SET(myHandle,FDSetE);
   ErrorCode:=WinSock.Select(myHandle, @FDSetR, @FDSetW, @FDSetE, @TimeVal);
   if ErrorCode=SOCKET_ERROR then Trouble('Select',WinSock.WSAGetLastError);
   if FD_ISSET(myHandle,FDSetE) then Trouble('Select',WinSock.WSAGetLastError);
   //
   // If socket is readable, try to read.
   //
   if FD_ISSET(myHandle,FDSetR) then
   while true do begin
    Size:=Min(myRxFifo.Space,SizeOf(myRxBuff)-1);
    if Size=0 then Break;
    Leng:=WinSock.Recv(myHandle, myRxBuff[1], Size, 0);
    if Leng=0 then begin                                 // Connection was gracefully closed by peer
     Report('Gracefully closed by peer',WSAECONNRESET);  // Report about
     Close(ERROR_SUCCESS,0,Length(myTxBuff));            // Close connection
     Exit;
    end else
    if Leng=SOCKET_ERROR then begin                      // Read error found
     if WinSock.WSAGetLastError<>WSAEWOULDBLOCK          // Get error code
     then Trouble('Recv',WinSock.WSAGetLastError)        // Fatal error found
     else Break;                                         // Blocking is not error
    end;
    myRxFifo.Put(@myRxBuff[1],Leng);
   end;
   //
   // If socket is writeable, try to write.
   //
   if FD_ISSET(myHandle,FDSetW) then
   while true do begin
    Size:=Length(myTxBuff);
    if Size=0 then begin
     myTxBuff:=myTxFifo.GetText(SizeOf(myTxBuff)-1);
     Size:=Length(myTxBuff);
    end;
    if Size=0 then Break;
    Leng:=WinSock.Send(myHandle, myTxBuff[1], Size, 0);
    if Leng=0 then Break else                            // Nothing to write
    if Leng=SOCKET_ERROR then begin                      // Write error found
     if WinSock.WSAGetLastError<>WSAEWOULDBLOCK          // Get error code
     then Trouble('Send',WinSock.WSAGetLastError)        // Fatal error found
     else Break;                                         // Blocking is not error
    end;
    System.Delete(myTxBuff,1,Leng);
   end;
  end;
 except
  on E:ESocketFail do {Nothing};
  on E:Exception do BugReport(E,Self);
 end;
end;

 ////////////////////////////
 // TTcpServer implementation
 ////////////////////////////

constructor TTcpServer.Create(aPort       : Word;
                              aMaxPipes   : Integer;
                              aReporter   : TSocketReporter;
                              aDelay      : Integer;
                              aPriority   : TThreadPriority;
                              aRxFifoSize : Integer;
                              aTxFifoSize : Integer;
                              aTimeOut    : Integer;
                              aOptions    : Integer);
var i:Integer;
begin
 inherited Create(nil,Max(1,aMaxPipes),Format('\tcp\server:%d',[aPort]));
 myPort:=aPort;
 myTimeOut:=aTimeOut;
 myOptions:=aOptions;
 myReporter:=aReporter;
 myPolling.Delay:=aDelay;
 myPolling.Priority:=aPriority;
 for i:=0 to Childs.Capacity-1 do TSocketPipe.Create(Self,0,'');
 for i:=0 to Count-1 do Self[i].RxFifo.Size:=aRxFifoSize;
 for i:=0 to Count-1 do Self[i].TxFifo.Size:=aTxFifoSize;
end;

destructor TTcpServer.Destroy;
begin
 inherited;
end;

 ////////////////////////////
 // TTcpClient implementation
 ////////////////////////////

constructor TTcpClient.Create(aPort       : Word;
                              aTarget     : LongString;
                              aReporter   : TSocketReporter;
                              aDelay      : Integer;
                              aPriority   : TThreadPriority;
                              aRxFifoSize : Integer;
                              aTxFifoSize : Integer;
                              aTimeOut    : Integer;
                              aOptions    : Integer);
begin
 inherited Create(nil,0,Format('\tcp\client:%d',[aPort]));
 myPort:=aPort;
 myTimeOut:=aTimeOut;
 myOptions:=aOptions;
 myReporter:=aReporter;
 myPolling.Delay:=aDelay;
 myPolling.Priority:=aPriority;
 StrPCopy(myTarget,SysUtils.Trim(aTarget));
 RxFifo.Size:=aRxFifoSize;
 TxFifo.Size:=aTxFifoSize;
end;

destructor TTcpClient.Destroy;
begin
 inherited;
end;

 ////////////////////
 // Utility functions
 ////////////////////

function NewTcpServer(aPort       : Word;
                      aMaxPipes   : Integer;
                      aReporter   : TSocketReporter;
                      aDelay      : Integer;
                      aPriority   : TThreadPriority;
                      aRxFifoSize : Integer;
                      aTxFifoSize : Integer;
                      aTimeOut    : Integer;
                      aOptions    : Integer):TTcpServer;
begin
 Result:=nil;
 if aPort>0 then
 if aMaxPipes>0 then
 try
  Result:=TTcpServer.Create(aPort,aMaxPipes,aReporter,aDelay,aPriority,aRxFifoSize,aTxFifoSize,aTimeOut,aOptions);
 except
  on E:Exception do BugReport(E);
 end;
end;

function NewTcpClient(aPort       : Word;
                      aTarget     : LongString;
                      aReporter   : TSocketReporter;
                      aDelay      : Integer;
                      aPriority   : TThreadPriority;
                      aRxFifoSize : Integer;
                      aTxFifoSize : Integer;
                      aTimeOut    : Integer;
                      aOptions    : Integer):TTcpClient;
begin
 Result:=nil;
 if aPort>0 then
 if Length(aTarget)>0 then
 try
  Result:=TTcpClient.Create(aPort,aTarget,aReporter,aDelay,aPriority,aRxFifoSize,aTxFifoSize,aTimeOut,aOptions);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TSocketPipe); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TTcpServer); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TTcpClient); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure TestReporter(Pipe:TSocketPipe; When:Double; What:PChar; Code:Integer);
begin
 Echo(WinToDosStr(SocketErrorReport(What,Code)));
end;

procedure TestSocketPipes;
var Sock:TSocketPipe; i,n,m:Integer; s:LongString;
begin
 n:=0;
 m:=ObjectRegistry.Count;
 if ParamStr(1)=''
 then Sock:=NewTcpServer(1234,2)
 else Sock:=NewTcpClient(1234,ParamStr(1));
 Sock.Master:=Sock;
 Sock.Reporter:=TestReporter;
 Echo(Sock.Polling.Name);
 while Sock.Ok do begin
  if Sock.Connected>0 then
  for i:=0 to Sock.Count-1 do
  if Sock[i].Connected>0 then begin
   s:=Sock[i].RxFifo.GetText;
   if s<>'' then Echo(Format('%g %s',[msecnow,s]));
   if GetTickCount mod 100 = 0 then begin
    Sock[i].TxFifo.PutText(Format('%d %s',[n,DateTimeToStr(Now)+CRLF]));
    inc(n);
   end;
   if Pos('exit',s)>0 then Sock.Free;
  end;
  Sleep(1);
 end;
 Kill(Sock);
 Echo(Format('Exit %d',[ObjectRegistry.Count-m]));
end;

const
 TheFullSocketList : TObjectStorage = nil;

function FullSocketList:TObjectStorage;
begin
 Result:=TheFullSocketList;
end;

var
 WSAData : TWSAData;

initialization

 WinSock.WSAStartup($0101,WSAData);
 TheFullSocketList:=NewObjectStorage;
 TheFullSocketList.Master:=TheFullSocketList;
 TheFullSocketList.OwnsObjects:=false;

finalization

 ResourceLeakageLog(Format('%-60s = %d',['FullSocketList.Count', TheFullSocketList.Count]));
 Kill(TheFullSocketList);
 WinSock.WSACleanup;

end.
