////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// TCP Sockets, TCP/IP routines.                                              //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20070204 - Creation                                                        //
// 20070215 - first tested release                                            //
// 20070228 - set SNDBUF, RCVBUF                                              //
// 20070303 - use DuplicateHandle                                             //
// 20231005 - Modified for FPC (A.K.)                                         //
// 20231008 - FPC tested release                                              //
////////////////////////////////////////////////////////////////////////////////

unit _crw_tcp; // TCP/IP routines

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 {$IFDEF WINDOWS} winsock, {$ENDIF}
 {$IFDEF UNIX} baseunix, unix, netdb, {$ENDIF}
 sysutils, classes, math, sockets,
 _crw_alloc, _crw_fifo, _crw_rtc, _crw_str, _crw_fio, _crw_ef, _crw_hl,
 _crw_polling, _crw_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
 INVALID_SOCKET    = TSocket(NOT(0));                                           // Invalid socket handle
 SOCKET_ERROR      = -1;                                                        // Socket error code

const // Shutdown flags
 SD_RECEIVE = SHUT_RD;
 SD_SEND    = SHUT_WR;
 SD_BOTH    = SHUT_RDWR;

const
 DefSocketFactor   = 2;                                                         // Default Rx/TxFifo GrowFactor
 DefSocketPriority = tpHigher;                                                  // Default socket thread priority

const
 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
 so_CloseClean     = so_CloseTxClean+so_CloseRxClean;                           // Clear Tx/RxFifo on close
 so_SetIoBuff      = so_SetSndBuff+so_SetRcvBuff;                               // Set Tx/Rx buffers size
 DefSocketOptions  = so_CloseShutdown+so_CloseClean+so_TcpNoDelay;              // Default socket options

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    : LongString;                                                     // Remote server name
  myHostName  : LongString;                                                     // Local host name
  myPeerName  : LongString;                                                     // 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    : LongString;                                                     // Uses as buffer to receive
  myTxBuff    : LongString;                                                     // Uses as buffer to transmit
  myRxLost    : Int64;                                                          // Last value of RxFifo.Lost
  myTxLost    : Int64;                                                          // Last value of TxFifo.Lost
  myLastPulse : Int64;                                                          // Time of last pulse
  {$IFDEF WINDOWS}
  myWSAData   : TWSAData;                                                       // Temporary
  {$ENDIF ~WINDOWS}
  myLogsHistory : Integer;                                                      // Logs history limit
  myLogsText    : TText;                                                        // Logs history text
  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    GetIsClient:Boolean;
  function    GetIsStream:Boolean;
  function    GetTimeout:Integer;
  function    GetRxFifo:TFifo;
  function    GetTxFifo:TFifo;
  function    GetPolling:TPolling;
  function    GetLogsText:TText;
  function    GetLogsHistory:Integer;
  function    GetLogsCount:Integer;
  function    GetLogsTextMove:LongString;
  function    GetLogsTextCopy:LongString;
  procedure   WsaInit(aInit:Boolean);
  procedure   Report(What:LongString; Code:Integer);
  procedure   SetReporter(aReporter:TSocketReporter);
  procedure   Close(aErrorCode:Integer=NO_ERROR; 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    IsClient           : Boolean         read  GetIsClient;           // Server or client?
  property    IsStream           : Boolean         read  GetIsStream;           // Read/writable?
  property    Timeout            : Integer         read  GetTimeout;            // Timeout to wait operations
  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
  property    LogsText           : TText           read  GetLogsText;           // Log events text
  property    LogsHistory        : Integer         read  GetLogsHistory;        // History for list of logs
  property    LogsCount          : Integer         read  GetLogsCount;          // Count of logs in list.
  property    LogsTextMove       : LongString      read  GetLogsTextMove;       // Get logs as text and clear
  property    LogsTextCopy       : LongString      read  GetLogsTextCopy;       // Get logs as text and keep
 public
  function    HasOwner:Boolean;                                                 // Socket has owner socket  (client)
  function    HasChilds:Boolean;                                                // Socket has child sockets (server)
 public
  function    GetProperties:LongString;                                         // Properties
  function    Ctrl(const arg:LongString):LongString;                            // Control
  procedure   Clear(const What:LongString);                                     // Clear What: Rx/TxLost/Fifo/Total,Logs
 public                                                                         // General I/O:
  function    Send(const aData:LongString):LongInt;                             // Send a data to port
  function    Recv(aMaxLen:LongInt=MaxInt):LongString;                          // Recveive a data from port
 public // Common service routines
  class function  Failed(aStatus:LongInt):Boolean; inline;
  class function  Succeed(aStatus:LongInt):Boolean; inline;
  class function  ValidIpAddr(aAddr:Cardinal):Boolean; inline;
  class function  ValidSocket(aSocket:TSocket):Boolean; inline;
  class procedure InvalidateSocket(var aSocket:TSocket); inline;
 private
  class var TheDefDelay:Integer;
  class function  GetDefDelay:Integer; static;
  class procedure SetDefDelay(aDelay:Integer); static;
  class var TheDefTimeout:Integer;
  class function  GetDefTimeout:Integer; static;
  class procedure SetDefTimeout(aTimeout:Integer); static;
  class var TheDefFifoSize:Integer;
  class function  GetDefFifoSize:Integer; static;
  class procedure SetDefFifoSize(aFifoSize:Integer); static;
  class var TheDefHistory:Integer;
  class function  GetDefHistory:Integer; static;
  class procedure SetDefHistory(aHistory:Integer); static;
  class var TheDefPriority:TThreadPriority;
  class function  GetDefPriority:TThreadPriority; static;
  class procedure SetDefPriority(aPriority:TThreadPriority); static;
 public
  class function  ValidateDelay(aDelay:Integer):Integer; static;
  class function  ValidateTimeout(aTimeOut:Integer):Integer; static;
  class function  ValidateFifoSize(aFifoSize:Integer):Integer; static;
  class function  ValidateHistory(aHistory:Integer):Integer; static;
  class function  ValidatePriority(aPriority:TThreadPriority):TThreadPriority; static;
  class function  ValidateTarget(aTarget:LongString):LongString; static;
 public // Default parameters for all tcp objects
  class property DefDelay    : Integer read GetDefDelay    write SetDefDelay;   // Polling period, ms
  class property DefTimeout  : Integer read GetDefTimeout  write SetDefTimeOut; // Timeout for IO, ms
  class property DefFifoSize : Integer read GetDefFifoSize write SetDefFifoSize;// Fifo size, bytes
  class property DefHistory  : Integer read GetDefHistory  write SetDefHistory; // Logs histiry, lines
  class property DefPriority : TThreadPriority read GetDefPriority write SetDefPriority; // Priority
 public
  class function LocalHostName:LongString; static;
  class function LocalHostIpAddr:LongString; static;
 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         = 0;                        // Polling delay; 0=Default
                       aPriority   : TThreadPriority = DefSocketPriority;        // Thread priority
                       aRxFifoSize : Integer         = 0;                        // Receiver fifo size; 0=Default
                       aTxFifoSize : Integer         = 0;                        // Transmitter fifo size; 0=Default
                       aTimeOut    : Integer         = 0;                        // Timeout for connections; 0=Default
                       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         = 0;                        // Polling delay; 0=Default
                       aPriority   : TThreadPriority = DefSocketPriority;        // Thread priority
                       aRxFifoSize : Integer         = 0;                        // Receiver fifo size; 0=Default
                       aTxFifoSize : Integer         = 0;                        // Transmitter fifo size; 0=Default
                       aTimeOut    : Integer         = 0;                        // Timeout for connections; 0=Default
                       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 GetFullSocketListPropertiesAsText:LongString;
function GetFullSocketListProperties(TheText:TText):TText;

function FullSocketList:TObjectStorage;

 ///////////////////////////
 // TCP/IP service 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

 /////////////////////////////////////////////////////
 // Private Dictionary for fast string identification.
 /////////////////////////////////////////////////////
type
 TStringIdentifier = (
  sid_Unknown,
  ////////////////////// Properties ReadOnly
  sid_Connected,
  sid_IsServer,
  sid_IsClient,
  sid_IsStream,
  sid_Port,
  sid_Target,
  sid_HostIP,
  sid_PeerIP,
  sid_HostName,
  sid_PeerName,
  sid_Handle,
  sid_TimeOut,
  sid_RxLost,
  sid_TxLost,
  sid_RxTotal,
  sid_TxTotal,
  sid_RxLength,
  sid_TxLength,
  sid_RxFifoLimit,
  sid_TxFifoLimit,
  sid_LogsCount,
  ////////////////////// Properties Writable
  sid_LogsHistory,
  sid_RxBuffSize,
  sid_TxBuffSize,
  sid_RxPipeSize,
  sid_TxPipeSize,
  sid_Polling,
  sid_Priority,
  sid_PollingDelay,
  sid_PollingPriority,
  ////////////////////// Special IO
  sid_LogsTextMove,
  sid_LogsTextCopy,
  sid_Clear,
  sid_RxRecv,
  sid_TxSend,
  ////////////////////// Properties End
  sid_Asterisk,
  sid_Question,
  sid_Unused
 );

const
 Dictionary:THashList=nil;

procedure FreeDictionary;
begin
 Kill(Dictionary);
end;

procedure InitDictionary;
 procedure AddSid(const key:LongString; sid:TStringIdentifier);
 begin
  Dictionary.KeyedLinks[key]:=Ord(sid);
 end;
begin
 if (Dictionary<>nil) then Exit;
 Dictionary:=NewHashList(false,HashList_DefaultHasher);
 Dictionary.Master:=@Dictionary;
 Dictionary.OwnsObjects:=false;
 /////////////////////////////////////////////
 // Dictionary for fast strings identification
 /////////////////////////////////////////////
 AddSid( 'Connected'           , sid_Connected);
 AddSid( 'IsServer'            , sid_IsServer);
 AddSid( 'IsClient'            , sid_IsClient);
 AddSid( 'IsStream'            , sid_IsStream);
 AddSid( 'Port'                , sid_Port);
 AddSid( 'Target'              , sid_Target);
 AddSid( 'HostIP'              , sid_HostIP);
 AddSid( 'PeerIP'              , sid_PeerIP);
 AddSid( 'HostName'            , sid_HostName);
 AddSid( 'PeerName'            , sid_PeerName);
 AddSid( 'Handle'              , sid_Handle);
 AddSid( 'TimeOut'             , sid_TimeOut);
 AddSid( 'RxLost'              , sid_RxLost);
 AddSid( 'TxLost'              , sid_TxLost);
 AddSid( 'RxTotal'             , sid_RxTotal);
 AddSid( 'TxTotal'             , sid_TxTotal);
 AddSid( 'RxLength'            , sid_RxLength);
 AddSid( 'TxLength'            , sid_TxLength);
 AddSid( 'RxFifoLimit'         , sid_RxFifoLimit);
 AddSid( 'TxFifoLimit'         , sid_TxFifoLimit);
 AddSid( 'LogsCount'           , sid_LogsCount);
 AddSid( 'LogsHistory'         , sid_LogsHistory);
 AddSid( 'RxBuffSize'          , sid_RxBuffSize);
 AddSid( 'TxBuffSize'          , sid_TxBuffSize);
 AddSid( 'RxPipeSize'          , sid_RxPipeSize);
 AddSid( 'TxPipeSize'          , sid_TxPipeSize);
 AddSid( 'Polling'             , sid_Polling);
 AddSid( 'Priority'            , sid_Priority);
 AddSid( 'PollingDelay'        , sid_PollingDelay);
 AddSid( 'PollingPriority'     , sid_PollingPriority);
 AddSid( 'LogsTextMove'        , sid_LogsTextMove);
 AddSid( 'LogsTextCopy'        , sid_LogsTextCopy);
 AddSid( 'Clear'               , sid_Clear);
 AddSid( 'RxRecv'              , sid_RxRecv);
 AddSid( 'TxSend'              , sid_TxSend);
 AddSid( '*'                   , sid_Asterisk);
 AddSid( '?'                   , sid_Question);
end;

function Identify(const key:LongString):TStringIdentifier;
var sid:Integer;
begin
 if (Dictionary=nil) then InitDictionary;
 sid:=Dictionary.KeyedLinks[key];
 if (sid>=Ord(Low(TStringIdentifier))) and (sid<=Ord(High(TStringIdentifier)))
 then Result:=TStringIdentifier(sid)
 else Result:=sid_Unknown;
end;

const
 sid_Ctrl_Hidden   = [sid_LogsTextMove..sid_TxSend];
 sid_Ctrl_Readable = [Succ(sid_Unknown)..Pred(sid_Asterisk)]-sid_Ctrl_Hidden;
 sid_Ctrl_Writable = [sid_LogsHistory..Pred(sid_Asterisk)]-sid_Ctrl_Hidden;

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

function StrToIP(Host:LongString):Cardinal;
begin
 Result:=StrToNetAddr(Host).s_addr;
end;

function SocketErrorMessage(ErrorCode:Integer):LongString;
begin
 Result:=SysErrorMessage(ErrorCode);
 {$IFDEF WINDOWS}
 if IsEmptyStr(Result) 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;
 {$ENDIF ~WINDOWS}
end;

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

{$IFDEF WINDOWS}
function SetNonBlocking(aHandle:THandle; aValue:Integer):Boolean;
begin
 Result:=(ioctlsocket(aHandle,Longint(FIONBIO),aValue)=NO_ERROR);
end;
function IsBlockError(const aError:Integer):Boolean; inline;
begin
 Result:=(aError=WSAEWOULDBLOCK);
end;
function FpSelect(nfds:Integer; readfds,writefds,exceptfds:PFDSet; timeout:PTimeVal):Longint; inline;
begin
 Result:=Select(nfds,readfds,writefds,exceptfds,timeout);
end;
function GetHostNameByAddr(Addr:Cardinal):LongString;
var HE:PHostEnt;
begin
 Result:='';
 HE:=gethostbyaddr(@Addr,SizeOf(Addr),AF_INET);
 if Assigned(HE) then Result:=HE^.h_name;
 if (Result='') then Result:=NetAddrToStr(in_addr(Addr));
end;
function GetHostAddrByName(aName:LongString; var aAddr:Cardinal):Boolean;
var HE:PHostEnt; P:PDWord;
begin
 Result:=false;
 HE:=gethostbyname(PChar(aName));
 if Assigned(HE) then begin
  P:=Pointer(HE.h_addr_list[0]);
  aAddr:=P^; Result:=true;
 end;
end;
{$ENDIF ~WINDOWS}
{$IFDEF UNIX}
const WSAECONNRESET=ESysECONNRESET;
function SetNonBlocking(aHandle:THandle; aValue:Integer):Boolean;
begin
 Result:=FileSetNonBlockFlag(aHandle,(aValue<>0));
end;
function IsBlockError(const aError:Integer):Boolean; inline;
begin
 Result:=(aError=ESysEAGAIN)       // Nonblocking operation: Try again later
      or (aError=ESysEWOULDBLOCK)  // Nonblocking operation: Try again later
   // or (aError=ESysENOBUFS)      // No buffer space available
      or (aError=ESysEINPROGRESS); // Nonblocking socket connection in progress
end;
function FD_ISSET(Socket:TSocket; var FDSet:TFDSet):Boolean; inline;
begin
 Result:=(FpFD_ISSET(Socket,FDSet)<>0);
end;
procedure FD_SET(Socket:TSocket; var FDSet:TFDSet); inline;
begin
 FpFD_SET(Socket,FDSet);
end;
procedure FD_ZERO(out FDSet:TFDSet); inline;
begin
 FpFD_ZERO(FDSet);
end;
function GetHostNameByAddr(Addr:Cardinal):LongString;
var tmpHostEnt:THostEntry; NameList:array of string; n:Integer;
begin
 SafeFillChar(tmpHostEnt,SizeOf(tmpHostEnt),0);
 if GetHostByAddr(THostAddr(ntohl(Addr)),tmpHostEnt)
 then Result:=tmpHostEnt.Name else Result:='';
 if IsEmptyStr(Result) then begin
  NameList:=nil; SetLength(NameList,32);
  n:=netdb.ResolveAddress(THostAddr(ntohl(Addr)),NameList);
  if (n>0) then Result:=NameList[0];
  SetLength(NameList,0);
 end;
 if IsEmptyStr(Result) then Result:=NetAddrToStr(THostAddr(Addr));
end;
function GetHostAddrByName(aName:LongString; var aAddr:Cardinal):Boolean;
var tmpHostEnt:THostEntry; AddrList:array of THostAddr; n:Integer;
begin
 SafeFillChar(tmpHostEnt,SizeOf(tmpHostEnt),0);
 Result:=GetHostByName(aName,tmpHostEnt);
 if Result then aAddr:=htonl(tmpHostEnt.Addr.s_addr) else begin
  AddrList:=nil; SetLength(AddrList,32);
  n:=netdb.ResolveName(aName,AddrList);
  if (n>0) then aAddr:=AddrList[0].s_addr;
  SetLength(AddrList,0);
  Result:=(n>0);
 end;
end;
{$ENDIF ~UNIX}

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

class function TSocketPipe.Failed(aStatus:LongInt):Boolean;
begin
 Result:=(aStatus<>NO_ERROR);
end;

class function TSocketPipe.Succeed(aStatus:LongInt):Boolean;
begin
 Result:=(aStatus=NO_ERROR);
end;

class function TSocketPipe.ValidIpAddr(aAddr:Cardinal):Boolean;
begin
 Result:=(aAddr<>0) and (LongInt(aAddr)<>-1);
end;

class function TSocketPipe.ValidSocket(aSocket:TSocket):Boolean;
begin
 Result:=(aSocket<>INVALID_SOCKET);
end;

class procedure TSocketPipe.InvalidateSocket(var aSocket:TSocket);
begin
 aSocket:=INVALID_SOCKET;
end;

procedure TSocketPipe.WsaInit(aInit:Boolean);
{$IFDEF WINDOWS}var ErrorCode : Integer;{$ENDIF ~WINDOWS}
begin
 {$IFDEF WINDOWS}
 if aInit then begin
  ErrorCode:=WinSock.WSAStartup($0101,myWSAData);
  Report('WSAStartup',ErrorCode);
 end else begin
  ErrorCode:=WinSock.WSACleanup;
  Report('WSACleanup',ErrorCode);
 end;
 {$ENDIF ~WINDOWS}
end;

constructor TSocketPipe.Create(aOwner:TSocketPipe; aMaxPipes:Integer; aName:LongString);
begin
 inherited Create;
 myOwner:=aOwner;
 InvalidateSocket(myHandle);
 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,DefDelay,DefPriority,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(DefFifoSize);
  myRxFifo.Master:=@myRxFifo;
  myRxFifo.GrowFactor:=DefSocketFactor;
  myTxFifo:=NewFifo(DefFifoSize);
  myTxFifo.Master:=@myTxFifo;
  myRxFifo.GrowFactor:=DefSocketFactor;
 end;
 myLogsHistory:=DefHistory;
 myLogsText:=NewText(DefHistory);
 myLogsText.Master:=@myLogsText;
 WsaInit(true);
end;

destructor TSocketPipe.Destroy;
begin
 try
  Polling.Enable(false);
  Close(NO_ERROR);
  Kill(myPolling);
  Kill(myRxFifo);
  Kill(myTxFifo);
  Kill(myChilds);
  Kill(myLogsText);
  WsaInit(false);
 except
  on E:Exception do BugReport(E,Self,'Destroy');
 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 ValidSocket(aSocket) then begin                    // If socket opened
  if HasFlags(aOptions,so_CloseShutdown) then
  if Failed(FpShutdown(aSocket,SHUT_RDWR))             // Shutdown socket
  then Report('Shutdown',SocketError)
  else Report('Shutdown',NO_ERROR);
  if Failed(CloseSocket(aSocket))                      // Close socket
  then Report('CloseSocket:'+d2s(aSocket),SocketError)
  else Report('CloseSocket:'+d2s(aSocket),NO_ERROR);
  InvalidateSocket(aSocket);                           // Mark it closed
 end;
end;

procedure CloseChildPipe(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if (aObject is TSocketPipe) then TSocketPipe(aObject).Close(PointerToPtrInt(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,PtrIntToPointer(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 HasFlags(myOptions,so_CloseRxClean)                            // If allow RxFifo clean
  then LostRx:=Length(myRxFifo.GetText)                             // Receiver data lost
  else LostRx:=0;                                                   // No FIFO clean
  if HasFlags(myOptions,so_CloseTxClean)                            // If allow TxFifo clean
  then LostTx:=Length(myTxFifo.GetText)                             // Transmitter data lost
  else LostTx:=0;                                                   // No FIFO clean
  myHostName:='';                                                   // Clear host name
  myPeerName:='';                                                   // 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 Failed(aErrorCode) 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',NO_ERROR);
 except
  on E:Exception do BugReport(E,Self,'Close');
 end;
end;

function TSocketPipe.HasOwner:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myOwner)
 else Result:=false;
end;

function TSocketPipe.HasChilds:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myChilds)
 else Result:=false;
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 not Assigned(Self) then Exit(0);
 if IsStream then Result:=1 else Result:=Childs.Count;
end;

function TSocketPipe.GetPipes(i:Integer):TSocketPipe;
begin
 if not Assigned(Self) then Exit(nil);
 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.GetIsClient:Boolean;
begin
 if Assigned(Self)
 then Result:=not IsServer
 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.GetTimeout:Integer;
begin
 if Assigned(Self)
 then Result:=myTimeout
 else Result:=0;
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;

function TSocketPipe.GetLogsText:TText;
begin
 if Assigned(Self)
 then Result:=myLogsText
 else Result:=nil;
end;

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

function TSocketPipe.GetLogsCount:Integer;
begin
 if Assigned(Self)
 then Result:=myLogsText.Count
 else Result:=0;
end;

function TSocketPipe.GetLogsTextMove:LongString;
begin
 if Assigned(Self)
 then begin Result:=myLogsText.Text; myLogsText.Count:=0; end
 else Result:='';
end;

function TSocketPipe.GetLogsTextCopy:LongString;
begin
 if Assigned(Self)
 then Result:=myLogsText.Text
 else Result:='';
end;

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

procedure TSocketPipe.Report(What:LongString; Code:Integer);
var Rep:TSocketReporter; When:Double; Line:LongString;
begin
 if Assigned(Self) then
 try
  When:=msecnow;
  if Assigned(myReporter) then Rep:=myReporter else
  if Assigned(myOwner) then Rep:=myOwner.myReporter else Rep:=nil;
  if Assigned(Rep) then begin
   Rep(Self,When,PChar(What),Code);
   Exit;
  end;
  if (LogsHistory>0) then begin
   Line:=FormatDateTime(StdDateTimeFormatMs,MsToOleTime(When))+' => '
        +Polling.Name+': '+What+', '+SysErrorMessage(Code);
   LogsText.AddLn(Line);
  end;
  while (LogsText.Count>LogsHistory) do LogsText.DelLn(0);
 except
  on E:Exception do BugReport(E,Self,'Report');
 end;
end;

function TSocketPipe.Send(const aData:LongString):LongInt;
begin
 if Assigned(Self) and (aData<>'')
 then Result:=Ord(myTxFifo.PutText(aData))*Length(aData)
 else Result:=0;
end;

function TSocketPipe.Recv(aMaxLen:LongInt=MaxInt):LongString;
begin
 if Assigned(Self) and (aMaxLen>0)
 then Result:=myRxFifo.GetText(aMaxLen)
 else Result:='';
end;

procedure PollChildPipe(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if (aObject is TSocketPipe) then TSocketPipe(aObject).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 TSocketPipe(aObject) do
 if not ValidSocket(myHandle) then begin
  TObject(CustomData^):=aObject;
  Terminate:=True;
 end;
end;

procedure TSocketPipe.Poll;
var Linger:TLinger; SndBuff,RcvBuff,ReuseAddr,TcpNoDelay:LongWord;
var TimerPulse:Boolean; tmpSocket:TSocket; Item:TSocketPipe;
var tmpSockAddrIn:TSockAddr; FDSetR,FDSetW,FDSetE:TFDSet;
var ErrorCode,Leng,Size,tmpSizeOf:Integer; tv:TTimeVal;
const NoBlocking=1;
 procedure Trouble(aComment:LongString; 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:LongString);
 begin
  Report(aComment,NO_ERROR);
 end;
begin
 if Assigned(Self) then
 try
  //
  // Generate timer pulse every TimeOut.
  //
  TimerPulse:=(GetTickCount64-myLastPulse>=TimeOut);
  if TimerPulse then myLastPulse:=GetTickCount64;
  //
  // 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 not ValidSocket(myHandle) then begin
    //
    // Get local host name and IP for future.
    //
    myHostName:=LocalHostName;
    myHostIP:=StrToNetAddr(LocalHostIpAddr).s_addr;
    //
    // Create TCP stream socket.
    //
    myHandle:=FpSocket(PF_INET,SOCK_STREAM,IPPROTO_TCP);
    if not ValidSocket(myHandle)
    then Trouble('Socket',SocketError)
    else Success('Socket:'+d2s(myHandle));
    //
    // Make socket private (non-inherited) for child processes.
    //
    {$IFDEF WINDOWS}
    if not Windows.DuplicateHandle(GetCurrentProcess,myHandle,
                                   GetCurrentProcess,@myHandle,
                                   GENERIC_READ or GENERIC_WRITE,
                                   FALSE,DUPLICATE_CLOSE_SOURCE)
    then Trouble('DuplicateHandle',GetLastOsError,FALSE)
    else Success('DuplicateHandle');
    {$ENDIF ~WINDOWS}
    {$IFDEF UNIX}
    if not FileSetCloseOnExec(myHandle,true)
    then Trouble('Fcntl:CloseOnExec',GetLastOsError,FALSE)
    else Success('Fcntl:CloseOnExec');
    {$ENDIF ~UNIX}
    //
    // Disables the Nagle algorithm for send coalescing.
    //
    if HasFlags(myOptions,so_TcpNoDelay) then
    if ValidSocket(myHandle) then begin
     TcpNoDelay:=1;
     if Failed(FpSetSockOpt(myHandle,IPPROTO_TCP,TCP_NODELAY,@TcpNoDelay,SizeOf(TcpNoDelay)))
     then Trouble('SetSockOpt:TcpNoDelay',SocketError,FALSE)
     else Success('SetSockOpt:TcpNoDelay');
    end;
    //
    // Set Rx buffer size
    //
    if HasFlags(myOptions,so_SetRcvBuff) then
    if ValidSocket(myHandle) then begin
     RcvBuff:=DefFifoSize;
     if Failed(FpSetSockOpt(myHandle,SOL_SOCKET,SO_RCVBUF,@RcvBuff,SizeOf(RcvBuff)))
     then Trouble('SetSockOpt:RcvBuff:'+d2s(RcvBuff),SocketError,FALSE)
     else Success('SetSockOpt:RcvBuff:'+d2s(RcvBuff));
    end;
    //
    // Set Tx buffer size
    //
    if HasFlags(myOptions,so_SetSndBuff) then
    if ValidSocket(myHandle) then begin
     SndBuff:=DefFifoSize;
     if Failed(FpSetSockOpt(myHandle,SOL_SOCKET,SO_SNDBUF,@SndBuff,SizeOf(SndBuff)))
     then Trouble('SetSockOpt:SndBuff:'+d2s(SndBuff),SocketError,FALSE)
     else Success('SetSockOpt:SndBuff:'+d2s(SndBuff));
    end;
    //
    // Use LINGER with zero timeout.
    //
    if HasFlags(myOptions,so_UseLinger0) then
    if ValidSocket(myHandle) then begin
     Linger.l_onoff:=1;
     Linger.l_linger:=0;
     if Failed(FpSetSockOpt(myHandle,SOL_SOCKET,SO_LINGER,@Linger,SizeOf(Linger)))
     then Trouble('SetSockOpt:Linger',SocketError,FALSE)
     else Success('SetSockOpt:Linger');
    end;
    //
    // Set no-blocking mode.
    //
    if ValidSocket(myHandle) then begin
     if not SetNonBlocking(myHandle,NoBlocking)
     then Trouble('IOCtlSocket:NonBlock',SocketError)
     else Success('IOCtlSocket:NonBlock');
    end;
    //
    // Bind server TCP port. Try reusing address.
    //
    if IsServer then
    if ValidSocket(myHandle) then begin
     SafeFillChar(tmpSockAddrIn,SizeOf(tmpSockAddrIn),0);
     tmpSockAddrIn.sin_family:=AF_INET;
     tmpSockAddrIn.sin_addr.s_addr:=htonl(INADDR_ANY);
     tmpSockAddrIn.sin_port:=htons(Port);
     ReuseAddr:=1;
     if Failed(FpSetSockOpt(myHandle,SOL_SOCKET,SO_REUSEADDR,@ReuseAddr,SizeOf(ReuseAddr)))
     then Trouble('SetSockOpt:ReuseAddr',SocketError)
     else Success('SetSockOpt:ReuseAddr');
     if Failed(FpBind(myHandle,@tmpSockAddrIn,SizeOf(tmpSockAddrIn)))
     then Trouble('Bind:'+d2s(Port),SocketError)
     else Success('Bind:'+d2s(Port));
    end;
    //
    // Put server to listen mode.
    //
    if IsServer then
    if ValidSocket(myHandle) then begin
     if Failed(FpListen(myHandle,SOMAXCONN))
     then Trouble('Listen:'+d2s(Port),SocketError)
     else Success('Listen:'+d2s(Port));
    end;
    //
    // Connect client to target server.
    //
    if not IsServer then
    if ValidSocket(myHandle) then begin
     FillChar(tmpSockAddrIn,SizeOf(tmpSockAddrIn),0);
     tmpSockAddrIn.sin_family:=AF_INET;
     tmpSockAddrIn.sin_addr.s_addr:=StrToNetAddr(Target).s_addr;
     if not ValidIpAddr(tmpSockAddrIn.sin_addr.s_addr) then begin
      if not GetHostAddrByName(Target,tmpSockAddrIn.sin_addr.s_addr)
      then Trouble('GetHostByName',SocketError)
      else Success('GetHostByName:'+NetAddrToStr(tmpSockAddrIn.sin_addr));
     end;
     tmpSockAddrIn.sin_port:=htons(Port);
     ErrorCode:=FpConnect(myHandle,@tmpSockAddrIn,SizeOf(tmpSockAddrIn));
     if Failed(ErrorCode) then begin
      if not IsBlockError(SocketError)
      then Trouble('Connect:'+NetAddrToStr(tmpSockAddrIn.sin_addr)+':'+d2s(Port),SocketError)
      else Success('Connecting:'+NetAddrToStr(tmpSockAddrIn.sin_addr)+':'+d2s(Port)); // Should wait for connection...
     end else Success('Connect:'+NetAddrToStr(tmpSockAddrIn.sin_addr)+':'+d2s(Port));
    end;
   end;
   //
   // Exit if socket handle still was not created.
   //
   if not ValidSocket(myHandle) 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 ValidSocket(myHandle) then begin
    tmpSizeOf:=SizeOf(tmpSockAddrIn);
    tmpSocket:=FpAccept(myHandle,@tmpSockAddrIn,@tmpSizeOf);
    if not ValidSocket(tmpSocket) then begin
     if not IsBlockError(SocketError)
     then Trouble('Accept',SocketError)
     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;
      Item.myHostName:=HostName;
      Item.myPeerIP:=tmpSockAddrIn.sin_addr.s_addr;
      Item.myPeerName:=GetHostNameByAddr(Item.myPeerIP);
      if not SetNonBlocking(Item.myHandle,NoBlocking)
      then Item.Report('IOCtlSocket:NonBlock',SocketError)
      else Item.Report('IOCtlSocket:NonBlock',NO_ERROR);
      LockedInc(Item.myConnected);
      LockedInc(myConnected);
      Item.Report(PChar(Format('Accepted %s=%s',[IpToStr(Item.PeerIP),Item.PeerName])),NO_ERROR);
     end else KillSocket(tmpSocket,so_CloseShutdown); // Because no free socket Item was found.
    end;
   end;
   //
   // Poll child server sockets.
   //
   if IsServer then
   if ValidSocket(myHandle) then Childs.ForEach(PollChildPipe,nil);
   //
   // Check connection is eastablished or not.
   //
   if Connected<1 then
   if not IsServer then
   if ValidSocket(myHandle) then begin
    //
    // Read socket state.
    //
    tv.tv_sec:=0; tv.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:=FpSelect(myHandle+1,@FDSetR,@FDSetW,@FDSetE,@tv);
    if (ErrorCode=SOCKET_ERROR) then Trouble('Select',SocketError);
    if FD_ISSET(myHandle,FDSetE) then Trouble('Select',SocketError);
    //
    // If socket is writeable, it means connection eastablished.
    //
    if FD_ISSET(myHandle,FDSetW) then begin
     tmpSizeOf:=SizeOf(tmpSockAddrIn);
     if Succeed(FpGetPeerName(myHandle,@tmpSockAddrIn,@tmpSizeOf)) then begin
      myPeerIP:=tmpSockAddrIn.sin_addr.S_addr;
      myPeerName:=GetHostNameByAddr(myPeerIP);
      LockedInc(myConnected);
      Success(Format('Connected %s=%s',[IpToStr(PeerIP),PeerName]));
     end else Trouble('GetPeerName',SocketError);
    end;
   end;
  end;
  //
  // Read/writable socket polling.
  // If connection is opened, check state, then read/write.
  //
  if IsStream then
  if (Connected>0) then
  if ValidSocket(myHandle) then begin
   //
   // Read socket state.
   //
   tv.tv_sec:=0; tv.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:=FpSelect(myHandle+1,@FDSetR,@FDSetW,@FDSetE,@tv);
   if (ErrorCode=SOCKET_ERROR) then Trouble('Select',SocketError);
   if FD_ISSET(myHandle,FDSetE) then Trouble('Select',SocketError);
   //
   // If socket is readable, try to read.
   //
   if FD_ISSET(myHandle,FDSetR) then
   while true do begin
    if (myRxBuff='') then myRxBuff:=StringBuffer(OS_PIPE_BUF);
    Size:=Length(myRxBuff); if (Size<=0) then Break;
    Leng:=FpRecv(myHandle,PChar(myRxBuff),Size,0);
    if (Leng=0) then begin                               // Connection was gracefully closed by peer
     Report('Gracefully closed by peer',WSAECONNRESET);  // Report about
     Close(NO_ERROR,0,Length(myTxBuff));                 // Close connection
     Exit;
    end else
    if (Leng<0) then begin                               // Read error found
     if not IsBlockError(SocketError)                    // Get error code
     then Trouble('Recv',SocketError)                    // Fatal error found
     else Break;                                         // Blocking is not error
    end;
    myRxFifo.Put(PChar(myRxBuff),Leng);
   end;
   //
   // If socket is writeable, try to write.
   //
   if FD_ISSET(myHandle,FDSetW) then
   while true do begin
    if (myTxBuff='') then myTxBuff:=myTxFifo.GetText(OS_PIPE_BUF);
    Size:=Length(myTxBuff); if (Size<=0) then Break;
    Leng:=FpSend(myHandle,PChar(myTxBuff),Size,0);
    if (Leng=0) then Break else                          // Nothing to write
    if (Leng<0) then begin                               // Write error found
     if not IsBlockError(SocketError)                    // Get error code
     then Trouble('Send',SocketError)                    // 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,'Poll');
 end;
end;

function TSocketPipe.GetProperties:LongString;
const PropList='Connected,Port,Target,HostName,PeerName,HostIP,PeerIP,'
              +'IsServer,IsClient,IsStream,Polling,Priority,TimeOut,'
              +'RxPipeSize,TxPipeSize,RxTotal,TxTotal,RxLost,TxLost';
var Lines:TText; i:Integer; id:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lines:=NewText;
  try
   for i:=1 to WordCount(PropList,ScanSpaces) do begin
    id:=ExtractWord(i,PropList,ScanSpaces);
    Lines.AddLn(id+' = '+Ctrl(id));
   end;
   Result:=Lines.Text;
  finally
   Kill(Lines);
  end;
 except
  on E:Exception do BugReport(E,Self,'GetProperties');
 end;
end;

function TSocketPipe.Ctrl(const arg:LongString):LongString;
var p,i,si,iv:Integer; sn,sv,par:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Result:='?'; sn:=''; sv:='';
  p:=ExtractNameValuePair(arg,sn,sv,'=',1);
  case Identify(sn) of
   sid_Connected:   Result:=IntToStr(Connected);
   sid_IsServer:    Result:=IntToStr(Ord(IsServer));
   sid_IsClient:    Result:=IntToStr(Ord(IsClient));
   sid_IsStream:    Result:=IntToStr(Ord(IsStream));
   sid_Port:        Result:=IntToStr(Port);
   sid_Target:      Result:=Target;
   sid_HostIP:      Result:=IpToStr(HostIP);
   sid_PeerIP:      Result:=IpToStr(PeerIP);
   sid_HostName:    Result:=HostName;
   sid_PeerName:    Result:=PeerName;
   sid_Handle:      Result:=IntToStr(Handle);
   sid_TimeOut:     Result:=IntToStr(TimeOut);
   sid_RxLost:      Result:=IntToStr(RxFifo.Lost);
   sid_TxLost:      Result:=IntToStr(TxFifo.Lost);
   sid_RxTotal:     Result:=IntToStr(RxFifo.Total);
   sid_TxTotal:     Result:=IntToStr(TxFifo.Total);
   sid_RxLength:    Result:=IntToStr(RxFifo.Count);
   sid_TxLength:    Result:=IntToStr(TxFifo.Count);
   sid_RxFifoLimit: Result:=IntToStr(RxFifo.GrowLimit);
   sid_TxFifoLimit: Result:=IntToStr(TxFifo.GrowLimit);
   sid_LogsHistory: begin
    if not IsEmptyStr(sv) then myLogsHistory:=StrToIntDef(Trim(sv),LogsHistory);
    Result:=IntToStr(LogsHistory);
   end;
   sid_RxBuffSize,
   sid_RxPipeSize:  begin
    if (p>0) and TryStrToInt(Trim(sv),iv) then RxFifo.Size:=ValidateFifoSize(iv);
    Result:=IntToStr(RxFifo.Size);
   end;
   sid_TxBuffSize,
   sid_TxPipeSize:  begin
    if (p>0) and TryStrToInt(Trim(sv),iv) then TxFifo.Size:=ValidateFifoSize(iv);
    Result:=IntToStr(TxFifo.Size);
   end;
   sid_Polling,
   sid_PollingDelay: begin
    if (p>0) and TryStrToInt(Trim(sv),iv) then Polling.Delay:=ValidateDelay(iv);
    Result:=IntToStr(Polling.Delay);
   end;
   sid_Priority,
   sid_PollingPriority: begin
    if (p>0) and not IsEmptyStr(sv) then Polling.Priority:=ValidatePriority(StringToThreadPriority(Trim(sv),DefPriority));
    Result:=ThreadPriorityToString(Polling.Priority);
   end;
   sid_LogsCount:    Result:=IntToStr(LogsCount);
   sid_LogsTextMove: Result:=LogsTextMove;
   sid_LogsTextCopy: Result:=LogsTextCopy;
   sid_Clear:        begin
    if not IsEmptyStr(sv) then Clear(Trim(sv));
    Result:='';
   end;
   sid_TxSend: begin
    if (p>0) then iv:=Send(sv) else iv:=0;
    Result:=IntToStr(iv);
   end;
   sid_RxRecv: begin
    iv:=MaxInt;
    if (p>0) then iv:=StrToIntDef(Trim(sv),iv);
    Result:=Recv(iv);
   end;
   sid_Asterisk,
   sid_Question: begin
    Result:='';
    if Assigned(Dictionary) then
    for i:=0 to Dictionary.Count-1 do begin
     si:=Dictionary.Links[i];
     if (si<=Ord(sid_Unknown)) then continue;
     if (si>=Ord(sid_Asterisk)) then continue;
     if not (TStringIdentifier(si) in sid_Ctrl_Readable) then continue;
     if (p>0) and not (TStringIdentifier(si) in sid_Ctrl_Writable) then continue;
     par:=Dictionary.Keys[i];
     if (sn='*') then Result:=Result+par+EOL;
     if (sn='?') then Result:=Result+par+'='+ctrl(par)+EOL;
    end;
   end;
  end;
  sn:=''; sv:='';
 except
  on E:Exception do ErrorFound(E,'Ctrl');
 end;
end;

procedure TSocketPipe.Clear(const What:LongString);
begin
 if Assigned(Self) then begin
  if (WordIndex('RxLost',What,ScanSpaces)>0) then RxFifo.Lost:=0;
  if (WordIndex('TxLost',What,ScanSpaces)>0) then TxFifo.Lost:=0;
  if (WordIndex('RxFifo',What,ScanSpaces)>0) then RxFifo.Clear;
  if (WordIndex('TxFifo',What,ScanSpaces)>0) then TxFifo.Clear;
  if (WordIndex('RxTotal',What,ScanSpaces)>0) then RxFifo.Total:=0;
  if (WordIndex('TxTotal',What,ScanSpaces)>0) then TxFifo.Total:=0;
  if (WordIndex('Logs',What,ScanSpaces)>0) then LogsText.Count:=0;
 end;
end;

class function TSocketPipe.ValidateDelay(aDelay:Integer):Integer;
begin
 if (aDelay<=0) then aDelay:=DefDelay;
 aDelay:=EnsureRange(aDelay,1,100);
 Result:=aDelay;
end;

class function TSocketPipe.GetDefDelay:Integer;
begin
 Result:=TheDefDelay;
end;

class procedure TSocketPipe.SetDefDelay(aDelay:Integer);
begin
 TheDefDelay:=ValidateDelay(aDelay);
end;

class function TSocketPipe.ValidateTimeout(aTimeOut:Integer):Integer;
begin
 if (aTimeOut<=0) then aTimeout:=DefTimeout;
 aTimeout:=EnsureRange(aTimeOut,(1000 div 5),(1000*5));
 Result:=aTimeOut;
end;

class function TSocketPipe.GetDefTimeout:Integer;
begin
 Result:=TheDefTimeout;
end;

class procedure TSocketPipe.SetDefTimeout(aTimeout:Integer);
begin
 TheDefTimeout:=ValidateTimeout(aTimeOut);
end;

class function TSocketPipe.ValidateFifoSize(aFifoSize:Integer):Integer;
begin
 if (aFifoSize<=0) then aFifoSize:=DefFifoSize;
 aFifoSize:=EnsureRange(aFifoSize,KiloByte*4,MegaByte*4);
 Result:=aFifoSize;
end;

class function TSocketPipe.GetDefFifoSize:Integer;
begin
 Result:=TheDefFifoSize;
end;

class procedure TSocketPipe.SetDefFifoSize(aFifoSize:Integer);
begin
 TheDefFifoSize:=ValidateFifoSize(aFifoSize);
end;

class function TSocketPipe.ValidateHistory(aHistory:Integer):Integer;
begin
 if (aHistory<=0) then aHistory:=DefHistory;
 aHistory:=EnsureRange(aHistory,0,1000*100);
 Result:=aHistory;
end;

class function TSocketPipe.GetDefHistory:Integer;
begin
 Result:=TheDefHistory;
end;

class procedure TSocketPipe.SetDefHistory(aHistory:Integer);
begin
 TheDefHistory:=ValidateHistory(aHistory);
end;

class function TSocketPipe.GetDefPriority:TThreadPriority;
begin
 Result:=TheDefPriority;
end;

class procedure TSocketPipe.SetDefPriority(aPriority:TThreadPriority);
begin
 TheDefPriority:=ValidatePriority(aPriority);
end;

class function TSocketPipe.ValidatePriority(aPriority:TThreadPriority):TThreadPriority;
begin
 Result:=aPriority;
end;

class function TSocketPipe.ValidateTarget(aTarget:LongString):LongString;
begin
 Result:=LowerCase(Trim(aTarget));
end;

class function TSocketPipe.LocalHostName:LongString;
begin
 Result:=_crw_fio.HostName;
end;

class function TSocketPipe.LocalHostIpAddr:LongString;
begin
 Result:=_crw_fio.GetIpAddress;
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:%d',[aPort]));
 myPort:=aPort;
 myTimeOut:=ValidateTimeout(aTimeOut);
 myOptions:=aOptions;
 myReporter:=aReporter;
 myPolling.Delay:=ValidateDelay(aDelay);
 myPolling.Priority:=ValidatePriority(aPriority);
 for i:=0 to Childs.Capacity-1 do TSocketPipe.Create(Self,0,'');
 for i:=0 to Count-1 do Self[i].RxFifo.Size:=ValidateFifoSize(aRxFifoSize);
 for i:=0 to Count-1 do Self[i].TxFifo.Size:=ValidateFifoSize(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@%s:%d',[ValidateTarget(aTarget),aPort]));
 myPort:=aPort;
 myReporter:=aReporter;
 myTarget:=ValidateTarget(aTarget);
 myTimeOut:=ValidateTimeout(aTimeOut);
 myPolling.Delay:=ValidateDelay(aDelay);
 myPolling.Priority:=ValidatePriority(aPriority);
 RxFifo.Size:=ValidateFifoSize(aRxFifoSize);
 TxFifo.Size:=ValidateFifoSize(aTxFifoSize);
 myOptions:=aOptions;
end;

destructor TTcpClient.Destroy;
begin
 myTarget:='';
 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
  aDelay:=TSocketPipe.ValidateDelay(aDelay);
  aTimeout:=TSocketPipe.ValidateTimeout(aTimeout);
  aPriority:=TSocketPipe.ValidatePriority(aPriority);
  aRxFifoSize:=TSocketPipe.ValidateFifoSize(aRxFifoSize);
  aTxFifoSize:=TSocketPipe.ValidateFifoSize(aTxFifoSize);
  Result:=TTcpServer.Create(aPort,aMaxPipes,aReporter,aDelay,aPriority,
                            aRxFifoSize,aTxFifoSize,aTimeOut,aOptions);
 except
  on E:Exception do BugReport(E,nil,'NewTcpServer');
 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 not IsEmptyStr(aTarget) then
 try
  aDelay:=TSocketPipe.ValidateDelay(aDelay);
  aTarget:=TSocketPipe.ValidateTarget(aTarget);
  aTimeout:=TSocketPipe.ValidateTimeout(aTimeout);
  aPriority:=TSocketPipe.ValidatePriority(aPriority);
  aRxFifoSize:=TSocketPipe.ValidateFifoSize(aRxFifoSize);
  aTxFifoSize:=TSocketPipe.ValidateFifoSize(aTxFifoSize);
  Result:=TTcpClient.Create(aPort,aTarget,aReporter,aDelay,aPriority,
                            aRxFifoSize,aTxFifoSize,aTimeOut,aOptions);
 except
  on E:Exception do BugReport(E,nil,'NewTcpClient');
 end;
end;

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

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

procedure Kill(var TheObject:TTcpClient); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 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;

procedure aSocketProperties(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if aObject is TSocketPipe then
 with TSocketPipe(aObject) do begin
  TText(CustomData).Addln(Format('[socket:%s]',[Polling.Name]));
  TText(CustomData).Text:=TText(CustomData).Text+GetProperties;
 end;
end;

function GetFullSocketListProperties(TheText:TText):TText;
begin
 Result:=TheText;
 FullSocketList.ForEach(aSocketProperties,TheText);
end;

function GetFullSocketListPropertiesAsText:LongString;
var T:TText;
begin
 Result:='';
 try
  T:=NewText;
  try
   Result:=GetFullSocketListProperties(T).Text;
  finally
   Kill(T);
  end;
 except
  on E:Exception do BugReport(E,nil,'GetFullSocketListPropertiesAsText');
 end;
end;

 /////////////////
 // FullSocketList
 /////////////////

const
 TheFullSocketList : TObjectStorage = nil;

function FullSocketList:TObjectStorage;
begin
 if not Assigned(TheFullSocketList) then begin
  TheFullSocketList:=NewObjectStorage;
  TheFullSocketList.Master:=@TheFullSocketList;
  TheFullSocketList.OwnsObjects:=false;
 end;
 Result:=TheFullSocketList;
end;

{$IFDEF WINDOWS}
var WSAData:TWSAData;
{$ENDIF ~WINDOWS}

procedure WsaInit(aInit:Boolean);
begin
 {$IFDEF WINDOWS}
 if aInit
 then WinSock.WSAStartup($0101,WSAData)
 else WinSock.WSACleanup;;
 {$ENDIF ~WINDOWS}
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_tcp;
begin
 WsaInit(true);
 InitDictionary;
 FullSocketList.Ok;
 TSocketPipe.DefDelay:=4;
 TSocketPipe.DefHistory:=16;
 TSocketPipe.DefTimeout:=1000;
 TSocketPipe.DefFifoSize:=KiloByte*16;
 TSocketPipe.DefPriority:=DefSocketPriority;
end;

procedure Free_crw_tcp;
begin
 ResourceLeakageLog(Format('%-60s = %d',['FullSocketList.Count', TheFullSocketList.Count]));
 Kill(TheFullSocketList);
 FreeDictionary;
 WsaInit(false);
end;

initialization

 Init_crw_tcp;

finalization

 Free_crw_tcp;

end.

//////////////
// END OF FILE
//////////////

