Guest User

Untitled

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