PageRenderTime 496ms CodeModel.GetById 5ms app.highlight 462ms RepoModel.GetById 1ms app.codeStats 1ms

/blcksock.pas

https://bitbucket.org/bsquared/fpctwit-git
Pascal | 4352 lines | 2990 code | 440 blank | 922 comment | 245 complexity | 8d865df43fcba42ca248a959ffd0b30c MD5 | raw file
   1{==============================================================================|
   2| Project : Ararat Synapse                                       | 009.009.000 |
   3|==============================================================================|
   4| Content: Library base                                                        |
   5|==============================================================================|
   6| Copyright (c)1999-2012, Lukas Gebauer                                        |
   7| All rights reserved.                                                         |
   8|                                                                              |
   9| Redistribution and use in source and binary forms, with or without           |
  10| modification, are permitted provided that the following conditions are met:  |
  11|                                                                              |
  12| Redistributions of source code must retain the above copyright notice, this  |
  13| list of conditions and the following disclaimer.                             |
  14|                                                                              |
  15| Redistributions in binary form must reproduce the above copyright notice,    |
  16| this list of conditions and the following disclaimer in the documentation    |
  17| and/or other materials provided with the distribution.                       |
  18|                                                                              |
  19| Neither the name of Lukas Gebauer nor the names of its contributors may      |
  20| be used to endorse or promote products derived from this software without    |
  21| specific prior written permission.                                           |
  22|                                                                              |
  23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
  24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
  25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
  26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
  27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
  28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
  29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
  30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
  31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
  32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
  33| DAMAGE.                                                                      |
  34|==============================================================================|
  35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36| Portions created by Lukas Gebauer are Copyright (c)1999-2012.                |
  37| All Rights Reserved.                                                         |
  38|==============================================================================|
  39| Contributor(s):                                                              |
  40|==============================================================================|
  41| History: see HISTORY.HTM from distribution package                           |
  42|          (Found at URL: http://www.ararat.cz/synapse/)                       |
  43|==============================================================================}
  44
  45{
  46Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
  47 (Intelicom d.o.o., http://www.intelicom.si)
  48 for good inspiration about SSL programming.
  49}
  50
  51{$DEFINE ONCEWINSOCK}
  52{Note about define ONCEWINSOCK:
  53If you remove this compiler directive, then socket interface is loaded and
  54initialized on constructor of TBlockSocket class for each socket separately.
  55Socket interface is used only if your need it.
  56
  57If you leave this directive here, then socket interface is loaded and
  58initialized only once at start of your program! It boost performace on high
  59count of created and destroyed sockets. It eliminate possible small resource
  60leak on Windows systems too.
  61}
  62
  63//{$DEFINE RAISEEXCEPT}
  64{When you enable this define, then is Raiseexcept property is on by default
  65}
  66
  67{:@abstract(Synapse's library core)
  68
  69Core with implementation basic socket classes.
  70}
  71
  72{$IFDEF FPC}
  73  {$MODE DELPHI}
  74{$ENDIF}
  75{$IFDEF VER125}
  76  {$DEFINE BCB}
  77{$ENDIF}
  78{$IFDEF BCB}
  79  {$ObjExportAll On}
  80{$ENDIF}
  81{$Q-}
  82{$H+}
  83{$M+}
  84{$TYPEDADDRESS OFF}
  85
  86
  87//old Delphi does not have MSWINDOWS define.
  88{$IFDEF WIN32}
  89  {$IFNDEF MSWINDOWS}
  90    {$DEFINE MSWINDOWS}
  91  {$ENDIF}
  92{$ENDIF}
  93
  94{$IFDEF UNICODE}
  95  {$WARN IMPLICIT_STRING_CAST OFF}
  96  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
  97{$ENDIF}
  98
  99unit blcksock;
 100
 101interface
 102
 103uses
 104  SysUtils, Classes,
 105  synafpc,
 106  synsock, synautil, synacode, synaip
 107{$IFDEF CIL}
 108  ,System.Net
 109  ,System.Net.Sockets
 110  ,System.Text
 111{$ENDIF}
 112  ;
 113
 114const
 115
 116  SynapseRelease = '40';
 117
 118  cLocalhost = '127.0.0.1';
 119  cAnyHost = '0.0.0.0';
 120  cBroadcast = '255.255.255.255';
 121  c6Localhost = '::1';
 122  c6AnyHost = '::0';
 123  c6Broadcast = 'ffff::1';
 124  cAnyPort = '0';
 125  CR = #$0d;
 126  LF = #$0a;
 127  CRLF = CR + LF;
 128  c64k = 65536;
 129
 130type
 131
 132  {:@abstract(Exception clas used by Synapse)
 133   When you enable generating of exceptions, this exception is raised by
 134   Synapse's units.}
 135  ESynapseError = class(Exception)
 136  private
 137    FErrorCode: Integer;
 138    FErrorMessage: string;
 139  published
 140    {:Code of error. Value depending on used operating system}
 141    property ErrorCode: Integer read FErrorCode Write FErrorCode;
 142    {:Human readable description of error.}
 143    property ErrorMessage: string read FErrorMessage Write FErrorMessage;
 144  end;
 145
 146  {:Types of OnStatus events}
 147  THookSocketReason = (
 148    {:Resolving is begin. Resolved IP and port is in parameter in format like:
 149     'localhost.somewhere.com:25'.}
 150    HR_ResolvingBegin,
 151    {:Resolving is done. Resolved IP and port is in parameter in format like:
 152     'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!}
 153    HR_ResolvingEnd,
 154    {:Socket created by CreateSocket method. It reporting Family of created
 155     socket too!}
 156    HR_SocketCreate,
 157    {:Socket closed by CloseSocket method.}
 158    HR_SocketClose,
 159    {:Socket binded to IP and Port. Binded IP and Port is in parameter in format
 160     like: 'localhost.somewhere.com:25'.}
 161    HR_Bind,
 162    {:Socket connected to IP and Port. Connected IP and Port is in parameter in
 163     format like: 'localhost.somewhere.com:25'.}
 164    HR_Connect,
 165    {:Called when CanRead method is used with @True result.}
 166    HR_CanRead,
 167    {:Called when CanWrite method is used with @True result.}
 168    HR_CanWrite,
 169    {:Socket is swithed to Listen mode. (TCP socket only)}
 170    HR_Listen,
 171    {:Socket Accepting client connection. (TCP socket only)}
 172    HR_Accept,
 173    {:report count of bytes readed from socket. Number is in parameter string.
 174     If you need is in integer, you must use StrToInt function!}
 175    HR_ReadCount,
 176    {:report count of bytes writed to socket. Number is in parameter string. If
 177     you need is in integer, you must use StrToInt function!}
 178    HR_WriteCount,
 179    {:If is limiting of bandwidth on, then this reason is called when sending or
 180     receiving is stopped for satisfy bandwidth limit. Parameter is count of
 181     waiting milliseconds.}
 182    HR_Wait,
 183    {:report situation where communication error occured. When raiseexcept is
 184     @true, then exception is called after this Hook reason.}
 185    HR_Error
 186    );
 187
 188  {:Procedural type for OnStatus event. Sender is calling TBlockSocket object,
 189   Reason is one of set Status events and value is optional data.}
 190  THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
 191    const Value: String) of object;
 192
 193  {:This procedural type is used for DataFilter hooks.}
 194  THookDataFilter = procedure(Sender: TObject; var Value: AnsiString) of object;
 195
 196  {:This procedural type is used for hook OnCreateSocket. By this hook you can
 197   insert your code after initialisation of socket. (you can set special socket
 198   options, etc.)}
 199  THookCreateSocket = procedure(Sender: TObject) of object;
 200
 201  {:This procedural type is used for monitoring of communication.}
 202  THookMonitor = procedure(Sender: TObject; Writing: Boolean;
 203    const Buffer: TMemory; Len: Integer) of object;
 204
 205  {:This procedural type is used for hook OnAfterConnect. By this hook you can
 206   insert your code after TCP socket has been sucessfully connected.}
 207  THookAfterConnect = procedure(Sender: TObject) of object;
 208
 209  {:This procedural type is used for hook OnVerifyCert. By this hook you can
 210   insert your additional certificate verification code. Usefull to verify server
 211   CN against URL. }
 212
 213  THookVerifyCert = function(Sender: TObject):boolean of object;
 214
 215 {:This procedural type is used for hook OnHeartbeat. By this hook you can
 216   call your code repeately during long socket operations.
 217   You must enable heartbeats by @Link(HeartbeatRate) property!}
 218  THookHeartbeat = procedure(Sender: TObject) of object;
 219
 220  {:Specify family of socket.}
 221  TSocketFamily = (
 222    {:Default mode. Socket family is defined by target address for connection.
 223     It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address
 224     as destination, then is used IPv6 mode. othervise is used IPv4 mode.
 225     However this mode not working properly with preliminary IPv6 supports!}
 226    SF_Any,
 227    {:Turn this class to pure IPv4 mode. This mode is totally compatible with
 228     previous Synapse releases.}
 229    SF_IP4,
 230    {:Turn to only IPv6 mode.}
 231    SF_IP6
 232    );
 233
 234  {:specify possible values of SOCKS modes.}
 235  TSocksType = (
 236    ST_Socks5,
 237    ST_Socks4
 238    );
 239
 240  {:Specify requested SSL/TLS version for secure connection.}
 241  TSSLType = (
 242    LT_all,
 243    LT_SSLv2,
 244    LT_SSLv3,
 245    LT_TLSv1,
 246    LT_TLSv1_1,
 247    LT_SSHv2
 248    );
 249
 250  {:Specify type of socket delayed option.}
 251  TSynaOptionType = (
 252    SOT_Linger,
 253    SOT_RecvBuff,
 254    SOT_SendBuff,
 255    SOT_NonBlock,
 256    SOT_RecvTimeout,
 257    SOT_SendTimeout,
 258    SOT_Reuse,
 259    SOT_TTL,
 260    SOT_Broadcast,
 261    SOT_MulticastTTL,
 262    SOT_MulticastLoop
 263    );
 264
 265  {:@abstract(this object is used for remember delayed socket option set.)}
 266  TSynaOption = class(TObject)
 267  public
 268    Option: TSynaOptionType;
 269    Enabled: Boolean;
 270    Value: Integer;
 271  end;
 272
 273  TCustomSSL = class;
 274  TSSLClass = class of TCustomSSL;
 275
 276  {:@abstract(Basic IP object.)
 277   This is parent class for other class with protocol implementations. Do not
 278   use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket),
 279   @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.}
 280  TBlockSocket = class(TObject)
 281  private
 282    FOnStatus: THookSocketStatus;
 283    FOnReadFilter: THookDataFilter;
 284    FOnCreateSocket: THookCreateSocket;
 285    FOnMonitor: THookMonitor;
 286    FOnHeartbeat: THookHeartbeat;
 287    FLocalSin: TVarSin;
 288    FRemoteSin: TVarSin;
 289    FTag: integer;
 290    FBuffer: AnsiString;
 291    FRaiseExcept: Boolean;
 292    FNonBlockMode: Boolean;
 293    FMaxLineLength: Integer;
 294    FMaxSendBandwidth: Integer;
 295    FNextSend: LongWord;
 296    FMaxRecvBandwidth: Integer;
 297    FNextRecv: LongWord;
 298    FConvertLineEnd: Boolean;
 299    FLastCR: Boolean;
 300    FLastLF: Boolean;
 301    FBinded: Boolean;
 302    FFamily: TSocketFamily;
 303    FFamilySave: TSocketFamily;
 304    FIP6used: Boolean;
 305    FPreferIP4: Boolean;
 306    FDelayedOptions: TList;
 307    FInterPacketTimeout: Boolean;
 308    {$IFNDEF CIL}
 309    FFDSet: TFDSet;
 310    {$ENDIF}
 311    FRecvCounter: Integer;
 312    FSendCounter: Integer;
 313    FSendMaxChunk: Integer;
 314    FStopFlag: Boolean;
 315    FNonblockSendTimeout: Integer;
 316    FHeartbeatRate: integer;
 317    FConnectionTimeout: integer;
 318    {$IFNDEF ONCEWINSOCK}
 319    FWsaDataOnce: TWSADATA;
 320    {$ENDIF}
 321    function GetSizeRecvBuffer: Integer;
 322    procedure SetSizeRecvBuffer(Size: Integer);
 323    function GetSizeSendBuffer: Integer;
 324    procedure SetSizeSendBuffer(Size: Integer);
 325    procedure SetNonBlockMode(Value: Boolean);
 326    procedure SetTTL(TTL: integer);
 327    function GetTTL:integer;
 328    procedure SetFamily(Value: TSocketFamily); virtual;
 329    procedure SetSocket(Value: TSocket); virtual;
 330    function GetWsaData: TWSAData;
 331    function FamilyToAF(f: TSocketFamily): TAddrFamily;
 332  protected
 333    FSocket: TSocket;
 334    FLastError: Integer;
 335    FLastErrorDesc: string;
 336    FOwner: TObject;
 337    procedure SetDelayedOption(const Value: TSynaOption);
 338    procedure DelayedOption(const Value: TSynaOption);
 339    procedure ProcessDelayedOptions;
 340    procedure InternalCreateSocket(Sin: TVarSin);
 341    procedure SetSin(var Sin: TVarSin; IP, Port: string);
 342    function GetSinIP(Sin: TVarSin): string;
 343    function GetSinPort(Sin: TVarSin): Integer;
 344    procedure DoStatus(Reason: THookSocketReason; const Value: string);
 345    procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
 346    procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
 347    procedure DoCreateSocket;
 348    procedure DoHeartbeat;
 349    procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
 350    procedure SetBandwidth(Value: Integer);
 351    function TestStopFlag: Boolean;
 352    procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
 353    function InternalCanRead(Timeout: Integer): Boolean; virtual;
 354  public
 355    constructor Create;
 356
 357    {:Create object and load all necessary socket library. What library is
 358     loaded is described by STUB parameter. If STUB is empty string, then is
 359     loaded default libraries.}
 360    constructor CreateAlternate(Stub: string);
 361    destructor Destroy; override;
 362
 363    {:If @link(family) is not SF_Any, then create socket with type defined in
 364     @link(Family) property. If family is SF_Any, then do nothing! (socket is
 365     created automaticly when you know what type of socket you need to create.
 366     (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created,
 367     then is aplyed all stored delayed socket options.}
 368    procedure CreateSocket;
 369
 370    {:It create socket. Address resolving of Value tells what type of socket is
 371     created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If
 372     value is resolved as IPv6 address, then is created IPv6 socket.}
 373    procedure CreateSocketByName(const Value: String);
 374
 375    {:Destroy socket in use. This method is also automatically called from
 376     object destructor.}
 377    procedure CloseSocket; virtual;
 378
 379    {:Abort any work on Socket and destroy them.}
 380    procedure AbortSocket; virtual;
 381
 382    {:Connects socket to local IP address and PORT. IP address may be numeric or
 383     symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT
 384     - it may be number or mnemonic port ('23', 'telnet').
 385
 386     If port value is '0', system chooses itself and conects unused port in the
 387     range 1024 to 4096 (this depending by operating system!). Structure
 388     LocalSin is filled after calling this method.
 389
 390     Note: If you call this on non-created socket, then socket is created
 391     automaticly.
 392
 393     Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this
 394     case is used implicit system bind instead.}
 395    procedure Bind(IP, Port: string);
 396
 397    {:Connects socket to remote IP address and PORT. The same rules as with
 398     @link(BIND) method are valid. The only exception is that PORT with 0 value
 399     will not be connected!
 400
 401     Structures LocalSin and RemoteSin will be filled with valid values.
 402
 403     When you call this on non-created socket, then socket is created
 404     automaticly. Type of created socket is by @link(Family) property. If is
 405     used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is
 406     created socket for IPv6. When you have family on SF_Any (default!), then
 407     type of created socket is determined by address resolving of destination
 408     address. (Not work properly on prilimitary winsock IPv6 support!)}
 409    procedure Connect(IP, Port: string); virtual;
 410
 411    {:Sets socket to receive mode for new incoming connections. It is necessary
 412     to use @link(TBlockSocket.BIND) function call before this method to select
 413     receiving port!}
 414    procedure Listen; virtual;
 415
 416    {:Waits until new incoming connection comes. After it comes a new socket is
 417     automatically created (socket handler is returned by this function as
 418     result).}
 419    function Accept: TSocket; virtual;
 420
 421    {:Sends data of LENGTH from BUFFER address via connected socket. System
 422     automatically splits data to packets.}
 423    function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual;
 424
 425    {:One data BYTE is sent via connected socket.}
 426    procedure SendByte(Data: Byte); virtual;
 427
 428    {:Send data string via connected socket. Any terminator is not added! If you
 429     need send true string with CR-LF termination, you must add CR-LF characters
 430     to sended string! Because any termination is not added automaticly, you can
 431     use this function for sending any binary data in binary string.}
 432    procedure SendString(Data: AnsiString); virtual;
 433
 434    {:Send integer as four bytes to socket.}
 435    procedure SendInteger(Data: integer); virtual;
 436
 437    {:Send data as one block to socket. Each block begin with 4 bytes with
 438     length of data in block. This 4 bytes is added automaticly by this
 439     function.}
 440    procedure SendBlock(const Data: AnsiString); virtual;
 441
 442    {:Send data from stream to socket.}
 443    procedure SendStreamRaw(const Stream: TStream); virtual;
 444
 445    {:Send content of stream to socket. It using @link(SendBlock) method}
 446    procedure SendStream(const Stream: TStream); virtual;
 447
 448    {:Send content of stream to socket. It using @link(SendBlock) method and
 449    this is compatible with streams in Indy library.}
 450    procedure SendStreamIndy(const Stream: TStream); virtual;
 451
 452    {:Note: This is low-level receive function. You must be sure if data is
 453     waiting for read before call this function for avoid deadlock!
 454
 455     Waits until allocated buffer is filled by received data. Returns number of
 456     data received, which equals to LENGTH value under normal operation. If it
 457     is not equal the communication channel is possibly broken.
 458
 459     On stream oriented sockets if is received 0 bytes, it mean 'socket is
 460     closed!"
 461
 462     On datagram socket is readed first waiting datagram.}
 463    function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
 464
 465    {:Note: This is high-level receive function. It using internal
 466     @link(LineBuffer) and you can combine this function freely with other
 467     high-level functions!
 468
 469     Method waits until data is received. If no data is received within TIMEOUT
 470     (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods
 471     serves for reading any size of data (i.e. one megabyte...). This method is
 472     preffered for reading from stream sockets (like TCP).}
 473    function RecvBufferEx(Buffer: Tmemory; Len: Integer;
 474      Timeout: Integer): Integer; virtual;
 475
 476    {:Similar to @link(RecvBufferEx), but readed data is stored in binary
 477     string, not in memory buffer.}
 478    function RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; virtual;
 479
 480    {:Note: This is high-level receive function. It using internal
 481     @link(LineBuffer) and you can combine this function freely with other
 482     high-level functions.
 483
 484     Waits until one data byte is received which is also returned as function
 485     result. If no data is received within TIMEOUT (in milliseconds)period,
 486     @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
 487    function RecvByte(Timeout: Integer): Byte; virtual;
 488
 489    {:Note: This is high-level receive function. It using internal
 490     @link(LineBuffer) and you can combine this function freely with other
 491     high-level functions.
 492
 493     Waits until one four bytes are received and return it as one Ineger Value.
 494     If no data is received within TIMEOUT (in milliseconds)period,
 495     @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
 496    function RecvInteger(Timeout: Integer): Integer; virtual;
 497
 498    {:Note: This is high-level receive function. It using internal
 499     @link(LineBuffer) and you can combine this function freely with other
 500     high-level functions.
 501
 502     Method waits until data string is received. This string is terminated by
 503     CR-LF characters. The resulting string is returned without this termination
 504     (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be
 505     exactly CR-LF. See @link(ConvertLineEnd) description. If no data is
 506     received within TIMEOUT (in milliseconds) period, @link(LastError) is set
 507     to WSAETIMEDOUT. You may also specify maximum length of reading data by
 508     @link(MaxLineLength) property.}
 509    function RecvString(Timeout: Integer): AnsiString; virtual;
 510
 511    {:Note: This is high-level receive function. It using internal
 512     @link(LineBuffer) and you can combine this function freely with other
 513     high-level functions.
 514
 515     Method waits until data string is received. This string is terminated by
 516     Terminator string. The resulting string is returned without this
 517     termination. If no data is received within TIMEOUT (in milliseconds)
 518     period, @link(LastError) is set to WSAETIMEDOUT. You may also specify
 519     maximum length of reading data by @link(MaxLineLength) property.}
 520    function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
 521
 522    {:Note: This is high-level receive function. It using internal
 523     @link(LineBuffer) and you can combine this function freely with other
 524     high-level functions.
 525
 526     Method reads all data waiting for read. If no data is received within
 527     TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT.
 528     Methods serves for reading unknown size of data. Because before call this
 529     function you don't know size of received data, returned data is stored in
 530     dynamic size binary string. This method is preffered for reading from
 531     stream sockets (like TCP). It is very goot for receiving datagrams too!
 532     (UDP protocol)}
 533    function RecvPacket(Timeout: Integer): AnsiString; virtual;
 534
 535    {:Read one block of data from socket. Each block begin with 4 bytes with
 536     length of data in block. This function read first 4 bytes for get lenght,
 537     then it wait for reported count of bytes.}
 538    function RecvBlock(Timeout: Integer): AnsiString; virtual;
 539
 540    {:Read all data from socket to stream until socket is closed (or any error
 541     occured.)}
 542    procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
 543    {:Read requested count of bytes from socket to stream.}
 544    procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
 545
 546    {:Receive data to stream. It using @link(RecvBlock) method.}
 547    procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
 548
 549    {:Receive data to stream. This function is compatible with similar function
 550    in Indy library. It using @link(RecvBlock) method.}
 551    procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
 552
 553    {:Same as @link(RecvBuffer), but readed data stays in system input buffer.
 554    Warning: this function not respect data in @link(LineBuffer)! Is not
 555    recommended to use this function!}
 556    function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
 557
 558    {:Same as @link(RecvByte), but readed data stays in input system buffer.
 559     Warning: this function not respect data in @link(LineBuffer)! Is not
 560    recommended to use this function!}
 561    function PeekByte(Timeout: Integer): Byte; virtual;
 562
 563    {:On stream sockets it returns number of received bytes waiting for picking.
 564     0 is returned when there is no such data. On datagram socket it returns
 565     length of the first waiting datagram. Returns 0 if no datagram is waiting.}
 566    function WaitingData: Integer; virtual;
 567
 568    {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer),
 569     return their length instead.}
 570    function WaitingDataEx: Integer;
 571
 572    {:Clear all waiting data for read from buffers.}
 573    procedure Purge;
 574
 575    {:Sets linger. Enabled linger means that the system waits another LINGER
 576     (in milliseconds) time for delivery of sent data. This function is only for
 577     stream type of socket! (TCP)}
 578    procedure SetLinger(Enable: Boolean; Linger: Integer);
 579
 580    {:Actualize values in @link(LocalSin).}
 581    procedure GetSinLocal;
 582
 583    {:Actualize values in @link(RemoteSin).}
 584    procedure GetSinRemote;
 585
 586    {:Actualize values in @link(LocalSin) and @link(RemoteSin).}
 587    procedure GetSins;
 588
 589    {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.}
 590    procedure ResetLastError;
 591
 592    {:If you "manually" call Socket API functions, forward their return code as
 593     parameter to this function, which evaluates it, eventually calls
 594     GetLastError and found error code returns and stores to @link(LastError).}
 595    function SockCheck(SockResult: Integer): Integer; virtual;
 596
 597    {:If @link(LastError) contains some error code and @link(RaiseExcept)
 598     property is @true, raise adequate exception.}
 599    procedure ExceptCheck;
 600
 601    {:Returns local computer name as numerical or symbolic value. It try get
 602     fully qualified domain name. Name is returned in the format acceptable by
 603     functions demanding IP as input parameter.}
 604    function LocalName: string;
 605
 606    {:Try resolve name to all possible IP address. i.e. If you pass as name
 607     result of @link(LocalName) method, you get all IP addresses used by local
 608     system.}
 609    procedure ResolveNameToIP(Name: string; const IPList: TStrings);
 610
 611    {:Try resolve name to primary IP address. i.e. If you pass as name result of
 612     @link(LocalName) method, you get primary IP addresses used by local system.}
 613    function ResolveName(Name: string): string;
 614
 615    {:Try resolve IP to their primary domain name. If IP not have domain name,
 616     then is returned original IP.}
 617    function ResolveIPToName(IP: string): string;
 618
 619    {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)}
 620    function ResolvePort(Port: string): Word;
 621
 622    {:Set information about remote side socket. It is good for seting remote
 623     side for sending UDP packet, etc.}
 624    procedure SetRemoteSin(IP, Port: string);
 625
 626    {:Picks IP socket address from @link(LocalSin).}
 627    function GetLocalSinIP: string; virtual;
 628
 629    {:Picks IP socket address from @link(RemoteSin).}
 630    function GetRemoteSinIP: string; virtual;
 631
 632    {:Picks socket PORT number from @link(LocalSin).}
 633    function GetLocalSinPort: Integer; virtual;
 634
 635    {:Picks socket PORT number from @link(RemoteSin).}
 636    function GetRemoteSinPort: Integer; virtual;
 637
 638    {:Return @TRUE, if you can read any data from socket or is incoming
 639     connection on TCP based socket. Status is tested for time Timeout (in
 640     milliseconds). If value in Timeout is 0, status is only tested and
 641     continue. If value in Timeout is -1, run is breaked and waiting for read
 642     data maybe forever.
 643
 644     This function is need only on special cases, when you need use
 645     @link(RecvBuffer) function directly! read functioms what have timeout as
 646     calling parameter, calling this function internally.}
 647    function CanRead(Timeout: Integer): Boolean; virtual;
 648
 649    {:Same as @link(CanRead), but additionally return @TRUE if is some data in
 650     @link(LineBuffer).}
 651    function CanReadEx(Timeout: Integer): Boolean; virtual;
 652
 653    {:Return @TRUE, if you can to socket write any data (not full sending
 654     buffer). Status is tested for time Timeout (in milliseconds). If value in
 655     Timeout is 0, status is only tested and continue. If value in Timeout is
 656     -1, run is breaked and waiting for write data maybe forever.
 657
 658     This function is need only on special cases!}
 659    function CanWrite(Timeout: Integer): Boolean; virtual;
 660
 661    {:Same as @link(SendBuffer), but send datagram to address from
 662     @link(RemoteSin). Usefull for sending reply to datagram received by
 663     function @link(RecvBufferFrom).}
 664    function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual;
 665
 666    {:Note: This is low-lever receive function. You must be sure if data is
 667     waiting for read before call this function for avoid deadlock!
 668
 669     Receives first waiting datagram to allocated buffer. If there is no waiting
 670     one, then waits until one comes. Returns length of datagram stored in
 671     BUFFER. If length exceeds buffer datagram is truncated. After this
 672     @link(RemoteSin) structure contains information about sender of UDP packet.}
 673    function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual;
 674{$IFNDEF CIL}
 675    {:This function is for check for incoming data on set of sockets. Whitch
 676    sockets is checked is decribed by SocketList Tlist with TBlockSocket
 677    objects. TList may have maximal number of objects defined by FD_SETSIZE
 678    constant. Return @TRUE, if you can from some socket read any data or is
 679    incoming connection on TCP based socket. Status is tested for time Timeout
 680    (in milliseconds). If value in Timeout is 0, status is only tested and
 681    continue. If value in Timeout is -1, run is breaked and waiting for read
 682    data maybe forever. If is returned @TRUE, CanReadList TList is filled by all
 683    TBlockSocket objects what waiting for read.}
 684    function GroupCanRead(const SocketList: TList; Timeout: Integer;
 685      const CanReadList: TList): Boolean;
 686{$ENDIF}
 687    {:By this method you may turn address reuse mode for local @link(bind). It
 688     is good specially for UDP protocol. Using this with TCP protocol is
 689     hazardous!}
 690    procedure EnableReuse(Value: Boolean);
 691
 692    {:Try set timeout for all sending and receiving operations, if socket
 693     provider can do it. (It not supported by all socket providers!)}
 694    procedure SetTimeout(Timeout: Integer);
 695
 696    {:Try set timeout for all sending operations, if socket provider can do it.
 697     (It not supported by all socket providers!)}
 698    procedure SetSendTimeout(Timeout: Integer);
 699
 700    {:Try set timeout for all receiving operations, if socket provider can do
 701     it. (It not supported by all socket providers!)}
 702    procedure SetRecvTimeout(Timeout: Integer);
 703
 704    {:Return value of socket type.}
 705    function GetSocketType: integer; Virtual;
 706
 707    {:Return value of protocol type for socket creation.}
 708    function GetSocketProtocol: integer; Virtual;
 709
 710    {:WSA structure with information about socket provider. On non-windows 
 711     platforms this structure is simulated!}
 712    property WSAData: TWSADATA read GetWsaData;
 713
 714    {:FDset structure prepared for usage with this socket.}
 715    property FDset: TFDSet read FFDset;
 716
 717    {:Structure describing local socket side.}
 718    property LocalSin: TVarSin read FLocalSin write FLocalSin;
 719
 720    {:Structure describing remote socket side.}
 721    property RemoteSin: TVarSin read FRemoteSin write FRemoteSin;
 722
 723    {:Socket handler. Suitable for "manual" calls to socket API or manual
 724     connection of socket to a previously created socket (i.e by Accept method
 725     on TCP socket)}
 726    property Socket: TSocket read FSocket write SetSocket;
 727
 728    {:Last socket operation error code. Error codes are described in socket
 729     documentation. Human readable error description is stored in
 730     @link(LastErrorDesc) property.}
 731    property LastError: Integer read FLastError;
 732
 733    {:Human readable error description of @link(LastError) code.}
 734    property LastErrorDesc: string read FLastErrorDesc;
 735
 736    {:Buffer used by all high-level receiving functions. This buffer is used for
 737     optimized reading of data from socket. In normal cases you not need access
 738     to this buffer directly!}
 739    property LineBuffer: AnsiString read FBuffer write FBuffer;
 740
 741    {:Size of Winsock receive buffer. If it is not supported by socket provider,
 742     it return as size one kilobyte.}
 743    property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
 744
 745    {:Size of Winsock send buffer. If it is not supported by socket provider, it
 746     return as size one kilobyte.}
 747    property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
 748
 749    {:If @True, turn class to non-blocking mode. Not all functions are working
 750     properly in this mode, you must know exactly what you are doing! However
 751     when you have big experience with non-blocking programming, then you can
 752     optimise your program by non-block mode!}
 753    property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
 754
 755    {:Set Time-to-live value. (if system supporting it!)}
 756    property TTL: Integer read GetTTL Write SetTTL;
 757
 758    {:If is @true, then class in in IPv6 mode.}
 759    property IP6used: Boolean read FIP6used;
 760
 761    {:Return count of received bytes on this socket from begin of current
 762     connection.}
 763    property RecvCounter: Integer read FRecvCounter;
 764
 765    {:Return count of sended bytes on this socket from begin of current
 766     connection.}
 767    property SendCounter: Integer read FSendCounter;
 768  published
 769    {:Return descriptive string for given error code. This is class function.
 770     You may call it without created object!}
 771    class function GetErrorDesc(ErrorCode: Integer): string;
 772
 773    {:Return descriptive string for @link(LastError).}
 774    function GetErrorDescEx: string; virtual;
 775
 776    {:this value is for free use.}
 777    property Tag: Integer read FTag write FTag;
 778
 779    {:If @true, winsock errors raises exception. Otherwise is setted
 780    @link(LastError) value only and you must check it from your program! Default
 781    value is @false.}
 782    property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
 783
 784    {:Define maximum length in bytes of @link(LineBuffer) for high-level
 785     receiving functions. If this functions try to read more data then this
 786     limit, error is returned! If value is 0 (default), no limitation is used.
 787     This is very good protection for stupid attacks to your server by sending
 788     lot of data without proper terminator... until all your memory is allocated
 789     by LineBuffer!
 790
 791     Note: This maximum length is checked only in functions, what read unknown
 792     number of bytes! (like @link(RecvString) or @link(RecvTerminated))}
 793    property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
 794
 795    {:Define maximal bandwidth for all sending operations in bytes per second.
 796     If value is 0 (default), bandwidth limitation is not used.}
 797    property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
 798
 799    {:Define maximal bandwidth for all receiving operations in bytes per second.
 800     If value is 0 (default), bandwidth limitation is not used.}
 801    property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
 802
 803    {:Define maximal bandwidth for all sending and receiving operations in bytes
 804     per second. If value is 0 (default), bandwidth limitation is not used.}
 805    property MaxBandwidth: Integer Write SetBandwidth;
 806
 807    {:Do a conversion of non-standard line terminators to CRLF. (Off by default)
 808     If @True, then terminators like sigle CR, single LF or LFCR are converted
 809     to CRLF internally. This have effect only in @link(RecvString) method!}
 810    property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
 811
 812    {:Specified Family of this socket. When you are using Windows preliminary
 813     support for IPv6, then I recommend to set this property!}
 814    property Family: TSocketFamily read FFamily Write SetFamily;
 815
 816    {:When resolving of domain name return both IPv4 and IPv6 addresses, then
 817     specify if is used IPv4 (dafault - @true) or IPv6.}
 818    property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4;
 819
 820    {:By default (@true) is all timeouts used as timeout between two packets in
 821     reading operations. If you set this to @false, then Timeouts is for overall
 822     reading operation!}
 823    property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
 824
 825    {:All sended datas was splitted by this value.}
 826    property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk;
 827
 828    {:By setting this property to @true you can stop any communication. You can
 829     use this property for soft abort of communication.}
 830    property StopFlag: Boolean read FStopFlag Write FStopFlag;
 831
 832    {:Timeout for data sending by non-blocking socket mode.}
 833    property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout;
 834
 835    {:Timeout for @link(Connect) call. Default value 0 means default system timeout.
 836     Non-zero value means timeout in millisecond.}
 837    property ConnectionTimeout: Integer read FConnectionTimeout write FConnectionTimeout;
 838
 839    {:This event is called by various reasons. It is good for monitoring socket,
 840     create gauges for data transfers, etc.}
 841    property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
 842
 843    {:this event is good for some internal thinks about filtering readed datas.
 844     It is used by telnet client by example.}
 845    property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
 846
 847    {:This event is called after real socket creation for setting special socket
 848     options, because you not know when socket is created. (it is depended on
 849     Ipv4, IPv6 or automatic mode)}
 850    property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket;
 851
 852    {:This event is good for monitoring content of readed or writed datas.}
 853    property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor;
 854
 855    {:This event is good for calling your code during long socket operations.
 856      (Example, for refresing UI if class in not called within the thread.)
 857      Rate of heartbeats can be modified by @link(HeartbeatRate) property.}
 858    property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat;
 859
 860    {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing.
 861      Default value 0 disabling heartbeats! Value is in milliseconds.
 862      Real rate can be higher or smaller then this value, because it depending
 863      on real socket operations too!
 864      Note: Each heartbeat slowing socket processing.}
 865    property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
 866    {:What class own this socket? Used by protocol implementation classes.}
 867    property Owner: TObject read FOwner Write FOwner;
 868  end;
 869
 870  {:@abstract(Support for SOCKS4 and SOCKS5 proxy)
 871   Layer with definition all necessary properties and functions for
 872   implementation SOCKS proxy client. Do not use this class directly.}
 873  TSocksBlockSocket = class(TBlockSocket)
 874  protected
 875    FSocksIP: string;
 876    FSocksPort: string;
 877    FSocksTimeout: integer;
 878    FSocksUsername: string;
 879    FSocksPassword: string;
 880    FUsingSocks: Boolean;
 881    FSocksResolver: Boolean;
 882    FSocksLastError: integer;
 883    FSocksResponseIP: string;
 884    FSocksResponsePort: string;
 885    FSocksLocalIP: string;
 886    FSocksLocalPort: string;
 887    FSocksRemoteIP: string;
 888    FSocksRemotePort: string;
 889    FBypassFlag: Boolean;
 890    FSocksType: TSocksType;
 891    function SocksCode(IP, Port: string): Ansistring;
 892    function SocksDecode(Value: Ansistring): integer;
 893  public
 894    constructor Create;
 895
 896    {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do
 897     authorisation to proxy. This is needed only in special cases! (it is called
 898     internally!)}
 899    function SocksOpen: Boolean;
 900
 901    {:Send specified request to SOCKS proxy. This is needed only in special
 902     cases! (it is called internally!)}
 903    function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean;
 904
 905    {:Receive response to previosly sended request. This is needed only in
 906     special cases! (it is called internally!)}
 907    function SocksResponse: Boolean;
 908
 909    {:Is @True when class is using SOCKS proxy.}
 910    property UsingSocks: Boolean read FUsingSocks;
 911
 912    {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.}
 913    property SocksLastError: integer read FSocksLastError;
 914  published
 915    {:Address of SOCKS server. If value is empty string, SOCKS support is
 916     disabled. Assingning any value to this property enable SOCKS mode.
 917     Warning: You cannot combine this mode with HTTP-tunneling mode!}
 918    property SocksIP: string read FSocksIP write FSocksIP;
 919
 920    {:Port of SOCKS server. Default value is '1080'.}
 921    property SocksPort: string read FSocksPort write FSocksPort;
 922
 923    {:If you need authorisation on SOCKS server, set username here.}
 924    property SocksUsername: string read FSocksUsername write FSocksUsername;
 925
 926    {:If you need authorisation on SOCKS server, set password here.}
 927    property SocksPassword: string read FSocksPassword write FSocksPassword;
 928
 929    {:Specify timeout for communicatin with SOCKS server. Default is one minute.}
 930    property SocksTimeout: integer read FSocksTimeout write FSocksTimeout;
 931
 932    {:If @True, all symbolic names of target hosts is not translated to IP's
 933     locally, but resolving is by SOCKS proxy. Default is @True.}
 934    property SocksResolver: Boolean read FSocksResolver write FSocksResolver;
 935
 936    {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too.
 937     When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is
 938     used SOCKS4a. Othervise is used pure SOCKS4.}
 939    property SocksType: TSocksType read FSocksType write FSocksType;
 940  end;
 941
 942  {:@abstract(Implementation of TCP socket.)
 943   Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin),
 944   SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy
 945   (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
 946  TTCPBlockSocket = class(TSocksBlockSocket)
 947  protected
 948    FOnAfterConnect: THookAfterConnect;
 949    FSSL: TCustomSSL;
 950    FHTTPTunnelIP: string;
 951    FHTTPTunnelPort: string;
 952    FHTTPTunnel: Boolean;
 953    FHTTPTunnelRemoteIP: string;
 954    FHTTPTunnelRemotePort: string;
 955    FHTTPTunnelUser: string;
 956    FHTTPTunnelPass: string;
 957    FHTTPTunnelTimeout: integer;
 958    procedure SocksDoConnect(IP, Port: string);
 959    procedure HTTPTunnelDoConnect(IP, Port: string);
 960    procedure DoAfterConnect;
 961  public
 962    {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
 963    (see @link(SSLImplementation))}
 964    constructor Create;
 965
 966    {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation}
 967    constructor CreateWithSSL(SSLPlugin: TSSLClass);
 968    destructor Destroy; override;
 969
 970    {:See @link(TBlockSocket.CloseSocket)}
 971    procedure CloseSocket; override;
 972
 973    {:See @link(TBlockSocket.WaitingData)}
 974    function WaitingData: Integer; override;
 975
 976    {:Sets socket to receive mode for new incoming connections. It is necessary
 977     to use @link(TBlockSocket.BIND) function call before this method to select
 978     receiving port!
 979
 980     If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND
 981     method of SOCKS.)}
 982    procedure Listen; override;
 983
 984    {:Waits until new incoming connection comes. After it comes a new socket is
 985     automatically created (socket handler is returned by this function as
 986     result).
 987
 988     If you use SOCKS, new socket is not created! In this case is used same
 989     socket as socket for listening! So, you can accept only one connection in
 990     SOCKS mode.}
 991    function Accept: TSocket; override;
 992
 993    {:Connects socket to remote IP address and PORT. The same rules as with
 994     @link(TBlockSocket.BIND) method are valid. The only exception is that PORT
 995     with 0 value will not be connected. After call to this method
 996     a communication channel between local and remote socket is created. Local
 997     socket is assigned automatically if not controlled by previous call to
 998     @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin)
 999     and @link(TBlockSocket.RemoteSin) will be filled with valid values.
1000
1001     If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified
1002     in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.)
1003
1004     If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP
1005     tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP
1006     protocol.)
1007
1008     Note: If you call this on non-created socket, then socket is created
1009     automaticly.}
1010    procedure Connect(IP, Port: string); override;
1011
1012    {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin
1013     allows it) mode, then call this method. This method switch this class to
1014     SSL mode and do SSL/TSL handshake.}
1015    procedure SSLDoConnect;
1016
1017    {:By this method you can downgrade existing SSL/TLS connection to normal TCP
1018     connection.}
1019    procedure SSLDoShutdown;
1020
1021    {:If you need use this component as SSL/TLS TCP server, then after accepting
1022     of inbound connection you need start SSL/TLS session by this method. Before
1023     call this function, you must have assigned all neeeded certificates and
1024     keys!}
1025    function SSLAcceptConnection: Boolean;
1026
1027    {:See @link(TBlockSocket.GetLocalSinIP)}
1028    function GetLocalSinIP: string; override;
1029
1030    {:See @link(TBlockSocket.GetRemoteSinIP)}
1031    function GetRemoteSinIP: string; override;
1032
1033    {:See @link(TBlockSocket.GetLocalSinPort)}
1034    function GetLocalSinPort: Integer; override;
1035
1036    {:See @link(TBlockSocket.GetRemoteSinPort)}
1037    function GetRemoteSinPort: Integer; override;
1038
1039    {:See @link(TBlockSocket.SendBuffer)}
1040    function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1041
1042    {:See @link(TBlockSocket.RecvBuffer)}
1043    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
1044
1045    {:Return value of socket type. For TCP return SOCK_STREAM.}
1046    function GetSocketType: integer; override;
1047
1048    {:Return value of protocol type for socket creation. For TCP return
1049     IPPROTO_TCP.}
1050    function GetSocketProtocol: integer; override;
1051
1052    {:Class implementing SSL/TLS support. It is allways some descendant
1053     of @link(TCustomSSL) class. When programmer not select some SSL plugin
1054     class, then is used @link(TSSLNone)}
1055    property SSL: TCustomSSL read FSSL;
1056
1057    {:@True if is used HTTP tunnel mode.}
1058    property HTTPTunnel: Boolean read FHTTPTunnel;
1059  published
1060    {:Return descriptive string for @link(LastError). On case of error
1061     in SSL/TLS subsystem, it returns right error description.}
1062    function GetErrorDescEx: string; override;
1063
1064    {:Specify IP address of HTTP proxy. Assingning non-empty value to this
1065     property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing
1066     TCP connection through HTTP proxy server. (If policy on HTTP proxy server
1067     allow this!) Warning: You cannot combine this mode with SOCK5 mode!}
1068    property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
1069
1070    {:Specify port of HTTP proxy for HTTP-tunneling.}
1071    property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
1072
1073    {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel
1074     mode. If you not need authorisation, then let this property empty.}
1075    property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser;
1076
1077    {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel
1078     mode.}
1079    property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass;
1080
1081    {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
1082    property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
1083
1084    {:This event is called after sucessful TCP socket connection.}
1085    property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
1086  end;
1087
1088  {:@abstract(Datagram based communication)
1089   This class implementing datagram based communication instead default stream
1090   based communication style.}
1091  TDgramBlockSocket = class(TSocksBlockSocket)
1092  public
1093    {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for
1094     sending data.}
1095    procedure Connect(IP, Port: string); override;
1096
1097    {:Silently redirected to @link(TBlockSocket.SendBufferTo).}
1098    function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1099
1100    {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).}
1101    function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override;
1102  end;
1103
1104  {:@abstract(Implementation of UDP socket.)
1105   NOTE: in this class is all receiving redirected to RecvBufferFrom. You can
1106   use for reading any receive function. Preffered is RecvPacket! Similary all
1107   sending is redirected to SendbufferTo. You can use for sending UDP packet any
1108   sending function, like SendString.
1109
1110   Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5
1111   proxy (only unicasts! Outgoing and incomming.)}
1112  TUDPBlockSocket = class(TDgramBlockSocket)
1113  protected
1114    FSocksControlSock: TTCPBlockSocket;
1115    function UdpAssociation: Boolean;
1116    procedure SetMulticastTTL(TTL: integer);
1117    function GetMulticastTTL:integer;
1118  public
1119    destructor Destroy; override;
1120
1121    {:Enable or disable sending of broadcasts. If seting OK, result is @true.
1122     This method is not supported in SOCKS5 mode! IPv6 does not support
1123     broadcasts! In this case you must use Multicasts instead.}
1124    procedure EnableBroadcast(Value: Boolean);
1125
1126    {:See @link(TBlockSocket.SendBufferTo)}
1127    function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override;
1128
1129    {:See @link(TBlockSocket.RecvBufferFrom)}
1130    function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override;
1131{$IFNDEF CIL}
1132    {:Add this socket to given multicast group. You cannot use Multicasts in
1133     SOCKS mode!}
1134    procedure AddMulticast(MCastIP:string);
1135
1136    {:Remove this socket from given multicast group.}
1137    procedure DropMulticast(MCastIP:string);
1138{$ENDIF}
1139    {:All sended multicast datagrams is loopbacked to your interface too. (you
1140     can read your sended datas.) You can disable this feature by this function.
1141     This function not working on some Windows systems!}
1142    procedure EnableMulticastLoop(Value: Boolean);
1143
1144    {:Return value of socket type. For UDP return SOCK_DGRAM.}
1145    function GetSocketType: integer; override;
1146
1147    {:Return value of protocol type for socket creation. For UDP return
1148     IPPROTO_UDP.}
1149    function GetSocketProtocol: integer; override;
1150
1151    {:Set Time-to-live value for multicasts packets. It define number of routers
1152     for transfer of datas. If you set this to 1 (dafault system value), then
1153     multicasts packet goes only to you local network. If you need transport
1154     multicast packet to worldwide, then increase this value, but be carefull,
1155     lot of routers on internet does not transport multicasts packets!}
1156    property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
1157  end;
1158
1159  {:@abstract(Implementation of RAW ICMP socket.)
1160   For this object you must have rights for creating RAW sockets!}
1161  TICMPBlockSocket = class(TDgramBlockSocket)
1162  public
1163    {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
1164    function GetSocketType: integer; override;
1165
1166    {:Return value of protocol type for socket creation. For ICMP returns
1167     IPPROTO_ICMP or IPPROTO_ICMPV6}
1168    function GetSocketProtocol: integer; override;
1169  end;
1170
1171  {:@abstract(Implementation of RAW socket.)
1172   For this object you must have rights for creating RAW sockets!}
1173  TRAWBlockSocket = class(TBlockSocket)
1174  public
1175    {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
1176    function GetSocketType: integer; override;
1177
1178    {:Return value of protocol type for socket creation. For RAW returns
1179     IPPROTO_RAW.}
1180    function GetSocketProtocol: integer; override;
1181  end;
1182
1183  {:@abstract(Implementation of PGM-message socket.)
1184   Not all systems supports this protocol!}
1185  TPGMMessageBlockSocket = class(TBlockSocket)
1186  public
1187    {:Return value of socket type. For PGM-message return SOCK_RDM.}
1188    function GetSocketType: integer; override;
1189
1190    {:Return value of protocol type for socket creation. For PGM-message returns
1191     IPPROTO_RM.}
1192    function GetSocketProtocol: integer; override;
1193  end;
1194
1195  {:@abstract(Implementation of PGM-stream socket.)
1196   Not all systems supports this protocol!}
1197  TPGMStreamBlockSocket = class(TBlockSocket)
1198  public
1199    {:Return value of socket type. For PGM-stream return SOCK_STREAM.}
1200    function GetSocketType: integer; override;
1201
1202    {:Return value of protocol type for socket creation. For PGM-stream returns
1203     IPPROTO_RM.}
1204    function GetSocketProtocol: integer; override;
1205  end;
1206
1207  {:@abstract(Parent class for all SSL plugins.)
1208   This is abstract class defining interface for other SSL plugins.
1209
1210   Instance of this class will be created for each @link(TTCPBlockSocket).
1211
1212   Warning: not all methods and propertis can work in all existing SSL plugins!
1213   Please, read documentation of used SSL plugin.}
1214  TCustomSSL = class(TObject)
1215  private
1216  protected
1217    FOnVerifyCert: THookVerifyCert;
1218    FSocket: TTCPBlockSocket;
1219    FSSLEnabled: Boolean;
1220    FLastError: integer;
1221    FLastErrorDesc: string;
1222    FSSLType: TSSLType;
1223    FKeyPassword: string;
1224    FCiphers: string;
1225    FCertificateFile: string;
1226    FPrivateKeyFile: string;
1227    FCertificate: Ansistring;
1228    FPrivateKey: Ansistring;
1229    FPFX: Ansistring;
1230    FPFXfile: string;
1231    FCertCA: Ansistring;
1232    FCertCAFile: string;
1233    FTrustCertificate: Ansistring;
1234    FTrustCertificateFile: string;
1235    FVerifyCert: Boolean;
1236    FUsername: string;
1237    FPassword: string;
1238    FSSHChannelType: string;
1239    FSSHChannelArg1: string;
1240    FSSHChannelArg2: string;
1241    FCertComplianceLevel: integer;
1242    FSNIHost: string;
1243    procedure ReturnError;
1244    procedure SetCertCAFile(const Value: string); virtual;
1245    function DoVerifyCert:boolean;
1246    function CreateSelfSignedCert(Host: string): Boolean; virtual;
1247  public
1248    {: Create plugin class. it is called internally from @link(TTCPBlockSocket)}
1249    constructor Create(const Value: TTCPBlockSocket); virtual;
1250
1251    {: Assign settings (certificates and configuration) from another SSL plugin
1252     class.}
1253    procedure Assign(const Value: TCustomSSL); virtual;
1254
1255    {: return description of used plugin. It usually return name and version
1256     of used SSL library.}
1257    function LibVersion: String; virtual;
1258
1259    {: return name of used plugin.}
1260    function LibName: String; virtual;
1261
1262    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1263
1264     Here is needed code for start SSL connection.}
1265    function Connect: boolean; virtual;
1266
1267    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1268
1269     Here is needed code for acept new SSL connection.}
1270    function Accept: boolean; virtual;
1271
1272    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1273
1274     Here is needed code for hard shutdown of SSL connection. (for example,
1275     before socket is closed)}
1276    function Shutdown: boolean; virtual;
1277
1278    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1279
1280     Here is needed code for soft shutdown of SSL connection. (for example,
1281     when you need to continue with unprotected connection.)}
1282    function BiShutdown: boolean; virtual;
1283
1284    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1285
1286     Here is needed code for sending some datas by SSL connection.}
1287    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
1288
1289    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1290
1291     Here is needed code for receiving some datas by SSL connection.}
1292    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
1293
1294    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
1295
1296     Here is needed code for getting count of datas what waiting for read.
1297     If SSL plugin not allows this, then it should return 0.}
1298    function WaitingData: Integer; virtual;
1299
1300    {:Return string with identificator of SSL/TLS version of existing
1301     connection.}
1302    function GetSSLVersion: string; virtual;
1303
1304    {:Return subject of remote SSL peer.}
1305    function GetPeerSubject: string; virtual;
1306
1307    {:Return Serial number if remote X509 certificate.}
1308    function GetPeerSerialNo: integer; virtual;
1309
1310    {:Return issuer certificate of remote SSL peer.}
1311    function GetPeerIssuer: string; virtual;
1312
1313    {:Return peer name from remote side certificate. This is good for verify,
1314     if certificate is generated for remote side IP name.}
1315    function GetPeerName: string; virtual;
1316
1317    {:Returns has of peer name from remote side certificate. This is good
1318     for fast remote side authentication.}
1319    function GetPeerNameHash: cardinal; virtual;
1320
1321    {:Return fingerprint of remote SSL peer.}
1322    function GetPeerFingerprint: string; virtual;
1323
1324    {:Return all detailed information about certificate from remote side of
1325     SSL/TLS connection. Result string can be multilined! Each plugin can return
1326     this informations in different format!}
1327    function GetCertInfo: string; virtual;
1328
1329    {:Return currently used Cipher.}
1330    function GetCipherName: string; virtual;
1331
1332    {:Return currently used number of bits in current Cipher algorythm.}
1333    function GetCipherBits: integer; virtual;
1334
1335    {:Return number of bits in current Cipher algorythm.}
1336    function GetCipherAlgBits: integer; virtual;
1337
1338    {:Return result value of verify remote side certificate. Look to OpenSSL
1339     documentation for possible values. For example 0 is successfuly verified
1340     certificate, or 18 is self-signed certificate.}
1341    function GetVerifyCert: integer; virtual;
1342
1343    {: Resurn @true if SSL mode is enabled on existing cvonnection.}
1344    property SSLEnabled: Boolean read FSSLEnabled;
1345
1346    {:Return error code of last SSL operation. 0 is OK.}
1347    property LastError: integer read FLastError;
1348
1349    {:Return error description of last SSL operation.}
1350    property LastErrorDesc: string read FLastErrorDesc;
1351  published
1352    {:Here you can specify requested SSL/TLS mode. Default is autodetection, but
1353     on some servers autodetection not working properly. In this case you must
1354     specify requested SSL/TLS mode by your hand!}
1355    property SSLType: TSSLType read FSSLType write FSSLType;
1356
1357    {:Password for decrypting of encoded certificate or key.}
1358    property KeyPassword: string read FKeyPassword write FKeyPassword;
1359
1360    {:Username for possible credentials.}
1361    property Username: string read FUsername write FUsername;
1362
1363    {:password for possible credentials.}
1364    property Password: string read FPassword write FPassword;
1365
1366    {:By this property you can modify default set of SSL/TLS ciphers.}
1367    property Ciphers: string read FCiphers write FCiphers;
1368
1369    {:Used for loading certificate from disk file. See to plugin documentation
1370     if this method is supported and how!}
1371    property CertificateFile: string read FCertificateFile write FCertificateFile;
1372
1373    {:Used for loading private key from disk file. See to plugin documentation
1374     if this method is supported and how!}
1375    property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile;
1376
1377    {:Used for loading certificate from binary string. See to plugin documentation
1378     if this method is supported and how!}
1379    property Certificate: Ansistring read FCertificate write FCertificate;
1380
1381    {:Used for loading private key from binary string. See to plugin documentation
1382     if this method is supported and how!}
1383    property PrivateKey: Ansistring read FPrivateKey write FPrivateKey;
1384
1385    {:Used for loading PFX from binary string. See to plugin documentation
1386     if this method is supported and how!}
1387    property PFX: Ansistring read FPFX write FPFX;
1388
1389    {:Used for loading PFX from disk file. See to plugin documentation
1390     if this method is supported and how!}
1391    property PFXfile: string read FPFXfile write FPFXfile;
1392
1393    {:Used for loading trusted certificates from disk file. See to plugin documentation
1394     if this method is supported and how!}
1395    property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile;
1396
1397    {:Used for loading trusted certificates from binary string. See to plugin documentation
1398     if this method is supported and how!}
1399    property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate;
1400
1401    {:Used for loading CA certificates from binary string. See to plugin documentation
1402     if this method is supported and how!}
1403    property CertCA: Ansistring read FCertCA write FCertCA;
1404
1405    {:Used for loading CA certificates from disk file. See to plugin documentation
1406     if this method is supported and how!}
1407    property CertCAFile: string read FCertCAFile write SetCertCAFile;
1408
1409    {:If @true, then is verified client certificate. (it is good for writing
1410     SSL/TLS servers.) When you are not server, but you are client, then if this
1411     property is @true, verify servers certificate.}
1412    property VerifyCert: Boolean read FVerifyCert write FVerifyCert;
1413
1414    {:channel type for possible SSH connections}
1415    property SSHChannelType: string read FSSHChannelType write FSSHChannelType;
1416
1417    {:First argument of channel type for possible SSH connections}
1418    property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1;
1419
1420    {:Second argument of channel type for possible SSH connections}
1421    property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2;
1422
1423    {: Level of standards compliance level
1424      (CryptLib: values in cryptlib.pas, -1: use default value )  }
1425    property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel;
1426
1427    {:This event is called when verifying the server certificate immediatally after
1428     a successfull verification in the ssl library.}
1429    property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert;
1430
1431    {: Server Name Identification. Host name to send to server. If empty the host name
1432       found in URL will be used, which should be the normal use (http Header Host = SNI Host).
1433       The value is cleared after the connection is established.
1434      (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet )  }
1435    property SNIHost:string read FSNIHost write FSNIHost;
1436  end;
1437
1438  {:@abstract(Default SSL plugin with no SSL support.)
1439   Dummy SSL plugin implementation for applications without SSL/TLS support.}
1440  TSSLNone = class (TCustomSSL)
1441  public
1442    {:See @inherited}
1443    function LibVersion: String; override;
1444    {:See @inherited}
1445    function LibName: String; override;
1446  end;
1447
1448  {:@abstract(Record with definition of IP packet header.)
1449   For reading data from ICMP or RAW sockets.}
1450  TIPHeader = record
1451    VerLen: Byte;
1452    TOS: Byte;
1453    TotalLen: Word;
1454    Identifer: Word;
1455    FragOffsets: Word;
1456    TTL: Byte;
1457    Protocol: Byte;
1458    CheckSum: Word;
1459    SourceIp: LongWord;
1460    DestIp: LongWord;
1461    Options: LongWord;
1462  end;
1463
1464  {:@abstract(Parent class of application protocol implementations.)
1465   By this class is defined common properties.}
1466  TSynaClient = Class(TObject)
1467  protected
1468    FTargetHost: string;
1469    FTargetPort: string;
1470    FIPInterface: string;
1471    FTimeout: integer;
1472    FUserName: string;
1473    FPassword: string;
1474  public
1475    constructor Create;
1476  published
1477    {:Specify terget server IP (or symbolic name). Default is 'localhost'.}
1478    property TargetHost: string read FTargetHost Write FTargetHost;
1479
1480    {:Specify terget server port (or symbolic name).}
1481    property TargetPort: string read FTargetPort Write FTargetPort;
1482
1483    {:Defined local socket address. (outgoing IP address). By default is used
1484     '0.0.0.0' as wildcard for default IP.}
1485    property IPInterface: string read FIPInterface Write FIPInterface;
1486
1487    {:Specify default timeout for socket operations.}
1488    property Timeout: integer read FTimeout Write FTimeout;
1489
1490    {:If protocol need user authorization, then fill here username.}
1491    property UserName: string read FUserName Write FUserName;
1492
1493    {:If protocol need user authorization, then fill here password.}
1494    property Password: string read FPassword Write FPassword;
1495  end;
1496
1497var
1498  {:Selected SSL plugin. Default is @link(TSSLNone).
1499
1500   Do not change this value directly!!!
1501
1502   Just add your plugin unit to your project uses instead. Each plugin unit have
1503   initialization code what modify this variable.}
1504  SSLImplementation: TSSLClass = TSSLNone;
1505
1506implementation
1507
1508{$IFDEF ONCEWINSOCK}
1509var
1510  WsaDataOnce: TWSADATA;
1511  e: ESynapseError;
1512{$ENDIF}
1513
1514
1515constructor TBlockSocket.Create;
1516begin
1517  CreateAlternate('');
1518end;
1519
1520constructor TBlockSocket.CreateAlternate(Stub: string);
1521{$IFNDEF ONCEWINSOCK}
1522var
1523  e: ESynapseError;
1524{$ENDIF}
1525begin
1526  inherited Create;
1527  FDelayedOptions := TList.Create;
1528  FRaiseExcept := False;
1529{$IFDEF RAISEEXCEPT}
1530  FRaiseExcept := True;
1531{$ENDIF}
1532  FSocket := INVALID_SOCKET;
1533  FBuffer := '';
1534  FLastCR := False;
1535  FLastLF := False;
1536  FBinded := False;
1537  FNonBlockMode := False;
1538  FMaxLineLength := 0;
1539  FMaxSendBandwidth := 0;
1540  FNextSend := 0;
1541  FMaxRecvBandwidth := 0;
1542  FNextRecv := 0;
1543  FConvertLineEnd := False;
1544  FFamily := SF_Any;
1545  FFamilySave := SF_Any;
1546  FIP6used := False;
1547  FPreferIP4 := True;
1548  FInterPacketTimeout := True;
1549  FRecvCounter := 0;
1550  FSendCounter := 0;
1551  FSendMaxChunk := c64k;
1552  FStopFlag := False;
1553  FNonblockSendTimeout := 15000;
1554  FHeartbeatRate := 0;
1555  FConnectionTimeout := 0;
1556  FOwner := nil;
1557{$IFNDEF ONCEWINSOCK}
1558  if Stub = '' then
1559    Stub := DLLStackName;
1560  if not InitSocketInterface(Stub) then
1561  begin
1562    e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!');
1563    e.ErrorCode := 0;
1564    e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!';
1565    raise e;
1566  end;
1567  SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce));
1568  ExceptCheck;
1569{$ENDIF}
1570end;
1571
1572destructor TBlockSocket.Destroy;
1573var
1574  n: integer;
1575  p: TSynaOption;
1576begin
1577  CloseSocket;
1578{$IFNDEF ONCEWINSOCK}
1579  synsock.WSACleanup;
1580  DestroySocketInterface;
1581{$ENDIF}
1582  for n := FDelayedOptions.Count - 1 downto 0 do
1583    begin
1584      p := TSynaOption(FDelayedOptions[n]);
1585      p.Free;
1586    end;
1587  FDelayedOptions.Free;
1588  inherited Destroy;
1589end;
1590
1591function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily;
1592begin
1593  case f of
1594    SF_ip4:
1595      Result := AF_INET;
1596    SF_ip6:
1597      Result := AF_INET6;
1598  else
1599    Result := AF_UNSPEC;
1600  end;
1601end;
1602
1603procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption);
1604var
1605  li: TLinger;
1606  x: integer;
1607  buf: TMemory;
1608{$IFNDEF MSWINDOWS}
1609  timeval: TTimeval;
1610{$ENDIF}
1611begin
1612  case value.Option of
1613    SOT_Linger:
1614      begin
1615        {$IFDEF CIL}
1616        li := TLinger.Create(Value.Enabled, Value.Value div 1000);
1617        synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li);
1618        {$ELSE}
1619        li.l_onoff := Ord(Value.Enabled);
1620        li.l_linger := Value.Value div 1000;
1621        buf := @li;
1622        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li));
1623        {$ENDIF}
1624      end;
1625    SOT_RecvBuff:
1626      begin
1627        {$IFDEF CIL}
1628        buf := System.BitConverter.GetBytes(value.Value);
1629        {$ELSE}
1630        buf := @Value.Value;
1631        {$ENDIF}
1632        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF),
1633          buf, SizeOf(Value.Value));
1634      end;
1635    SOT_SendBuff:
1636      begin
1637        {$IFDEF CIL}
1638        buf := System.BitConverter.GetBytes(value.Value);
1639        {$ELSE}
1640        buf := @Value.Value;
1641        {$ENDIF}
1642        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF),
1643          buf, SizeOf(Value.Value));
1644      end;
1645    SOT_NonBlock:
1646      begin
1647        FNonBlockMode := Value.Enabled;
1648        x := Ord(FNonBlockMode);
1649        synsock.IoctlSocket(FSocket, FIONBIO, x);
1650      end;
1651    SOT_RecvTimeout:
1652      begin
1653        {$IFDEF CIL}
1654        buf := System.BitConverter.GetBytes(value.Value);
1655        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1656          buf, SizeOf(Value.Value));
1657        {$ELSE}
1658          {$IFDEF MSWINDOWS}
1659        buf := @Value.Value;
1660        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1661          buf, SizeOf(Value.Value));
1662          {$ELSE}
1663        timeval.tv_sec:=Value.Value div 1000;
1664        timeval.tv_usec:=(Value.Value mod 1000) * 1000;
1665        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
1666          @timeval, SizeOf(timeval));
1667          {$ENDIF}
1668        {$ENDIF}
1669      end;
1670    SOT_SendTimeout:
1671      begin
1672        {$IFDEF CIL}
1673        buf := System.BitConverter.GetBytes(value.Value);
1674        {$ELSE}
1675          {$IFDEF MSWINDOWS}
1676        buf := @Value.Value;
1677        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
1678          buf, SizeOf(Value.Value));
1679          {$ELSE}
1680        timeval.tv_sec:=Value.Value div 1000;
1681        timeval.tv_usec:=(Value.Value mod 1000) * 1000;
1682        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
1683          @timeval, SizeOf(timeval));
1684          {$ENDIF}
1685        {$ENDIF}
1686      end;
1687    SOT_Reuse:
1688      begin
1689        x := Ord(Value.Enabled);
1690        {$IFDEF CIL}
1691        buf := System.BitConverter.GetBytes(x);
1692        {$ELSE}
1693        buf := @x;
1694        {$ENDIF}
1695        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x));
1696      end;
1697    SOT_TTL:
1698      begin
1699        {$IFDEF CIL}
1700        buf := System.BitConverter.GetBytes(value.Value);
1701        {$ELSE}
1702        buf := @Value.Value;
1703        {$ENDIF}
1704        if FIP6Used then
1705          synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS),
1706            buf, SizeOf(Value.Value))
1707        else
1708          synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL),
1709            buf, SizeOf(Value.Value));
1710      end;
1711    SOT_Broadcast:
1712      begin
1713//#todo1 broadcasty na IP6
1714        x := Ord(Value.Enabled);
1715        {$IFDEF CIL}
1716        buf := System.BitConverter.GetBytes(x);
1717        {$ELSE}
1718        buf := @x;
1719        {$ENDIF}
1720        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x));
1721      end;
1722    SOT_MulticastTTL:
1723      begin
1724        {$IFDEF CIL}
1725        buf := System.BitConverter.GetBytes(value.Value);
1726        {$ELSE}
1727        buf := @Value.Value;
1728        {$ENDIF}
1729        if FIP6Used then
1730          synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS),
1731            buf, SizeOf(Value.Value))
1732        else
1733          synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL),
1734            buf, SizeOf(Value.Value));
1735      end;
1736   SOT_MulticastLoop:
1737      begin
1738        x := Ord(Value.Enabled);
1739        {$IFDEF CIL}
1740        buf := System.BitConverter.GetBytes(x);
1741        {$ELSE}
1742        buf := @x;
1743        {$ENDIF}
1744        if FIP6Used then
1745          synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x))
1746        else
1747          synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x));
1748      end;
1749  end;
1750  Value.free;
1751end;
1752
1753procedure TBlockSocket.DelayedOption(const Value: TSynaOption);
1754begin
1755  if FSocket = INVALID_SOCKET then
1756  begin
1757    FDelayedOptions.Insert(0, Value);
1758  end
1759  else
1760    SetDelayedOption(Value);
1761end;
1762
1763procedure TBlockSocket.ProcessDelayedOptions;
1764var
1765  n: integer;
1766  d: TSynaOption;
1767begin
1768  for n := FDelayedOptions.Count - 1 downto 0 do
1769  begin
1770    d := TSynaOption(FDelayedOptions[n]);
1771    SetDelayedOption(d);
1772  end;
1773  FDelayedOptions.Clear;
1774end;
1775
1776procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string);
1777var
1778  f: TSocketFamily;
1779begin
1780  DoStatus(HR_ResolvingBegin, IP + ':' + Port);
1781  ResetLastError;
1782  //if socket exists, then use their type, else use users selection
1783  f := SF_Any;
1784  if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
1785  begin
1786    if IsIP(IP) then
1787      f := SF_IP4
1788    else
1789      if IsIP6(IP) then
1790        f := SF_IP6;
1791  end
1792  else
1793    f := FFamily;
1794  FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f),
1795    GetSocketprotocol, GetSocketType, FPreferIP4);
1796  DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin)));
1797end;
1798
1799function TBlockSocket.GetSinIP(Sin: TVarSin): string;
1800begin
1801  Result := synsock.GetSinIP(sin);
1802end;
1803
1804function TBlockSocket.GetSinPort(Sin: TVarSin): Integer;
1805begin
1806  Result := synsock.GetSinPort(sin);
1807end;
1808
1809procedure TBlockSocket.CreateSocket;
1810var
1811  sin: TVarSin;
1812begin
1813  //dummy for SF_Any Family mode
1814  ResetLastError;
1815  if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
1816  begin
1817    {$IFDEF CIL}
1818    if FFamily = SF_IP6 then
1819      sin := TVarSin.Create(IPAddress.Parse('::0'), 0)
1820    else
1821      sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0);
1822    {$ELSE}
1823    FillChar(Sin, Sizeof(Sin), 0);
1824    if FFamily = SF_IP6 then
1825      sin.sin_family := AF_INET6
1826    else
1827      sin.sin_family := AF_INET;
1828    {$ENDIF}
1829    InternalCreateSocket(Sin);
1830  end;
1831end;
1832
1833procedure TBlockSocket.CreateSocketByName(const Value: String);
1834var
1835  sin: TVarSin;
1836begin
1837  ResetLastError;
1838  if FSocket = INVALID_SOCKET then
1839  begin
1840    SetSin(sin, value, '0');
1841    if FLastError = 0 then
1842      InternalCreateSocket(Sin);
1843  end;
1844end;
1845
1846procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin);
1847begin
1848  FStopFlag := False;
1849  FRecvCounter := 0;
1850  FSendCounter := 0;
1851  ResetLastError;
1852  if FSocket = INVALID_SOCKET then
1853  begin
1854    FBuffer := '';
1855    FBinded := False;
1856    FIP6Used := Sin.AddressFamily = AF_INET6;
1857    FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol);
1858    if FSocket = INVALID_SOCKET then
1859      FLastError := synsock.WSAGetLastError;
1860    {$IFNDEF CIL}
1861    FD_ZERO(FFDSet);
1862    FD_SET(FSocket, FFDSet);
1863    {$ENDIF}
1864    ExceptCheck;
1865    if FIP6used then
1866      DoStatus(HR_SocketCreate, 'IPv6')
1867    else
1868      DoStatus(HR_SocketCreate, 'IPv4');
1869    ProcessDelayedOptions;
1870    DoCreateSocket;
1871  end;
1872end;
1873
1874procedure TBlockSocket.CloseSocket;
1875begin
1876  AbortSocket;
1877end;
1878
1879procedure TBlockSocket.AbortSocket;
1880var
1881  n: integer;
1882  p: TSynaOption;
1883begin
1884  if FSocket <> INVALID_SOCKET then
1885    synsock.CloseSocket(FSocket);
1886  FSocket := INVALID_SOCKET;
1887  for n := FDelayedOptions.Count - 1 downto 0 do
1888    begin
1889      p := TSynaOption(FDelayedOptions[n]);
1890      p.Free;
1891    end;
1892  FDelayedOptions.Clear;
1893  FFamily := FFamilySave;
1894  DoStatus(HR_SocketClose, '');
1895end;
1896
1897procedure TBlockSocket.Bind(IP, Port: string);
1898var
1899  Sin: TVarSin;
1900begin
1901  ResetLastError;
1902  if (FSocket <> INVALID_SOCKET)
1903    or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
1904  begin
1905    SetSin(Sin, IP, Port);
1906    if FLastError = 0 then
1907    begin
1908      if FSocket = INVALID_SOCKET then
1909        InternalCreateSocket(Sin);
1910      SockCheck(synsock.Bind(FSocket, Sin));
1911      GetSinLocal;
1912      FBuffer := '';
1913      FBinded := True;
1914    end;
1915    ExceptCheck;
1916    DoStatus(HR_Bind, IP + ':' + Port);
1917  end;
1918end;
1919
1920procedure TBlockSocket.Connect(IP, Port: string);
1921var
1922  Sin: TVarSin;
1923  b: boolean;
1924begin
1925  SetSin(Sin, IP, Port);
1926  if FLastError = 0 then
1927  begin
1928    if FSocket = INVALID_SOCKET then
1929      InternalCreateSocket(Sin);
1930    if FConnectionTimeout > 0 then
1931    begin
1932      // connect in non-blocking mode
1933      b := NonBlockMode;
1934      NonBlockMode := true;
1935      SockCheck(synsock.Connect(FSocket, Sin));
1936      if (FLastError = WSAEINPROGRESS) OR (FLastError = WSAEWOULDBLOCK) then
1937        if not CanWrite(FConnectionTimeout) then
1938          FLastError := WSAETIMEDOUT;
1939      NonBlockMode := b;
1940    end
1941    else
1942      SockCheck(synsock.Connect(FSocket, Sin));
1943    if FLastError = 0 then
1944      GetSins;
1945    FBuffer := '';
1946    FLastCR := False;
1947    FLastLF := False;
1948  end;
1949  ExceptCheck;
1950  DoStatus(HR_Connect, IP + ':' + Port);
1951end;
1952
1953procedure TBlockSocket.Listen;
1954begin
1955  SockCheck(synsock.Listen(FSocket, SOMAXCONN));
1956  GetSins;
1957  ExceptCheck;
1958  DoStatus(HR_Listen, '');
1959end;
1960
1961function TBlockSocket.Accept: TSocket;
1962begin
1963  Result := synsock.Accept(FSocket, FRemoteSin);
1964///    SockCheck(Result);
1965  ExceptCheck;
1966  DoStatus(HR_Accept, '');
1967end;
1968
1969procedure TBlockSocket.GetSinLocal;
1970begin
1971  synsock.GetSockName(FSocket, FLocalSin);
1972end;
1973
1974procedure TBlockSocket.GetSinRemote;
1975begin
1976  synsock.GetPeerName(FSocket, FRemoteSin);
1977end;
1978
1979procedure TBlockSocket.GetSins;
1980begin
1981  GetSinLocal;
1982  GetSinRemote;
1983end;
1984
1985procedure TBlockSocket.SetBandwidth(Value: Integer);
1986begin
1987  MaxSendBandwidth := Value;
1988  MaxRecvBandwidth := Value;
1989end;
1990
1991procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
1992var
1993  x: LongWord;
1994  y: LongWord;
1995  n: integer;
1996begin
1997  if FStopFlag then
1998    exit;
1999  if MaxB > 0 then
2000  begin
2001    y := GetTick;
2002    if Next > y then
2003    begin
2004      x := Next - y;
2005      if x > 0 then
2006      begin
2007        DoStatus(HR_Wait, IntToStr(x));
2008        sleep(x mod 250);
2009        for n := 1 to x div 250 do
2010          if FStopFlag then
2011            Break
2012          else
2013            sleep(250);
2014      end;
2015    end;
2016    Next := GetTick + Trunc((Length / MaxB) * 1000);
2017  end;
2018end;
2019
2020function TBlockSocket.TestStopFlag: Boolean;
2021begin
2022  DoHeartbeat;
2023  Result := FStopFlag;
2024  if Result then
2025  begin
2026    FStopFlag := False;
2027    FLastError := WSAECONNABORTED;
2028    ExceptCheck;
2029  end;
2030end;
2031
2032
2033function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
2034{$IFNDEF CIL}
2035var
2036  x, y: integer;
2037  l, r: integer;
2038  p: Pointer;
2039{$ENDIF}
2040begin
2041  Result := 0;
2042  if TestStopFlag then
2043    Exit;
2044  DoMonitor(True, Buffer, Length);
2045{$IFDEF CIL}
2046  Result := synsock.Send(FSocket, Buffer, Length, 0);
2047{$ELSE}
2048  l := Length;
2049  x := 0;
2050  while x < l do
2051  begin
2052    y := l - x;
2053    if y > FSendMaxChunk then
2054      y := FSendMaxChunk;
2055    if y > 0 then
2056    begin
2057      LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
2058      p := IncPoint(Buffer, x);
2059      r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
2060      SockCheck(r);
2061      if FLastError = WSAEWOULDBLOCK then
2062      begin
2063        if CanWrite(FNonblockSendTimeout) then
2064        begin
2065          r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
2066          SockCheck(r);
2067        end
2068        else
2069          FLastError := WSAETIMEDOUT;
2070      end;
2071      if FLastError <> 0 then
2072        Break;
2073      Inc(x, r);
2074      Inc(Result, r);
2075      Inc(FSendCounter, r);
2076      DoStatus(HR_WriteCount, IntToStr(r));
2077    end
2078    else
2079      break;
2080  end;
2081{$ENDIF}
2082  ExceptCheck;
2083end;
2084
2085procedure TBlockSocket.SendByte(Data: Byte);
2086{$IFDEF CIL}
2087var
2088  buf: TMemory;
2089{$ENDIF}
2090begin
2091{$IFDEF CIL}
2092  setlength(buf, 1);
2093  buf[0] := Data;
2094  SendBuffer(buf, 1);
2095{$ELSE}
2096  SendBuffer(@Data, 1);
2097{$ENDIF}
2098end;
2099
2100procedure TBlockSocket.SendString(Data: AnsiString);
2101var
2102  buf: TMemory;
2103begin
2104  {$IFDEF CIL}
2105  buf := BytesOf(Data);
2106  {$ELSE}
2107  buf := Pointer(data);
2108  {$ENDIF}
2109  SendBuffer(buf, Length(Data));
2110end;
2111
2112procedure TBlockSocket.SendInteger(Data: integer);
2113var
2114  buf: TMemory;
2115begin
2116  {$IFDEF CIL}
2117  buf := System.BitConverter.GetBytes(Data);
2118  {$ELSE}
2119  buf := @Data;
2120  {$ENDIF}
2121  SendBuffer(buf, SizeOf(Data));
2122end;
2123
2124procedure TBlockSocket.SendBlock(const Data: AnsiString);
2125var
2126  i: integer;
2127begin
2128  i := SwapBytes(Length(data));
2129  SendString(Codelongint(i) + Data);
2130end;
2131
2132procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean);
2133var
2134  l: integer;
2135  yr: integer;
2136  s: AnsiString;
2137  b: boolean;
2138{$IFDEF CIL}
2139  buf: TMemory;
2140{$ENDIF}
2141begin
2142  b := true;
2143  l := 0;
2144  if WithSize then
2145  begin
2146    l := Stream.Size - Stream.Position;;
2147    if not Indy then
2148      l := synsock.HToNL(l);
2149  end;
2150  repeat
2151    {$IFDEF CIL}
2152    Setlength(buf, FSendMaxChunk);
2153    yr := Stream.read(buf, FSendMaxChunk);
2154    if yr > 0 then
2155    begin
2156      if WithSize and b then
2157      begin
2158        b := false;
2159        SendString(CodeLongInt(l));
2160      end;
2161      SendBuffer(buf, yr);
2162      if FLastError <> 0 then
2163        break;
2164    end
2165    {$ELSE}
2166    Setlength(s, FSendMaxChunk);
2167    yr := Stream.read(Pointer(s)^, FSendMaxChunk);
2168    if yr > 0 then
2169    begin
2170      SetLength(s, yr);
2171      if WithSize and b then
2172      begin
2173        b := false;
2174        SendString(CodeLongInt(l) + s);
2175      end
2176      else
2177        SendString(s);
2178      if FLastError <> 0 then
2179        break;
2180    end
2181    {$ENDIF}
2182  until yr <= 0;
2183end;
2184
2185procedure TBlockSocket.SendStreamRaw(const Stream: TStream);
2186begin
2187  InternalSendStream(Stream, false, false);
2188end;
2189
2190procedure TBlockSocket.SendStreamIndy(const Stream: TStream);
2191begin
2192  InternalSendStream(Stream, true, true);
2193end;
2194
2195procedure TBlockSocket.SendStream(const Stream: TStream);
2196begin
2197  InternalSendStream(Stream, true, false);
2198end;
2199
2200function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
2201begin
2202  Result := 0;
2203  if TestStopFlag then
2204    Exit;
2205  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
2206//  Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL);
2207  Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL);
2208  if Result = 0 then
2209    FLastError := WSAECONNRESET
2210  else
2211    SockCheck(Result);
2212  ExceptCheck;
2213  if Result > 0 then
2214  begin
2215    Inc(FRecvCounter, Result);
2216    DoStatus(HR_ReadCount, IntToStr(Result));
2217    DoMonitor(False, Buffer, Result);
2218    DoReadFilter(Buffer, Result);
2219  end;
2220end;
2221
2222function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer;
2223  Timeout: Integer): Integer;
2224var
2225  s: AnsiString;
2226  rl, l: integer;
2227  ti: LongWord;
2228{$IFDEF CIL}
2229  n: integer;
2230  b: TMemory;
2231{$ENDIF}
2232begin
2233  ResetLastError;
2234  Result := 0;
2235  if Len > 0 then
2236  begin
2237    rl := 0;
2238    repeat
2239      ti := GetTick;
2240      s := RecvPacket(Timeout);
2241      l := Length(s);
2242      if (rl + l) > Len then
2243        l := Len - rl;
2244      {$IFDEF CIL}
2245      b := BytesOf(s);
2246      for n := 0 to l do
2247        Buffer[rl + n] := b[n];
2248      {$ELSE}
2249      Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
2250      {$ENDIF}
2251      rl := rl + l;
2252      if FLastError <> 0 then
2253        Break;
2254      if rl >= Len then
2255        Break;
2256      if not FInterPacketTimeout then
2257      begin
2258        Timeout := Timeout - integer(TickDelta(ti, GetTick));
2259        if Timeout <= 0 then
2260        begin
2261          FLastError := WSAETIMEDOUT;
2262          Break;
2263        end;
2264      end;
2265    until False;
2266    delete(s, 1, l);
2267    FBuffer := s;
2268    Result := rl;
2269  end;
2270end;
2271
2272function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString;
2273var
2274  x: integer;
2275{$IFDEF CIL}
2276  buf: Tmemory;
2277{$ENDIF}
2278begin
2279  Result := '';
2280  if Len > 0 then
2281  begin
2282    {$IFDEF CIL}
2283    Setlength(Buf, Len);
2284    x := RecvBufferEx(buf, Len , Timeout);
2285    if FLastError = 0 then
2286    begin
2287      SetLength(Buf, x);
2288      Result := StringOf(buf);
2289    end
2290    else
2291      Result := '';
2292    {$ELSE}
2293    Setlength(Result, Len);
2294    x := RecvBufferEx(Pointer(Result), Len , Timeout);
2295    if FLastError = 0 then
2296      SetLength(Result, x)
2297    else
2298      Result := '';
2299    {$ENDIF}
2300  end;
2301end;
2302
2303function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString;
2304var
2305  x: integer;
2306{$IFDEF CIL}
2307  buf: TMemory;
2308{$ENDIF}
2309begin
2310  Result := '';
2311  ResetLastError;
2312  if FBuffer <> '' then
2313  begin
2314    Result := FBuffer;
2315    FBuffer := '';
2316  end
2317  else
2318  begin
2319    {$IFDEF MSWINDOWS}
2320    //not drain CPU on large downloads...
2321    Sleep(0);
2322    {$ENDIF}
2323    x := WaitingData;
2324    if x > 0 then
2325    begin
2326      {$IFDEF CIL}
2327      SetLength(Buf, x);
2328      x := RecvBuffer(Buf, x);
2329      if x >= 0 then
2330      begin
2331        SetLength(Buf, x);
2332        Result := StringOf(Buf);
2333      end;
2334      {$ELSE}
2335      SetLength(Result, x);
2336      x := RecvBuffer(Pointer(Result), x);
2337      if x >= 0 then
2338        SetLength(Result, x);
2339      {$ENDIF}
2340    end
2341    else
2342    begin
2343      if CanRead(Timeout) then
2344      begin
2345        x := WaitingData;
2346        if x = 0 then
2347          FLastError := WSAECONNRESET;
2348        if x > 0 then
2349        begin
2350          {$IFDEF CIL}
2351          SetLength(Buf, x);
2352          x := RecvBuffer(Buf, x);
2353          if x >= 0 then
2354          begin
2355            SetLength(Buf, x);
2356            result := StringOf(Buf);
2357          end;
2358          {$ELSE}
2359          SetLength(Result, x);
2360          x := RecvBuffer(Pointer(Result), x);
2361          if x >= 0 then
2362            SetLength(Result, x);
2363          {$ENDIF}
2364        end;
2365      end
2366      else
2367        FLastError := WSAETIMEDOUT;
2368    end;
2369  end;
2370  if FConvertLineEnd and (Result <> '') then
2371  begin
2372    if FLastCR and (Result[1] = LF) then
2373      Delete(Result, 1, 1);
2374    if FLastLF and (Result[1] = CR) then
2375      Delete(Result, 1, 1);
2376    FLastCR := False;
2377    FLastLF := False;
2378  end;
2379  ExceptCheck;
2380end;
2381
2382
2383function TBlockSocket.RecvByte(Timeout: Integer): Byte;
2384begin
2385  Result := 0;
2386  ResetLastError;
2387  if FBuffer = '' then
2388    FBuffer := RecvPacket(Timeout);
2389  if (FLastError = 0) and (FBuffer <> '') then
2390  begin
2391    Result := Ord(FBuffer[1]);
2392    Delete(FBuffer, 1, 1);
2393  end;
2394  ExceptCheck;
2395end;
2396
2397function TBlockSocket.RecvInteger(Timeout: Integer): Integer;
2398var
2399  s: AnsiString;
2400begin
2401  Result := 0;
2402  s := RecvBufferStr(4, Timeout);
2403  if FLastError = 0 then
2404    Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
2405end;
2406
2407function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
2408var
2409  x: Integer;
2410  s: AnsiString;
2411  l: Integer;
2412  CorCRLF: Boolean;
2413  t: AnsiString;
2414  tl: integer;
2415  ti: LongWord;
2416begin
2417  ResetLastError;
2418  Result := '';
2419  l := Length(Terminator);
2420  if l = 0 then
2421    Exit;
2422  tl := l;
2423  CorCRLF := FConvertLineEnd and (Terminator = CRLF);
2424  s := '';
2425  x := 0;
2426  repeat
2427    //get rest of FBuffer or incomming new data...
2428    ti := GetTick;
2429    s := s + RecvPacket(Timeout);
2430    if FLastError <> 0 then
2431      Break;
2432    x := 0;
2433    if Length(s) > 0 then
2434      if CorCRLF then
2435      begin
2436        t := '';
2437        x := PosCRLF(s, t);
2438        tl := Length(t);
2439        if t = CR then
2440          FLastCR := True;
2441        if t = LF then
2442          FLastLF := True;
2443      end
2444      else
2445      begin
2446        x := pos(Terminator, s);
2447        tl := l;
2448      end;
2449    if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then
2450    begin
2451      FLastError := WSAENOBUFS;
2452      Break;
2453    end;
2454    if x > 0 then
2455      Break;
2456    if not FInterPacketTimeout then
2457    begin
2458      Timeout := Timeout - integer(TickDelta(ti, GetTick));
2459      if Timeout <= 0 then
2460      begin
2461        FLastError := WSAETIMEDOUT;
2462        Break;
2463      end;
2464    end;
2465  until False;
2466  if x > 0 then
2467  begin
2468    Result := Copy(s, 1, x - 1);
2469    Delete(s, 1, x + tl - 1);
2470  end;
2471  FBuffer := s;
2472  ExceptCheck;
2473end;
2474
2475function TBlockSocket.RecvString(Timeout: Integer): AnsiString;
2476var
2477  s: AnsiString;
2478begin
2479  Result := '';
2480  s := RecvTerminated(Timeout, CRLF);
2481  if FLastError = 0 then
2482    Result := s;
2483end;
2484
2485function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString;
2486var
2487  x: integer;
2488begin
2489  Result := '';
2490  x := RecvInteger(Timeout);
2491  if FLastError = 0 then
2492    Result := RecvBufferStr(x, Timeout);
2493end;
2494
2495procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
2496var
2497  s: AnsiString;
2498begin
2499  repeat
2500    s := RecvPacket(Timeout);
2501    if FLastError = 0 then
2502      WriteStrToStream(Stream, s);
2503  until FLastError <> 0;
2504end;
2505
2506procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
2507var
2508  s: AnsiString;
2509  n: integer;
2510{$IFDEF CIL}
2511  buf: TMemory;
2512{$ENDIF}
2513begin
2514  for n := 1 to (Size div FSendMaxChunk) do
2515  begin
2516    {$IFDEF CIL}
2517    SetLength(buf, FSendMaxChunk);
2518    RecvBufferEx(buf, FSendMaxChunk, Timeout);
2519    if FLastError <> 0 then
2520      Exit;
2521    Stream.Write(buf, FSendMaxChunk);
2522    {$ELSE}
2523    s := RecvBufferStr(FSendMaxChunk, Timeout);
2524    if FLastError <> 0 then
2525      Exit;
2526    WriteStrToStream(Stream, s);
2527    {$ENDIF}
2528  end;
2529  n := Size mod FSendMaxChunk;
2530  if n > 0 then
2531  begin
2532    {$IFDEF CIL}
2533    SetLength(buf, n);
2534    RecvBufferEx(buf, n, Timeout);
2535    if FLastError <> 0 then
2536      Exit;
2537    Stream.Write(buf, n);
2538    {$ELSE}
2539    s := RecvBufferStr(n, Timeout);
2540    if FLastError <> 0 then
2541      Exit;
2542    WriteStrToStream(Stream, s);
2543    {$ENDIF}
2544  end;
2545end;
2546
2547procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
2548var
2549  x: integer;
2550begin
2551  x := RecvInteger(Timeout);
2552  x := synsock.NToHL(x);
2553  if FLastError = 0 then
2554    RecvStreamSize(Stream, Timeout, x);
2555end;
2556
2557procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer);
2558var
2559  x: integer;
2560begin
2561  x := RecvInteger(Timeout);
2562  if FLastError = 0 then
2563    RecvStreamSize(Stream, Timeout, x);
2564end;
2565
2566function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer;
2567begin
2568 {$IFNDEF CIL}
2569//  Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL);
2570  Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL);
2571  SockCheck(Result);
2572  ExceptCheck;
2573  {$ENDIF}
2574end;
2575
2576function TBlockSocket.PeekByte(Timeout: Integer): Byte;
2577var
2578  s: string;
2579begin
2580 {$IFNDEF CIL}
2581  Result := 0;
2582  if CanRead(Timeout) then
2583  begin
2584    SetLength(s, 1);
2585    PeekBuffer(Pointer(s), 1);
2586    if s <> '' then
2587      Result := Ord(s[1]);
2588  end
2589  else
2590    FLastError := WSAETIMEDOUT;
2591  ExceptCheck;
2592  {$ENDIF}
2593end;
2594
2595procedure TBlockSocket.ResetLastError;
2596begin
2597  FLastError := 0;
2598  FLastErrorDesc := '';
2599end;
2600
2601function TBlockSocket.SockCheck(SockResult: Integer): Integer;
2602begin
2603  ResetLastError;
2604  if SockResult = integer(SOCKET_ERROR) then
2605  begin
2606    FLastError := synsock.WSAGetLastError;
2607    FLastErrorDesc := GetErrorDescEx;
2608  end;
2609  Result := FLastError;
2610end;
2611
2612procedure TBlockSocket.ExceptCheck;
2613var
2614  e: ESynapseError;
2615begin
2616  FLastErrorDesc := GetErrorDescEx;
2617  if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
2618    and (LastError <> WSAEWOULDBLOCK) then
2619  begin
2620    DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc);
2621    if FRaiseExcept then
2622    begin
2623      e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s',
2624        [FLastError, FLastErrorDesc]));
2625      e.ErrorCode := FLastError;
2626      e.ErrorMessage := FLastErrorDesc;
2627      raise e;
2628    end;
2629  end;
2630end;
2631
2632function TBlockSocket.WaitingData: Integer;
2633var
2634  x: Integer;
2635begin
2636  Result := 0;
2637  if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then
2638    Result := x;
2639  if Result > c64k then
2640    Result := c64k;
2641end;
2642
2643function TBlockSocket.WaitingDataEx: Integer;
2644begin
2645  if FBuffer <> '' then
2646    Result := Length(FBuffer)
2647  else
2648    Result := WaitingData;
2649end;
2650
2651procedure TBlockSocket.Purge;
2652begin
2653  Sleep(1);
2654  try
2655    while (Length(FBuffer) > 0) or (WaitingData > 0) do
2656    begin
2657      RecvPacket(0);
2658      if FLastError <> 0 then
2659        break;
2660    end;
2661  except
2662    on exception do;
2663  end;
2664  ResetLastError;
2665end;
2666
2667procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
2668var
2669  d: TSynaOption;
2670begin
2671  d := TSynaOption.Create;
2672  d.Option := SOT_Linger;
2673  d.Enabled := Enable;
2674  d.Value := Linger;
2675  DelayedOption(d);
2676end;
2677
2678function TBlockSocket.LocalName: string;
2679begin
2680  Result := synsock.GetHostName;
2681  if Result = '' then
2682    Result := '127.0.0.1';
2683end;
2684
2685procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings);
2686begin
2687  IPList.Clear;
2688  synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList);
2689  if IPList.Count = 0 then
2690    IPList.Add(cAnyHost);
2691end;
2692
2693function TBlockSocket.ResolveName(Name: string): string;
2694var
2695  l: TStringList;
2696begin
2697  l := TStringList.Create;
2698  try
2699    ResolveNameToIP(Name, l);
2700    Result := l[0];
2701  finally
2702    l.Free;
2703  end;
2704end;
2705
2706function TBlockSocket.ResolvePort(Port: string): Word;
2707begin
2708  Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
2709end;
2710
2711function TBlockSocket.ResolveIPToName(IP: string): string;
2712begin
2713  if not IsIP(IP) and not IsIp6(IP) then
2714    IP := ResolveName(IP);
2715  Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
2716end;
2717
2718procedure TBlockSocket.SetRemoteSin(IP, Port: string);
2719begin
2720  SetSin(FRemoteSin, IP, Port);
2721end;
2722
2723function TBlockSocket.GetLocalSinIP: string;
2724begin
2725  Result := GetSinIP(FLocalSin);
2726end;
2727
2728function TBlockSocket.GetRemoteSinIP: string;
2729begin
2730  Result := GetSinIP(FRemoteSin);
2731end;
2732
2733function TBlockSocket.GetLocalSinPort: Integer;
2734begin
2735  Result := GetSinPort(FLocalSin);
2736end;
2737
2738function TBlockSocket.GetRemoteSinPort: Integer;
2739begin
2740  Result := GetSinPort(FRemoteSin);
2741end;
2742
2743function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
2744{$IFDEF CIL}
2745begin
2746  Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
2747{$ELSE}
2748var
2749  TimeVal: PTimeVal;
2750  TimeV: TTimeVal;
2751  x: Integer;
2752  FDSet: TFDSet;
2753begin
2754  TimeV.tv_usec := (Timeout mod 1000) * 1000;
2755  TimeV.tv_sec := Timeout div 1000;
2756  TimeVal := @TimeV;
2757  if Timeout = -1 then
2758    TimeVal := nil;
2759  FDSet := FFdSet;
2760  x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal);
2761  SockCheck(x);
2762  if FLastError <> 0 then
2763    x := 0;
2764  Result := x > 0;
2765{$ENDIF}
2766end;
2767
2768function TBlockSocket.CanRead(Timeout: Integer): Boolean;
2769var
2770  ti, tr: Integer;
2771  n: integer;
2772begin
2773  if (FHeartbeatRate <> 0) and (Timeout <> -1) then
2774  begin
2775    ti := Timeout div FHeartbeatRate;
2776    tr := Timeout mod FHeartbeatRate;
2777  end
2778  else
2779  begin
2780    ti := 0;
2781    tr := Timeout;
2782  end;
2783  Result := InternalCanRead(tr);
2784  if not Result then
2785    for n := 0 to ti do
2786    begin
2787      DoHeartbeat;
2788      if FStopFlag then
2789      begin
2790        Result := False;
2791        FStopFlag := False;
2792        Break;
2793      end;
2794      Result := InternalCanRead(FHeartbeatRate);
2795      if Result then
2796        break;
2797    end;
2798  ExceptCheck;
2799  if Result then
2800    DoStatus(HR_CanRead, '');
2801end;
2802
2803function TBlockSocket.CanWrite(Timeout: Integer): Boolean;
2804{$IFDEF CIL}
2805begin
2806  Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite);
2807{$ELSE}
2808var
2809  TimeVal: PTimeVal;
2810  TimeV: TTimeVal;
2811  x: Integer;
2812  FDSet: TFDSet;
2813begin
2814  TimeV.tv_usec := (Timeout mod 1000) * 1000;
2815  TimeV.tv_sec := Timeout div 1000;
2816  TimeVal := @TimeV;
2817  if Timeout = -1 then
2818    TimeVal := nil;
2819  FDSet := FFdSet;
2820  x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal);
2821  SockCheck(x);
2822  if FLastError <> 0 then
2823    x := 0;
2824  Result := x > 0;
2825{$ENDIF}
2826  ExceptCheck;
2827  if Result then
2828    DoStatus(HR_CanWrite, '');
2829end;
2830
2831function TBlockSocket.CanReadEx(Timeout: Integer): Boolean;
2832begin
2833  if FBuffer <> '' then
2834    Result := True
2835  else
2836    Result := CanRead(Timeout);
2837end;
2838
2839function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
2840begin
2841  Result := 0;
2842  if TestStopFlag then
2843    Exit;
2844  DoMonitor(True, Buffer, Length);
2845  LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
2846  Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
2847  SockCheck(Result);
2848  ExceptCheck;
2849  Inc(FSendCounter, Result);
2850  DoStatus(HR_WriteCount, IntToStr(Result));
2851end;
2852
2853function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
2854begin
2855  Result := 0;
2856  if TestStopFlag then
2857    Exit;
2858  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
2859  Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
2860  SockCheck(Result);
2861  ExceptCheck;
2862  Inc(FRecvCounter, Result);
2863  DoStatus(HR_ReadCount, IntToStr(Result));
2864  DoMonitor(False, Buffer, Result);
2865end;
2866
2867function TBlockSocket.GetSizeRecvBuffer: Integer;
2868var
2869  l: Integer;
2870{$IFDEF CIL}
2871  buf: TMemory;
2872{$ENDIF}
2873begin
2874{$IFDEF CIL}
2875  setlength(buf, 4);
2876  SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l));
2877  Result := System.BitConverter.ToInt32(buf,0);
2878{$ELSE}
2879  l := SizeOf(Result);
2880  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l));
2881  if FLastError <> 0 then
2882    Result := 1024;
2883  ExceptCheck;
2884{$ENDIF}
2885end;
2886
2887procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer);
2888var
2889  d: TSynaOption;
2890begin
2891  d := TSynaOption.Create;
2892  d.Option := SOT_RecvBuff;
2893  d.Value := Size;
2894  DelayedOption(d);
2895end;
2896
2897function TBlockSocket.GetSizeSendBuffer: Integer;
2898var
2899  l: Integer;
2900{$IFDEF CIL}
2901  buf: TMemory;
2902{$ENDIF}
2903begin
2904{$IFDEF CIL}
2905  setlength(buf, 4);
2906  SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l));
2907  Result := System.BitConverter.ToInt32(buf,0);
2908{$ELSE}
2909  l := SizeOf(Result);
2910  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l));
2911  if FLastError <> 0 then
2912    Result := 1024;
2913  ExceptCheck;
2914{$ENDIF}
2915end;
2916
2917procedure TBlockSocket.SetSizeSendBuffer(Size: Integer);
2918var
2919  d: TSynaOption;
2920begin
2921  d := TSynaOption.Create;
2922  d.Option := SOT_SendBuff;
2923  d.Value := Size;
2924  DelayedOption(d);
2925end;
2926
2927procedure TBlockSocket.SetNonBlockMode(Value: Boolean);
2928var
2929  d: TSynaOption;
2930begin
2931  d := TSynaOption.Create;
2932  d.Option := SOT_nonblock;
2933  d.Enabled := Value;
2934  DelayedOption(d);
2935end;
2936
2937procedure TBlockSocket.SetTimeout(Timeout: Integer);
2938begin
2939  SetSendTimeout(Timeout);
2940  SetRecvTimeout(Timeout);
2941end;
2942
2943procedure TBlockSocket.SetSendTimeout(Timeout: Integer);
2944var
2945  d: TSynaOption;
2946begin
2947  d := TSynaOption.Create;
2948  d.Option := SOT_sendtimeout;
2949  d.Value := Timeout;
2950  DelayedOption(d);
2951end;
2952
2953procedure TBlockSocket.SetRecvTimeout(Timeout: Integer);
2954var
2955  d: TSynaOption;
2956begin
2957  d := TSynaOption.Create;
2958  d.Option := SOT_recvtimeout;
2959  d.Value := Timeout;
2960  DelayedOption(d);
2961end;
2962
2963{$IFNDEF CIL}
2964function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer;
2965  const CanReadList: TList): boolean;
2966var
2967  FDSet: TFDSet;
2968  TimeVal: PTimeVal;
2969  TimeV: TTimeVal;
2970  x, n: Integer;
2971  Max: Integer;
2972begin
2973  TimeV.tv_usec := (Timeout mod 1000) * 1000;
2974  TimeV.tv_sec := Timeout div 1000;
2975  TimeVal := @TimeV;
2976  if Timeout = -1 then
2977    TimeVal := nil;
2978  FD_ZERO(FDSet);
2979  Max := 0;
2980  for n := 0 to SocketList.Count - 1 do
2981    if TObject(SocketList.Items[n]) is TBlockSocket then
2982    begin
2983      if TBlockSocket(SocketList.Items[n]).Socket > Max then
2984        Max := TBlockSocket(SocketList.Items[n]).Socket;
2985      FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet);
2986    end;
2987  x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal);
2988  SockCheck(x);
2989  ExceptCheck;
2990  if FLastError <> 0 then
2991    x := 0;
2992  Result := x > 0;
2993  CanReadList.Clear;
2994  if Result then
2995    for n := 0 to SocketList.Count - 1 do
2996      if TObject(SocketList.Items[n]) is TBlockSocket then
2997        if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then
2998          CanReadList.Add(TBlockSocket(SocketList.Items[n]));
2999end;
3000{$ENDIF}
3001
3002procedure TBlockSocket.EnableReuse(Value: Boolean);
3003var
3004  d: TSynaOption;
3005begin
3006  d := TSynaOption.Create;
3007  d.Option := SOT_reuse;
3008  d.Enabled := Value;
3009  DelayedOption(d);
3010end;
3011
3012procedure TBlockSocket.SetTTL(TTL: integer);
3013var
3014  d: TSynaOption;
3015begin
3016  d := TSynaOption.Create;
3017  d.Option := SOT_TTL;
3018  d.Value := TTL;
3019  DelayedOption(d);
3020end;
3021
3022function TBlockSocket.GetTTL:integer;
3023var
3024  l: Integer;
3025begin
3026{$IFNDEF CIL}
3027  l := SizeOf(Result);
3028  if FIP6Used then
3029    synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l)
3030  else
3031    synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l);
3032{$ENDIF}
3033end;
3034
3035procedure TBlockSocket.SetFamily(Value: TSocketFamily);
3036begin
3037  FFamily := Value;
3038  FFamilySave := Value;
3039end;
3040
3041procedure TBlockSocket.SetSocket(Value: TSocket);
3042begin
3043  FRecvCounter := 0;
3044  FSendCounter := 0;
3045  FSocket := Value;
3046{$IFNDEF CIL}
3047  FD_ZERO(FFDSet);
3048  FD_SET(FSocket, FFDSet);
3049{$ENDIF}
3050  GetSins;
3051  FIP6Used := FRemoteSin.AddressFamily = AF_INET6;
3052end;
3053
3054function TBlockSocket.GetWsaData: TWSAData;
3055begin
3056  {$IFDEF ONCEWINSOCK}
3057  Result := WsaDataOnce;
3058  {$ELSE}
3059  Result := FWsaDataOnce;
3060  {$ENDIF}
3061end;
3062
3063function TBlockSocket.GetSocketType: integer;
3064begin
3065  Result := 0;
3066end;
3067
3068function TBlockSocket.GetSocketProtocol: integer;
3069begin
3070  Result := integer(IPPROTO_IP);
3071end;
3072
3073procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
3074begin
3075  if assigned(OnStatus) then
3076    OnStatus(Self, Reason, Value);
3077end;
3078
3079procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer);
3080var
3081  s: AnsiString;
3082begin
3083  if assigned(OnReadFilter) then
3084    if Len > 0 then
3085      begin
3086        {$IFDEF CIL}
3087        s := StringOf(Buffer);
3088        {$ELSE}
3089        SetLength(s, Len);
3090        Move(Buffer^, Pointer(s)^, Len);
3091        {$ENDIF}
3092        OnReadFilter(Self, s);
3093        if Length(s) > Len then
3094          SetLength(s, Len);
3095        Len := Length(s);
3096        {$IFDEF CIL}
3097        Buffer := BytesOf(s);
3098        {$ELSE}
3099        Move(Pointer(s)^, Buffer^, Len);
3100        {$ENDIF}
3101      end;
3102end;
3103
3104procedure TBlockSocket.DoCreateSocket;
3105begin
3106  if assigned(OnCreateSocket) then
3107    OnCreateSocket(Self);
3108end;
3109
3110procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
3111begin
3112  if assigned(OnMonitor) then
3113  begin
3114    OnMonitor(Self, Writing, Buffer, Len);
3115  end;
3116end;
3117
3118procedure TBlockSocket.DoHeartbeat;
3119begin
3120  if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then
3121  begin
3122    OnHeartbeat(Self);
3123  end;
3124end;
3125
3126function TBlockSocket.GetErrorDescEx: string;
3127begin
3128  Result := GetErrorDesc(FLastError);
3129end;
3130
3131class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
3132begin
3133{$IFDEF CIL}
3134  if ErrorCode = 0 then
3135    Result := ''
3136  else
3137  begin
3138    Result := WSAGetLastErrorDesc;
3139    if Result = '' then
3140      Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
3141  end;
3142{$ELSE}
3143  case ErrorCode of
3144    0:
3145      Result := '';
3146    WSAEINTR: {10004}
3147      Result := 'Interrupted system call';
3148    WSAEBADF: {10009}
3149      Result := 'Bad file number';
3150    WSAEACCES: {10013}
3151      Result := 'Permission denied';
3152    WSAEFAULT: {10014}
3153      Result := 'Bad address';
3154    WSAEINVAL: {10022}
3155      Result := 'Invalid argument';
3156    WSAEMFILE: {10024}
3157      Result := 'Too many open files';
3158    WSAEWOULDBLOCK: {10035}
3159      Result := 'Operation would block';
3160    WSAEINPROGRESS: {10036}
3161      Result := 'Operation now in progress';
3162    WSAEALREADY: {10037}
3163      Result := 'Operation already in progress';
3164    WSAENOTSOCK: {10038}
3165      Result := 'Socket operation on nonsocket';
3166    WSAEDESTADDRREQ: {10039}
3167      Result := 'Destination address required';
3168    WSAEMSGSIZE: {10040}
3169      Result := 'Message too long';
3170    WSAEPROTOTYPE: {10041}
3171      Result := 'Protocol wrong type for Socket';
3172    WSAENOPROTOOPT: {10042}
3173      Result := 'Protocol not available';
3174    WSAEPROTONOSUPPORT: {10043}
3175      Result := 'Protocol not supported';
3176    WSAESOCKTNOSUPPORT: {10044}
3177      Result := 'Socket not supported';
3178    WSAEOPNOTSUPP: {10045}
3179      Result := 'Operation not supported on Socket';
3180    WSAEPFNOSUPPORT: {10046}
3181      Result := 'Protocol family not supported';
3182    WSAEAFNOSUPPORT: {10047}
3183      Result := 'Address family not supported';
3184    WSAEADDRINUSE: {10048}
3185      Result := 'Address already in use';
3186    WSAEADDRNOTAVAIL: {10049}
3187      Result := 'Can''t assign requested address';
3188    WSAENETDOWN: {10050}
3189      Result := 'Network is down';
3190    WSAENETUNREACH: {10051}
3191      Result := 'Network is unreachable';
3192    WSAENETRESET: {10052}
3193      Result := 'Network dropped connection on reset';
3194    WSAECONNABORTED: {10053}
3195      Result := 'Software caused connection abort';
3196    WSAECONNRESET: {10054}
3197      Result := 'Connection reset by peer';
3198    WSAENOBUFS: {10055}
3199      Result := 'No Buffer space available';
3200    WSAEISCONN: {10056}
3201      Result := 'Socket is already connected';
3202    WSAENOTCONN: {10057}
3203      Result := 'Socket is not connected';
3204    WSAESHUTDOWN: {10058}
3205      Result := 'Can''t send after Socket shutdown';
3206    WSAETOOMANYREFS: {10059}
3207      Result := 'Too many references:can''t splice';
3208    WSAETIMEDOUT: {10060}
3209      Result := 'Connection timed out';
3210    WSAECONNREFUSED: {10061}
3211      Result := 'Connection refused';
3212    WSAELOOP: {10062}
3213      Result := 'Too many levels of symbolic links';
3214    WSAENAMETOOLONG: {10063}
3215      Result := 'File name is too long';
3216    WSAEHOSTDOWN: {10064}
3217      Result := 'Host is down';
3218    WSAEHOSTUNREACH: {10065}
3219      Result := 'No route to host';
3220    WSAENOTEMPTY: {10066}
3221      Result := 'Directory is not empty';
3222    WSAEPROCLIM: {10067}
3223      Result := 'Too many processes';
3224    WSAEUSERS: {10068}
3225      Result := 'Too many users';
3226    WSAEDQUOT: {10069}
3227      Result := 'Disk quota exceeded';
3228    WSAESTALE: {10070}
3229      Result := 'Stale NFS file handle';
3230    WSAEREMOTE: {10071}
3231      Result := 'Too many levels of remote in path';
3232    WSASYSNOTREADY: {10091}
3233      Result := 'Network subsystem is unusable';
3234    WSAVERNOTSUPPORTED: {10092}
3235      Result := 'Winsock DLL cannot support this application';
3236    WSANOTINITIALISED: {10093}
3237      Result := 'Winsock not initialized';
3238    WSAEDISCON: {10101}
3239      Result := 'Disconnect';
3240    WSAHOST_NOT_FOUND: {11001}
3241      Result := 'Host not found';
3242    WSATRY_AGAIN: {11002}
3243      Result := 'Non authoritative - host not found';
3244    WSANO_RECOVERY: {11003}
3245      Result := 'Non recoverable error';
3246    WSANO_DATA: {11004}
3247      Result := 'Valid name, no data record of requested type'
3248  else
3249    Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
3250  end;
3251{$ENDIF}
3252end;
3253
3254{======================================================================}
3255
3256constructor TSocksBlockSocket.Create;
3257begin
3258  inherited Create;
3259  FSocksIP:= '';
3260  FSocksPort:= '1080';
3261  FSocksTimeout:= 60000;
3262  FSocksUsername:= '';
3263  FSocksPassword:= '';
3264  FUsingSocks := False;
3265  FSocksResolver := True;
3266  FSocksLastError := 0;
3267  FSocksResponseIP := '';
3268  FSocksResponsePort := '';
3269  FSocksLocalIP := '';
3270  FSocksLocalPort := '';
3271  FSocksRemoteIP := '';
3272  FSocksRemotePort := '';
3273  FBypassFlag := False;
3274  FSocksType := ST_Socks5;
3275end;
3276
3277function TSocksBlockSocket.SocksOpen: boolean;
3278var
3279  Buf: AnsiString;
3280  n: integer;
3281begin
3282  Result := False;
3283  FUsingSocks := False;
3284  if FSocksType <> ST_Socks5 then
3285  begin
3286    FUsingSocks := True;
3287    Result := True;
3288  end
3289  else
3290  begin
3291    FBypassFlag := True;
3292    try
3293      if FSocksUsername = '' then
3294        Buf := #5 + #1 + #0
3295      else
3296        Buf := #5 + #2 + #2 +#0;
3297      SendString(Buf);
3298      Buf := RecvBufferStr(2, FSocksTimeout);
3299      if Length(Buf) < 2 then
3300        Exit;
3301      if Buf[1] <> #5 then
3302        Exit;
3303      n := Ord(Buf[2]);
3304      case n of
3305        0: //not need authorisation
3306          ;
3307        2:
3308          begin
3309            Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername
3310              + AnsiChar(Length(FSocksPassword)) + FSocksPassword;
3311            SendString(Buf);
3312            Buf := RecvBufferStr(2, FSocksTimeout);
3313            if Length(Buf) < 2 then
3314              Exit;
3315            if Buf[2] <> #0 then
3316              Exit;
3317          end;
3318      else
3319        //other authorisation is not supported!
3320        Exit;
3321      end;
3322      FUsingSocks := True;
3323      Result := True;
3324    finally
3325      FBypassFlag := False;
3326    end;
3327  end;
3328end;
3329
3330function TSocksBlockSocket.SocksRequest(Cmd: Byte;
3331  const IP, Port: string): Boolean;
3332var
3333  Buf: AnsiString;
3334begin
3335  FBypassFlag := True;
3336  try
3337    if FSocksType <> ST_Socks5 then
3338      Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port)
3339    else
3340      Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port);
3341    SendString(Buf);
3342    Result := FLastError = 0;
3343  finally
3344    FBypassFlag := False;
3345  end;
3346end;
3347
3348function TSocksBlockSocket.SocksResponse: Boolean;
3349var
3350  Buf, s: AnsiString;
3351  x: integer;
3352begin
3353  Result := False;
3354  FBypassFlag := True;
3355  try
3356    FSocksResponseIP := '';
3357    FSocksResponsePort := '';
3358    FSocksLastError := -1;
3359    if FSocksType <> ST_Socks5 then
3360    begin
3361      Buf := RecvBufferStr(8, FSocksTimeout);
3362      if FLastError <> 0 then
3363        Exit;
3364      if Buf[1] <> #0 then
3365        Exit;
3366      FSocksLastError := Ord(Buf[2]);
3367    end
3368    else
3369    begin
3370      Buf := RecvBufferStr(4, FSocksTimeout);
3371      if FLastError <> 0 then
3372        Exit;
3373      if Buf[1] <> #5 then
3374        Exit;
3375      case Ord(Buf[4]) of
3376        1:
3377          s := RecvBufferStr(4, FSocksTimeout);
3378        3:
3379          begin
3380            x := RecvByte(FSocksTimeout);
3381            if FLastError <> 0 then
3382              Exit;
3383            s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout);
3384          end;
3385        4:
3386          s := RecvBufferStr(16, FSocksTimeout);
3387      else
3388        Exit;
3389      end;
3390      Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
3391      if FLastError <> 0 then
3392        Exit;
3393      FSocksLastError := Ord(Buf[2]);
3394    end;
3395    if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then
3396      Exit;
3397    SocksDecode(Buf);
3398    Result := True;
3399  finally
3400    FBypassFlag := False;
3401  end;
3402end;
3403
3404function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring;
3405var
3406  ip6: TIp6Bytes;
3407  n: integer;
3408begin
3409  if FSocksType <> ST_Socks5 then
3410  begin
3411    Result := CodeInt(ResolvePort(Port));
3412    if not FSocksResolver then
3413      IP := ResolveName(IP);
3414    if IsIP(IP) then
3415    begin
3416      Result := Result + IPToID(IP);
3417      Result := Result + FSocksUsername + #0;
3418    end
3419    else
3420    begin
3421      Result := Result + IPToID('0.0.0.1');
3422      Result := Result + FSocksUsername + #0;
3423      Result := Result + IP + #0;
3424    end;
3425  end
3426  else
3427  begin
3428    if not FSocksResolver then
3429      IP := ResolveName(IP);
3430    if IsIP(IP) then
3431      Result := #1 + IPToID(IP)
3432    else
3433      if IsIP6(IP) then
3434      begin
3435        ip6 := StrToIP6(IP);
3436        Result := #4;
3437        for n := 0 to 15 do
3438          Result := Result + AnsiChar(ip6[n]);
3439      end
3440      else
3441        Result := #3 + AnsiChar(Length(IP)) + IP;
3442    Result := Result + CodeInt(ResolvePort(Port));
3443  end;
3444end;
3445
3446function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer;
3447var
3448  Atyp: Byte;
3449  y, n: integer;
3450  w: Word;
3451  ip6: TIp6Bytes;
3452begin
3453  FSocksResponsePort := '0';
3454  Result := 0;
3455  if FSocksType <> ST_Socks5 then
3456  begin
3457    if Length(Value) < 8 then
3458      Exit;
3459    Result := 3;
3460    w := DecodeInt(Value, Result);
3461    FSocksResponsePort := IntToStr(w);
3462    FSocksResponseIP := Format('%d.%d.%d.%d',
3463      [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
3464    Result := 9;
3465  end
3466  else
3467  begin
3468    if Length(Value) < 4 then
3469      Exit;
3470    Atyp := Ord(Value[4]);
3471    Result := 5;
3472    case Atyp of
3473      1:
3474        begin
3475          if Length(Value) < 10 then
3476            Exit;
3477          FSocksResponseIP := Format('%d.%d.%d.%d',
3478              [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
3479          Result := 9;
3480        end;
3481      3:
3482        begin
3483          y := Ord(Value[5]);
3484          if Length(Value) < (5 + y + 2) then
3485            Exit;
3486          for n := 6 to 6 + y - 1 do
3487            FSocksResponseIP := FSocksResponseIP + Value[n];
3488          Result := 5 + y + 1;
3489        end;
3490      4:
3491        begin
3492          if Length(Value) < 22 then
3493            Exit;
3494          for n := 0 to 15 do
3495            ip6[n] := ord(Value[n + 5]);
3496          FSocksResponseIP := IP6ToStr(ip6);
3497          Result := 21;
3498        end;
3499    else
3500      Exit;
3501    end;
3502    w := DecodeInt(Value, Result);
3503    FSocksResponsePort := IntToStr(w);
3504    Result := Result + 2;
3505  end;
3506end;
3507
3508{======================================================================}
3509
3510procedure TDgramBlockSocket.Connect(IP, Port: string);
3511begin
3512  SetRemoteSin(IP, Port);
3513  InternalCreateSocket(FRemoteSin);
3514  FBuffer := '';
3515  DoStatus(HR_Connect, IP + ':' + Port);
3516end;
3517
3518function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
3519begin
3520  Result := RecvBufferFrom(Buffer, Length);
3521end;
3522
3523function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
3524begin
3525  Result := SendBufferTo(Buffer, Length);
3526end;
3527
3528{======================================================================}
3529
3530destructor TUDPBlockSocket.Destroy;
3531begin
3532  if Assigned(FSocksControlSock) then
3533    FSocksControlSock.Free;
3534  inherited;
3535end;
3536
3537procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean);
3538var
3539  d: TSynaOption;
3540begin
3541  d := TSynaOption.Create;
3542  d.Option := SOT_Broadcast;
3543  d.Enabled := Value;
3544  DelayedOption(d);
3545end;
3546
3547function TUDPBlockSocket.UdpAssociation: Boolean;
3548var
3549  b: Boolean;
3550begin
3551  Result := True;
3552  FUsingSocks := False;
3553  if FSocksIP <> '' then
3554  begin
3555    Result := False;
3556    if not Assigned(FSocksControlSock) then
3557      FSocksControlSock := TTCPBlockSocket.Create;
3558    FSocksControlSock.CloseSocket;
3559    FSocksControlSock.CreateSocketByName(FSocksIP);
3560    FSocksControlSock.Connect(FSocksIP, FSocksPort);
3561    if FSocksControlSock.LastError <> 0 then
3562      Exit;
3563    // if not assigned local port, assign it!
3564    if not FBinded then
3565      Bind(cAnyHost, cAnyPort);
3566    //open control TCP connection to SOCKS
3567    FSocksControlSock.FSocksUsername := FSocksUsername;
3568    FSocksControlSock.FSocksPassword := FSocksPassword;
3569    b := FSocksControlSock.SocksOpen;
3570    if b then
3571      b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
3572    if b then
3573      b := FSocksControlSock.SocksResponse;
3574    if not b and (FLastError = 0) then
3575      FLastError := WSANO_RECOVERY;
3576    FUsingSocks :=FSocksControlSock.UsingSocks;
3577    FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
3578    FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
3579    Result := b and (FLastError = 0);
3580  end;
3581end;
3582
3583function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer;
3584var
3585  SIp: string;
3586  SPort: integer;
3587  Buf: Ansistring;
3588begin
3589  Result := 0;
3590  FUsingSocks := False;
3591  if (FSocksIP <> '') and (not UdpAssociation) then
3592    FLastError := WSANO_RECOVERY
3593  else
3594  begin
3595    if FUsingSocks then
3596    begin
3597{$IFNDEF CIL}
3598      Sip := GetRemoteSinIp;
3599      SPort := GetRemoteSinPort;
3600      SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
3601      SetLength(Buf,Length);
3602      Move(Buffer^, Pointer(Buf)^, Length);
3603      Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
3604      Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf));
3605      SetRemoteSin(Sip, IntToStr(SPort));
3606{$ENDIF}
3607    end
3608    else
3609      Result := inherited SendBufferTo(Buffer, Length);
3610  end;
3611end;
3612
3613function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
3614var
3615  Buf: Ansistring;
3616  x: integer;
3617begin
3618  Result := inherited RecvBufferFrom(Buffer, Length);
3619  if FUsingSocks then
3620  begin
3621{$IFNDEF CIL}
3622    SetLength(Buf, Result);
3623    Move(Buffer^, Pointer(Buf)^, Result);
3624    x := SocksDecode(Buf);
3625    Result := Result - x + 1;
3626    Buf := Copy(Buf, x, Result);
3627    Move(Pointer(Buf)^, Buffer^, Result);
3628    SetRemoteSin(FSocksResponseIP, FSocksResponsePort);
3629{$ENDIF}
3630  end;
3631end;
3632
3633{$IFNDEF CIL}
3634procedure TUDPBlockSocket.AddMulticast(MCastIP: string);
3635var
3636  Multicast: TIP_mreq;
3637  Multicast6: TIPv6_mreq;
3638  n: integer;
3639  ip6: Tip6bytes;
3640begin
3641  if FIP6Used then
3642  begin
3643    ip6 := StrToIp6(MCastIP);
3644    for n := 0 to 15 do
3645      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
3646    Multicast6.ipv6mr_interface := 0;
3647    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
3648      PAnsiChar(@Multicast6), SizeOf(Multicast6)));
3649  end
3650  else
3651  begin
3652    Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
3653    Multicast.imr_interface.S_addr := INADDR_ANY;
3654    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
3655      PAnsiChar(@Multicast), SizeOf(Multicast)));
3656  end;
3657  ExceptCheck;
3658end;
3659
3660procedure TUDPBlockSocket.DropMulticast(MCastIP: string);
3661var
3662  Multicast: TIP_mreq;
3663  Multicast6: TIPv6_mreq;
3664  n: integer;
3665  ip6: Tip6bytes;
3666begin
3667  if FIP6Used then
3668  begin
3669    ip6 := StrToIp6(MCastIP);
3670    for n := 0 to 15 do
3671      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
3672    Multicast6.ipv6mr_interface := 0;
3673    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
3674      PAnsiChar(@Multicast6), SizeOf(Multicast6)));
3675  end
3676  else
3677  begin
3678    Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
3679    Multicast.imr_interface.S_addr := INADDR_ANY;
3680    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
3681      PAnsiChar(@Multicast), SizeOf(Multicast)));
3682  end;
3683  ExceptCheck;
3684end;
3685{$ENDIF}
3686
3687procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
3688var
3689  d: TSynaOption;
3690begin
3691  d := TSynaOption.Create;
3692  d.Option := SOT_MulticastTTL;
3693  d.Value := TTL;
3694  DelayedOption(d);
3695end;
3696
3697function TUDPBlockSocket.GetMulticastTTL:integer;
3698var
3699  l: Integer;
3700begin
3701{$IFNDEF CIL}
3702  l := SizeOf(Result);
3703  if FIP6Used then
3704    synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l)
3705  else
3706    synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l);
3707{$ENDIF}
3708end;
3709
3710procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean);
3711var
3712  d: TSynaOption;
3713begin
3714  d := TSynaOption.Create;
3715  d.Option := SOT_MulticastLoop;
3716  d.Enabled := Value;
3717  DelayedOption(d);
3718end;
3719
3720function TUDPBlockSocket.GetSocketType: integer;
3721begin
3722  Result := integer(SOCK_DGRAM);
3723end;
3724
3725function TUDPBlockSocket.GetSocketProtocol: integer;
3726begin
3727 Result := integer(IPPROTO_UDP);
3728end;
3729
3730{======================================================================}
3731constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass);
3732begin
3733  inherited Create;
3734  FSSL := SSLPlugin.Create(self);
3735  FHTTPTunnelIP := '';
3736  FHTTPTunnelPort := '';
3737  FHTTPTunnel := False;
3738  FHTTPTunnelRemoteIP := '';
3739  FHTTPTunnelRemotePort := '';
3740  FHTTPTunnelUser := '';
3741  FHTTPTunnelPass := '';
3742  FHTTPTunnelTimeout := 30000;
3743end;
3744
3745constructor TTCPBlockSocket.Create;
3746begin
3747  CreateWithSSL(SSLImplementation);
3748end;
3749
3750destructor TTCPBlockSocket.Destroy;
3751begin
3752  inherited Destroy;
3753  FSSL.Free;
3754end;
3755
3756function TTCPBlockSocket.GetErrorDescEx: string;
3757begin
3758  Result := inherited GetErrorDescEx;
3759  if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then
3760  begin
3761    Result := self.SSL.LastErrorDesc;
3762  end;
3763end;
3764
3765procedure TTCPBlockSocket.CloseSocket;
3766begin
3767  if FSSL.SSLEnabled then
3768    FSSL.Shutdown;
3769  if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
3770  begin
3771    Synsock.Shutdown(FSocket, 1);
3772    Purge;
3773  end;
3774  inherited CloseSocket;
3775end;
3776
3777procedure TTCPBlockSocket.DoAfterConnect;
3778begin
3779  if assigned(OnAfterConnect) then
3780  begin
3781    OnAfterConnect(Self);
3782  end;
3783end;
3784
3785function TTCPBlockSocket.WaitingData: Integer;
3786begin
3787  Result := 0;
3788  if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then
3789    Result := FSSL.WaitingData;
3790  if Result = 0 then
3791    Result := inherited WaitingData;
3792end;
3793
3794procedure TTCPBlockSocket.Listen;
3795var
3796  b: Boolean;
3797  Sip,SPort: string;
3798begin
3799  if FSocksIP = '' then
3800  begin
3801    inherited Listen;
3802  end
3803  else
3804  begin
3805    Sip := GetLocalSinIP;
3806    if Sip = cAnyHost then
3807      Sip := LocalName;
3808    SPort := IntToStr(GetLocalSinPort);
3809    inherited Connect(FSocksIP, FSocksPort);
3810    b := SocksOpen;
3811    if b then
3812      b := SocksRequest(2, Sip, SPort);
3813    if b then
3814      b := SocksResponse;
3815    if not b and (FLastError = 0) then
3816      FLastError := WSANO_RECOVERY;
3817    FSocksLocalIP := FSocksResponseIP;
3818    if FSocksLocalIP = cAnyHost then
3819      FSocksLocalIP := FSocksIP;
3820    FSocksLocalPort := FSocksResponsePort;
3821    FSocksRemoteIP := '';
3822    FSocksRemotePort := '';
3823    ExceptCheck;
3824    DoStatus(HR_Listen, '');
3825  end;
3826end;
3827
3828function TTCPBlockSocket.Accept: TSocket;
3829begin
3830  if FUsingSocks then
3831  begin
3832    if not SocksResponse and (FLastError = 0) then
3833      FLastError := WSANO_RECOVERY;
3834    FSocksRemoteIP := FSocksResponseIP;
3835    FSocksRemotePort := FSocksResponsePort;
3836    Result := FSocket;
3837    ExceptCheck;
3838    DoStatus(HR_Accept, '');
3839  end
3840  else
3841  begin
3842    result := inherited Accept;
3843  end;
3844end;
3845
3846procedure TTCPBlockSocket.Connect(IP, Port: string);
3847begin
3848  if FSocksIP <> '' then
3849    SocksDoConnect(IP, Port)
3850  else
3851    if FHTTPTunnelIP <> '' then
3852      HTTPTunnelDoConnect(IP, Port)
3853    else
3854      inherited Connect(IP, Port);
3855  if FLasterror = 0 then
3856    DoAfterConnect;
3857end;
3858
3859procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string);
3860var
3861  b: Boolean;
3862begin
3863  inherited Connect(FSocksIP, FSocksPort);
3864  if FLastError = 0 then
3865  begin
3866    b := SocksOpen;
3867    if b then
3868      b := SocksRequest(1, IP, Port);
3869    if b then
3870      b := SocksResponse;
3871    if not b and (FLastError = 0) then
3872      FLastError := WSASYSNOTREADY;
3873    FSocksLocalIP := FSocksResponseIP;
3874    FSocksLocalPort := FSocksResponsePort;
3875    FSocksRemoteIP := IP;
3876    FSocksRemotePort := Port;
3877  end;
3878  ExceptCheck;
3879  DoStatus(HR_Connect, IP + ':' + Port);
3880end;
3881
3882procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
3883//bugfixed by Mike Green (mgreen@emixode.com)
3884var
3885  s: string;
3886begin
3887  Port := IntToStr(ResolvePort(Port));
3888  inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
3889  if FLastError <> 0 then
3890    Exit;
3891  FHTTPTunnel := False;
3892  if IsIP6(IP) then
3893    IP := '[' + IP + ']';
3894  SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
3895  if FHTTPTunnelUser <> '' then
3896  Sendstring('Proxy-Authorization: Basic ' +
3897    EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
3898  SendString(CRLF);
3899  repeat
3900    s := RecvTerminated(FHTTPTunnelTimeout, #$0a);
3901    if FLastError <> 0 then
3902      Break;
3903    if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
3904      FHTTPTunnel := s[10] = '2';
3905  until (s = '') or (s = #$0d);
3906  if (FLasterror = 0) and not FHTTPTunnel then
3907    FLastError := WSASYSNOTREADY;
3908  FHTTPTunnelRemoteIP := IP;
3909  FHTTPTunnelRemotePort := Port;
3910  ExceptCheck;
3911end;
3912
3913procedure TTCPBlockSocket.SSLDoConnect;
3914begin
3915  ResetLastError;
3916  if not FSSL.Connect then
3917    FLastError := WSASYSNOTREADY;
3918  ExceptCheck;
3919end;
3920
3921procedure TTCPBlockSocket.SSLDoShutdown;
3922begin
3923  ResetLastError;
3924  FSSL.BiShutdown;
3925end;
3926
3927function TTCPBlockSocket.GetLocalSinIP: string;
3928begin
3929  if FUsingSocks then
3930    Result := FSocksLocalIP
3931  else
3932    Result := inherited GetLocalSinIP;
3933end;
3934
3935function TTCPBlockSocket.GetRemoteSinIP: string;
3936begin
3937  if FUsingSocks then
3938    Result := FSocksRemoteIP
3939  else
3940    if FHTTPTunnel then
3941      Result := FHTTPTunnelRemoteIP
3942    else
3943      Result := inherited GetRemoteSinIP;
3944end;
3945
3946function TTCPBlockSocket.GetLocalSinPort: Integer;
3947begin
3948  if FUsingSocks then
3949    Result := StrToIntDef(FSocksLocalPort, 0)
3950  else
3951    Result := inherited GetLocalSinPort;
3952end;
3953
3954function TTCPBlockSocket.GetRemoteSinPort: Integer;
3955begin
3956  if FUsingSocks then
3957    Result := ResolvePort(FSocksRemotePort)
3958  else
3959    if FHTTPTunnel then
3960      Result := StrToIntDef(FHTTPTunnelRemotePort, 0)
3961    else
3962      Result := inherited GetRemoteSinPort;
3963end;
3964
3965function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
3966begin
3967  if FSSL.SSLEnabled then
3968  begin
3969    Result := 0;
3970    if TestStopFlag then
3971      Exit;
3972    ResetLastError;
3973    LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
3974    Result := FSSL.RecvBuffer(Buffer, Len);
3975    if FSSL.LastError <> 0 then
3976      FLastError := WSASYSNOTREADY;
3977    ExceptCheck;
3978    Inc(FRecvCounter, Result);
3979    DoStatus(HR_ReadCount, IntToStr(Result));
3980    DoMonitor(False, Buffer, Result);
3981    DoReadFilter(Buffer, Result);
3982  end
3983  else
3984    Result := inherited RecvBuffer(Buffer, Len);
3985end;
3986
3987function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer;
3988var
3989  x, y: integer;
3990  l, r: integer;
3991{$IFNDEF CIL}
3992  p: Pointer;
3993{$ENDIF}
3994begin
3995  if FSSL.SSLEnabled then
3996  begin
3997    Result := 0;
3998    if TestStopFlag then
3999      Exit;
4000    ResetLastError;
4001    DoMonitor(True, Buffer, Length);
4002{$IFDEF CIL}
4003    Result := FSSL.SendBuffer(Buffer, Length);
4004    if FSSL.LastError <> 0 then
4005      FLastError := WSASYSNOTREADY;
4006    Inc(FSendCounter, Result);
4007    DoStatus(HR_WriteCount, IntToStr(Result));
4008{$ELSE}
4009    l := Length;
4010    x := 0;
4011    while x < l do
4012    begin
4013      y := l - x;
4014      if y > FSendMaxChunk then
4015        y := FSendMaxChunk;
4016      if y > 0 then
4017      begin
4018        LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
4019        p := IncPoint(Buffer, x);
4020        r := FSSL.SendBuffer(p, y);
4021        if FSSL.LastError <> 0 then
4022          FLastError := WSASYSNOTREADY;
4023        if Flasterror <> 0 then
4024          Break;
4025        Inc(x, r);
4026        Inc(Result, r);
4027        Inc(FSendCounter, r);
4028        DoStatus(HR_WriteCount, IntToStr(r));
4029      end
4030      else
4031        break;
4032    end;
4033{$ENDIF}
4034    ExceptCheck;
4035  end
4036  else
4037    Result := inherited SendBuffer(Buffer, Length);
4038end;
4039
4040function TTCPBlockSocket.SSLAcceptConnection: Boolean;
4041begin
4042  ResetLastError;
4043  if not FSSL.Accept then
4044    FLastError := WSASYSNOTREADY;
4045  ExceptCheck;
4046  Result := FLastError = 0;
4047end;
4048
4049function TTCPBlockSocket.GetSocketType: integer;
4050begin
4051  Result := integer(SOCK_STREAM);
4052end;
4053
4054function TTCPBlockSocket.GetSocketProtocol: integer;
4055begin
4056  Result := integer(IPPROTO_TCP);
4057end;
4058
4059{======================================================================}
4060
4061function TICMPBlockSocket.GetSocketType: integer;
4062begin
4063  Result := integer(SOCK_RAW);
4064end;
4065
4066function TICMPBlockSocket.GetSocketProtocol: integer;
4067begin
4068  if FIP6Used then
4069    Result := integer(IPPROTO_ICMPV6)
4070  else
4071    Result := integer(IPPROTO_ICMP);
4072end;
4073
4074{======================================================================}
4075
4076function TRAWBlockSocket.GetSocketType: integer;
4077begin
4078  Result := integer(SOCK_RAW);
4079end;
4080
4081function TRAWBlockSocket.GetSocketProtocol: integer;
4082begin
4083  Result := integer(IPPROTO_RAW);
4084end;
4085
4086{======================================================================}
4087
4088function TPGMmessageBlockSocket.GetSocketType: integer;
4089begin
4090  Result := integer(SOCK_RDM);
4091end;
4092
4093function TPGMmessageBlockSocket.GetSocketProtocol: integer;
4094begin
4095  Result := integer(IPPROTO_RM);
4096end;
4097
4098{======================================================================}
4099
4100function TPGMstreamBlockSocket.GetSocketType: integer;
4101begin
4102  Result := integer(SOCK_STREAM);
4103end;
4104
4105function TPGMstreamBlockSocket.GetSocketProtocol: integer;
4106begin
4107  Result := integer(IPPROTO_RM);
4108end;
4109
4110{======================================================================}
4111
4112constructor TSynaClient.Create;
4113begin
4114  inherited Create;
4115  FIPInterface := cAnyHost;
4116  FTargetHost := cLocalhost;
4117  FTargetPort := cAnyPort;
4118  FTimeout := 5000;
4119  FUsername := '';
4120  FPassword := '';
4121end;
4122
4123{======================================================================}
4124
4125constructor TCustomSSL.Create(const Value: TTCPBlockSocket);
4126begin
4127  inherited Create;
4128  FSocket := Value;
4129  FSSLEnabled := False;
4130  FUsername := '';
4131  FPassword := '';
4132  FLastError := 0;
4133  FLastErrorDesc := '';
4134  FVerifyCert := False;
4135  FSSLType := LT_all;
4136  FKeyPassword := '';
4137  FCiphers := '';
4138  FCertificateFile := '';
4139  FPrivateKeyFile := '';
4140  FCertCAFile := '';
4141  FCertCA := '';
4142  FTrustCertificate := '';
4143  FTrustCertificateFile := '';
4144  FCertificate := '';
4145  FPrivateKey := '';
4146  FPFX := '';
4147  FPFXfile := '';
4148  FSSHChannelType := '';
4149  FSSHChannelArg1 := '';
4150  FSSHChannelArg2 := '';
4151  FCertComplianceLevel := -1; //default
4152  FSNIHost := '';
4153end;
4154
4155procedure TCustomSSL.Assign(const Value: TCustomSSL);
4156begin
4157  FUsername := Value.Username;
4158  FPassword := Value.Password;
4159  FVerifyCert := Value.VerifyCert;
4160  FSSLType := Value.SSLType;
4161  FKeyPassword := Value.KeyPassword;
4162  FCiphers := Value.Ciphers;
4163  FCertificateFile := Value.CertificateFile;
4164  FPrivateKeyFile := Value.PrivateKeyFile;
4165  FCertCAFile := Value.CertCAFile;
4166  FCertCA := Value.CertCA;
4167  FTrustCertificate := Value.TrustCertificate;
4168  FTrustCertificateFile := Value.TrustCertificateFile;
4169  FCertificate := Value.Certificate;
4170  FPrivateKey := Value.PrivateKey;
4171  FPFX := Value.PFX;
4172  FPFXfile := Value.PFXfile;
4173  FCertComplianceLevel := Value.CertComplianceLevel;
4174  FSNIHost := Value.FSNIHost;
4175end;
4176
4177procedure TCustomSSL.ReturnError;
4178begin
4179  FLastError := -1;
4180  FLastErrorDesc := 'SSL/TLS support is not compiled!';
4181end;
4182
4183function TCustomSSL.LibVersion: String;
4184begin
4185  Result := '';
4186end;
4187
4188function TCustomSSL.LibName: String;
4189begin
4190  Result := '';
4191end;
4192
4193function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean;
4194begin
4195  Result := False;
4196end;
4197
4198function TCustomSSL.Connect: boolean;
4199begin
4200  ReturnError;
4201  Result := False;
4202end;
4203
4204function TCustomSSL.Accept: boolean;
4205begin
4206  ReturnError;
4207  Result := False;
4208end;
4209
4210function TCustomSSL.Shutdown: boolean;
4211begin
4212  ReturnError;
4213  Result := False;
4214end;
4215
4216function TCustomSSL.BiShutdown: boolean;
4217begin
4218  ReturnError;
4219  Result := False;
4220end;
4221
4222function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
4223begin
4224  ReturnError;
4225  Result := integer(SOCKET_ERROR);
4226end;
4227
4228procedure TCustomSSL.SetCertCAFile(const Value: string);
4229begin
4230  FCertCAFile := Value;
4231end;
4232
4233function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
4234begin
4235  ReturnError;
4236  Result := integer(SOCKET_ERROR);
4237end;
4238
4239function TCustomSSL.WaitingData: Integer;
4240begin
4241  ReturnError;
4242  Result := 0;
4243end;
4244
4245function TCustomSSL.GetSSLVersion: string;
4246begin
4247  Result := '';
4248end;
4249
4250function TCustomSSL.GetPeerSubject: string;
4251begin
4252  Result := '';
4253end;
4254
4255function TCustomSSL.GetPeerSerialNo: integer;
4256begin
4257  Result := -1;
4258end;
4259
4260function TCustomSSL.GetPeerName: string;
4261begin
4262  Result := '';
4263end;
4264
4265function TCustomSSL.GetPeerNameHash: cardinal;
4266begin
4267  Result := 0;
4268end;
4269
4270function TCustomSSL.GetPeerIssuer: string;
4271begin
4272  Result := '';
4273end;
4274
4275function TCustomSSL.GetPeerFingerprint: string;
4276begin
4277  Result := '';
4278end;
4279
4280function TCustomSSL.GetCertInfo: string;
4281begin
4282  Result := '';
4283end;
4284
4285function TCustomSSL.GetCipherName: string;
4286begin
4287  Result := '';
4288end;
4289
4290function TCustomSSL.GetCipherBits: integer;
4291begin
4292  Result := 0;
4293end;
4294
4295function TCustomSSL.GetCipherAlgBits: integer;
4296begin
4297  Result := 0;
4298end;
4299
4300function TCustomSSL.GetVerifyCert: integer;
4301begin
4302  Result := 1;
4303end;
4304
4305function TCustomSSL.DoVerifyCert:boolean;
4306begin
4307  if assigned(OnVerifyCert) then
4308  begin
4309    result:=OnVerifyCert(Self);
4310  end
4311  else
4312    result:=true;
4313end;
4314
4315
4316{======================================================================}
4317
4318function TSSLNone.LibVersion: String;
4319begin
4320  Result := 'Without SSL support';
4321end;
4322
4323function TSSLNone.LibName: String;
4324begin
4325  Result := 'ssl_none';
4326end;
4327
4328{======================================================================}
4329
4330initialization
4331begin
4332{$IFDEF ONCEWINSOCK}
4333  if not InitSocketInterface(DLLStackName) then
4334  begin
4335    e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!');
4336    e.ErrorCode := 0;
4337    e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!';
4338    raise e;
4339  end;
4340  synsock.WSAStartup(WinsockLevel, WsaDataOnce);
4341{$ENDIF}
4342end;
4343
4344finalization
4345begin
4346{$IFDEF ONCEWINSOCK}
4347  synsock.WSACleanup;
4348  DestroySocketInterface;
4349{$ENDIF}
4350end;
4351
4352end.