home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / scktcomp.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  62KB  |  2,087 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {       Windows socket components                       }
  6. {                                                       }
  7. {       Copyright (c) 1997,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit ScktComp;
  12.  
  13. interface
  14.  
  15. uses SysUtils, Windows, Messages, Classes, WinSock, SyncObjs;
  16.  
  17. const
  18.   CM_SOCKETMESSAGE = WM_USER + $0001;
  19.   CM_DEFERFREE = WM_USER + $0002;
  20.   CM_LOOKUPCOMPLETE = WM_USER + $0003;
  21.  
  22. type
  23.   ESocketError = class(Exception);
  24.  
  25.   TCMSocketMessage = record
  26.     Msg: Cardinal;
  27.     Socket: TSocket;
  28.     SelectEvent: Word;
  29.     SelectError: Word;
  30.     Result: Longint;
  31.   end;
  32.  
  33.   TCMLookupComplete = record
  34.     Msg: Cardinal;
  35.     LookupHandle: THandle;
  36.     AsyncBufLen: Word;
  37.     AsyncError: Word;
  38.     Result: Longint;
  39.   end;
  40.  
  41.   TCustomWinSocket = class;
  42.   TCustomSocket = class;
  43.   TServerAcceptThread = class;
  44.   TServerClientThread = class;
  45.   TServerWinSocket = class;
  46.   TServerClientWinSocket = class;
  47.  
  48.   TServerType = (stNonBlocking, stThreadBlocking);
  49.   TClientType = (ctNonBlocking, ctBlocking);
  50.   TAsyncStyle = (asRead, asWrite, asOOB, asAccept, asConnect, asClose);
  51.   TAsyncStyles = set of TAsyncStyle;
  52.   TSocketEvent = (seLookup, seConnecting, seConnect, seDisconnect, seListen,
  53.     seAccept, seWrite, seRead);
  54.   TLookupState = (lsIdle, lsLookupAddress, lsLookupService);
  55.   TErrorEvent = (eeGeneral, eeSend, eeReceive, eeConnect, eeDisconnect, eeAccept);
  56.  
  57.   TSocketEventEvent = procedure (Sender: TObject; Socket: TCustomWinSocket;
  58.     SocketEvent: TSocketEvent) of object;
  59.   TSocketErrorEvent = procedure (Sender: TObject; Socket: TCustomWinSocket;
  60.     ErrorEvent: TErrorEvent; var ErrorCode: Integer) of object;
  61.   TGetSocketEvent = procedure (Sender: TObject; Socket: TSocket;
  62.     var ClientSocket: TServerClientWinSocket) of object;
  63.   TGetThreadEvent = procedure (Sender: TObject; ClientSocket: TServerClientWinSocket;
  64.     var SocketThread: TServerClientThread) of object;
  65.   TSocketNotifyEvent = procedure (Sender: TObject; Socket: TCustomWinSocket) of object;
  66.  
  67.   TCustomWinSocket = class
  68.   private
  69.     FSocket: TSocket;
  70.     FConnected: Boolean;
  71.     FSendStream: TStream;
  72.     FDropAfterSend: Boolean;
  73.     FHandle: HWnd;
  74.     FAddr: TSockAddrIn;
  75.     FAsyncStyles: TASyncStyles;
  76.     FLookupState: TLookupState;
  77.     FLookupHandle: THandle;
  78.     FOnSocketEvent: TSocketEventEvent;
  79.     FOnErrorEvent: TSocketErrorEvent;
  80.     FSocketLock: TCriticalSection;
  81.     FGetHostData: Pointer;
  82.     FData: Pointer;
  83.     // Used during non-blocking host and service lookups
  84.     FService: string;
  85.     FPort: Word;
  86.     FClient: Boolean;
  87.     FQueueSize: Integer;
  88.     function SendStreamPiece: Boolean;
  89.     procedure WndProc(var Message: TMessage);
  90.     procedure CMLookupComplete(var Message: TCMLookupComplete); message CM_LOOKUPCOMPLETE;
  91.     procedure CMSocketMessage(var Message: TCMSocketMessage); message CM_SOCKETMESSAGE;
  92.     procedure CMDeferFree(var Message); message CM_DEFERFREE;
  93.     procedure DeferFree;
  94.     procedure DoSetAsyncStyles;
  95.     function GetHandle: HWnd;
  96.     function GetLocalHost: string;
  97.     function GetLocalAddress: string;
  98.     function GetLocalPort: Integer;
  99.     function GetRemoteHost: string;
  100.     function GetRemoteAddress: string;
  101.     function GetRemotePort: Integer;
  102.     function GetRemoteAddr: TSockAddrIn;
  103.   protected
  104.     procedure AsyncInitSocket(const Name, Address, Service: string; Port: Word;
  105.       QueueSize: Integer; Client: Boolean);
  106.     procedure DoOpen;
  107.     procedure DoListen(QueueSize: Integer);
  108.     function InitSocket(const Name, Address, Service: string; Port: Word;
  109.       Client: Boolean): TSockAddrIn;
  110.     procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent); dynamic;
  111.     procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  112.       var ErrorCode: Integer); dynamic;
  113.     procedure SetAsyncStyles(Value: TASyncStyles);
  114.   public
  115.     constructor Create(ASocket: TSocket);
  116.     destructor Destroy; override;
  117.     procedure Close;
  118.     procedure DefaultHandler(var Message); override;
  119.     procedure Lock;
  120.     procedure Unlock;
  121.     procedure Listen(const Name, Address, Service: string; Port: Word;
  122.       QueueSize: Integer; Block: Boolean = True);
  123.     procedure Open(const Name, Address, Service: string; Port: Word; Block: Boolean = True);
  124.     procedure Accept(Socket: TSocket); virtual;
  125.     procedure Connect(Socket: TSocket); virtual;
  126.     procedure Disconnect(Socket: TSocket); virtual;
  127.     procedure Read(Socket: TSocket); virtual;
  128.     procedure Write(Socket: TSocket); virtual;
  129.     function LookupName(const name: string): TInAddr;
  130.     function LookupService(const service: string): Integer;
  131.  
  132.     function ReceiveLength: Integer;
  133.     function ReceiveBuf(var Buf; Count: Integer): Integer;
  134.     function ReceiveText: string;
  135.     function SendBuf(var Buf; Count: Integer): Integer;
  136.     function SendStream(AStream: TStream): Boolean;
  137.     function SendStreamThenDrop(AStream: TStream): Boolean;
  138.     function SendText(const S: string): Integer;
  139.  
  140.     property LocalHost: string read GetLocalHost;
  141.     property LocalAddress: string read GetLocalAddress;
  142.     property LocalPort: Integer read GetLocalPort;
  143.  
  144.     property RemoteHost: string read GetRemoteHost;
  145.     property RemoteAddress: string read GetRemoteAddress;
  146.     property RemotePort: Integer read GetRemotePort;
  147.     property RemoteAddr: TSockAddrIn read GetRemoteAddr;
  148.  
  149.     property Connected: Boolean read FConnected;
  150.     property Addr: TSockAddrIn read FAddr;
  151.     property ASyncStyles: TAsyncStyles read FAsyncStyles write SetAsyncStyles;
  152.     property Handle: HWnd read GetHandle;
  153.     property SocketHandle: TSocket read FSocket;
  154.     property LookupState: TLookupState read FLookupState;
  155.  
  156.     property OnSocketEvent: TSocketEventEvent read FOnSocketEvent write FOnSocketEvent;
  157.     property OnErrorEvent: TSocketErrorEvent read FOnErrorEvent write FOnErrorEvent;
  158.  
  159.     property Data: Pointer read FData write FData;
  160.   end;
  161.  
  162.   TClientWinSocket = class(TCustomWinSocket)
  163.   private
  164.     FClientType: TClientType;
  165.   protected
  166.     procedure SetClientType(Value: TClientType);
  167.   public
  168.     procedure Connect(Socket: TSocket); override;
  169.     property ClientType: TClientType read FClientType write SetClientType;
  170.   end;
  171.  
  172.   TServerClientWinSocket = class(TCustomWinSocket)
  173.   private
  174.     FServerWinSocket: TServerWinSocket;
  175.   public
  176.     constructor Create(Socket: TSocket; ServerWinSocket: TServerWinSocket);
  177.     destructor Destroy; override;
  178.  
  179.     property ServerWinSocket: TServerWinSocket read FServerWinSocket;
  180.   end;
  181.  
  182.   TThreadNotifyEvent = procedure (Sender: TObject;
  183.     Thread: TServerClientThread) of object;
  184.  
  185.   TServerWinSocket = class(TCustomWinSocket)
  186.   private
  187.     FServerType: TServerType;
  188.     FThreadCacheSize: Integer;
  189.     FConnections: TList;
  190.     FActiveThreads: TList;
  191.     FListLock: TCriticalSection;
  192.     FServerAcceptThread: TServerAcceptThread;
  193.     FOnGetSocket: TGetSocketEvent;
  194.     FOnGetThread: TGetThreadEvent;
  195.     FOnThreadStart: TThreadNotifyEvent;
  196.     FOnThreadEnd: TThreadNotifyEvent;
  197.     FOnClientConnect: TSocketNotifyEvent;
  198.     FOnClientDisconnect: TSocketNotifyEvent;
  199.     FOnClientRead: TSocketNotifyEvent;
  200.     FOnClientWrite: TSocketNotifyEvent;
  201.     FOnClientError: TSocketErrorEvent;
  202.     procedure AddClient(AClient: TServerClientWinSocket);
  203.     procedure RemoveClient(AClient: TServerClientWinSocket);
  204.     procedure AddThread(AThread: TServerClientThread);
  205.     procedure RemoveThread(AThread: TServerClientThread);
  206.     procedure ClientEvent(Sender: TObject; Socket: TCustomWinSocket;
  207.       SocketEvent: TSocketEvent);
  208.     procedure ClientError(Sender: TObject; Socket: TCustomWinSocket;
  209.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  210.     function GetActiveConnections: Integer;
  211.     function GetActiveThreads: Integer;
  212.     function GetConnections(Index: Integer): TCustomWinSocket;
  213.     function GetIdleThreads: Integer;
  214.   protected
  215.     function DoCreateThread(ClientSocket: TServerClientWinSocket): TServerClientThread; virtual;
  216.     procedure Listen(var Name, Address, Service: string; Port: Word;
  217.       QueueSize: Integer);
  218.     procedure SetServerType(Value: TServerType);
  219.     procedure SetThreadCacheSize(Value: Integer);
  220.     procedure ThreadEnd(AThread: TServerClientThread); dynamic;
  221.     procedure ThreadStart(AThread: TServerClientThread); dynamic;
  222.     function GetClientSocket(Socket: TSocket): TServerClientWinSocket; dynamic;
  223.     function GetServerThread(ClientSocket: TServerClientWinSocket): TServerClientThread; dynamic;
  224.     procedure ClientRead(Socket: TCustomWinSocket); dynamic;
  225.     procedure ClientWrite(Socket: TCustomWinSOcket); dynamic;
  226.     procedure ClientConnect(Socket: TCustomWinSOcket); dynamic;
  227.     procedure ClientDisconnect(Socket: TCustomWinSOcket); dynamic;
  228.     procedure ClientErrorEvent(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  229.       var ErrorCode: Integer); dynamic;
  230.   public
  231.     constructor Create(ASocket: TSocket);
  232.     destructor Destroy; override;
  233.     procedure Accept(Socket: TSocket); override;
  234.     procedure Disconnect(Socket: TSocket); override;
  235.     function GetClientThread(ClientSocket: TServerClientWinSocket): TServerClientThread;
  236.     property ActiveConnections: Integer read GetActiveConnections;
  237.     property ActiveThreads: Integer read GetActiveThreads;
  238.     property Connections[Index: Integer]: TCustomWinSocket read GetConnections;
  239.     property IdleThreads: Integer read GetIdleThreads;
  240.     property ServerType: TServerType read FServerType write SetServerType;
  241.     property ThreadCacheSize: Integer read FThreadCacheSize write SetThreadCacheSize;
  242.     property OnGetSocket: TGetSocketEvent read FOnGetSocket write FOnGetSocket;
  243.     property OnGetThread: TGetThreadEvent read FOnGetThread write FOnGetThread;
  244.     property OnThreadStart: TThreadNotifyEvent read FOnThreadStart write FOnThreadStart;
  245.     property OnThreadEnd: TThreadNotifyEvent read FOnThreadEnd write FOnThreadEnd;
  246.     property OnClientConnect: TSocketNotifyEvent read FOnClientConnect write FOnClientConnect;
  247.     property OnClientDisconnect: TSocketNotifyEvent read FOnClientDisconnect write FOnClientDisconnect;
  248.     property OnClientRead: TSocketNotifyEvent read FOnClientRead write FOnClientRead;
  249.     property OnClientWrite: TSocketNotifyEvent read FOnClientWrite write FOnClientWrite;
  250.     property OnClientError: TSocketErrorEvent read FOnClientError write FOnClientError;
  251.   end;
  252.  
  253.   TServerAcceptThread = class(TThread)
  254.   private
  255.     FServerSocket: TServerWinSocket;
  256.   public
  257.     constructor Create(CreateSuspended: Boolean; ASocket: TServerWinSocket);
  258.     procedure Execute; override;
  259.  
  260.     property ServerSocket: TServerWinSocket read FServerSocket;
  261.   end;
  262.  
  263.   TServerClientThread = class(TThread)
  264.   private
  265.     FClientSocket: TServerClientWinSocket;
  266.     FServerSocket: TServerWinSocket;
  267.     FException: Exception;
  268.     FEvent: TSimpleEvent;
  269.     FKeepInCache: Boolean;
  270.     FData: Pointer;
  271.     procedure HandleEvent(Sender: TObject; Socket: TCustomWinSocket;
  272.       SocketEvent: TSocketEvent);
  273.     procedure HandleError(Sender: TObject; Socket: TCustomWinSocket;
  274.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  275.     procedure DoHandleException;
  276.     procedure DoRead;
  277.     procedure DoWrite;
  278.   protected
  279.     procedure DoTerminate; override;
  280.     procedure Execute; override;
  281.     procedure ClientExecute; virtual;
  282.     procedure Event(SocketEvent: TSocketEvent); virtual;
  283.     procedure Error(ErrorEvent: TErrorEvent; var ErrorCode: Integer); virtual;
  284.     procedure HandleException; virtual;
  285.     procedure ReActivate(ASocket: TServerClientWinSocket);
  286.     function StartConnect: Boolean;
  287.     function EndConnect: Boolean;
  288.   public
  289.     constructor Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket);
  290.     destructor Destroy; override;
  291.  
  292.     property ClientSocket: TServerClientWinSocket read FClientSocket;
  293.     property ServerSocket: TServerWinSocket read FServerSocket;
  294.     property KeepInCache: Boolean read FKeepInCache write FKeepInCache;
  295.     property Data: Pointer read FData write FData;
  296.   end;
  297.  
  298.   TAbstractSocket = class(TComponent)
  299.   private
  300.     FActive: Boolean;
  301.     FPort: Integer;
  302.     FAddress: string;
  303.     FHost: string;
  304.     FService: string;
  305.     procedure DoEvent(Sender: TObject; Socket: TCustomWinSocket;
  306.       SocketEvent: TSocketEvent);
  307.     procedure DoError(Sender: TObject; Socket: TCustomWinSocket;
  308.       ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  309.   protected
  310.     procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
  311.       virtual; abstract;
  312.     procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  313.       var ErrorCode: Integer); virtual; abstract;
  314.     procedure DoActivate(Value: Boolean); virtual; abstract;
  315.     procedure InitSocket(Socket: TCustomWinSocket);
  316.     procedure Loaded; override;
  317.     procedure SetActive(Value: Boolean);
  318.     procedure SetAddress(Value: string);
  319.     procedure SetHost(Value: string);
  320.     procedure SetPort(Value: Integer);
  321.     procedure SetService(Value: string);
  322.     property Active: Boolean read FActive write SetActive;
  323.     property Address: string read FAddress write SetAddress;
  324.     property Host: string read FHost write SetHost;
  325.     property Port: Integer read FPort write SetPort;
  326.     property Service: string read FService write SetService;
  327.   public
  328.     procedure Open;
  329.     procedure Close;
  330.   end;
  331.  
  332.   TCustomSocket = class(TAbstractSocket)
  333.   private
  334.     FOnLookup: TSocketNotifyEvent;
  335.     FOnConnect: TSocketNotifyEvent;
  336.     FOnConnecting: TSocketNotifyEvent;
  337.     FOnDisconnect: TSocketNotifyEvent;
  338.     FOnListen: TSocketNotifyEvent;
  339.     FOnAccept: TSocketNotifyEvent;
  340.     FOnRead: TSocketNotifyEvent;
  341.     FOnWrite: TSocketNotifyEvent;
  342.     FOnError: TSocketErrorEvent;
  343.   protected
  344.     procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent); override;
  345.     procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  346.       var ErrorCode: Integer); override;
  347.     property OnLookup: TSocketNotifyEvent read FOnLookup write FOnLookup;
  348.     property OnConnecting: TSocketNotifyEvent read FOnConnecting write FOnConnecting;
  349.     property OnConnect: TSocketNotifyEvent read FOnConnect write FOnConnect;
  350.     property OnDisconnect: TSocketNotifyEvent read FOnDisconnect write FOnDisconnect;
  351.     property OnListen: TSocketNotifyEvent read FOnListen write FOnListen;
  352.     property OnAccept: TSocketNotifyEvent read FOnAccept write FOnAccept;
  353.     property OnRead: TSocketNotifyEvent read FOnRead write FOnRead;
  354.     property OnWrite: TSocketNotifyEvent read FOnWrite write FOnWrite;
  355.     property OnError: TSocketErrorEvent read FOnError write FOnError;
  356.   end;
  357.  
  358.   TWinSocketStream = class(TStream)
  359.   private
  360.     FSocket: TCustomWinSocket;
  361.     FTimeout: Longint;
  362.     FEvent: TSimpleEvent;
  363.   public
  364.     constructor Create(ASocket: TCustomWinSocket; TimeOut: Longint);
  365.     destructor Destroy; override;
  366.     function WaitForData(Timeout: Longint): Boolean;
  367.     function Read(var Buffer; Count: Longint): Longint; override;
  368.     function Write(const Buffer; Count: Longint): Longint; override;
  369.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  370.     property TimeOut: Longint read FTimeout write FTimeout;
  371.   end;
  372.  
  373.   TClientSocket = class(TCustomSocket)
  374.   private
  375.     FClientSocket: TClientWinSocket;
  376.   protected
  377.     procedure DoActivate(Value: Boolean); override;
  378.     function GetClientType: TClientType;
  379.     procedure SetClientType(Value: TClientType);
  380.   public
  381.     constructor Create(AOwner: TComponent); override;
  382.     destructor Destroy; override;
  383.     property Socket: TClientWinSocket read FClientSocket;
  384.   published
  385.     property Active;
  386.     property Address;
  387.     property ClientType: TClientType read GetClientType write SetClientType;
  388.     property Host;
  389.     property Port;
  390.     property Service;
  391.     property OnLookup;
  392.     property OnConnecting;
  393.     property OnConnect;
  394.     property OnDisconnect;
  395.     property OnRead;
  396.     property OnWrite;
  397.     property OnError;
  398.   end;
  399.  
  400.   TCustomServerSocket = class(TCustomSocket)
  401.   protected
  402.     FServerSocket: TServerWinSocket;
  403.     procedure DoActivate(Value: Boolean); override;
  404.     function GetServerType: TServerType;
  405.     function GetGetThreadEvent: TGetThreadEvent;
  406.     function GetGetSocketEvent: TGetSocketEvent;
  407.     function GetThreadCacheSize: Integer;
  408.     function GetOnThreadStart: TThreadNotifyEvent;
  409.     function GetOnThreadEnd: TThreadNotifyEvent;
  410.     function GetOnClientEvent(Index: Integer): TSocketNotifyEvent;
  411.     function GetOnClientError: TSocketErrorEvent;
  412.     procedure SetServerType(Value: TServerType);
  413.     procedure SetGetThreadEvent(Value: TGetThreadEvent);
  414.     procedure SetGetSocketEvent(Value: TGetSocketEvent);
  415.     procedure SetThreadCacheSize(Value: Integer);
  416.     procedure SetOnThreadStart(Value: TThreadNotifyEvent);
  417.     procedure SetOnThreadEnd(Value: TThreadNotifyEvent);
  418.     procedure SetOnClientEvent(Index: Integer; Value: TSocketNotifyEvent);
  419.     procedure SetOnClientError(Value: TSocketErrorEvent);
  420.     property ServerType: TServerType read GetServerType write SetServerType;
  421.     property ThreadCacheSize: Integer read GetThreadCacheSize
  422.       write SetThreadCacheSize;
  423.     property OnGetThread: TGetThreadEvent read GetGetThreadEvent
  424.       write SetGetThreadEvent;
  425.     property OnGetSocket: TGetSocketEvent read GetGetSocketEvent
  426.       write SetGetSocketEvent;
  427.     property OnThreadStart: TThreadNotifyEvent read GetOnThreadStart
  428.       write SetOnThreadStart;
  429.     property OnThreadEnd: TThreadNotifyEvent read GetOnThreadEnd
  430.       write SetOnThreadEnd;
  431.     property OnClientConnect: TSocketNotifyEvent index 2 read GetOnClientEvent
  432.       write SetOnClientEvent;
  433.     property OnClientDisconnect: TSocketNotifyEvent index 3 read GetOnClientEvent
  434.       write SetOnClientEvent;
  435.     property OnClientRead: TSocketNotifyEvent index 0 read GetOnClientEvent
  436.       write SetOnClientEvent;
  437.     property OnClientWrite: TSocketNotifyEvent index 1 read GetOnClientEvent
  438.       write SetOnClientEvent;
  439.     property OnClientError: TSocketErrorEvent read GetOnClientError write SetOnClientError;
  440.   public
  441.     destructor Destroy; override;
  442.   end;
  443.  
  444.   TServerSocket = class(TCustomServerSocket)
  445.   public
  446.     constructor Create(AOwner: TComponent); override;
  447.     property Socket: TServerWinSocket read FServerSocket;
  448.   published
  449.     property Active;
  450.     property Port;
  451.     property Service;
  452.     property ServerType;
  453.     property ThreadCacheSize default 10;
  454.     property OnListen;
  455.     property OnAccept;
  456.     property OnGetThread;
  457.     property OnGetSocket;
  458.     property OnThreadStart;
  459.     property OnThreadEnd;
  460.     property OnClientConnect;
  461.     property OnClientDisconnect;
  462.     property OnClientRead;
  463.     property OnClientWrite;
  464.     property OnClientError;
  465.   end;
  466.  
  467.   TSocketErrorProc = procedure (ErrorCode: Integer);
  468.  
  469. function SetErrorProc(ErrorProc: TSocketErrorProc): TSocketErrorProc;
  470.  
  471. implementation
  472.  
  473. uses Forms, Consts;
  474.  
  475. threadvar
  476.   SocketErrorProc: TSocketErrorProc;
  477.  
  478. var
  479.   WSAData: TWSAData;
  480.  
  481. function SetErrorProc(ErrorProc: TSocketErrorProc): TSocketErrorProc;
  482. begin
  483.   Result := SocketErrorProc;
  484.   SocketErrorProc := ErrorProc;
  485. end;
  486.  
  487. function CheckSocketResult(ResultCode: Integer; const Op: string): Integer;
  488. begin
  489.   if ResultCode <> 0 then
  490.   begin
  491.     Result := WSAGetLastError;
  492.     if Result <> WSAEWOULDBLOCK then
  493.       if Assigned(SocketErrorProc) then
  494.         SocketErrorProc(Result)
  495.       else raise ESocketError.CreateResFmt(@sWindowsSocketError,
  496.         [SysErrorMessage(Result), Result, Op]);
  497.   end else Result := 0;
  498. end;
  499.  
  500. procedure Startup;
  501. var
  502.   ErrorCode: Integer;
  503. begin
  504.   ErrorCode := WSAStartup($0101, WSAData);
  505.   if ErrorCode <> 0 then
  506.     raise ESocketError.CreateResFmt(@sWindowsSocketError,
  507.       [SysErrorMessage(ErrorCode), ErrorCode, 'WSAStartup']);
  508. end;
  509.  
  510. procedure Cleanup;
  511. var
  512.   ErrorCode: Integer;
  513. begin
  514.   ErrorCode := WSACleanup;
  515.   if ErrorCode <> 0 then
  516.     raise ESocketError.CreateResFmt(@sWindowsSocketError,
  517.       [SysErrorMessage(ErrorCode), ErrorCode, 'WSACleanup']);
  518. end;
  519.  
  520. { TCustomWinSocket }
  521.  
  522. constructor TCustomWinSocket.Create(ASocket: TSocket);
  523. begin
  524.   inherited Create;
  525.   Startup;
  526.   FSocketLock := TCriticalSection.Create;
  527.   FASyncStyles := [asRead, asWrite, asConnect, asClose];
  528.   FSocket := ASocket;
  529.   FAddr.sin_family := PF_INET;
  530.   FAddr.sin_addr.s_addr := INADDR_ANY;
  531.   FAddr.sin_port := 0;
  532.   FConnected := FSocket <> INVALID_SOCKET;
  533. end;
  534.  
  535. destructor TCustomWinSocket.Destroy;
  536. begin
  537.   FOnSocketEvent := nil;  { disable events }
  538.   if FConnected and (FSocket <> INVALID_SOCKET) then
  539.     Disconnect(FSocket);
  540.   if FHandle <> 0 then DeallocateHWnd(FHandle);
  541.   FSocketLock.Free;
  542.   Cleanup;
  543.   FreeMem(FGetHostData);
  544.   FGetHostData := nil;
  545.   inherited Destroy;
  546. end;
  547.  
  548. procedure TCustomWinSocket.Accept(Socket: TSocket);
  549. begin
  550. end;
  551.  
  552. procedure TCustomWinSocket.AsyncInitSocket(const Name, Address,
  553.   Service: string; Port: Word; QueueSize: Integer; Client: Boolean);
  554. begin
  555.   try
  556.     case FLookupState of
  557.       lsIdle:
  558.         begin
  559.           if not Client then
  560.           begin
  561.             FLookupState := lsLookupAddress;
  562.             FAddr.sin_addr.S_addr := INADDR_ANY;
  563.           end else if Name <> '' then
  564.           begin
  565.             if FGetHostData = nil then
  566.               FGetHostData := AllocMem(MAXGETHOSTSTRUCT);
  567.             FLookupHandle := WSAAsyncGetHostByName(Handle, CM_LOOKUPCOMPLETE,
  568.               PChar(Name), FGetHostData, MAXGETHOSTSTRUCT);
  569.             CheckSocketResult(Ord(FLookupHandle = 0), 'WSAASyncGetHostByName');
  570.             FService := Service;
  571.             FPort := Port;
  572.             FQueueSize := QueueSize;
  573.             FClient := Client;
  574.             FLookupState := lsLookupAddress;
  575.             Exit;
  576.           end else if Address <> '' then
  577.           begin
  578.             FLookupState := lsLookupAddress;
  579.             FAddr.sin_addr.S_addr := inet_addr(PChar(Address));
  580.           end else raise ESocketError.CreateRes(@sNoAddress);
  581.         end;
  582.       lsLookupAddress:
  583.         begin
  584.           if Service <> '' then
  585.           begin
  586.             if FGetHostData = nil then
  587.               FGetHostData := AllocMem(MAXGETHOSTSTRUCT);
  588.             FLookupHandle := WSAASyncGetServByName(Handle, CM_LOOKUPCOMPLETE,
  589.               PChar(Service), 'tcp' , FGetHostData, MAXGETHOSTSTRUCT);
  590.             CheckSocketResult(Ord(FLookupHandle = 0), 'WSAASyncGetServByName');
  591.             FLookupState := lsLookupService;
  592.             Exit;
  593.           end else
  594.           begin
  595.             FLookupState := lsLookupService;
  596.             FAddr.sin_port := htons(Port);
  597.           end;
  598.         end;
  599.       lsLookupService:
  600.         begin
  601.           FLookupState := lsIdle;
  602.           if Client then
  603.             DoOpen
  604.           else DoListen(QueueSize);
  605.         end;
  606.     end;
  607.     if FLookupState <> lsIdle then
  608.       ASyncInitSocket(Name, Address, Service, Port, QueueSize, Client);
  609.   except
  610.     Disconnect(FSocket);
  611.     raise;
  612.   end;
  613. end;
  614.  
  615. procedure TCustomWinSocket.Close;
  616. begin
  617.   Disconnect(FSocket);
  618. end;
  619.  
  620. procedure TCustomWinSocket.Connect(Socket: TSocket);
  621. begin
  622. end;
  623.  
  624. procedure TCustomWinSocket.Lock;
  625. begin
  626.   FSocketLock.Enter;
  627. end;
  628.  
  629. procedure TCustomWinSocket.Unlock;
  630. begin
  631.   FSocketLock.Leave;
  632. end;
  633.  
  634. procedure TCustomWinSocket.CMSocketMessage(var Message: TCMSocketMessage);
  635.  
  636.   function CheckError: Boolean;
  637.   var
  638.     ErrorEvent: TErrorEvent;
  639.     ErrorCode: Integer;
  640.   begin
  641.     if Message.SelectError <> 0 then
  642.     begin
  643.       Result := False;
  644.       ErrorCode := Message.SelectError;
  645.       case Message.SelectEvent of
  646.         FD_CONNECT: ErrorEvent := eeConnect;
  647.         FD_CLOSE: ErrorEvent := eeDisconnect;
  648.         FD_READ: ErrorEvent := eeReceive;
  649.         FD_WRITE: ErrorEvent := eeSend;
  650.         FD_ACCEPT: ErrorEvent := eeAccept;
  651.       else
  652.         ErrorEvent := eeGeneral;
  653.       end;
  654.       Error(Self, ErrorEvent, ErrorCode);
  655.       if ErrorCode <> 0 then
  656.         raise ESocketError.CreateResFmt(@sASyncSocketError, [ErrorCode]);
  657.     end else Result := True;
  658.   end;
  659.  
  660. begin
  661.   with Message do
  662.     if CheckError then
  663.       case SelectEvent of
  664.         FD_CONNECT: Connect(Socket);
  665.         FD_CLOSE: Disconnect(Socket);
  666.         FD_READ: Read(Socket);
  667.         FD_WRITE: Write(Socket);
  668.         FD_ACCEPT: Accept(Socket);
  669.       end;
  670. end;
  671.  
  672. procedure TCustomWinSocket.CMDeferFree(var Message);
  673. begin
  674.   Free;
  675. end;
  676.  
  677. procedure TCustomWinSocket.DeferFree;
  678. begin
  679.   if FHandle <> 0 then PostMessage(FHandle, CM_DEFERFREE, 0, 0);
  680. end;
  681.  
  682. procedure TCustomWinSocket.DoSetAsyncStyles;
  683. var
  684.   Msg: Integer;
  685.   Wnd: HWnd;
  686.   Blocking: Longint;
  687. begin
  688.   Msg := 0;
  689.   Wnd := 0;
  690.   if FAsyncStyles <> [] then
  691.   begin
  692.     Msg := CM_SOCKETMESSAGE;
  693.     Wnd := Handle;
  694.   end;
  695.   WSAAsyncSelect(FSocket, Wnd, Msg, Longint(Byte(FAsyncStyles)));
  696.   if FASyncStyles = [] then
  697.   begin
  698.     Blocking := 0;
  699.     ioctlsocket(FSocket, FIONBIO, Blocking);
  700.   end;
  701. end;
  702.  
  703. procedure TCustomWinSocket.DoListen(QueueSize: Integer);
  704. begin
  705.   CheckSocketResult(bind(FSocket, FAddr, SizeOf(FAddr)), 'bind');
  706.   DoSetASyncStyles;
  707.   if QueueSize > SOMAXCONN then QueueSize := SOMAXCONN;
  708.   Event(Self, seListen);
  709.   CheckSocketResult(Winsock.listen(FSocket, QueueSize), 'listen');
  710.   FLookupState := lsIdle;
  711.   FConnected := True;
  712. end;
  713.  
  714. procedure TCustomWinSocket.DoOpen;
  715. begin
  716.   DoSetASyncStyles;
  717.   Event(Self, seConnecting);
  718.   CheckSocketResult(WinSock.connect(FSocket, FAddr, SizeOf(FAddr)), 'connect');
  719.   FLookupState := lsIdle;
  720.   if not (asConnect in FAsyncStyles) then
  721.   begin
  722.     FConnected := FSocket <> INVALID_SOCKET;
  723.     Event(Self, seConnect);
  724.   end;
  725. end;
  726.  
  727. function TCustomWinSocket.GetHandle: HWnd;
  728. begin
  729.   if FHandle = 0 then
  730.     FHandle := AllocateHwnd(WndProc);
  731.   Result := FHandle;
  732. end;
  733.  
  734. function TCustomWinSocket.GetLocalAddress: string;
  735. var
  736.   SockAddrIn: TSockAddrIn;
  737.   Size: Integer;
  738. begin
  739.   Lock;
  740.   try
  741.     Result := '';
  742.     if FSocket = INVALID_SOCKET then Exit;
  743.     Size := SizeOf(SockAddrIn);
  744.     if getsockname(FSocket, SockAddrIn, Size) = 0 then
  745.       Result := inet_ntoa(SockAddrIn.sin_addr);
  746.   finally
  747.     Unlock;
  748.   end;
  749. end;
  750.  
  751. function TCustomWinSocket.GetLocalHost: string;
  752. var
  753.   LocalName: array[0..255] of Char;
  754. begin
  755.   Lock;
  756.   try
  757.     Result := '';
  758.     if FSocket = INVALID_SOCKET then Exit;
  759.     if gethostname(LocalName, SizeOf(LocalName)) = 0 then
  760.       Result := LocalName;
  761.   finally
  762.     Unlock;
  763.   end;
  764. end;
  765.  
  766. function TCustomWinSocket.GetLocalPort: Integer;
  767. var
  768.   SockAddrIn: TSockAddrIn;
  769.   Size: Integer;
  770. begin
  771.   Lock;
  772.   try
  773.     Result := -1;
  774.     if FSocket = INVALID_SOCKET then Exit;
  775.     Size := SizeOf(SockAddrIn);
  776.     if getsockname(FSocket, SockAddrIn, Size) = 0 then
  777.       Result := ntohs(SockAddrIn.sin_port);
  778.   finally
  779.     Unlock;
  780.   end;
  781. end;
  782.  
  783. function TCustomWinSocket.GetRemoteHost: string;
  784. var
  785.   SockAddrIn: TSockAddrIn;
  786.   Size: Integer;
  787.   HostEnt: PHostEnt;
  788. begin
  789.   Lock;
  790.   try
  791.     Result := '';
  792.     if not FConnected then Exit;
  793.     Size := SizeOf(SockAddrIn);
  794.     CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
  795.     HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.s_addr, 4, PF_INET);
  796.     if HostEnt <> nil then Result := HostEnt.h_name;
  797.   finally
  798.     Unlock;
  799.   end;
  800. end;
  801.  
  802. function TCustomWinSocket.GetRemoteAddress: string;
  803. var
  804.   SockAddrIn: TSockAddrIn;
  805.   Size: Integer;
  806. begin
  807.   Lock;
  808.   try
  809.     Result := '';
  810.     if not FConnected then Exit;
  811.     Size := SizeOf(SockAddrIn);
  812.     CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
  813.     Result := inet_ntoa(SockAddrIn.sin_addr);
  814.   finally
  815.     Unlock;
  816.   end;
  817. end;
  818.  
  819. function TCustomWinSocket.GetRemotePort: Integer;
  820. var
  821.   SockAddrIn: TSockAddrIn;
  822.   Size: Integer;
  823. begin
  824.   Lock;
  825.   try
  826.     Result := 0;
  827.     if not FConnected then Exit;
  828.     Size := SizeOf(SockAddrIn);
  829.     CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
  830.     Result := ntohs(SockAddrIn.sin_port);
  831.   finally
  832.     Unlock;
  833.   end;
  834. end;
  835.  
  836. function TCustomWinSocket.GetRemoteAddr: TSockAddrIn;
  837. var
  838.   Size: Integer;
  839. begin
  840.   Lock;
  841.   try
  842.     FillChar(Result, SizeOf(Result), 0);
  843.     if not FConnected then Exit;
  844.     Size := SizeOf(Result);
  845.     if getpeername(FSocket, Result, Size) <> 0 then
  846.       FillChar(Result, SizeOf(Result), 0);
  847.   finally
  848.     Unlock;
  849.   end;
  850. end;
  851.  
  852. function TCustomWinSocket.LookupName(const Name: string): TInAddr;
  853. var
  854.   HostEnt: PHostEnt;
  855.   InAddr: TInAddr;
  856. begin
  857.   HostEnt := gethostbyname(PChar(Name));
  858.   FillChar(InAddr, SizeOf(InAddr), 0);
  859.   if HostEnt <> nil then
  860.   begin
  861.     with InAddr, HostEnt^ do
  862.     begin
  863.       S_un_b.s_b1 := h_addr^[0];
  864.       S_un_b.s_b2 := h_addr^[1];
  865.       S_un_b.s_b3 := h_addr^[2];
  866.       S_un_b.s_b4 := h_addr^[3];
  867.     end;
  868.   end;
  869.   Result := InAddr;
  870. end;
  871.  
  872. function TCustomWinSocket.LookupService(const Service: string): Integer;
  873. var
  874.   ServEnt: PServEnt;
  875. begin
  876.   ServEnt := getservbyname(PChar(Service), 'tcp');
  877.   if ServEnt <> nil then
  878.     Result := ntohs(ServEnt.s_port)
  879.   else Result := 0;
  880. end;
  881.  
  882. function TCustomWinSocket.InitSocket(const Name, Address, Service: string; Port: Word;
  883.   Client: Boolean): TSockAddrIn;
  884. begin
  885.   Result.sin_family := PF_INET;
  886.   if Name <> '' then
  887.     Result.sin_addr := LookupName(name)
  888.   else if Address <> '' then
  889.     Result.sin_addr.s_addr := inet_addr(PChar(Address))
  890.   else if not Client then
  891.     Result.sin_addr.s_addr := INADDR_ANY
  892.   else raise ESocketError.CreateRes(@sNoAddress);
  893.   if Service <> '' then
  894.     Result.sin_port := htons(LookupService(Service))
  895.   else
  896.     Result.sin_port := htons(Port);
  897. end;
  898.  
  899. procedure TCustomWinSocket.Listen(const Name, Address, Service: string; Port: Word;
  900.   QueueSize: Integer; Block: Boolean);
  901. begin
  902.   if FConnected then raise ESocketError.CreateRes(@sCannotListenOnOpen);
  903.   FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
  904.   if FSocket = INVALID_SOCKET then raise ESocketError.CreateRes(@sCannotCreateSocket);
  905.   try
  906.     Event(Self, seLookUp);
  907.     if Block then
  908.     begin
  909.       FAddr := InitSocket(Name, Address, Service, Port, False);
  910.       DoListen(QueueSize);
  911.     end else
  912.       AsyncInitSocket(Name, Address, Service, Port, QueueSize, False);
  913.   except
  914.     Disconnect(FSocket);
  915.     raise;
  916.   end;
  917. end;
  918.  
  919. procedure TCustomWinSocket.Open(const Name, Address, Service: string; Port: Word; Block: Boolean);
  920. begin
  921.   if FConnected then raise ESocketError.CreateRes(@sSocketAlreadyOpen);
  922.   FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
  923.   if FSocket = INVALID_SOCKET then raise ESocketError.CreateRes(@sCannotCreateSocket);
  924.   try
  925.     Event(Self, seLookUp);
  926.     if Block then
  927.     begin
  928.       FAddr := InitSocket(Name, Address, Service, Port, True);
  929.       DoOpen;
  930.     end else
  931.       AsyncInitSocket(Name, Address, Service, Port, 0, True);
  932.   except
  933.     Disconnect(FSocket);
  934.     raise;
  935.   end;
  936. end;
  937.  
  938. procedure TCustomWinSocket.Disconnect(Socket: TSocket);
  939. begin
  940.   Lock;
  941.   try
  942.     if FLookupHandle <> 0 then
  943.       CheckSocketResult(WSACancelASyncRequest(FLookupHandle), 'WSACancelASyncRequest');
  944.     FLookupHandle := 0;
  945.     if (Socket = INVALID_SOCKET) or (Socket <> FSocket) then exit;
  946.     Event(Self, seDisconnect);
  947.     CheckSocketResult(closesocket(FSocket), 'closesocket');
  948.     FSocket := INVALID_SOCKET;
  949.     FAddr.sin_family := PF_INET;
  950.     FAddr.sin_addr.s_addr := INADDR_ANY;
  951.     FAddr.sin_port := 0;
  952.     FConnected := False;
  953.     FreeAndNil(FSendStream);
  954.   finally
  955.     Unlock;
  956.   end;
  957. end;
  958.  
  959. procedure TCustomWinSocket.DefaultHandler(var Message);
  960. begin
  961.   with TMessage(Message) do
  962.     if FHandle <> 0 then
  963.       Result := CallWindowProc(@DefWindowProc, FHandle, Msg, wParam, lParam);
  964. end;
  965.  
  966. procedure TCustomWinSocket.Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
  967. begin
  968.   if Assigned(FOnSocketEvent) then FOnSocketEvent(Self, Socket, SocketEvent);
  969. end;
  970.  
  971. procedure TCustomWinSocket.Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  972.   var ErrorCode: Integer);
  973. begin
  974.   if Assigned(FOnErrorEvent) then FOnErrorEvent(Self, Socket, ErrorEvent, ErrorCode);
  975. end;
  976.  
  977. function TCustomWinSocket.SendText(const s: string): Integer;
  978. begin
  979.   Result := SendBuf(Pointer(S)^, Length(S));
  980. end;
  981.  
  982. function TCustomWinSocket.SendStreamPiece: Boolean;
  983. var
  984.   Buffer: array[0..4095] of Byte;
  985.   StartPos: Integer;
  986.   AmountInBuf: Integer;
  987.   AmountSent: Integer;
  988.   ErrorCode: Integer;
  989.  
  990.   procedure DropStream;
  991.   begin
  992.     if FDropAfterSend then Disconnect(FSocket);
  993.     FDropAfterSend := False;
  994.     FSendStream.Free;
  995.     FSendStream := nil;
  996.   end;
  997.  
  998. begin
  999.   Lock;
  1000.   try
  1001.     Result := False;
  1002.     if FSendStream <> nil then
  1003.     begin
  1004.       if (FSocket = INVALID_SOCKET) or (not FConnected) then exit;
  1005.       while True do
  1006.       begin
  1007.         StartPos := FSendStream.Position;
  1008.         AmountInBuf := FSendStream.Read(Buffer, SizeOf(Buffer));
  1009.         if AmountInBuf > 0 then
  1010.         begin
  1011.           AmountSent := send(FSocket, Buffer, AmountInBuf, 0);
  1012.           if AmountSent = SOCKET_ERROR then
  1013.           begin
  1014.             ErrorCode := WSAGetLastError;
  1015.             if ErrorCode <> WSAEWOULDBLOCK then
  1016.             begin
  1017.               Error(Self, eeSend, ErrorCode);
  1018.               Disconnect(FSocket);
  1019.               DropStream;
  1020.               if FAsyncStyles <> [] then Abort;
  1021.               Break;
  1022.             end else
  1023.             begin
  1024.               FSendStream.Position := StartPos;
  1025.               Break;
  1026.             end;
  1027.           end else if AmountInBuf > AmountSent then
  1028.             FSendStream.Position := StartPos + AmountSent
  1029.           else if FSendStream.Position = FSendStream.Size then
  1030.           begin
  1031.             DropStream;
  1032.             Break;
  1033.           end;
  1034.         end else
  1035.         begin
  1036.           DropStream;
  1037.           Break;
  1038.         end;
  1039.       end;
  1040.       Result := True;
  1041.     end;
  1042.   finally
  1043.     Unlock;
  1044.   end;
  1045. end;
  1046.  
  1047. function TCustomWinSocket.SendStream(AStream: TStream): Boolean;
  1048. begin
  1049.   Result := False;
  1050.   if FSendStream = nil then
  1051.   begin
  1052.     FSendStream := AStream;
  1053.     Result := SendStreamPiece;
  1054.   end;
  1055. end;
  1056.  
  1057. function TCustomWinSocket.SendStreamThenDrop(AStream: TStream): Boolean;
  1058. begin
  1059.   FDropAfterSend := True;
  1060.   Result := SendStream(AStream);
  1061.   if not Result then FDropAfterSend := False;
  1062. end;
  1063.  
  1064. function TCustomWinSocket.SendBuf(var Buf; Count: Integer): Integer;
  1065. var
  1066.   ErrorCode: Integer;
  1067. begin
  1068.   Lock;
  1069.   try
  1070.     Result := 0;
  1071.     if not FConnected then Exit;
  1072.     Result := send(FSocket, Buf, Count, 0);
  1073.     if Result = SOCKET_ERROR then
  1074.     begin
  1075.       ErrorCode := WSAGetLastError;
  1076.       if (ErrorCode <> WSAEWOULDBLOCK) then
  1077.       begin
  1078.         Error(Self, eeSend, ErrorCode);
  1079.         Disconnect(FSocket);
  1080.         if ErrorCode <> 0 then
  1081.           raise ESocketError.CreateResFmt(@sWindowsSocketError,
  1082.             [SysErrorMessage(ErrorCode), ErrorCode, 'send']);
  1083.       end;
  1084.     end;
  1085.   finally
  1086.     Unlock;
  1087.   end;
  1088. end;
  1089.  
  1090. procedure TCustomWinSocket.SetAsyncStyles(Value: TASyncStyles);
  1091. begin
  1092.   if Value <> FASyncStyles then
  1093.   begin
  1094.     FASyncStyles := Value;
  1095.     if FSocket <> INVALID_SOCKET then
  1096.       DoSetAsyncStyles;
  1097.   end;
  1098. end;
  1099.  
  1100. procedure TCustomWinSocket.Read(Socket: TSocket);
  1101. begin
  1102.   if (FSocket = INVALID_SOCKET) or (Socket <> FSocket) then Exit;
  1103.   Event(Self, seRead);
  1104. end;
  1105.  
  1106. function TCustomWinSocket.ReceiveBuf(var Buf; Count: Integer): Integer;
  1107. var
  1108.   ErrorCode: Integer;
  1109. begin
  1110.   Lock;
  1111.   try
  1112.     Result := 0;
  1113.     if (Count = -1) and FConnected then
  1114.       ioctlsocket(FSocket, FIONREAD, Longint(Result))
  1115.     else begin
  1116.       if not FConnected then Exit;
  1117.       Result := recv(FSocket, Buf, Count, 0);
  1118.       if Result = SOCKET_ERROR then
  1119.       begin
  1120.         ErrorCode := WSAGetLastError;
  1121.         if ErrorCode <> WSAEWOULDBLOCK then
  1122.         begin
  1123.           Error(Self, eeReceive, ErrorCode);
  1124.           Disconnect(FSocket);
  1125.           if ErrorCode <> 0 then
  1126.             raise ESocketError.CreateResFmt(@sWindowsSocketError,
  1127.               [SysErrorMessage(ErrorCode), ErrorCode, 'recv']);
  1128.         end;
  1129.       end;
  1130.     end;
  1131.   finally
  1132.     Unlock;
  1133.   end;
  1134. end;
  1135.  
  1136. function TCustomWinSocket.ReceiveLength: Integer;
  1137. begin
  1138.   Result := ReceiveBuf(Pointer(nil)^, -1);
  1139. end;
  1140.  
  1141. function TCustomWinSocket.ReceiveText: string;
  1142. begin
  1143.   SetLength(Result, ReceiveBuf(Pointer(nil)^, -1));
  1144.   SetLength(Result, ReceiveBuf(Pointer(Result)^, Length(Result)));
  1145. end;
  1146.  
  1147. procedure TCustomWinSocket.WndProc(var Message: TMessage);
  1148. begin
  1149.   try
  1150.     Dispatch(Message);
  1151.   except
  1152.     Application.HandleException(Self);
  1153.   end;
  1154. end;
  1155.  
  1156. procedure TCustomWinSocket.Write(Socket: TSocket);
  1157. begin
  1158.   if (FSocket = INVALID_SOCKET) or (Socket <> FSocket) then Exit;
  1159.   if not SendStreamPiece then Event(Self, seWrite);
  1160. end;
  1161.  
  1162. procedure TCustomWinSocket.CMLookupComplete(var Message: TCMLookupComplete);
  1163. begin
  1164.   if Message.LookupHandle = FLookupHandle then
  1165.   begin
  1166.     FLookupHandle := 0;
  1167.     if Message.AsyncError <> 0 then
  1168.     begin
  1169.       Disconnect(FSocket);
  1170.       raise ESocketError.CreateResFmt(@sWindowsSocketError,
  1171.         [SysErrorMessage(Message.AsyncError), Message.ASyncError, 'ASync Lookup']);
  1172.     end;
  1173.     if FLookupState = lsLookupAddress then
  1174.     begin
  1175.       FAddr.sin_addr.S_addr := Integer(Pointer(PHostEnt(FGetHostData).h_addr^)^);
  1176.       ASyncInitSocket('', '', FService, FPort, FQueueSize, FClient);
  1177.     end else if FLookupState = lsLookupService then
  1178.     begin
  1179.       FAddr.sin_port := PServEnt(FGetHostData).s_port;
  1180.       FPort := 0;
  1181.       FService := '';
  1182.       ASyncInitSocket('', '', '', 0, FQueueSize, FClient);
  1183.     end;
  1184.   end;
  1185. end;
  1186.  
  1187. { TClientWinSocket }
  1188.  
  1189. procedure TClientWinSocket.Connect(Socket: TSocket);
  1190. begin
  1191.   FConnected := True;
  1192.   Event(Self, seConnect);
  1193. end;
  1194.  
  1195. procedure TClientWinSocket.SetClientType(Value: TClientType);
  1196. begin
  1197.   if Value <> FClientType then
  1198.     if not FConnected then
  1199.     begin
  1200.       FClientType := Value;
  1201.       if FClientType = ctBlocking then
  1202.         ASyncStyles := []
  1203.       else ASyncStyles := [asRead, asWrite, asConnect, asClose];
  1204.     end else raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1205. end;
  1206.  
  1207. { TServerClientWinsocket }
  1208.  
  1209. constructor TServerClientWinSocket.Create(Socket: TSocket; ServerWinSocket: TServerWinSocket);
  1210. begin
  1211.   FServerWinSocket := ServerWinSocket;
  1212.   if Assigned(FServerWinSocket) then
  1213.   begin
  1214.     FServerWinSocket.AddClient(Self);
  1215.     if FServerWinSocket.AsyncStyles <> [] then
  1216.     begin
  1217.       OnSocketEvent := FServerWinSocket.ClientEvent;
  1218.       OnErrorEvent := FServerWinSocket.ClientError;
  1219.     end;
  1220.   end;
  1221.   inherited Create(Socket);
  1222.   if FServerWinSocket.ASyncStyles <> [] then DoSetAsyncStyles;
  1223.   if FConnected then Event(Self, seConnect);
  1224. end;
  1225.  
  1226. destructor TServerClientWinSocket.Destroy;
  1227. begin
  1228.   if Assigned(FServerWinSocket) then
  1229.     FServerWinSocket.RemoveClient(Self);
  1230.   inherited Destroy;
  1231. end;
  1232.  
  1233. { TServerWinSocket }
  1234.  
  1235. constructor TServerWinSocket.Create(ASocket: TSocket);
  1236. begin
  1237.   FConnections := TList.Create;
  1238.   FActiveThreads := TList.Create;
  1239.   FListLock := TCriticalSection.Create;
  1240.   inherited Create(ASocket);
  1241.   FAsyncStyles := [asAccept];
  1242. end;
  1243.  
  1244. destructor TServerWinSocket.Destroy;
  1245. begin
  1246.   inherited Destroy;
  1247.   FConnections.Free;
  1248.   FActiveThreads.Free;
  1249.   FListLock.Free;
  1250. end;
  1251.  
  1252. procedure TServerWinSocket.AddClient(AClient: TServerClientWinSocket);
  1253. begin
  1254.   FListLock.Enter;
  1255.   try
  1256.     if FConnections.IndexOf(AClient) < 0 then
  1257.       FConnections.Add(AClient);
  1258.   finally
  1259.     FListLock.Leave;
  1260.   end;
  1261. end;
  1262.  
  1263. procedure TServerWinSocket.RemoveClient(AClient: TServerClientWinSocket);
  1264. begin
  1265.   FListLock.Enter;
  1266.   try
  1267.     FConnections.Remove(AClient);
  1268.   finally
  1269.     FListLock.Leave;
  1270.   end;
  1271. end;
  1272.  
  1273. procedure TServerWinSocket.AddThread(AThread: TServerClientThread);
  1274. begin
  1275.   FListLock.Enter;
  1276.   try
  1277.     if FActiveThreads.IndexOf(AThread) < 0 then
  1278.     begin
  1279.       FActiveThreads.Add(AThread);
  1280.       if FActiveThreads.Count <= FThreadCacheSize then
  1281.         AThread.KeepInCache := True;
  1282.     end;
  1283.   finally
  1284.     FListLock.Leave;
  1285.   end;
  1286. end;
  1287.  
  1288. procedure TServerWinSocket.RemoveThread(AThread: TServerClientThread);
  1289. begin
  1290.   FListLock.Enter;
  1291.   try
  1292.     FActiveThreads.Remove(AThread);
  1293.   finally
  1294.     FListLock.Leave;
  1295.   end;
  1296. end;
  1297.  
  1298. procedure TServerWinSocket.ClientEvent(Sender: TObject; Socket: TCustomWinSocket;
  1299.   SocketEvent: TSocketEvent);
  1300. begin
  1301.   case SocketEvent of
  1302.     seAccept,
  1303.     seLookup,
  1304.     seConnecting,
  1305.     seListen:
  1306.       begin end;
  1307.     seConnect: ClientConnect(Socket);
  1308.     seDisconnect: ClientDisconnect(Socket);
  1309.     seRead: ClientRead(Socket);
  1310.     seWrite: ClientWrite(Socket);
  1311.   end;
  1312. end;
  1313.  
  1314. procedure TServerWinSocket.ClientError(Sender: TObject; Socket: TCustomWinSocket;
  1315.   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1316. begin
  1317.   ClientErrorEvent(Socket, ErrorEvent, ErrorCode);
  1318. end;
  1319.  
  1320. function TServerWinSocket.GetActiveConnections: Integer;
  1321. begin
  1322.   Result := FConnections.Count;
  1323. end;
  1324.  
  1325. function TServerWinSocket.GetConnections(Index: Integer): TCustomWinSocket;
  1326. begin
  1327.   Result := FConnections[Index];
  1328. end;
  1329.  
  1330. function TServerWinSocket.GetActiveThreads: Integer;
  1331. var
  1332.   I: Integer;
  1333. begin
  1334.   FListLock.Enter;
  1335.   try
  1336.     Result := 0;
  1337.     for I := 0 to FActiveThreads.Count - 1 do
  1338.       if TServerClientThread(FActiveThreads[I]).ClientSocket <> nil then
  1339.         Inc(Result);
  1340.   finally
  1341.     FListLock.Leave;
  1342.   end;
  1343. end;
  1344.  
  1345. function TServerWinSocket.GetIdleThreads: Integer;
  1346. var
  1347.   I: Integer;
  1348. begin
  1349.   FListLock.Enter;
  1350.   try
  1351.     Result := 0;
  1352.     for I := 0 to FActiveThreads.Count - 1 do
  1353.       if TServerClientThread(FActiveThreads[I]).ClientSocket = nil then
  1354.         Inc(Result);
  1355.   finally
  1356.     FListLock.Leave;
  1357.   end;
  1358. end;
  1359.  
  1360. procedure TServerWinSocket.Accept(Socket: TSocket);
  1361. var
  1362.   ClientSocket: TServerClientWinSocket;
  1363.   ClientWinSocket: TSocket;
  1364.   Addr: TSockAddrIn;
  1365.   Len: Integer;
  1366.   OldOpenType, NewOpenType: Integer;
  1367. begin
  1368.   Len := SizeOf(OldOpenType);
  1369.   if getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType),
  1370.     Len) = 0 then
  1371.   try
  1372.     if FServerType = stThreadBlocking then
  1373.     begin
  1374.       NewOpenType := SO_SYNCHRONOUS_NONALERT;
  1375.       setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@NewOpenType), Len);
  1376.     end;
  1377.     Len := SizeOf(Addr);
  1378.     ClientWinSocket := WinSock.accept(Socket, @Addr, @Len);
  1379.     if ClientWinSocket <> INVALID_SOCKET then
  1380.     begin
  1381.       ClientSocket := GetClientSocket(ClientWinSocket);
  1382.       if Assigned(FOnSocketEvent) then
  1383.         FOnSocketEvent(Self, ClientSocket, seAccept);
  1384.       if FServerType = stThreadBlocking then
  1385.       begin
  1386.         ClientSocket.ASyncStyles := [];
  1387.         GetServerThread(ClientSocket);
  1388.       end;
  1389.     end;
  1390.   finally
  1391.     Len := SizeOf(OldOpenType);
  1392.     setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType), Len);
  1393.   end;
  1394. end;
  1395.  
  1396. procedure TServerWinSocket.Disconnect(Socket: TSocket);
  1397. var
  1398.   SaveCacheSize: Integer;
  1399. begin
  1400.   Lock;
  1401.   try
  1402.     SaveCacheSize := ThreadCacheSize;
  1403.     try
  1404.       ThreadCacheSize := 0;
  1405.       while FActiveThreads.Count > 0 do
  1406.         with TServerClientThread(FActiveThreads.Last) do
  1407.         begin
  1408.           FreeOnTerminate := False;
  1409.           Terminate;
  1410.           FEvent.SetEvent;
  1411.           if (ClientSocket <> nil) and ClientSocket.Connected then
  1412.             ClientSocket.Close;
  1413.           WaitFor;  
  1414.           Free;
  1415.         end;
  1416.       while FConnections.Count > 0 do
  1417.         TCustomWinSocket(FConnections.Last).Free;
  1418.       if FServerAcceptThread <> nil then
  1419.         FServerAcceptThread.Terminate;
  1420.       inherited Disconnect(Socket);
  1421.       FServerAcceptThread.Free;
  1422.       FServerAcceptThread := nil;
  1423.     finally
  1424.       ThreadCacheSize := SaveCacheSize;
  1425.     end;
  1426.   finally
  1427.     Unlock;
  1428.   end;
  1429. end;
  1430.  
  1431. function TServerWinSocket.DoCreateThread(ClientSocket: TServerClientWinSocket): TServerClientThread;
  1432. begin
  1433.   Result := TServerClientThread.Create(False, ClientSocket);
  1434. end;
  1435.  
  1436. procedure TServerWinSocket.Listen(var Name, Address, Service: string; Port: Word;
  1437.   QueueSize: Integer);
  1438. begin
  1439.   inherited Listen(Name, Address, Service, Port, QueueSize, ServerType = stThreadBlocking);
  1440.   if FConnected and (ServerType = stThreadBlocking) then
  1441.     FServerAcceptThread := TServerAcceptThread.Create(False, Self);
  1442. end;
  1443.  
  1444. procedure TServerWinSocket.SetServerType(Value: TServerType);
  1445. begin
  1446.   if Value <> FServerType then
  1447.     if not FConnected then
  1448.     begin
  1449.       FServerType := Value;
  1450.       if FServerType = stThreadBlocking then
  1451.         ASyncStyles := []
  1452.       else ASyncStyles := [asAccept];
  1453.     end else raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1454. end;
  1455.  
  1456. procedure TServerWinSocket.SetThreadCacheSize(Value: Integer);
  1457. var
  1458.   Start, I: Integer;
  1459. begin
  1460.   if Value <> FThreadCacheSize then
  1461.   begin
  1462.     if Value < FThreadCacheSize then
  1463.       Start := Value
  1464.     else Start := FThreadCacheSize;
  1465.     FThreadCacheSize := Value;
  1466.     FListLock.Enter;
  1467.     try
  1468.       for I := 0 to FActiveThreads.Count - 1 do
  1469.         with TServerClientThread(FActiveThreads[I]) do
  1470.           KeepInCache := I < Start;
  1471.     finally
  1472.       FListLock.Leave;
  1473.     end;
  1474.   end;
  1475. end;
  1476.  
  1477. function TServerWinSocket.GetClientSocket(Socket: TSocket): TServerClientWinSocket;
  1478. begin
  1479.   Result := nil;
  1480.   if Assigned(FOnGetSocket) then FOnGetSocket(Self, Socket, Result);
  1481.   if Result = nil then
  1482.     Result := TServerClientWinSocket.Create(Socket, Self);
  1483. end;
  1484.  
  1485. procedure TServerWinSocket.ThreadEnd(AThread: TServerClientThread);
  1486. begin
  1487.   if Assigned(FOnThreadEnd) then FOnThreadEnd(Self, AThread);
  1488. end;
  1489.  
  1490. procedure TServerWinSocket.ThreadStart(AThread: TServerClientThread);
  1491. begin
  1492.   if Assigned(FOnThreadStart) then FOnThreadStart(Self, AThread);
  1493. end;
  1494.  
  1495. function TServerWinSocket.GetServerThread(ClientSocket: TServerClientWinSocket): TServerClientThread;
  1496. var
  1497.   I: Integer;
  1498. begin
  1499.   Result := nil;
  1500.   FListLock.Enter;
  1501.   try
  1502.     for I := 0 to FActiveThreads.Count - 1 do
  1503.       if TServerClientThread(FActiveThreads[I]).ClientSocket = nil then
  1504.       begin
  1505.         Result := FActiveThreads[I];
  1506.         Result.ReActivate(ClientSocket);
  1507.         Break;
  1508.       end;
  1509.   finally
  1510.     FListLock.Leave;
  1511.   end;
  1512.   if Result = nil then
  1513.   begin
  1514.     if Assigned(FOnGetThread) then FOnGetThread(Self, ClientSocket, Result);
  1515.     if Result = nil then Result := DoCreateThread(ClientSocket);
  1516.   end;
  1517. end;
  1518.  
  1519. function TServerWinSocket.GetClientThread(ClientSocket: TServerClientWinSocket): TServerClientThread;
  1520. var
  1521.   I: Integer;
  1522. begin
  1523.   Result := nil;
  1524.   FListLock.Enter;
  1525.   try
  1526.     for I := 0 to FActiveThreads.Count - 1 do
  1527.       if TServerClientThread(FActiveThreads[I]).ClientSocket = ClientSocket then
  1528.       begin
  1529.         Result := FActiveThreads[I];
  1530.         Break;
  1531.       end;
  1532.   finally
  1533.     FListLock.Leave;
  1534.   end;
  1535. end;
  1536.  
  1537. procedure TServerWinSocket.ClientConnect(Socket: TCustomWinSocket);
  1538. begin
  1539.   if Assigned(FOnClientConnect) then FOnClientConnect(Self, Socket);
  1540. end;
  1541.  
  1542. procedure TServerWinSocket.ClientDisconnect(Socket: TCustomWinSocket);
  1543. begin
  1544.   if Assigned(FOnClientDisconnect) then FOnClientDisconnect(Self, Socket);
  1545.   if ServerType = stNonBlocking then Socket.DeferFree;
  1546. end;
  1547.  
  1548. procedure TServerWinSocket.ClientRead(Socket: TCustomWinSocket);
  1549. begin
  1550.   if Assigned(FOnClientRead) then FOnClientRead(Self, Socket);
  1551. end;
  1552.  
  1553. procedure TServerWinSocket.ClientWrite(Socket: TCustomWinSocket);
  1554. begin
  1555.   if Assigned(FOnClientWrite) then FOnClientWrite(Self, Socket);
  1556. end;
  1557.  
  1558. procedure TServerWinSocket.ClientErrorEvent(Socket: TCustomWinSocket;
  1559.   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1560. begin
  1561.   if Assigned(FOnClientError) then FOnClientError(Self, Socket, ErrorEvent, ErrorCode);
  1562. end;
  1563.  
  1564. { TServerAcceptThread }
  1565.  
  1566. constructor TServerAcceptThread.Create(CreateSuspended: Boolean;
  1567.   ASocket: TServerWinSocket);
  1568. begin
  1569.   FServerSocket := ASocket;
  1570.   inherited Create(CreateSuspended);
  1571. end;
  1572.  
  1573. procedure TServerAcceptThread.Execute;
  1574. begin
  1575.   while not Terminated do
  1576.     FServerSocket.Accept(FServerSocket.SocketHandle);
  1577. end;
  1578.  
  1579. { TServerClientThread }
  1580.  
  1581. constructor TServerClientThread.Create(CreateSuspended: Boolean;
  1582.   ASocket: TServerClientWinSocket);
  1583. begin
  1584.   FreeOnTerminate := True;
  1585.   FEvent := TSimpleEvent.Create;
  1586.   inherited Create(True);
  1587.   Priority := tpHigher;
  1588.   ReActivate(ASocket);
  1589.   if not CreateSuspended then Resume;
  1590. end;
  1591.  
  1592. destructor TServerClientThread.Destroy;
  1593. begin
  1594.   FClientSocket.Free;
  1595.   FEvent.Free;
  1596.   inherited Destroy;
  1597. end;
  1598.  
  1599. procedure TServerClientThread.ReActivate(ASocket: TServerClientWinSocket);
  1600. begin
  1601.   FClientSocket := ASocket;
  1602.   if Assigned(FClientSocket) then
  1603.   begin
  1604.     FServerSocket := FClientSocket.ServerWinSocket;
  1605.     FServerSocket.AddThread(Self);
  1606.     FClientSocket.OnSocketEvent := HandleEvent;
  1607.     FClientSocket.OnErrorEvent := HandleError;
  1608.     FEvent.SetEvent;
  1609.   end;
  1610. end;
  1611.  
  1612. procedure TServerClientThread.DoHandleException;
  1613. begin
  1614.   if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  1615.   if FException is Exception then
  1616.   begin
  1617.     Application.ShowException(FException);
  1618.   end else
  1619.     SysUtils.ShowException(FException, nil);
  1620. end;
  1621.  
  1622. procedure TServerClientThread.DoRead;
  1623. begin
  1624.   ClientSocket.ServerWinSocket.Event(ClientSocket, seRead);
  1625. end;
  1626.  
  1627. procedure TServerClientThread.DoTerminate;
  1628. begin
  1629.   if Assigned(FServerSocket) then
  1630.     FServerSocket.RemoveThread(Self);
  1631. end;
  1632.  
  1633. procedure TServerClientThread.DoWrite;
  1634. begin
  1635.   FServerSocket.Event(ClientSocket, seWrite);
  1636. end;
  1637.  
  1638. procedure TServerClientThread.HandleEvent(Sender: TObject; Socket: TCustomWinSocket;
  1639.   SocketEvent: TSocketEvent);
  1640. begin
  1641.   Event(SocketEvent);
  1642. end;
  1643.  
  1644. procedure TServerClientThread.HandleError(Sender: TObject; Socket: TCustomWinSocket;
  1645.   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1646. begin
  1647.   Error(ErrorEvent, ErrorCode);
  1648. end;
  1649.  
  1650. procedure TServerClientThread.Event(SocketEvent: TSocketEvent);
  1651. begin
  1652.   FServerSocket.ClientEvent(Self, ClientSocket, SocketEvent);
  1653. end;
  1654.  
  1655. procedure TServerClientThread.Error(ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1656. begin
  1657.   FServerSocket.ClientError(Self, ClientSocket, ErrorEvent, ErrorCode);
  1658. end;
  1659.  
  1660. procedure TServerClientThread.HandleException;
  1661. begin
  1662.   FException := Exception(ExceptObject);
  1663.   try
  1664.     if not (FException is EAbort) then
  1665.       Synchronize(DoHandleException);
  1666.   finally
  1667.     FException := nil;
  1668.   end;
  1669. end;
  1670.  
  1671. procedure TServerClientThread.Execute;
  1672. begin
  1673.   FServerSocket.ThreadStart(Self);
  1674.   try
  1675.     try
  1676.       while True do
  1677.       begin
  1678.         if StartConnect then ClientExecute;
  1679.         if EndConnect then Break;
  1680.       end;
  1681.     except
  1682.       HandleException;
  1683.       KeepInCache := False;
  1684.     end;
  1685.   finally
  1686.     FServerSocket.ThreadEnd(Self);
  1687.   end;
  1688. end;
  1689.  
  1690. procedure TServerClientThread.ClientExecute;
  1691. var
  1692.   FDSet: TFDSet;
  1693.   TimeVal: TTimeVal;
  1694. begin
  1695.   while not Terminated and ClientSocket.Connected do
  1696.   begin
  1697.     FD_ZERO(FDSet);
  1698.     FD_SET(ClientSocket.SocketHandle, FDSet);
  1699.     TimeVal.tv_sec := 0;
  1700.     TimeVal.tv_usec := 500;
  1701.     if (select(0, @FDSet, nil, nil, @TimeVal) > 0) and not Terminated then
  1702.       if ClientSocket.ReceiveBuf(FDSet, -1) = 0 then Break
  1703.       else Synchronize(DoRead);
  1704.     if (select(0, nil, @FDSet, nil, @TimeVal) > 0) and not Terminated then
  1705.       Synchronize(DoWrite);
  1706.   end;
  1707. end;
  1708.  
  1709. function TServerClientThread.StartConnect: Boolean;
  1710. begin
  1711.   if FEvent.WaitFor(INFINITE) = wrSignaled then
  1712.     FEvent.ResetEvent;
  1713.   Result := not Terminated;
  1714. end;
  1715.  
  1716. function TServerClientThread.EndConnect: Boolean;
  1717. begin
  1718.   FClientSocket.Free;
  1719.   FClientSocket := nil;
  1720.   Result := Terminated or not KeepInCache;
  1721. end;
  1722.  
  1723. { TAbstractSocket }
  1724.  
  1725. procedure TAbstractSocket.DoEvent(Sender: TObject; Socket: TCustomWinSocket;
  1726.   SocketEvent: TSocketEvent);
  1727. begin
  1728.   Event(Socket, SocketEvent);
  1729. end;
  1730.  
  1731. procedure TAbstractSocket.DoError(Sender: TObject; Socket: TCustomWinSocket;
  1732.   ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  1733. begin
  1734.   Error(Socket, ErrorEvent, ErrorCode);
  1735. end;
  1736.  
  1737. procedure TAbstractSocket.SetActive(Value: Boolean);
  1738. begin
  1739.   if Value <> FActive then
  1740.   begin
  1741.     if (csDesigning in ComponentState) or (csLoading in ComponentState) then
  1742.       FActive := Value;
  1743.     if not (csLoading in ComponentState) then
  1744.       DoActivate(Value);
  1745.   end;
  1746. end;
  1747.  
  1748. procedure TAbstractSocket.InitSocket(Socket: TCustomWinSocket);
  1749. begin
  1750.   Socket.OnSocketEvent := DoEvent;
  1751.   Socket.OnErrorEvent := DoError;
  1752. end;
  1753.  
  1754. procedure TAbstractSocket.Loaded;
  1755. begin
  1756.   inherited Loaded;
  1757.   DoActivate(FActive);
  1758. end;
  1759.  
  1760. procedure TAbstractSocket.SetAddress(Value: string);
  1761. begin
  1762.   if CompareText(Value, FAddress) <> 0 then
  1763.   begin
  1764.     if not (csLoading in ComponentState) and FActive then
  1765.       raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1766.     FAddress := Value;
  1767.   end;
  1768. end;
  1769.  
  1770. procedure TAbstractSocket.SetHost(Value: string);
  1771. begin
  1772.   if CompareText(Value, FHost) <> 0 then
  1773.   begin
  1774.     if not (csLoading in ComponentState) and FActive then
  1775.       raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1776.     FHost := Value;
  1777.   end;
  1778. end;
  1779.  
  1780. procedure TAbstractSocket.SetPort(Value: Integer);
  1781. begin
  1782.   if FPort <> Value then
  1783.   begin
  1784.     if not (csLoading in ComponentState) and FActive then
  1785.       raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1786.     FPort := Value;
  1787.   end;
  1788. end;
  1789.  
  1790. procedure TAbstractSocket.SetService(Value: string);
  1791. begin
  1792.   if CompareText(Value, FService) <> 0 then
  1793.   begin
  1794.     if not (csLoading in ComponentState) and FActive then
  1795.       raise ESocketError.CreateRes(@sCantChangeWhileActive);
  1796.     FService := Value;
  1797.   end;
  1798. end;
  1799.  
  1800. procedure TAbstractSocket.Open;
  1801. begin
  1802.   Active := True;
  1803. end;
  1804.  
  1805. procedure TAbstractSocket.Close;
  1806. begin
  1807.   Active := False;
  1808. end;
  1809.  
  1810. { TCustomSocket }
  1811.  
  1812. procedure TCustomSocket.Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
  1813. begin
  1814.   case SocketEvent of
  1815.     seLookup: if Assigned(FOnLookup) then FOnLookup(Self, Socket);
  1816.     seConnecting: if Assigned(FOnConnecting) then FOnConnecting(Self, Socket);
  1817.     seConnect:
  1818.       begin
  1819.         FActive := True;
  1820.         if Assigned(FOnConnect) then FOnConnect(Self, Socket);
  1821.       end;
  1822.     seListen:
  1823.       begin
  1824.         FActive := True;
  1825.         if Assigned(FOnListen) then FOnListen(Self, Socket);
  1826.       end;
  1827.     seDisconnect:
  1828.       begin
  1829.         FActive := False;
  1830.         if Assigned(FOnDisconnect) then FOnDisconnect(Self, Socket);
  1831.       end;
  1832.     seAccept: if Assigned(FOnAccept) then FOnAccept(Self, Socket);
  1833.     seRead: if Assigned(FOnRead) then FOnRead(Self, Socket);
  1834.     seWrite: if Assigned(FOnWrite) then FOnWrite(Self, Socket);
  1835.   end;
  1836. end;
  1837.  
  1838. procedure TCustomSocket.Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  1839.   var ErrorCode: Integer);
  1840. begin
  1841.   if Assigned(FOnError) then FOnError(Self, Socket, ErrorEvent, ErrorCode);
  1842. end;
  1843.  
  1844. { TWinSocketStream }
  1845.  
  1846. constructor TWinSocketStream.Create(ASocket: TCustomWinSocket; TimeOut: Longint);
  1847. begin
  1848.   if ASocket.ASyncStyles <> [] then
  1849.     raise ESocketError.CreateRes(@sSocketMustBeBlocking);
  1850.   FSocket := ASocket;
  1851.   FTimeOut := TimeOut;
  1852.   FEvent := TSimpleEvent.Create;
  1853.   inherited Create;
  1854. end;
  1855.  
  1856. destructor TWinSocketStream.Destroy;
  1857. begin
  1858.   FEvent.Free;
  1859.   inherited Destroy;
  1860. end;
  1861.  
  1862. function TWinSocketStream.WaitForData(Timeout: Longint): Boolean;
  1863. var
  1864.   FDSet: TFDSet;
  1865.   TimeVal: TTimeVal;
  1866. begin
  1867.   TimeVal.tv_sec := Timeout div 1000;
  1868.   TimeVal.tv_usec := (Timeout mod 1000) * 1000;
  1869.   FD_ZERO(FDSet);
  1870.   FD_SET(FSocket.SocketHandle, FDSet);
  1871.   Result := select(0, @FDSet, nil, nil, @TimeVal) > 0;
  1872. end;
  1873.  
  1874. function TWinSocketStream.Read(var Buffer; Count: Longint): Longint;
  1875. var
  1876.   Overlapped: TOverlapped;
  1877.   ErrorCode: Integer;
  1878. begin
  1879.   FSocket.Lock;
  1880.   try
  1881.     FillChar(OVerlapped, SizeOf(Overlapped), 0);
  1882.     Overlapped.hEvent := FEvent.Handle;
  1883.     if not ReadFile(FSocket.SocketHandle, Buffer, Count, DWORD(Result),
  1884.       @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
  1885.     begin
  1886.       ErrorCode := GetLastError;
  1887.       raise ESocketError.CreateResFmt(@sSocketIOError, [sSocketRead, ErrorCode,
  1888.         SysErrorMessage(ErrorCode)]);
  1889.     end;
  1890.     if FEvent.WaitFor(FTimeOut) <> wrSignaled then
  1891.       Result := 0
  1892.     else
  1893.     begin
  1894.       GetOverlappedResult(FSocket.SocketHandle, Overlapped, DWORD(Result), False);
  1895.       FEvent.ResetEvent;
  1896.     end;
  1897.   finally
  1898.     FSocket.Unlock;
  1899.   end;
  1900. end;
  1901.  
  1902. function TWinSocketStream.Write(const Buffer; Count: Longint): Longint;
  1903. var
  1904.   Overlapped: TOverlapped;
  1905.   ErrorCode: Integer;
  1906. begin
  1907.   FSocket.Lock;
  1908.   try
  1909.     FillChar(OVerlapped, SizeOf(Overlapped), 0);
  1910.     Overlapped.hEvent := FEvent.Handle;
  1911.     if not WriteFile(FSocket.SocketHandle, Buffer, Count, DWORD(Result),
  1912.       @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
  1913.     begin
  1914.       ErrorCode := GetLastError;
  1915.       raise ESocketError.CreateResFmt(@sSocketIOError, [sSocketWrite, ErrorCode,
  1916.         SysErrorMessage(ErrorCode)]);
  1917.     end;
  1918.     if FEvent.WaitFor(FTimeOut) <> wrSignaled then
  1919.       Result := 0
  1920.     else GetOverlappedResult(FSocket.SocketHandle, Overlapped, DWORD(Result), False);
  1921.   finally
  1922.     FSocket.Unlock;
  1923.   end;
  1924. end;
  1925.  
  1926. function TWinSocketStream.Seek(Offset: Longint; Origin: Word): Longint;
  1927. begin
  1928.   Result := 0;
  1929. end;
  1930.  
  1931. { TClientSocket }
  1932.  
  1933. constructor TClientSocket.Create(AOwner: TComponent);
  1934. begin
  1935.   inherited Create(AOwner);
  1936.   FClientSocket := TClientWinSocket.Create(INVALID_SOCKET);
  1937.   InitSocket(FClientSocket);
  1938. end;
  1939.  
  1940. destructor TClientSocket.Destroy;
  1941. begin
  1942.   FClientSocket.Free;
  1943.   inherited Destroy;
  1944. end;
  1945.  
  1946. procedure TClientSocket.DoActivate(Value: Boolean);
  1947. begin
  1948.   if (Value <> FClientSocket.Connected) and not (csDesigning in ComponentState) then
  1949.   begin
  1950.     if FClientSocket.Connected then
  1951.       FClientSocket.Disconnect(FClientSocket.FSocket)
  1952.     else FClientSocket.Open(FHost, FAddress, FService, FPort, ClientType = ctBlocking);
  1953.   end;
  1954. end;
  1955.  
  1956. function TClientSocket.GetClientType: TClientType;
  1957. begin
  1958.   Result := FClientSocket.ClientType;
  1959. end;
  1960.  
  1961. procedure TClientSocket.SetClientType(Value: TClientType);
  1962. begin
  1963.   FClientSocket.ClientType := Value;
  1964. end;
  1965.  
  1966. { TCustomServerSocket }
  1967.  
  1968. destructor TCustomServerSocket.Destroy;
  1969. begin
  1970.   FServerSocket.Free;
  1971.   inherited Destroy;
  1972. end;
  1973.  
  1974. procedure TCustomServerSocket.DoActivate(Value: Boolean);
  1975. begin
  1976.   if (Value <> FServerSocket.Connected) and not (csDesigning in ComponentState) then
  1977.   begin
  1978.     if FServerSocket.Connected then
  1979.       FServerSocket.Disconnect(FServerSocket.SocketHandle)
  1980.     else FServerSocket.Listen(FHost, FAddress, FService, FPort, SOMAXCONN);
  1981.   end;
  1982. end;
  1983.  
  1984. function TCustomServerSocket.GetServerType: TServerType;
  1985. begin
  1986.   Result := FServerSocket.ServerType;
  1987. end;
  1988.  
  1989. procedure TCustomServerSocket.SetServerType(Value: TServerType);
  1990. begin
  1991.   FServerSocket.ServerType := Value;
  1992. end;
  1993.  
  1994. function TCustomServerSocket.GetGetThreadEvent: TGetThreadEvent;
  1995. begin
  1996.   Result := FServerSocket.OnGetThread;
  1997. end;
  1998.  
  1999. procedure TCustomServerSocket.SetGetThreadEvent(Value: TGetThreadEvent);
  2000. begin
  2001.   FServerSocket.OnGetThread := Value;
  2002. end;
  2003.  
  2004. function TCustomServerSocket.GetGetSocketEvent: TGetSocketEvent;
  2005. begin
  2006.   Result := FServerSocket.OnGetSocket;
  2007. end;
  2008.  
  2009. procedure TCustomServerSocket.SetGetSocketEvent(Value: TGetSocketEvent);
  2010. begin
  2011.   FServerSocket.OnGetSocket := Value;
  2012. end;
  2013.  
  2014. function TCustomServerSocket.GetThreadCacheSize: Integer;
  2015. begin
  2016.   Result := FServerSocket.ThreadCacheSize;
  2017. end;
  2018.  
  2019. procedure TCustomServerSocket.SetThreadCacheSize(Value: Integer);
  2020. begin
  2021.   FServerSocket.ThreadCacheSize := Value;
  2022. end;
  2023.  
  2024. function TCustomServerSocket.GetOnThreadStart: TThreadNotifyEvent;
  2025. begin
  2026.   Result := FServerSocket.OnThreadStart;
  2027. end;
  2028.  
  2029. function TCustomServerSocket.GetOnThreadEnd: TThreadNotifyEvent;
  2030. begin
  2031.   Result := FServerSocket.OnThreadEnd;
  2032. end;
  2033.  
  2034. procedure TCustomServerSocket.SetOnThreadStart(Value: TThreadNotifyEvent);
  2035. begin
  2036.   FServerSocket.OnThreadStart := Value;
  2037. end;
  2038.  
  2039. procedure TCustomServerSocket.SetOnThreadEnd(Value: TThreadNotifyEvent);
  2040. begin
  2041.   FServerSocket.OnThreadEnd := Value;
  2042. end;
  2043.  
  2044. function TCustomServerSocket.GetOnClientEvent(Index: Integer): TSocketNotifyEvent;
  2045. begin
  2046.   case Index of
  2047.     0: Result := FServerSocket.OnClientRead;
  2048.     1: Result := FServerSocket.OnClientWrite;
  2049.     2: Result := FServerSocket.OnClientConnect;
  2050.     3: Result := FServerSocket.OnClientDisconnect;
  2051.   end;
  2052. end;
  2053.  
  2054. procedure TCustomServerSocket.SetOnClientEvent(Index: Integer;
  2055.   Value: TSocketNotifyEvent);
  2056. begin
  2057.   case Index of
  2058.     0: FServerSocket.OnClientRead := Value;
  2059.     1: FServerSocket.OnClientWrite := Value;
  2060.     2: FServerSocket.OnClientConnect := Value;
  2061.     3: FServerSocket.OnClientDisconnect := Value;
  2062.   end;
  2063. end;
  2064.  
  2065. function TCustomServerSocket.GetOnClientError: TSocketErrorEvent;
  2066. begin
  2067.   Result := FServerSocket.OnClientError;
  2068. end;
  2069.  
  2070. procedure TCustomServerSocket.SetOnClientError(Value: TSocketErrorEvent);
  2071. begin
  2072.   FServerSocket.OnClientError := Value;
  2073. end;
  2074.  
  2075. { TServerSocket }
  2076.  
  2077. constructor TServerSocket.Create(AOwner: TComponent);
  2078. begin
  2079.   inherited Create(AOwner);
  2080.   FServerSocket := TServerWinSocket.Create(INVALID_SOCKET);
  2081.   InitSocket(FServerSocket);
  2082.   FServerSocket.ThreadCacheSize := 10;
  2083. end;
  2084.  
  2085. end.
  2086.  
  2087.