From 9fc9a696f4ee16fc83c959df06f3dddc68a65798 Mon Sep 17 00:00:00 2001 From: geby Date: Thu, 24 Apr 2008 07:29:09 +0000 Subject: [PATCH] Release 33 git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@72 7c85be65-684b-0410-a082-b2ed4fbef004 --- asn1util.pas | 128 +-- blcksock.pas | 2113 +++++++++++++++++++++++++++++++++++++++++--------- dnssend.pas | 164 ++-- ftpsend.pas | 1254 ++++++++++++++++++++++-------- ftptsend.pas | 77 +- httpsend.pas | 215 ++++- imapsend.pas | 194 ++++- ldapsend.pas | 163 +++- mimeinln.pas | 66 +- mimemess.pas | 434 +++++++++-- mimepart.pas | 274 ++++++- nntpsend.pas | 101 ++- pingsend.pas | 62 +- pop3send.pas | 102 ++- slogsend.pas | 194 ++++- smtpsend.pas | 172 +++- snmpsend.pas | 780 +++++++++++++++++-- snmptrap.pas | 361 --------- sntpsend.pas | 139 +++- ssdotnet.pas | 1013 ++++++++++++++++++++++++ sslinux.pas | 963 +++++++++++++++++++++++ sswin32.pas | 1234 +++++++++++++++++++++++++++++ synachar.pas | 1367 ++++++++++++++++++++++---------- synacode.pas | 723 +++++++++++++---- synafpc.pas | 2 + synaicnv.pas | 351 +++++++++ synamisc.pas | 111 ++- synassl.pas | 702 ++++++++++++++--- synautil.pas | 560 +++++++++++-- synsock.pas | 1421 +-------------------------------- tlntsend.pas | 29 +- 31 files changed, 11698 insertions(+), 3771 deletions(-) delete mode 100644 snmptrap.pas create mode 100644 ssdotnet.pas create mode 100644 sslinux.pas create mode 100644 sswin32.pas create mode 100644 synaicnv.pas diff --git a/asn1util.pas b/asn1util.pas index 9de6970..ba92bb1 100644 --- a/asn1util.pas +++ b/asn1util.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.004.002 | +| Project : Ararat Synapse | 001.004.003 | |==============================================================================| | Content: support for ASN.1 BER coding and decoding | |==============================================================================| @@ -44,6 +44,18 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{: @abstract(Utilities for handling ASN.1 BER encoding) +By this unit you can parse ASN.1 BER encoded data to elements or build back any + elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to + human readable form for easy debugging, too. + +Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL, + ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER, + ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE + +For sample of using, look to @link(TSnmpSend) class. +} + {$Q-} {$H+} {$IFDEF FPC} @@ -55,7 +67,7 @@ unit asn1util; interface uses - SysUtils, Classes; + SysUtils, Classes, SynaUtil; const ASN1_BOOL = $01; @@ -72,24 +84,50 @@ const ASN1_TIMETICKS = $43; ASN1_OPAQUE = $44; -function ASNEncOIDItem(Value: Integer): string; -function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer; -function ASNEncLen(Len: Integer): string; -function ASNDecLen(var Start: Integer; const Buffer: string): Integer; -function ASNEncInt(Value: Integer): string; -function ASNEncUInt(Value: Integer): string; -function ASNObject(const Data: string; ASNType: Integer): string; -function ASNItem(var Start: Integer; const Buffer: string; - var ValueType: Integer): string; -function MibToId(Mib: string): string; -function IdToMib(const Id: string): string; -function IntMibToStr(const Value: string): string; -function ASNdump(const Value: string): string; +{:Encodes OID item to binary form.} +function ASNEncOIDItem(Value: Integer): AnsiString; + +{:Decodes an OID item of the next element in the "Buffer" from the "Start" + position.} +function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; + +{:Encodes the length of ASN.1 element to binary.} +function ASNEncLen(Len: Integer): AnsiString; + +{:Decodes length of next element in "Buffer" from the "Start" position.} +function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; + +{:Encodes a signed integer to ASN.1 binary} +function ASNEncInt(Value: Integer): AnsiString; + +{:Encodes unsigned integer into ASN.1 binary} +function ASNEncUInt(Value: Integer): AnsiString; + +{:Encodes ASN.1 object to binary form.} +function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; + +{:Beginning with the "Start" position, decode the ASN.1 item of the next element + in "Buffer". Type of item is stored in "ValueType."} +function ASNItem(var Start: Integer; const Buffer: AnsiString; + var ValueType: Integer): AnsiString; + +{:Encodes an MIB OID string to binary form.} +function MibToId(Mib: String): AnsiString; + +{:Decodes MIB OID from binary form to string form.} +function IdToMib(const Id: AnsiString): String; + +{:Encodes an one number from MIB OID to binary form. (used internally from +@link(MibToId))} +function IntMibToStr(const Value: AnsiString): AnsiString; + +{:Convert ASN.1 BER encoded buffer to human readable form for debugging.} +function ASNdump(const Value: AnsiString): AnsiString; implementation {==============================================================================} -function ASNEncOIDItem(Value: Integer): string; +function ASNEncOIDItem(Value: Integer): AnsiString; var x, xm: Integer; b: Boolean; @@ -104,12 +142,12 @@ begin xm := xm or $80; if x > 0 then b := True; - Result := Char(xm) + Result; + Result := AnsiChar(xm) + Result; until x = 0; end; {==============================================================================} -function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer; +function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; var x: Integer; b: Boolean; @@ -126,12 +164,12 @@ begin end; {==============================================================================} -function ASNEncLen(Len: Integer): string; +function ASNEncLen(Len: Integer): AnsiString; var x, y: Integer; begin if Len < $80 then - Result := Char(Len) + Result := AnsiChar(Len) else begin x := Len; @@ -139,16 +177,16 @@ begin repeat y := x mod 256; x := x div 256; - Result := Char(y) + Result; + Result := AnsiChar(y) + Result; until x = 0; y := Length(Result); y := y or $80; - Result := Char(y) + Result; + Result := AnsiChar(y) + Result; end; end; {==============================================================================} -function ASNDecLen(var Start: Integer; const Buffer: string): Integer; +function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; var x, n: Integer; begin @@ -171,7 +209,7 @@ begin end; {==============================================================================} -function ASNEncInt(Value: Integer): string; +function ASNEncInt(Value: Integer): AnsiString; var x, y: Cardinal; neg: Boolean; @@ -184,14 +222,14 @@ begin repeat y := x mod 256; x := x div 256; - Result := Char(y) + Result; + Result := AnsiChar(y) + Result; until x = 0; if (not neg) and (Result[1] > #$7F) then Result := #0 + Result; end; {==============================================================================} -function ASNEncUInt(Value: Integer): string; +function ASNEncUInt(Value: Integer): AnsiString; var x, y: Integer; neg: Boolean; @@ -204,28 +242,28 @@ begin repeat y := x mod 256; x := x div 256; - Result := Char(y) + Result; + Result := AnsiChar(y) + Result; until x = 0; if neg then - Result[1] := Char(Ord(Result[1]) or $80); + Result[1] := AnsiChar(Ord(Result[1]) or $80); end; {==============================================================================} -function ASNObject(const Data: string; ASNType: Integer): string; +function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; begin - Result := Char(ASNType) + ASNEncLen(Length(Data)) + Data; + Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; end; {==============================================================================} -function ASNItem(var Start: Integer; const Buffer: string; - var ValueType: Integer): string; +function ASNItem(var Start: Integer; const Buffer: AnsiString; + var ValueType: Integer): AnsiString; var ASNType: Integer; ASNSize: Integer; y, n: Integer; x: byte; - s: string; - c: char; + s: AnsiString; + c: AnsiChar; neg: Boolean; l: Integer; begin @@ -277,7 +315,7 @@ begin begin for n := 1 to ASNSize do begin - c := Char(Buffer[Start]); + c := AnsiChar(Buffer[Start]); Inc(Start); s := s + c; end; @@ -287,7 +325,7 @@ begin begin for n := 1 to ASNSize do begin - c := Char(Buffer[Start]); + c := AnsiChar(Buffer[Start]); Inc(Start); s := s + c; end; @@ -315,7 +353,7 @@ begin begin for n := 1 to ASNSize do begin - c := Char(Buffer[Start]); + c := AnsiChar(Buffer[Start]); Inc(Start); s := s + c; end; @@ -325,14 +363,14 @@ begin end; {==============================================================================} -function MibToId(Mib: string): string; +function MibToId(Mib: String): AnsiString; var x: Integer; - function WalkInt(var s: string): Integer; + function WalkInt(var s: String): Integer; var x: Integer; - t: string; + t: AnsiString; begin x := Pos('.', s); if x < 1 then @@ -361,7 +399,7 @@ begin end; {==============================================================================} -function IdToMib(const Id: string): string; +function IdToMib(const Id: AnsiString): String; var x, y, n: Integer; begin @@ -381,7 +419,7 @@ begin end; {==============================================================================} -function IntMibToStr(const Value: string): string; +function IntMibToStr(const Value: AnsiString): AnsiString; var n, y: Integer; begin @@ -392,10 +430,10 @@ begin end; {==============================================================================} -function ASNdump(const Value: string): string; +function ASNdump(const Value: AnsiString): AnsiString; var i, at, x, n: integer; - s, indent: string; + s, indent: AnsiString; il: TStringList; begin il := TStringList.Create; @@ -451,6 +489,8 @@ begin else // other Result := Result + ' unknown: '; end; + if IsBinaryString(s) then + s := DumpExStr(s); Result := Result + s; end; Result := Result + #$0d + #$0a; diff --git a/blcksock.pas b/blcksock.pas index 7692d03..f4037a6 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 007.009.001 | +| Project : Ararat Synapse | 008.003.004 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2003. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -41,6 +41,7 @@ | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} + { Special thanks to Gregor Ibic (Intelicom d.o.o., http://www.intelicom.si) @@ -63,6 +64,11 @@ leak on Windows systems too. {When you enable this define, then is Raiseexcept property is on by default } +{:@abstract(Synapse's library core) + +Core with implementation basic socket classes. +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -74,6 +80,7 @@ leak on Windows systems too. {$ENDIF} {$Q-} {$H+} +{$M+} unit blcksock; @@ -86,14 +93,21 @@ uses synafpc, {$ENDIF} Libc, -{$ELSE} +{$ENDIF} +{$IFDEF WIN32} Windows, {$ENDIF} - synsock, synautil, synacode, synassl; + synsock, synautil, synacode +{$IFDEF CIL} + ,System.Net + ,System.Net.Sockets + ,System.Text +{$ENDIF} + , synassl; const - SynapseRelease = '32'; + SynapseRelease = '33'; cLocalhost = '127.0.0.1'; cAnyHost = '0.0.0.0'; @@ -105,55 +119,101 @@ const CR = #$0d; LF = #$0a; CRLF = CR + LF; - c64k = 65536; + c64k = 65535; type + {:@abstract(Exception clas used by Synapse) + When you enable generating of exceptions, this exception is raised by + Synapse's units.} ESynapseError = class(Exception) private FErrorCode: Integer; FErrorMessage: string; published + {:Code of error. Value depending on used operating system} property ErrorCode: Integer read FErrorCode Write FErrorCode; + {:Human readable description of error.} property ErrorMessage: string read FErrorMessage Write FErrorMessage; end; + {:Types of OnStatus events} THookSocketReason = ( + {:Resolving is begin. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'.} HR_ResolvingBegin, + {:Resolving is done. Resolved IP and port is in parameter in format like: + 'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!} HR_ResolvingEnd, + {:Socket created by CreateSocket method. It reporting Family of created + socket too!} HR_SocketCreate, + {:Socket closed by CloseSocket method.} HR_SocketClose, + {:Socket binded to IP and Port. Binded IP and Port is in parameter in format + like: 'localhost.somewhere.com:25'.} HR_Bind, + {:Socket connected to IP and Port. Connected IP and Port is in parameter in + format like: 'localhost.somewhere.com:25'.} HR_Connect, + {:Called when CanRead method is used with @True result.} HR_CanRead, + {:Called when CanWrite method is used with @True result.} HR_CanWrite, + {:Socket is swithed to Listen mode. (TCP socket only)} HR_Listen, + {:Socket Accepting client connection. (TCP socket only)} HR_Accept, + {:report count of bytes readed from socket. Number is in parameter string. + If you need is in integer, you must use StrToInt function!} HR_ReadCount, + {:report count of bytes writed to socket. Number is in parameter string. If + you need is in integer, you must use StrToInt function!} HR_WriteCount, + {:If is limiting of bandwidth on, then this reason is called when sending or + receiving is stopped for satisfy bandwidth limit. Parameter is count of + waiting milliseconds.} HR_Wait, + {:report situation where communication error occured. When raiseexcept is + @true, then exception is called after this Hook reason.} HR_Error ); + {:Procedural type for OnStatus event. Sender is calling TBlockSocket object, + Reason is one of set Status events and value is optional data.} THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason; const Value: string) of object; + {:this procedural type is used for dataFilter hooks.} THookDataFilter = procedure(Sender: TObject; var Value: string) of object; + {:This procedural type is used for hook OnCreateSocket. By this hook you can + insert your code after initialisation of socket. (you can set special socket + options, etc.)} THookCreateSocket = procedure(Sender: TObject) of object; + {:Specify family of socket.} TSocketFamily = ( + {:Default mode. Socket family is defined by target address for connection. + It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address + as destination, then is used IPv6 mode. othervise is used IPv4 mode. + However this mode not working properly with preliminary IPv6 supports!} SF_Any, + {:Turn this class to pure IPv4 mode. This mode is totally compatible with + previous Synapse releases.} SF_IP4, + {:Turn to only IPv6 mode.} SF_IP6 ); + {:specify possible values of SOCKS modes.} TSocksType = ( ST_Socks5, ST_Socks4 ); + {:Specify requested SSL/TLS version for secure connection.} TSSLType = ( LT_SSLv2, LT_SSLv3, @@ -161,6 +221,7 @@ type LT_all ); + {:Specify type of socket delayed option.} TSynaOptionType = ( SOT_Linger, SOT_RecvBuff, @@ -175,22 +236,27 @@ type SOT_MulticastLoop ); - TSynaOption = record + {:@abstract(this object is used for remember delayed socket option set.)} + TSynaOption = class(TObject) + public Option: TSynaOptionType; Enabled: Boolean; Value: Integer; end; - PSynaOption = ^TSynaOption; + {:@abstract(Basic IP object.) + This is parent class for other class with protocol implementations. Do not + use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket), + @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.} TBlockSocket = class(TObject) private FOnStatus: THookSocketStatus; FOnReadFilter: THookDataFilter; FOnWriteFilter: THookDataFilter; FOnCreateSocket: THookCreateSocket; - FWsaData: TWSADATA; FLocalSin: TVarSin; FRemoteSin: TVarSin; + FTag: integer; FBuffer: string; FRaiseExcept: Boolean; FNonBlockMode: Boolean; @@ -209,9 +275,13 @@ type FPreferIP4: Boolean; FDelayedOptions: TList; FInterPacketTimeout: Boolean; + {$IFNDEF CIL} FFDSet: TFDSet; + {$ENDIF} FRecvCounter: Integer; FSendCounter: Integer; + FSendMaxChunk: Integer; + FStopFlag: Boolean; function GetSizeRecvBuffer: Integer; procedure SetSizeRecvBuffer(Size: Integer); function GetSizeSendBuffer: Integer; @@ -222,118 +292,511 @@ type function IsNewApi: Boolean; procedure SetFamily(Value: TSocketFamily); virtual; procedure SetSocket(Value: TSocket); virtual; + function GetWsaData: TWSAData; protected FSocket: TSocket; FLastError: Integer; FLastErrorDesc: string; - procedure SetDelayedOption(Value: TSynaOption); - procedure DelayedOption(Value: TSynaOption); + procedure SetDelayedOption(const Value: TSynaOption); + procedure DelayedOption(const Value: TSynaOption); procedure ProcessDelayedOptions; procedure InternalCreateSocket(Sin: TVarSin); procedure SetSin(var Sin: TVarSin; IP, Port: string); function GetSinIP(Sin: TVarSin): string; function GetSinPort(Sin: TVarSin): Integer; procedure DoStatus(Reason: THookSocketReason; const Value: string); - procedure DoReadFilter(Buffer: Pointer; var Length: Integer); - procedure DoWriteFilter(Buffer: Pointer; var Length: Integer); + procedure DoReadFilter(Buffer: TMemory; var Len: Integer); + procedure DoWriteFilter(Buffer: TMemory; var Len: Integer); procedure DoCreateSocket; procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: ULong); procedure SetBandwidth(Value: Integer); + function TestStopFlag: Boolean; public constructor Create; + + {:Create object and load all necessary socket library. What library is + loaded is described by STUB parameter. If STUB is empty string, then is + loaded default libraries.} constructor CreateAlternate(Stub: string); destructor Destroy; override; + + {:If @link(family) is not SF_Any, then create socket with type defined in + @link(Family) property. If family is SF_Any, then do nothing! (socket is + created automaticly when you know what type of socket you need to create. + (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created, + then is aplyed all stored delayed socket options.} procedure CreateSocket; + + {:It create socket. Address resolving of Value tells what type of socket is + created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If + value is resolved as IPv6 address, then is created IPv6 socket.} procedure CreateSocketByName(const Value: String); + + {:Destroy socket in use. This method is also automatically called from + object destructor.} procedure CloseSocket; virtual; - procedure AbortSocket; + + {:Abort any work on Socket and destroy them.} + procedure AbortSocket; virtual; + + {:Connects socket to local IP address and PORT. IP address may be numeric or + symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT + - it may be number or mnemonic port ('23', 'telnet'). + + If port value is '0', system chooses itself and conects unused port in the + range 1024 to 4096 (this depending by operating system!). Structure + LocalSin is filled after calling this method. + + Note: If you call this on non-created socket, then socket is created + automaticly. + + Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this + case is used implicit system bind instead.} procedure Bind(IP, Port: string); + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(BIND) method are valid. The only exception is that PORT with 0 value + will not be connected! + + Structures LocalSin and RemoteSin will be filled with valid values. + + When you call this on non-created socket, then socket is created + automaticly. Type of created socket is by @link(Family) property. If is + used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is + created socket for IPv6. When you have family on SF_Any (default!), then + type of created socket is determined by address resolving of destination + address. (Not work properly on prilimitary winsock IPv6 support!)} procedure Connect(IP, Port: string); virtual; - function SendBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; + + {:Sends data of LENGTH from BUFFER address via connected socket. System + automatically splits data to packets.} + function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual; + + {:One data BYTE is sent via connected socket.} procedure SendByte(Data: Byte); virtual; - procedure SendString(const Data: string); virtual; - procedure SendBlock(const Data: string); virtual; + + {:Send data string via connected socket. Any terminator is not added! If you + need send true string with CR-LF termination, you must add CR-LF characters + to sended string! Because any termination is not added automaticly, you can + use this function for sending any binary data in binary string.} + procedure SendString(Data: AnsiString); virtual; + + {:Send integer as four bytes to socket.} + procedure SendInteger(Data: integer); virtual; + + {:Send data as one block to socket. Each block begin with 4 bytes with + length of data in block. This 4 bytes is added automaticly by this + function.} + procedure SendBlock(const Data: AnsiString); virtual; + + {:Send data from stream to socket.} + procedure SendStreamRaw(const Stream: TStream); virtual; + + {:Send content of stream to socket. It using @link(SendBlock) method} procedure SendStream(const Stream: TStream); virtual; - function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; - function RecvBufferEx(Buffer: Pointer; Length: Integer; + + {:Send content of stream to socket. It using @link(SendBlock) method and + this is compatible with streams in Indy library.} + procedure SendStreamIndy(const Stream: TStream); virtual; + + {:Note: This is low-level receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Waits until allocated buffer is filled by received data. Returns number of + data received, which equals to LENGTH value under normal operation. If it + is not equal the communication channel is possibly broken. + + On stream oriented sockets if is received 0 bytes, it mean 'socket is + closed!" + + On datagram socket is readed first waiting datagram.} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions! + + Method waits until data is received. If no data is received within TIMEOUT + (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods + serves for reading any size of data (i.e. one megabyte...). This method is + preffered for reading from stream sockets (like TCP).} + function RecvBufferEx(Buffer: Tmemory; Len: Integer; Timeout: Integer): Integer; virtual; - function RecvBufferStr(Length: Integer; Timeout: Integer): String; virtual; + + {:Similar to @link(RecvBufferEx), but readed data is stored in binary + string, not in memory buffer.} + function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one data byte is received which is also returned as function + result. If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} function RecvByte(Timeout: Integer): Byte; virtual; - function RecvString(Timeout: Integer): string; virtual; - function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual; - function RecvPacket(Timeout: Integer): string; virtual; - function RecvBlock(Timeout: Integer): string; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Waits until one four bytes are received and return it as one Ineger Value. + If no data is received within TIMEOUT (in milliseconds)period, + @link(LastError) is set to WSAETIMEDOUT and result have value 0.} + function RecvInteger(Timeout: Integer): Integer; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + CR-LF characters. The resulting string is returned without this termination + (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be + exactly CR-LF. See @link(ConvertLineEnd) description. If no data is + received within TIMEOUT (in milliseconds) period, @link(LastError) is set + to WSAETIMEDOUT. You may also specify maximum length of reading data by + @link(MaxLineLength) property.} + function RecvString(Timeout: Integer): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method waits until data string is received. This string is terminated by + Terminator string. The resulting string is returned without this + termination. If no data is received within TIMEOUT (in milliseconds) + period, @link(LastError) is set to WSAETIMEDOUT. You may also specify + maximum length of reading data by @link(MaxLineLength) property.} + function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; + + {:Note: This is high-level receive function. It using internal + @link(LineBuffer) and you can combine this function freely with other + high-level functions. + + Method reads all data waiting for read. If no data is received within + TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. + Methods serves for reading unknown size of data. Because before call this + function you don't know size of received data, returned data is stored in + dynamic size binary string. This method is preffered for reading from + stream sockets (like TCP). It is very goot for receiving datagrams too! + (UDP protocol)} + function RecvPacket(Timeout: Integer): AnsiString; virtual; + + {:Read one block of data from socket. Each block begin with 4 bytes with + length of data in block. This function read first 4 bytes for get lenght, + then it wait for reported count of bytes.} + function RecvBlock(Timeout: Integer): AnsiString; virtual; + + {:Read all data from socket to stream until socket is closed (or any error + occured.)} + procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; + {:Read requested count of bytes from socket to stream.} + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); + + {:Receive data to stream. It using @link(RecvBlock) method.} procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; - function PeekBuffer(Buffer: Pointer; Length: Integer): Integer; virtual; + + {:Receive data to stream. This function is compatible with similar function + in Indy library. It using @link(RecvBlock) method.} + procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; + + {:Same as @link(RecvBuffer), but readed data stays in system input buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} + function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Same as @link(RecvByte), but readed data stays in input system buffer. + Warning: this function not respect data in @link(LineBuffer)! Is not + recommended to use this function!} function PeekByte(Timeout: Integer): Byte; virtual; + + {:On stream sockets it returns number of received bytes waiting for picking. + 0 is returned when there is no such data. On datagram socket it returns + length of the first waiting datagram. Returns 0 if no datagram is waiting.} function WaitingData: Integer; virtual; + + {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer), + return their length instead.} function WaitingDataEx: Integer; + + {:Clear all waiting data for read from buffers.} procedure Purge; + + {:Sets linger. Enabled linger means that the system waits another LINGER + (in milliseconds) time for delivery of sent data. This function is only for + stream type of socket! (TCP)} procedure SetLinger(Enable: Boolean; Linger: Integer); + + {:Actualize values in @link(LocalSin).} procedure GetSinLocal; + + {:Actualize values in @link(RemoteSin).} procedure GetSinRemote; + + {:Actualize values in @link(LocalSin) and @link(RemoteSin).} procedure GetSins; + + {:If you "manually" call Socket API functions, forward their return code as + parameter to this function, which evaluates it, eventually calls + GetLastError and found error code returns and stores to @link(LastError).} function SockCheck(SockResult: Integer): Integer; + + {:If @link(LastError) contains some error code and @link(RaiseExcept) + property is @true, raise adequate exception.} procedure ExceptCheck; + + {:Returns local computer name as numerical or symbolic value. It try get + fully qualified domain name. Name is returned in the format acceptable by + functions demanding IP as input parameter.} function LocalName: string; - procedure ResolveNameToIP(Name: string; IPList: TStrings); + + {:Try resolve name to all possible IP address. i.e. If you pass as name + result of @link(LocalName) method, you get all IP addresses used by local + system.} + procedure ResolveNameToIP(Name: string; const IPList: TStrings); + + {:Try resolve name to primary IP address. i.e. If you pass as name result of + @link(LocalName) method, you get primary IP addresses used by local system.} function ResolveName(Name: string): string; + + {:Try resolve IP to their primary domain name. If IP not have domain name, + then is returned original IP.} function ResolveIPToName(IP: string): string; + + {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)} function ResolvePort(Port: string): Word; + + {:Set information about remote side socket. It is good for seting remote + side for sending UDP packet, etc.} procedure SetRemoteSin(IP, Port: string); + + {:Picks IP socket address from @link(LocalSin).} function GetLocalSinIP: string; virtual; + + {:Picks IP socket address from @link(RemoteSin).} function GetRemoteSinIP: string; virtual; + + {:Picks socket PORT number from @link(LocalSin).} function GetLocalSinPort: Integer; virtual; + + {:Picks socket PORT number from @link(RemoteSin).} function GetRemoteSinPort: Integer; virtual; - function CanRead(Timeout: Integer): Boolean; - function CanReadEx(Timeout: Integer): Boolean; - function CanWrite(Timeout: Integer): Boolean; - function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; virtual; - function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; virtual; + + {:Return @TRUE, if you can read any data from socket or is incoming + connection on TCP based socket. Status is tested for time Timeout (in + milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. + + This function is need only on special cases, when you need use + @link(RecvBuffer) function directly!} + function CanRead(Timeout: Integer): Boolean; virtual; + + {:Same as @link(CanRead), but additionally return @TRUE if is some data in + @link(LineBuffer).} + function CanReadEx(Timeout: Integer): Boolean; virtual; + + {:Return @TRUE, if you can to socket write any data (not full sending + buffer). Status is tested for time Timeout (in milliseconds). If value in + Timeout is 0, status is only tested and continue. If value in Timeout is + -1, run is breaked and waiting for write data maybe forever. + + This function is need only on special cases!} + function CanWrite(Timeout: Integer): Boolean; virtual; + + {:Same as @link(SendBuffer), but send datagram to address from + @link(RemoteSin). Usefull for sending reply to datagram received by + function @link(RecvBufferFrom).} + function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; virtual; + + {:Note: This is low-lever receive function. You must be sure if data is + waiting for read before call this function for avoid deadlock! + + Receives first waiting datagram to allocated buffer. If there is no waiting + one, then waits until one comes. Returns length of datagram stored in + BUFFER. If length exceeds buffer datagram is truncated. After this + @link(RemoteSin) structure contains information about sender of UDP packet.} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual; +{$IFNDEF CIL} + {:This function is for check for incoming data on set of sockets. Whitch + sockets is checked is decribed by SocketList Tlist with TBlockSocket + objects. TList may have maximal number of objects defined by FD_SETSIZE + constant. Return @TRUE, if you can from some socket read any data or is + incoming connection on TCP based socket. Status is tested for time Timeout + (in milliseconds). If value in Timeout is 0, status is only tested and + continue. If value in Timeout is -1, run is breaked and waiting for read + data maybe forever. If is returned @TRUE, CanReadList TList is filled by all + TBlockSocket objects what waiting for read.} function GroupCanRead(const SocketList: TList; Timeout: Integer; const CanReadList: TList): Boolean; +{$ENDIF} + {:By this method you may turn address reuse mode for local @link(bind). It + is good specially for UDP protocol. Using this with TCP protocol is + hazardous!} procedure EnableReuse(Value: Boolean); + + {:Try set timeout for all sending and receiving operations, if socket + provider can do it. (It not supported by all socket providers!)} procedure SetTimeout(Timeout: Integer); + + {:Try set timeout for all sending operations, if socket provider can do it. + (It not supported by all socket providers!)} procedure SetSendTimeout(Timeout: Integer); + + {:Try set timeout for all receiving operations, if socket provider can do + it. (It not supported by all socket providers!)} procedure SetRecvTimeout(Timeout: Integer); + {:Convert IPv6 address from their string form to binary. This function + working only on systems with IPv6 support!} function StrToIP6(const value: string): TSockAddrIn6; + + {:Convert IPv6 address from binary to string form. This function working + only on systems with IPv6 support!} function IP6ToStr(const value: TSockAddrIn6): string; + {:Return value of socket type.} function GetSocketType: integer; Virtual; + + {:Return value of protocol type for socket creation.} function GetSocketProtocol: integer; Virtual; - property WSAData: TWSADATA read FWsaData; + {:WSA structure with information about socket provider. On linux is this + structure simulated!} + property WSAData: TWSADATA read GetWsaData; + + {:Structure describing local socket side.} property LocalSin: TVarSin read FLocalSin write FLocalSin; + + {:Structure describing remote socket side.} property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; - published - class function GetErrorDesc(ErrorCode: Integer): string; + + {:Socket handler. Suitable for "manual" calls to socket API or manual + connection of socket to a previously created socket (i.e by Accept method + on TCP socket)} property Socket: TSocket read FSocket write SetSocket; + + {:Last socket operation error code. Error codes are described in socket + documentation. Human readable error description is stored in + @link(LastErrorDesc) property.} property LastError: Integer read FLastError; + + {:Human readable error description of @link(LastError) code.} property LastErrorDesc: string read FLastErrorDesc; + + {:Buffer used by all high-level receiving functions. This buffer is used for + optimized reading of data from socket. In normal cases you not need access + to this buffer directly!} property LineBuffer: string read FBuffer write FBuffer; - property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; + + {:Size of Winsock receive buffer. If it is not supported by socket provider, + it return as size one kilobyte.} property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer; + + {:Size of Winsock send buffer. If it is not supported by socket provider, it + return as size one kilobyte.} property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer; + + {:If @True, turn class to non-blocking mode. Not all functions are working + properly in this mode, you must know exactly what you are doing! However + when you have big experience with non-blocking programming, then you can + optimise your program by non-block mode!} property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode; - property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; - property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; - property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; - property MaxBandwidth: Integer Write SetBandwidth; - property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Set Time-to-live value. (if system supporting it!)} property TTL: Integer read GetTTL Write SetTTL; - property Family: TSocketFamily read FFamily Write SetFamily; - property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; + + {:If is @true, then class in in IPv6 mode.} property IP6used: Boolean read FIP6used; - property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + + {:Return count of received bytes on this socket from begin of current + connection.} property RecvCounter: Integer read FRecvCounter; + + {:Return count of sended bytes on this socket from begin of current + connection.} property SendCounter: Integer read FSendCounter; + published + {:Return descriptive string for given error code. This is class function. + You may call it without created object!} + class function GetErrorDesc(ErrorCode: Integer): string; + + {:this value is for free use.} + property Tag: Integer read FTag write FTag; + + {:If @true, winsock errors raises exception. Otherwise is setted + @link(LastError) value only and you must check it from your program! Default + value is @false.} + property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept; + + {:Define maximum length in bytes of @link(LineBuffer) for high-level + receiving functions. If this functions try to read more data then this + limit, error is returned! If value is 0 (default), no limitation is used. + This is very good protection for stupid attacks to your server by sending + lot of data without proper terminator... until all your memory is allocated + by LineBuffer! + + Note: This maximum length is checked only in functions, what read unknown + number of bytes! (like @link(RecvString) or @link(RecvTerminated))} + property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; + + {:Define maximal bandwidth for all sending operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; + + {:Define maximal bandwidth for all receiving operations in bytes per second. + If value is 0 (default), bandwidth limitation is not used.} + property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; + + {:Define maximal bandwidth for all sending and receiving operations in bytes + per second. If value is 0 (default), bandwidth limitation is not used.} + property MaxBandwidth: Integer Write SetBandwidth; + + {:Do a conversion of non-standard line terminators to CRLF. (Off by default) + If @True, then terminators like sigle CR, single LF or LFCR are converted + to CRLF internally. This have effect only in @link(RecvString) method!} + property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; + + {:Specified Family of this socket. When you are using Windows preliminary + support for IPv6, then I recommend to set this property!} + property Family: TSocketFamily read FFamily Write SetFamily; + + {:When resolving of domain name return both IPv4 and IPv6 addresses, then + specify if is used IPv4 (dafault - @true) or IPv6.} + property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; + + {:By dafault (@false) is all timeouts used as timeout between two packets in + reading operations. If you set this to @true, then Timeouts is for overall + reading operation!} + property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; + + {:All sended datas was splitted by this value.} + property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk; + + {:By setting this property to @true you can stop any communication. You can + use this property for soft abort of communication.} + property StopFlag: Boolean read FStopFlag Write FStopFlag; + + {:This event is called by various reasons. It is good for monitoring socket, + create gauges for data transfers, etc.} property OnStatus: THookSocketStatus read FOnStatus write FOnStatus; + + {:this event is good for some internal thinks about filtering readed datas. + It is used by telnet client by example.} property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter; + + {:This event is good for some internal thinks about filtering writed datas.} property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter; + + {:This event is called after real socket creation for setting special socket + options, because you not know when socket is created. (it is depended on + Ipv4, IPv6 or automatic mode)} property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket; end; + {:@abstract(Support for SOCKS4 and SOCKS5 proxy) + Layer with definition all necessary properties and functions for + implementation SOCKS proxy client. Do not use this class directly.} TSocksBlockSocket = class(TBlockSocket) protected FSocksIP: string; @@ -356,21 +819,57 @@ type function SocksDecode(Value: string): integer; public constructor Create; + + {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do + authorisation to proxy. This is needed only in special cases! (it is called + internally!)} function SocksOpen: Boolean; + + {:Send specified request to SOCKS proxy. This is needed only in special + cases! (it is called internally!)} function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean; + + {:Receive response to previosly sended request. This is needed only in + special cases! (it is called internally!)} function SocksResponse: Boolean; - published - property SocksIP: string read FSocksIP write FSocksIP; - property SocksPort: string read FSocksPort write FSocksPort; - property SocksUsername: string read FSocksUsername write FSocksUsername; - property SocksPassword: string read FSocksPassword write FSocksPassword; - property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; + + {:Is @True when class is using SOCKS proxy.} property UsingSocks: Boolean read FUsingSocks; - property SocksResolver: Boolean read FSocksResolver write FSocksResolver; + + {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.} property SocksLastError: integer read FSocksLastError; + published + {:Address of SOCKS server. If value is empty string, SOCKS support is + disabled. Assingning any value to this property enable SOCKS mode. + Warning: You cannot combine this mode with HTTP-tunneling mode!} + property SocksIP: string read FSocksIP write FSocksIP; + + {:Port of SOCKS server. Default value is '1080'.} + property SocksPort: string read FSocksPort write FSocksPort; + + {:If you need authorisation on SOCKS server, set username here.} + property SocksUsername: string read FSocksUsername write FSocksUsername; + + {:If you need authorisation on SOCKS server, set password here.} + property SocksPassword: string read FSocksPassword write FSocksPassword; + + {:Specify timeout for communicatin with SOCKS server. Default is one minute.} + property SocksTimeout: integer read FSocksTimeout write FSocksTimeout; + + {:If @True, all symbolic names of target hosts is not translated to IP's + locally, but resolving is by SOCKS proxy. Default is @True.} + property SocksResolver: Boolean read FSocksResolver write FSocksResolver; + + {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too. + When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is + used SOCKS4a. Othervise is used pure SOCKS4.} property SocksType: TSocksType read FSocksType write FSocksType; end; + {:@abstract(Implementation of TCP socket.) + Supported features: IPv4, IPv6, SSL/TLS (SSL2, SSL3 and TLS), SOCKS5 proxy + (outgoing connections and limited incomming), SOCKS4/4a proxy (outgoing + connections and limited incomming), TCP through HTTP proxy tunnel.} TTCPBlockSocket = class(TSocksBlockSocket) protected FSslEnabled: Boolean; @@ -396,68 +895,241 @@ type FHTTPTunnelTimeout: integer; procedure SetSslEnabled(Value: Boolean); function SetSslKeys: boolean; + function GetSSLLoaded: Boolean; procedure SocksDoConnect(IP, Port: string); procedure HTTPTunnelDoConnect(IP, Port: string); - function GetSSLLoaded: Boolean; public constructor Create; + + {:See @link(TBlockSocket.CloseSocket)} procedure CloseSocket; override; + + {:See @link(TBlockSocket.WaitingData)} function WaitingData: Integer; override; + + {:Sets socket to receive mode for new incoming connections. It is necessary + to use @link(TBlockSocket.BIND) function call before this method to select + receiving port! + + If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND + method of SOCKS.)} procedure Listen; virtual; + + {:Waits until new incoming connection comes. After it comes a new socket is + automatically created (socket handler is returned by this function as + result). + + If you use SOCKS, new socket is not created! In this case is used same + socket as socket for listening! So, you can accept only one connection in + SOCKS mode.} function Accept: TSocket; + + {:Connects socket to remote IP address and PORT. The same rules as with + @link(TBlockSocket.BIND) method are valid. The only exception is that PORT + with 0 value will not be connected. After call to this method + a communication channel between local and remote socket is created. Local + socket is assigned automatically if not controlled by previous call to + @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin) + and @link(TBlockSocket.RemoteSin) will be filled with valid values. + + If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified + in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.) + + If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP + tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP + protocol.) + + If you additionally use SSL mode, then SSL/TLS session was started. + + Note: If you call this on non-created socket, then socket is created + automaticly.} procedure Connect(IP, Port: string); override; + + {:If you need upgrade existing TCP connection to SSL/TLS mode, then call + this method. This method switch this class to SSL mode and do SSL/TSL + handshake.} procedure SSLDoConnect; + + {:By this method you can downgrade existing SSL/TLS connection to normal TCP + connection.} procedure SSLDoShutdown; + + {:If you need use this component as SSL/TLS TCP server, then after accepting + of inbound connection you need start SSL/TLS session by this method. Before + call this function, you must have assigned all neeeded certificates and + keys!} function SSLAcceptConnection: Boolean; + + {:See @link(TBlockSocket.GetLocalSinIP)} function GetLocalSinIP: string; override; + + {:See @link(TBlockSocket.GetRemoteSinIP)} function GetRemoteSinIP: string; override; + + {:See @link(TBlockSocket.GetLocalSinPort)} function GetLocalSinPort: Integer; override; + + {:See @link(TBlockSocket.GetRemoteSinPort)} function GetRemoteSinPort: Integer; override; - function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override; - function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.SendBuffer)} + function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBuffer)} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + + {:Return string with identificator of SSL/TLS version of existing + connection.} function SSLGetSSLVersion: string; + + {:Return subject of remote SSL peer.} function SSLGetPeerSubject: string; + + {:Return issuer certificate of remote SSL peer.} function SSLGetPeerIssuer: string; + + {:Return peer name from remote side certificate. This is good for verify, + if certificate is generated for remote side IP name.} function SSLGetPeerName: string; + + {:Return subject's hash of remote SSL peer.} function SSLGetPeerSubjectHash: Cardinal; + + {:Return issuer's certificate hash of remote SSL peer.} function SSLGetPeerIssuerHash: Cardinal; + + {:Return fingerprint of remote SSL peer.} function SSLGetPeerFingerprint: string; + + {:Return all detailed information about certificate from remote side of + SSL/TLS connection. Result string is multilined!} function SSLGetCertInfo: string; + + {:Return currently used Cipher.} function SSLGetCipherName: string; + + {:Return currently used number of bits in current Cipher algorythm.} function SSLGetCipherBits: integer; + + {:Return number of bits in current Cipher algorythm.} function SSLGetCipherAlgBits: integer; + + {:Return result value of verify remote side certificate. Look to OpenSSL + documentation for possible values. For example 0 is successfuly verified + certificate, or 18 is self-signed certificate.} function SSLGetVerifyCert: integer; + + {:Test last SSL operation for errors. If error occured, then is filled + @link(SSLLastError) and @link(SSLLastErrorDesc) properties.} function SSLCheck: Boolean; + + {:Return value of socket type. For TCP return SOCK_STREAM.} function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For TCP return + IPPROTO_TCP.} function GetSocketProtocol: integer; override; - published + + {:Is SSL interface loaded or not?} property SSLLoaded: Boolean read GetSslLoaded; + + {:By this property you can enable or disable SSL mode. Enabling loads needed + OpenSSL or SSLeay libraries. Libraries is loaded to memory only once for + all Synapse's objects. + + Note: when you enable SSL mode, all keys and certificates are loaded (if + needed property is unempty)} property SSLEnabled: Boolean read FSslEnabled write SetSslEnabled; - property SSLType: TSSLType read FSSLType write FSSLType; - property SSLBypass: Boolean read FSslBypass write FSslBypass; - property SSLPassword: string read FSSLPassword write FSSLPassword; - property SSLCiphers: string read FSSLCiphers write FSSLCiphers; - property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; - property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; - property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; + + {:Contains last SSL error code.} property SSLLastError: integer read FSSLLastError; + + {:If some SSL error is occured, then contains human readable description of + this error.} property SSLLastErrorDesc: string read FSSLLastErrorDesc; - property SSLverifyCert: Boolean read FSSLverifyCert write FSSLverifyCert; - property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; - property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; + + {:@True if is used HTTP tunnel mode.} property HTTPTunnel: Boolean read FHTTPTunnel; + published + {:Here you can specify requested SSL/TLS mode. Default is autodetection, but + on some servers autodetection not working properly. In this case you must + specify requested SSL/TLS mode by your hand!} + property SSLType: TSSLType read FSSLType write FSSLType; + + {:If is SSL mode enabled and this property is @TRUE, then all data (read + and write) will not be encrypted/decrypted.} + property SSLBypass: Boolean read FSslBypass write FSslBypass; + + {:Password for decrypting of encoded certificate. + + Note: This not work with delphi8. You cannot use password protected + certificates with .NET!} + property SSLPassword: string read FSSLPassword write FSSLPassword; + + {:By this property you can modify default set of SSL/TLS ciphers.} + property SSLCiphers: string read FSSLCiphers write FSSLCiphers; + + {:Filename and path to PEM file with your certificate. If certificate need + password for decrypt, you can assign this password to SSLPassword property.} + property SSLCertificateFile: string read FSSLCertificateFile write FSSLCertificateFile; + + {:Filename and path to PEM file with your private key.} + property SSLPrivateKeyFile: string read FSSLPrivateKeyFile write FSSLPrivateKeyFile; + + {:filename and path to file with bundle of CA certificates. (you may use + ca-bundle.crt file from SynaCert.zip)} + property SSLCertCAFile: string read FSSLCertCAFile write FSSLCertCAFile; + + {:If @true, then is verified client certificate. (it is good for writing + SSL/TLS servers.) When you are not server, but you are client, then if this + property is @true, verify servers certificate.} + property SSLverifyCert: Boolean read FSSLverifyCert write FSSLverifyCert; + + {:Specify IP address of HTTP proxy. Assingning non-empty value to this + property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing + TCP connection through HTTP proxy server. (If policy on HTTP proxy server + allow this!) Warning: You cannot combine this mode with SOCK5 mode!} + property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP; + + {:Specify port of HTTP proxy for HTTP-tunneling.} + property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort; + + {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel + mode. If you not need authorisation, then let this property empty.} property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser; + + {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel + mode.} property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass; + + {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.} property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout; end; + {:@abstract(Datagram based communication) + This class implementing datagram based communication instead default stream + based communication style.} TDgramBlockSocket = class(TSocksBlockSocket) public + {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for + sending data.} procedure Connect(IP, Port: string); override; - function SendBuffer(Buffer: Pointer; Length: Integer): Integer; override; - function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; override; + + {:Silently redirected to @link(TBlockSocket.SendBufferTo).} + function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + + {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).} + function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override; end; + {:@abstract(Implementation of UDP socket.) + NOTE: in this class is all receiving redirected to RecvBufferFrom. You can + use for reading any receive function. Preffered is RecvPacket! Similary all + sending is redirected to SendbufferTo. You can use for sending UDP packet any + sending function, like SendString. + + Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5 + proxy (only unicasts! Outgoing and incomming.)} TUDPBlockSocket = class(TDgramBlockSocket) protected FSocksControlSock: TTCPBlockSocket; @@ -466,30 +1138,71 @@ type function GetMulticastTTL:integer; public destructor Destroy; override; + + {:Enable or disable sending of broadcasts. If seting OK, result is @true. + This method is not supported in SOCKS5 mode! IPv6 does not support + broadcasts! In this case you must use Multicasts instead.} procedure EnableBroadcast(Value: Boolean); - function SendBufferTo(Buffer: Pointer; Length: Integer): Integer; override; - function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.SendBufferTo)} + function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override; + + {:See @link(TBlockSocket.RecvBufferFrom)} + function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override; +{$IFNDEF CIL} + {:Add this socket to given multicast group. You cannot use Multicasts in + SOCKS mode!} procedure AddMulticast(MCastIP:string); + + {:Remove this socket from given multicast group.} procedure DropMulticast(MCastIP:string); +{$ENDIF} + {:All sended multicast datagrams is loopbacked to your interface too. (you + can read your sended datas.) You can disable this feature by this function. + This function not working on some Windows systems!} procedure EnableMulticastLoop(Value: Boolean); + + {:Return value of socket type. For UDP return SOCK_DGRAM.} function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For UDP return + IPPROTO_UDP.} function GetSocketProtocol: integer; override; - published + + {:Set Time-to-live value for multicasts packets. It define number of routers + for transfer of datas. If you set this to 1 (dafault system value), then + multicasts packet goes only to you local network. If you need transport + multicast packet to worldwide, then increase this value, but be carefull, + lot of routers on internet does not transport multicasts packets!} property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL; end; + {:@abstract(Implementation of RAW ICMP socket.) + For this object you must have rights for creating RAW sockets!} TICMPBlockSocket = class(TDgramBlockSocket) public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For ICMP returns + IPPROTO_ICMP or IPPROTO_ICMPV6} function GetSocketProtocol: integer; override; end; + {:@abstract(Implementation of RAW socket.) + For this object you must have rights for creating RAW sockets!} TRAWBlockSocket = class(TBlockSocket) public + {:Return value of socket type. For RAW and ICMP return SOCK_RAW.} function GetSocketType: integer; override; + + {:Return value of protocol type for socket creation. For RAW returns + IPPROTO_RAW.} function GetSocketProtocol: integer; override; end; + {:@abstract(Record with definition of IP packet header.) + For reading data from ICMP or RAW sockets.} TIPHeader = record VerLen: Byte; TOS: Byte; @@ -504,19 +1217,37 @@ type Options: DWORD; end; + {:@abstract(Parent class of application protocol implementations.) + By this class is defined common properties.} TSynaClient = Class(TObject) protected FTargetHost: string; FTargetPort: string; FIPInterface: string; FTimeout: integer; + FUserName: string; + FPassword: string; public constructor Create; published + {:Specify terget server IP (or symbolic name). Default is 'localhost'.} property TargetHost: string read FTargetHost Write FTargetHost; + + {:Specify terget server port (or symbolic name).} property TargetPort: string read FTargetPort Write FTargetPort; + + {:Defined local socket address. (outgoing IP address). By default is used + '0.0.0.0' as wildcard for default IP.} property IPInterface: string read FIPInterface Write FIPInterface; + + {:Specify default timeout for socket operations.} property Timeout: integer read FTimeout Write FTimeout; + + {:If protocol need user authorization, then fill here username.} + property UserName: string read FUserName Write FUserName; + + {:If protocol need user authorization, then fill here password.} + property Password: string read FPassword Write FPassword; end; implementation @@ -564,9 +1295,9 @@ begin FInterPacketTimeout := True; FRecvCounter := 0; FSendCounter := 0; -{$IFDEF ONCEWINSOCK} - FWsaData := WsaDataOnce; -{$ELSE} + FSendMaxChunk := c64k; + FStopFlag := False; +{$IFNDEF ONCEWINSOCK} if Stub = '' then Stub := DLLStackName; if not InitSocketInterface(Stub) then @@ -576,7 +1307,7 @@ begin e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!'; raise e; end; - SockCheck(synsock.WSAStartup(WinsockLevel, FWsaData)); + SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce)); ExceptCheck; {$ENDIF} end; @@ -584,7 +1315,7 @@ end; destructor TBlockSocket.Destroy; var n: integer; - p: PSynaOption; + p: TSynaOption; begin CloseSocket; {$IFNDEF ONCEWINSOCK} @@ -593,8 +1324,8 @@ begin {$ENDIF} for n := FDelayedOptions.Count - 1 downto 0 do begin - p := PSynaOption(FDelayedOptions[n]); - Dispose(p); + p := TSynaOption(FDelayedOptions[n]); + p.Free; end; FDelayedOptions.Free; inherited Destroy; @@ -607,27 +1338,44 @@ begin Result := (FFamily = SF_ip6) and SockWship6Api; end; -procedure TBlockSocket.SetDelayedOption(Value: TSynaOption); +procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); var li: TLinger; x: integer; + buf: TMemory; begin case value.Option of SOT_Linger: begin + {$IFDEF CIL} + li := TLinger.Create(Value.Enabled, Value.Value div 1000); + synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li); + {$ELSE} li.l_onoff := Ord(Value.Enabled); li.l_linger := Value.Value div 1000; - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_LINGER, @li, SizeOf(li)); + buf := @li; + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li)); + {$ENDIF} end; SOT_RecvBuff: begin - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, - @Value.Value, SizeOf(Value.Value)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), + buf, SizeOf(Value.Value)); end; SOT_SendBuff: begin - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, - @Value.Value, SizeOf(Value.Value)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), + buf, SizeOf(Value.Value)); end; SOT_NonBlock: begin @@ -637,63 +1385,95 @@ begin end; SOT_RecvTimeout: begin - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, - @Value.Value, SizeOf(Value.Value)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), + buf, SizeOf(Value.Value)); end; SOT_SendTimeout: begin - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, - @Value.Value, SizeOf(Value.Value)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), + buf, SizeOf(Value.Value)); end; SOT_Reuse: begin x := Ord(Value.Enabled); - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_REUSEADDR, @x, SizeOf(x)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x)); end; SOT_TTL: begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} if FIP6Used then - synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, - @Value.Value, SizeOf(Value.Value)) + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS), + buf, SizeOf(Value.Value)) else - synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_TTL, - @Value.Value, SizeOf(Value.Value)); + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL), + buf, SizeOf(Value.Value)); end; SOT_Broadcast: begin //#todo1 broadcasty na IP6 x := Ord(Value.Enabled); - synsock.SetSockOpt(FSocket, SOL_SOCKET, SO_BROADCAST, @x, SizeOf(x)); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} + synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x)); end; SOT_MulticastTTL: begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(value.Value); + {$ELSE} + buf := @Value.Value; + {$ENDIF} if FIP6Used then - synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, - @Value.Value, SizeOf(Value.Value)) + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS), + buf, SizeOf(Value.Value)) else - synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, - @Value.Value, SizeOf(Value.Value)); + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL), + buf, SizeOf(Value.Value)); end; - SOT_MulticastLoop: + SOT_MulticastLoop: begin x := Ord(Value.Enabled); + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(x); + {$ELSE} + buf := @x; + {$ENDIF} if FIP6Used then - synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_LOOP, @x, SizeOf(x)) + synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x)) else - synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_LOOP, @x, SizeOf(x)); + synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)); end; end; + Value.free; end; -procedure TBlockSocket.DelayedOption(Value: TSynaOption); -var - d: PSynaOption; +procedure TBlockSocket.DelayedOption(const Value: TSynaOption); begin if FSocket = INVALID_SOCKET then begin - new(d); - d^ := Value; - FDelayedOptions.Insert(0, d); + FDelayedOptions.Insert(0, Value); end else SetDelayedOption(Value); @@ -702,46 +1482,72 @@ end; procedure TBlockSocket.ProcessDelayedOptions; var n: integer; - d: PSynaOption; + d: TSynaOption; begin for n := FDelayedOptions.Count - 1 downto 0 do begin - d := FDelayedOptions[n]; - SetDelayedOption(d^); - Dispose(d); + d := TSynaOption(FDelayedOptions[n]); + SetDelayedOption(d); end; FDelayedOptions.Clear; end; procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); +{$IFNDEF CIL} type pu_long = ^u_long; var ProtoEnt: PProtoEnt; ServEnt: PServEnt; HostEnt: PHostEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; r: integer; - Sin4, Sin6: TVarSin; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + begin DoStatus(HR_ResolvingBegin, IP + ':' + Port); + FLastError := 0; FillChar(Sin, Sizeof(Sin), 0); - //for prelimitary IP6 support try fake Family by given IP - if SockWship6Api and (FFamily = SF_Any) then - begin - if IsIP(IP) then - FFamily := SF_IP4 - else - if IsIP6(IP) then - FFamily := SF_IP6 - else - if FPreferIP4 then - FFamily := SF_IP4 - else - FFamily := SF_IP6; - end; if not IsNewApi then begin SynSockCS.Enter; @@ -763,6 +1569,7 @@ begin if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then begin HostEnt := synsock.GetHostByName(PChar(IP)); + FLastError := synsock.WSAGetLastError; if HostEnt <> nil then Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); end; @@ -773,82 +1580,114 @@ begin end else begin - Addr := nil; - try - FillChar(Sin4, Sizeof(Sin4), 0); - FillChar(Sin6, Sizeof(Sin6), 0); - FillChar(Hints, Sizeof(Hints), 0); - //if socket exists, then use their type, else use users selection - if FSocket = INVALID_SOCKET then - case FFamily of - SF_Any: Hints.ai_family := AF_UNSPEC; - SF_IP4: Hints.ai_family := AF_INET; - SF_IP6: Hints.ai_family := AF_INET6; - end - else - if FIP6Used then - Hints.ai_family := AF_INET6 - else - Hints.ai_family := AF_INET; - Hints.ai_socktype := GetSocketType; - Hints.ai_protocol := GetSocketprotocol; - if Hints.ai_socktype = SOCK_RAW then - begin - Hints.ai_socktype := 0; - Hints.ai_protocol := 0; - r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); - end - else - begin - if IP = cAnyHost then - begin - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - if IP = cLocalhost then + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + //if socket exists, then use their type, else use users selection + if FSocket = INVALID_SOCKET then + case FFamily of + SF_Any: begin - r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - begin - r := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr); + if IsIP(IP) then + Hints1.ai_family := AF_INET + else + if IsIP6(IP) then + Hints1.ai_family := AF_INET6 + else + if FPreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end end; - end; - if r = 0 then + SF_IP4: + Hints1.ai_family := AF_INET; + SF_IP6: + Hints1.ai_family := AF_INET6; + end + else + if FIP6Used then + Hints1.ai_family := AF_INET6 + else + Hints1.ai_family := AF_INET; + Hints1.ai_socktype := GetSocketType; + Hints1.ai_protocol := GetSocketprotocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + FLastError := r; + sin := sin1; + if r <> 0 then + if TwoPass then begin - AddrNext := Addr; - while not (AddrNext = nil) do - begin - if not(Sin4.sin_family = AF_INET) and (AddrNext^.ai_family = AF_INET) then - Move(AddrNext^.ai_addr^, Sin4, AddrNext^.ai_addrlen); - if not(Sin6.sin_family = AF_INET6) and (AddrNext^.ai_family = AF_INET6) then - Move(AddrNext^.ai_addr^, Sin6, AddrNext^.ai_addrlen); - AddrNext := AddrNext^.ai_next; - end; - if (Sin4.sin_family = AF_INET) and (Sin6.sin_family = AF_INET6) then + r := GetAddr(IP, Port, Hints2, Sin2); + FLastError := r; + if r = 0 then + sin := sin2; + end; + end; +{$ELSE} +var + IPs: array of IPAddress; + n: integer; + ip4, ip6: string; + sip: string; +begin + ip4 := ''; + ip6 := ''; + IPs := Dns.Resolve(IP).AddressList; + for n :=low(IPs) to high(IPs) do begin + if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then + ip4 := IPs[n].toString; + if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then + ip6 := IPs[n].toString; + if (ip4 <> '') and (ip6 <> '') then + break; + end; + if FSocket = INVALID_SOCKET then + case FFamily of + SF_Any: + begin + if (ip4 <> '') and (ip6 <> '') then begin if FPreferIP4 then - Sin := Sin4 + sip := ip4 else - Sin := Sin6; - end + Sip := ip6; + end else begin - sin := sin4; - if (Sin6.sin_family = AF_INET6) then - sin := sin6; + sip := ip4; + if (ip6 <> '') then + sip := ip6; end; end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; + SF_IP4: + sip := ip4; + SF_IP6: + sip := ip6; + end + else + if FIP6Used then + sip := ip6 + else + sip := ip4; + + sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); +{$ENDIF} DoStatus(HR_ResolvingEnd, IP + ':' + Port); end; function TBlockSocket.GetSinIP(Sin: TVarSin): string; +{$IFNDEF CIL} var p: PChar; host, serv: string; @@ -873,14 +1712,23 @@ begin if r = 0 then Result := PChar(host); end; +{$ELSE} +begin + Result := Sin.Address.ToString; +{$ENDIF} end; function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; +{$IFNDEF CIL} begin if (Sin.sin_family = AF_INET6) then Result := synsock.ntohs(Sin.sin6_port) else Result := synsock.ntohs(Sin.sin_port); +{$ELSE} +begin + Result := Sin.Port; +{$ENDIF} end; procedure TBlockSocket.CreateSocket; @@ -891,11 +1739,18 @@ begin FLastError := 0; if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then begin + {$IFDEF CIL} + if FFamily = SF_IP6 then + sin := TVarSin.Create(IPAddress.Parse('::0'), 0) + else + sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0); + {$ELSE} FillChar(Sin, Sizeof(Sin), 0); if FFamily = SF_IP6 then sin.sin_family := AF_INET6 else sin.sin_family := AF_INET; + {$ENDIF} InternalCreateSocket(Sin); end; end; @@ -908,12 +1763,14 @@ begin if FSocket = INVALID_SOCKET then begin SetSin(sin, value, '0'); - InternalCreateSocket(Sin); + if FLastError = 0 then + InternalCreateSocket(Sin); end; end; procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); begin + FStopFlag := False; FRecvCounter := 0; FSendCounter := 0; FLastError := 0; @@ -921,12 +1778,14 @@ begin begin FBuffer := ''; FBinded := False; - FIP6Used := Sin.sin_family = AF_INET6; - FSocket := synsock.Socket(Sin.sin_family, GetSocketType, GetSocketProtocol); + FIP6Used := Sin.AddressFamily = AF_INET6; + FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol); if FSocket = INVALID_SOCKET then FLastError := synsock.WSAGetLastError; + {$IFNDEF CIL} FD_ZERO(FFDSet); FD_SET(FSocket, FFDSet); + {$ENDIF} ExceptCheck; if FIP6used then DoStatus(HR_SocketCreate, 'IPv6') @@ -945,14 +1804,15 @@ end; procedure TBlockSocket.AbortSocket; var n: integer; - p: PSynaOption; + p: TSynaOption; begin - synsock.CloseSocket(FSocket); + if FSocket <> INVALID_SOCKET then + synsock.CloseSocket(FSocket); FSocket := INVALID_SOCKET; for n := FDelayedOptions.Count - 1 downto 0 do begin - p := PSynaOption(FDelayedOptions[n]); - Dispose(p); + p := TSynaOption(FDelayedOptions[n]); + p.Free; end; FDelayedOptions.Clear; FFamily := FFamilySave; @@ -969,12 +1829,15 @@ begin or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then begin SetSin(Sin, IP, Port); - if FSocket = INVALID_SOCKET then - InternalCreateSocket(Sin); - SockCheck(synsock.Bind(FSocket, @Sin, SizeOfVarSin(Sin))); - GetSinLocal; - FBuffer := ''; - FBinded := True; + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + SockCheck(synsock.Bind(FSocket, Sin)); + GetSinLocal; + FBuffer := ''; + FBinded := True; + end; ExceptCheck; DoStatus(HR_Bind, IP + ':' + Port); end; @@ -985,33 +1848,29 @@ var Sin: TVarSin; begin SetSin(Sin, IP, Port); - if FSocket = INVALID_SOCKET then - InternalCreateSocket(Sin); - SockCheck(synsock.Connect(FSocket, @Sin, SizeOfVarSin(Sin))); - GetSins; - FBuffer := ''; - FLastCR := False; - FLastLF := False; + if FLastError = 0 then + begin + if FSocket = INVALID_SOCKET then + InternalCreateSocket(Sin); + SockCheck(synsock.Connect(FSocket, Sin)); + if FLastError = 0 then + GetSins; + FBuffer := ''; + FLastCR := False; + FLastLF := False; + end; ExceptCheck; DoStatus(HR_Connect, IP + ':' + Port); end; procedure TBlockSocket.GetSinLocal; -var - Len: Integer; begin - FillChar(FLocalSin, Sizeof(FLocalSin), 0); - Len := SizeOf(FLocalSin); - synsock.GetSockName(FSocket, @FLocalSin, Len); + synsock.GetSockName(FSocket, FLocalSin); end; procedure TBlockSocket.GetSinRemote; -var - Len: Integer; begin - FillChar(FRemoteSin, Sizeof(FRemoteSin), 0); - Len := SizeOf(FRemoteSin); - synsock.GetPeerName(FSocket, @FRemoteSin, Len); + synsock.GetPeerName(FSocket, FRemoteSin); end; procedure TBlockSocket.GetSins; @@ -1047,52 +1906,137 @@ begin end; end; -function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; +function TBlockSocket.TestStopFlag: Boolean; begin - LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); + Result := FStopFlag; + if Result then + begin + FStopFlag := False; + FLastError := WSAECONNABORTED; + FLastErrorDesc := GetErrorDesc(FLastError); + ExceptCheck; + end; +end; + + +function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +{$IFNDEF CIL} +var + x, y: integer; + l, r: integer; + p: Pointer; +{$ENDIF} +begin + Result := 0; + if TestStopFlag then + Exit; DoWriteFilter(Buffer, Length); - Result := synsock.Send(FSocket, Buffer^, Length, MSG_NOSIGNAL); - SockCheck(Result); +{$IFDEF CIL} + Result := synsock.Send(FSocket, Buffer, Length, 0); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); +// r := synsock.Send(FSocket, p^, y, MSG_NOSIGNAL); + r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); + SockCheck(r); + if Flasterror <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} ExceptCheck; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); end; procedure TBlockSocket.SendByte(Data: Byte); -begin - SendBuffer(@Data, 1); -end; - -procedure TBlockSocket.SendString(const Data: string); -begin - SendBuffer(PChar(Data), Length(Data)); -end; - -procedure TBlockSocket.SendBlock(const Data: string); +{$IFDEF CIL} var - x: integer; + buf: TMemory; +{$ENDIF} begin - x := Length(Data); - SendBuffer(@x, SizeOf(x)); +{$IFDEF CIL} + setlength(buf, 1); + buf[0] := Data; + SendBuffer(buf, 1); +{$ELSE} + SendBuffer(@Data, 1); +{$ENDIF} +end; + +procedure TBlockSocket.SendString(Data: AnsiString); +var + buf: TMemory; +begin +// SendBuffer(PChar(Data), Length(Data)); + {$IFDEF CIL} + buf := BytesOf(Data); + {$ELSE} + buf := pchar(data); + {$ENDIF} + SendBuffer(buf, Length(Data)); +end; + +procedure TBlockSocket.SendInteger(Data: integer); +var + buf: TMemory; +begin + {$IFDEF CIL} + buf := System.BitConverter.GetBytes(Data); + {$ELSE} + buf := @Data; + {$ENDIF} + SendBuffer(buf, SizeOf(Data)); +end; + +procedure TBlockSocket.SendBlock(const Data: AnsiString); +begin + SendInteger(Length(data)); SendString(Data); end; -procedure TBlockSocket.SendStream(const Stream: TStream); +procedure TBlockSocket.SendStreamRaw(const Stream: TStream); var si: integer; x, y, yr: integer; - s: string; + s: AnsiString; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} begin si := Stream.Size - Stream.Position; - SendBuffer(@si, SizeOf(si)); x := 0; while x < si do begin y := si - x; - if y > c64k then - y := c64k; - Setlength(s, c64k); - yr := Stream.read(s, y); + if y > FSendMaxChunk then + y := FSendMaxChunk; + {$IFDEF CIL} + Setlength(buf, y); + yr := Stream.read(buf, y); + if yr > 0 then + begin + SendBuffer(buf, yr); + Inc(x, yr); + end + else + break; + {$ELSE} + Setlength(s, y); + yr := Stream.read(Pchar(s)^, y); if yr > 0 then begin SetLength(s, yr); @@ -1101,13 +2045,37 @@ begin end else break; + {$ENDIF} end; end; -function TBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; +procedure TBlockSocket.SendStreamIndy(const Stream: TStream); +var + si: integer; begin + si := Stream.Size - Stream.Position; + si := synsock.HToNL(si); + SendInteger(si); + SendStreamRaw(Stream); +end; + +procedure TBlockSocket.SendStream(const Stream: TStream); +var + si: integer; +begin + si := Stream.Size - Stream.Position; + SendInteger(si); + SendStreamRaw(Stream); +end; + +function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; +begin + Result := 0; + if TestStopFlag then + Exit; LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL); +// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_NOSIGNAL); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL); if Result = 0 then FLastError := WSAECONNRESET else @@ -1118,26 +2086,36 @@ begin DoReadFilter(Buffer, Result); end; -function TBlockSocket.RecvBufferEx(Buffer: Pointer; Length: Integer; +function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; Timeout: Integer): Integer; var - s: string; + s: AnsiString; rl, l: integer; ti: ULong; +{$IFDEF CIL} + n: integer; + b: TMemory; +{$ENDIF} begin FLastError := 0; rl := 0; repeat ti := GetTick; s := RecvPacket(Timeout); - l := System.Length(s); - if (rl + l) > Length then - l := Length - rl; + l := Length(s); + if (rl + l) > Len then + l := Len - rl; + {$IFDEF CIL} + b := BytesOf(s); + for n := 0 to l do + Buffer[rl + n] := b[n]; + {$ELSE} Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + {$ENDIF} rl := rl + l; if FLastError <> 0 then Break; - if rl >= Length then + if rl >= Len then Break; if not FInterPacketTimeout then begin @@ -1154,25 +2132,43 @@ begin Result := rl; end; -function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): string; +function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; var x: integer; +{$IFDEF CIL} + buf: Tmemory; +{$ENDIF} begin Result := ''; if Length > 0 then begin + {$IFDEF CIL} + Setlength(Buf, Length); + x := RecvBufferEx(buf, Length , Timeout); + if FLastError = 0 then + begin + SetLength(Buf, x); + Result := StringOf(buf); + end + else + Result := ''; + {$ELSE} Setlength(Result, Length); x := RecvBufferEx(PChar(Result), Length , Timeout); if FLastError = 0 then SetLength(Result, x) else Result := ''; + {$ENDIF} end; end; -function TBlockSocket.RecvPacket(Timeout: Integer): string; +function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString; var x: integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} begin Result := ''; FLastError := 0; @@ -1188,10 +2184,20 @@ begin x := WaitingData; if x > 0 then begin + {$IFDEF CIL} + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + Result := StringOf(Buf); + end; + {$ELSE} SetLength(Result, x); x := RecvBuffer(Pointer(Result), x); if x >= 0 then SetLength(Result, x); + {$ENDIF} end else begin @@ -1202,10 +2208,20 @@ begin FLastError := WSAECONNRESET; if x > 0 then begin + {$IFDEF CIL} + SetLength(Buf, x); + x := RecvBuffer(Buf, x); + if x >= 0 then + begin + SetLength(Buf, x); + result := StringOf(Buf); + end; + {$ELSE} SetLength(Result, x); x := RecvBuffer(Pointer(Result), x); if x >= 0 then SetLength(Result, x); + {$ENDIF} end; end else @@ -1225,24 +2241,34 @@ begin if (FLastError = 0) and (FBuffer <> '') then begin Result := Ord(FBuffer[1]); - System.Delete(FBuffer, 1, 1); + Delete(FBuffer, 1, 1); end; ExceptCheck; end; -function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string; +function TBlockSocket.RecvInteger(Timeout: Integer): Integer; +var + s: AnsiString; +begin + Result := 0; + s := RecvBufferStr(4, Timeout); + if FLastError = 0 then + Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536; +end; + +function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; var x: Integer; - s: string; + s: AnsiString; l: Integer; CorCRLF: Boolean; - t: string; + t: AnsiString; tl: integer; ti: ULong; begin FLastError := 0; Result := ''; - l := system.Length(Terminator); + l := Length(Terminator); if l = 0 then Exit; tl := l; @@ -1267,7 +2293,7 @@ begin FLastLF := False; t := ''; x := PosCRLF(s, t); - tl := system.Length(t); + tl := Length(t); if t = CR then FLastCR := True; if t = LF then @@ -1278,7 +2304,7 @@ begin x := pos(Terminator, s); tl := l; end; - if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then + if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then begin FLastError := WSAENOBUFS; Break; @@ -1298,15 +2324,15 @@ begin if x > 0 then begin Result := Copy(s, 1, x - 1); - System.Delete(s, 1, x + tl - 1); + Delete(s, 1, x + tl - 1); end; FBuffer := s; ExceptCheck; end; -function TBlockSocket.RecvString(Timeout: Integer): string; +function TBlockSocket.RecvString(Timeout: Integer): AnsiString; var - s: string; + s: AnsiString; begin Result := ''; s := RecvTerminated(Timeout, CRLF); @@ -1314,54 +2340,102 @@ begin Result := s; end; -function TBlockSocket.RecvBlock(Timeout: Integer): string; +function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString; var x: integer; begin Result := ''; - RecvBufferEx(@x, SizeOf(x), Timeout); + x := RecvInteger(Timeout); if FLastError = 0 then Result := RecvBufferStr(x, Timeout); end; +procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer); +var + s: AnsiString; +begin + repeat + s := RecvPacket(Timeout); + if FLastError = 0 then + WriteStrToStream(Stream, s); + until FLastError <> 0; +end; + +procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +var + s: AnsiString; + n: integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} +begin + for n := 1 to (Size div FSendMaxChunk) do + begin + {$IFDEF CIL} + SetLength(buf, FSendMaxChunk); + RecvBufferEx(buf, FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, FSendMaxChunk); + {$ELSE} + s := RecvBufferStr(FSendMaxChunk, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(Pchar(s)^, FSendMaxChunk); + {$ENDIF} + end; + n := Size mod FSendMaxChunk; + if n > 0 then + begin + {$IFDEF CIL} + SetLength(buf, n); + RecvBufferEx(buf, n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(buf, n); + {$ELSE} + s := RecvBufferStr(n, Timeout); + if FLastError <> 0 then + Exit; + Stream.Write(Pchar(s)^, n); + {$ENDIF} + end; +end; + +procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer); +var + x: integer; +begin + x := RecvInteger(Timeout); + x := synsock.NToHL(x); + if FLastError = 0 then + RecvStreamSize(Stream, Timeout, x); +end; + procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer); var x: integer; - s: string; - n: integer; begin - RecvBufferEx(@x, SizeOf(x), Timeout); + x := RecvInteger(Timeout); if FLastError = 0 then - begin - for n := 1 to (x div c64k) do - begin - s := RecvBufferStr(c64k, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(s, c64k); - end; - n := x mod c64k; - if n > 0 then - begin - s := RecvBufferStr(n, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(s, n); - end; - end; + RecvStreamSize(Stream, Timeout, x); end; -function TBlockSocket.PeekBuffer(Buffer: Pointer; Length: Integer): Integer; +function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer; begin - Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); + {$IFNDEF CIL} +// Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL); + Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL); SockCheck(Result); ExceptCheck; + {$ENDIF} end; function TBlockSocket.PeekByte(Timeout: Integer): Byte; var s: string; begin + {$IFNDEF CIL} Result := 0; if CanRead(Timeout) then begin @@ -1373,6 +2447,7 @@ begin else FLastError := WSAETIMEDOUT; ExceptCheck; + {$ENDIF} end; function TBlockSocket.SockCheck(SockResult: Integer): Integer; @@ -1399,8 +2474,10 @@ begin DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); if FRaiseExcept then begin - e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s', - [FLastError, FLastErrorDesc]); + e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', + [FLastError, FLastErrorDesc])); +// e := ESynapseError.CreateFmt('Synapse TCP/IP Socket error %d: %s', +// [FLastError, FLastErrorDesc]); e.ErrorCode := FLastError; e.ErrorMessage := FLastErrorDesc; raise e; @@ -1437,6 +2514,7 @@ procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_Linger; d.Enabled := Enable; d.Value := Linger; @@ -1444,18 +2522,32 @@ begin end; function TBlockSocket.LocalName: string; -var - s: string; begin - Result := ''; - setlength(s, 255); - synsock.GetHostName(pchar(s), Length(s) - 1); - Result := Pchar(s); + Result := synsock.GetHostName; if Result = '' then Result := '127.0.0.1'; end; -procedure TBlockSocket.ResolveNameToIP(Name: string; IPList: TStrings); +{$IFDEF CIL} +procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); +var + IPs :array of IPAddress; + n: integer; +begin + IPList.Clear; + IPs := Dns.Resolve(Name).AddressList; + for n := low(IPs) to high(IPs) do + begin + if not(((FFamily = SF_IP6) and (IPs[n].AddressFamily = AF_INET)) + or ((FFamily = SF_IP4) and (IPs[n].AddressFamily = AF_INET6))) then + begin + IPList.Add(IPs[n].toString); + end; + end; +end; + +{$ELSE} +procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); type TaPInAddr = array[0..250] of PInAddr; PaPInAddr = ^TaPInAddr; @@ -1545,6 +2637,7 @@ begin if IPList.Count = 0 then IPList.Add(cAnyHost); end; +{$ENDIF} function TBlockSocket.ResolveName(Name: string): string; var @@ -1560,6 +2653,11 @@ begin end; function TBlockSocket.ResolvePort(Port: string): Word; +{$IFDEF CIL} +begin + Result := SynSock.GetPortService(Port); +end; +{$ELSE} var ProtoEnt: PProtoEnt; ServEnt: PServEnt; @@ -1607,7 +2705,14 @@ begin end; end; end; +{$ENDIF} +{$IFDEF CIL} +function TBlockSocket.ResolveIPToName(IP: string): string; +begin + Result := Dns.GetHostByAddress(IP).HostName; +end; +{$ELSE} function TBlockSocket.ResolveIPToName(IP: string): string; var Hints: TAddrInfo; @@ -1664,6 +2769,7 @@ begin end; end; end; +{$ENDIF} procedure TBlockSocket.SetRemoteSin(IP, Port: string); begin @@ -1691,6 +2797,10 @@ begin end; function TBlockSocket.CanRead(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); +{$ELSE} var TimeVal: PTimeVal; TimeV: TTimeVal; @@ -1708,12 +2818,17 @@ begin if FLastError <> 0 then x := 0; Result := x > 0; +{$ENDIF} ExceptCheck; if Result then DoStatus(HR_CanRead, ''); end; function TBlockSocket.CanWrite(Timeout: Integer): Boolean; +{$IFDEF CIL} +begin + Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite); +{$ELSE} var TimeVal: PTimeVal; TimeV: TTimeVal; @@ -1731,6 +2846,7 @@ begin if FLastError <> 0 then x := 0; Result := x > 0; +{$ENDIF} ExceptCheck; if Result then DoStatus(HR_CanWrite, ''); @@ -1744,26 +2860,26 @@ begin Result := CanRead(Timeout); end; -function TBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer; -var - Len: Integer; +function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; begin + Result := 0; + if TestStopFlag then + Exit; LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - Len := SizeOfVarSin(FRemoteSin); - Result := synsock.SendTo(FSocket, Buffer^, Length, 0, @FRemoteSin, Len); + Result := synsock.SendTo(FSocket, Buffer, Length, 0, FRemoteSin); SockCheck(Result); ExceptCheck; Inc(FSendCounter, Result); DoStatus(HR_WriteCount, IntToStr(Result)); end; -function TBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; -var - Len: Integer; +function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; begin + Result := 0; + if TestStopFlag then + Exit; LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - Len := SizeOf(FRemoteSin); - Result := synsock.RecvFrom(FSocket, Buffer^, Length, 0, @FRemoteSin, Len); + Result := synsock.RecvFrom(FSocket, Buffer, Length, 0, FRemoteSin); SockCheck(Result); ExceptCheck; Inc(FRecvCounter, Result); @@ -1773,18 +2889,28 @@ end; function TBlockSocket.GetSizeRecvBuffer: Integer; var l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} l := SizeOf(Result); SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l)); if FLastError <> 0 then Result := 1024; ExceptCheck; +{$ENDIF} end; procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_RecvBuff; d.Value := Size; DelayedOption(d); @@ -1793,18 +2919,28 @@ end; function TBlockSocket.GetSizeSendBuffer: Integer; var l: Integer; +{$IFDEF CIL} + buf: TMemory; +{$ENDIF} begin +{$IFDEF CIL} + setlength(buf, 4); + SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l)); + Result := System.BitConverter.ToInt32(buf,0); +{$ELSE} l := SizeOf(Result); SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l)); if FLastError <> 0 then Result := 1024; ExceptCheck; +{$ENDIF} end; procedure TBlockSocket.SetSizeSendBuffer(Size: Integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_SendBuff; d.Value := Size; DelayedOption(d); @@ -1814,6 +2950,7 @@ procedure TBlockSocket.SetNonBlockMode(Value: Boolean); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_nonblock; d.Enabled := Value; DelayedOption(d); @@ -1829,6 +2966,7 @@ procedure TBlockSocket.SetSendTimeout(Timeout: Integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_sendtimeout; d.Value := Timeout; DelayedOption(d); @@ -1838,11 +2976,13 @@ procedure TBlockSocket.SetRecvTimeout(Timeout: Integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_recvtimeout; d.Value := Timeout; DelayedOption(d); end; +{$IFNDEF CIL} function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer; const CanReadList: TList): boolean; var @@ -1879,11 +3019,13 @@ begin if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then CanReadList.Add(TBlockSocket(SocketList.Items[n])); end; +{$ENDIF} procedure TBlockSocket.EnableReuse(Value: Boolean); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_reuse; d.Enabled := Value; DelayedOption(d); @@ -1893,6 +3035,7 @@ procedure TBlockSocket.SetTTL(TTL: integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_TTL; d.Value := TTL; DelayedOption(d); @@ -1902,11 +3045,13 @@ function TBlockSocket.GetTTL:integer; var l: Integer; begin +{$IFNDEF CIL} l := SizeOf(Result); if FIP6Used then synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l) else synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l); +{$ENDIF} end; procedure TBlockSocket.SetFamily(Value: TSocketFamily); @@ -1920,12 +3065,41 @@ begin FRecvCounter := 0; FSendCounter := 0; FSocket := Value; +{$IFNDEF CIL} FD_ZERO(FFDSet); FD_SET(FSocket, FFDSet); +{$ENDIF} GetSins; - FIP6Used := FRemoteSin.sin_family = AF_INET6; + FIP6Used := FRemoteSin.AddressFamily = AF_INET6; end; +{$IFDEF CIL} +function TBlockSocket.StrToIP6(const value: string): TSockAddrIn6; +var + buf: TMemory; + IP: IPAddress; +begin + IP := IPAddress.Parse(Value); + buf := IP.GetAddressBytes; + result.sin6_addr.S_un_b.s_b1 := char(buf[0]); + result.sin6_addr.S_un_b.s_b2 := char(buf[1]); + result.sin6_addr.S_un_b.s_b3 := char(buf[2]); + result.sin6_addr.S_un_b.s_b4 := char(buf[3]); + result.sin6_addr.S_un_b.s_b5 := char(buf[4]); + result.sin6_addr.S_un_b.s_b6 := char(buf[5]); + result.sin6_addr.S_un_b.s_b7 := char(buf[6]); + result.sin6_addr.S_un_b.s_b8 := char(buf[7]); + result.sin6_addr.S_un_b.s_b9 := char(buf[8]); + result.sin6_addr.S_un_b.s_b10 := char(buf[9]); + result.sin6_addr.S_un_b.s_b11 := char(buf[10]); + result.sin6_addr.S_un_b.s_b12 := char(buf[11]); + result.sin6_addr.S_un_b.s_b13 := char(buf[12]); + result.sin6_addr.S_un_b.s_b14 := char(buf[13]); + result.sin6_addr.S_un_b.s_b15 := char(buf[14]); + result.sin6_addr.S_un_b.s_b16 := char(buf[15]); + result.sin6_family := Word(AF_INET6); +end; +{$ELSE} function TBlockSocket.StrToIP6(const value: string): TSockAddrIn6; var addr: PAddrInfo; @@ -1950,7 +3124,35 @@ begin end; end; end; +{$ENDIF} +{$IFDEF CIL} +function TBlockSocket.IP6ToStr(const value: TSockAddrIn6): string; +var + buf: TMemory; + IP: IPAddress; +begin + setlength(buf, 16); + buf[0] := byte(value.sin6_addr.S_un_b.s_b1); + buf[1] := byte(value.sin6_addr.S_un_b.s_b2); + buf[2] := byte(value.sin6_addr.S_un_b.s_b3); + buf[3] := byte(value.sin6_addr.S_un_b.s_b4); + buf[4] := byte(value.sin6_addr.S_un_b.s_b5); + buf[5] := byte(value.sin6_addr.S_un_b.s_b6); + buf[6] := byte(value.sin6_addr.S_un_b.s_b7); + buf[7] := byte(value.sin6_addr.S_un_b.s_b8); + buf[8] := byte(value.sin6_addr.S_un_b.s_b9); + buf[9] := byte(value.sin6_addr.S_un_b.s_b10); + buf[10] := byte(value.sin6_addr.S_un_b.s_b11); + buf[11] := byte(value.sin6_addr.S_un_b.s_b12); + buf[12] := byte(value.sin6_addr.S_un_b.s_b13); + buf[13] := byte(value.sin6_addr.S_un_b.s_b14); + buf[14] := byte(value.sin6_addr.S_un_b.s_b15); + buf[15] := byte(value.sin6_addr.S_un_b.s_b16); + IP := IPAddress.Create(buf); + Result := IP.ToString; +end; +{$ELSE} function TBlockSocket.IP6ToStr(const value: TSockAddrIn6): string; var host, serv: string; @@ -1970,6 +3172,12 @@ begin Result := PChar(host); end; end; +{$ENDIF} + +function TBlockSocket.GetWsaData: TWSAData; +begin + Result := WsaDataOnce; +end; function TBlockSocket.GetSocketType: integer; begin @@ -1978,7 +3186,7 @@ end; function TBlockSocket.GetSocketProtocol: integer; begin - Result := IPPROTO_IP + Result := integer(IPPROTO_IP); end; procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); @@ -1987,37 +3195,53 @@ begin OnStatus(Self, Reason, Value); end; -procedure TBlockSocket.DoReadFilter(Buffer: Pointer; var Length: Integer); +procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer); var s: string; begin if assigned(OnReadFilter) then - if Length > 0 then + if Len > 0 then begin - SetLength(s, Length); - Move(Buffer^, Pointer(s)^, Length); + {$IFDEF CIL} + s := StringOf(Buffer); + {$ELSE} + SetLength(s, Len); + Move(Buffer^, Pointer(s)^, Len); + {$ENDIF} OnReadFilter(Self, s); - if System.Length(s) > Length then - SetLength(s, Length); - Length := System.Length(s); - Move(Pointer(s)^, Buffer^, Length); + if Length(s) > Len then + SetLength(s, Len); + Len := Length(s); + {$IFDEF CIL} + Buffer := BytesOf(s); + {$ELSE} + Move(Pointer(s)^, Buffer^, Len); + {$ENDIF} end; end; -procedure TBlockSocket.DoWriteFilter(Buffer: Pointer; var Length: Integer); +procedure TBlockSocket.DoWriteFilter(Buffer: TMemory; var Len: Integer); var s: string; begin if assigned(OnWriteFilter) then - if Length > 0 then + if Len > 0 then begin - SetLength(s, Length); - Move(Buffer^, Pointer(s)^, Length); + {$IFDEF CIL} + s := StringOf(Buffer); + {$ELSE} + SetLength(s, Len); + Move(Buffer^, Pointer(s)^, Len); + {$ENDIF} OnWriteFilter(Self, s); - if System.Length(s) > Length then - SetLength(s, Length); - Length := System.Length(s); - Move(Pointer(s)^, Buffer^, Length); + if Length(s) > Len then + SetLength(s, Len); + Len := Length(s); + {$IFDEF CIL} + Buffer := BytesOf(s); + {$ELSE} + Move(Pointer(s)^, Buffer^, Len); + {$ENDIF} end; end; @@ -2029,6 +3253,16 @@ end; class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string; begin +{$IFDEF CIL} + if ErrorCode = 0 then + Result := '' + else + begin + Result := WSAGetLastErrorDesc; + if Result = '' then + Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; + end; +{$ELSE} case ErrorCode of 0: Result := ''; @@ -2135,8 +3369,9 @@ begin WSANO_DATA: {11004} Result := 'Valid name, no data record of requested type' else - Result := 'Not a Winsock error (' + IntToStr(ErrorCode) + ')'; + Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; end; +{$ENDIF} end; {======================================================================} @@ -2394,7 +3629,6 @@ begin begin if Length(Value) < 22 then Exit; - FillChar(ip6, SizeOf(ip6), 0); ip6.sin6_addr.S_un_b.s_b1 := Value[5]; ip6.sin6_addr.S_un_b.s_b2 := Value[6]; ip6.sin6_addr.S_un_b.s_b3 := Value[7]; @@ -2411,7 +3645,10 @@ begin ip6.sin6_addr.S_un_b.s_b14 := Value[18]; ip6.sin6_addr.S_un_b.s_b15 := Value[19]; ip6.sin6_addr.S_un_b.s_b16 := Value[20]; - ip6.sin6_family := AF_INET6; + ip6.sin6_family := word(AF_INET6); + ip6.sin6_port := 0; + ip6.sin6_flowinfo := 0; + ip6.sin6_scope_id := 0; FSocksResponseIP := IP6ToStr(ip6); Result := 21; end; @@ -2434,12 +3671,12 @@ begin DoStatus(HR_Connect, IP + ':' + Port); end; -function TDgramBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; +function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; begin Result := RecvBufferFrom(Buffer, Length); end; -function TDgramBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; +function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; begin Result := SendBufferTo(Buffer, Length); end; @@ -2457,6 +3694,7 @@ procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_Broadcast; d.Enabled := Value; DelayedOption(d); @@ -2498,7 +3736,7 @@ begin end; end; -function TUDPBlockSocket.SendBufferTo(Buffer: Pointer; Length: Integer): Integer; +function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; var SIp: string; SPort: integer; @@ -2512,6 +3750,7 @@ begin begin if FUsingSocks then begin +{$IFNDEF CIL} Sip := GetRemoteSinIp; SPort := GetRemoteSinPort; SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); @@ -2520,16 +3759,14 @@ begin Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; Result := inherited SendBufferTo(PChar(Buf), System.Length(buf)); SetRemoteSin(Sip, IntToStr(SPort)); +{$ENDIF} end else - begin Result := inherited SendBufferTo(Buffer, Length); - GetSins; - end; end; end; -function TUDPBlockSocket.RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; +function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; var Buf: string; x: integer; @@ -2537,6 +3774,7 @@ begin Result := inherited RecvBufferFrom(Buffer, Length); if FUsingSocks then begin +{$IFNDEF CIL} SetLength(Buf, Result); Move(Buffer^, PChar(Buf)^, Result); x := SocksDecode(Buf); @@ -2544,9 +3782,11 @@ begin Buf := Copy(Buf, x, Result); Move(PChar(Buf)^, Buffer^, Result); SetRemoteSin(FSocksResponseIP, FSocksResponsePort); +{$ENDIF} end; end; +{$IFNDEF CIL} procedure TUDPBlockSocket.AddMulticast(MCastIP: string); var Multicast: TIP_mreq; @@ -2590,11 +3830,13 @@ begin end; ExceptCheck; end; +{$ENDIF} procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_MulticastTTL; d.Value := TTL; DelayedOption(d); @@ -2604,17 +3846,20 @@ function TUDPBlockSocket.GetMulticastTTL:integer; var l: Integer; begin +{$IFNDEF CIL} l := SizeOf(Result); if FIP6Used then synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l) else synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l); +{$ENDIF} end; procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean); var d: TSynaOption; begin + d := TSynaOption.Create; d.Option := SOT_MulticastLoop; d.Enabled := Value; DelayedOption(d); @@ -2622,16 +3867,17 @@ end; function TUDPBlockSocket.GetSocketType: integer; begin - Result := SOCK_DGRAM; + Result := integer(SOCK_DGRAM); end; function TUDPBlockSocket.GetSocketProtocol: integer; begin - Result := IPPROTO_UDP; + Result := integer(IPPROTO_UDP); end; {======================================================================} +{$IFNDEF CIL} function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; var Password: String; @@ -2644,6 +3890,7 @@ begin Result := Length(Password); StrLCopy(buf, PChar(Password + #0), Result + 1); end; +{$ENDIF} constructor TTCPBlockSocket.Create; begin @@ -2727,8 +3974,6 @@ begin end; function TTCPBlockSocket.Accept: TSocket; -var - Len: Integer; begin if FUsingSocks then begin @@ -2740,9 +3985,8 @@ begin end else begin - Len := SizeOf(FRemoteSin); - Result := synsock.Accept(FSocket, @FRemoteSin, Len); - SockCheck(Result); + Result := synsock.Accept(FSocket, FRemoteSin); +/// SockCheck(Result); end; ExceptCheck; DoStatus(HR_Accept, ''); @@ -2837,7 +4081,11 @@ begin if not FSSLEnabled then SSLEnabled := True; if (FLastError = 0) then +{$IFDEF CIL} + if sslsetfd(FSsl, FSocket.Handle.ToInt32) < 1 then +{$ELSE} if sslsetfd(FSsl, FSocket) < 1 then +{$ENDIF} begin FLastError := WSASYSNOTREADY; SSLCheck; @@ -2851,6 +4099,9 @@ begin SSLcheck; end; end; + if FSSLverifyCert then + if SSLGetVerifyCert <> 0 then + FLastError := WSAEACCES; if FLastError <> 0 then begin x := FLastError; @@ -2869,7 +4120,10 @@ begin begin x := sslshutdown(FSsl); if x = 0 then + begin + Synsock.Shutdown(FSocket, 1); sslshutdown(FSsl); + end; end; SSLEnabled := False; ExceptCheck; @@ -2944,21 +4198,21 @@ begin else Result := True; if FSSLCertificateFile <> '' then - if SslCtxUseCertificateChainFile(FCtx, PChar(FSSLCertificateFile)) <> 1 then + if SslCtxUseCertificateChainFile(FCtx, FSSLCertificateFile) <> 1 then begin Result := False; SSLCheck; Exit; end; if FSSLPrivateKeyFile <> '' then - if SslCtxUsePrivateKeyFile(FCtx, PChar(FSSLPrivateKeyFile), 1) <> 1 then + if SslCtxUsePrivateKeyFile(FCtx, FSSLPrivateKeyFile, 1) <> 1 then begin Result := False; SSLCheck; Exit; end; if FSSLCertCAFile <> '' then - if SslCtxLoadVerifyLocations(FCtx, PChar(FSSLCertCAFile), nil) <> 1 then + if SslCtxLoadVerifyLocations(FCtx, FSSLCertCAFile, '') <> 1 then begin Result := False; SSLCheck; @@ -2998,13 +4252,15 @@ begin end else begin - SslCtxSetCipherList(Fctx, PChar(FSSLCiphers)); + SslCtxSetCipherList(Fctx, FSSLCiphers); if FSSLverifyCert then SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) else SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); +{$IFNDEF CIL} SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); SslCtxSetDefaultPasswdCbUserdata(FCtx, self); +{$ENDIF} if not SetSSLKeys then FLastError := WSAEINVAL else @@ -3037,15 +4293,33 @@ begin ExceptCheck; end; -function TTCPBlockSocket.RecvBuffer(Buffer: Pointer; Length: Integer): Integer; +function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; var err: integer; +{$IFDEF CIL} + sb: stringbuilder; + s: ansistring; +{$ENDIF} begin if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then begin + Result := 0; + if TestStopFlag then + Exit; FLastError := 0; repeat - Result := SslRead(FSsl, Buffer, Length); +{$IFDEF CIL} + sb := StringBuilder.Create(Len); + Result := SslRead(FSsl, sb, Len); + if Result > 0 then + begin + sb.Length := Result; + s := sb.ToString; + System.Array.Copy(BytesOf(s), Buffer, length(s)); + end; +{$ELSE} + Result := SslRead(FSsl, Buffer , Len); +{$ENDIF} err := SslGetError(FSsl, Result); until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); if err = SSL_ERROR_ZERO_RETURN then @@ -3059,29 +4333,74 @@ begin DoReadFilter(Buffer, Result); end else - Result := inherited RecvBuffer(Buffer, Length); + Result := inherited RecvBuffer(Buffer, Len); end; -function TTCPBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer; +function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; var err: integer; + x, y: integer; + l, r: integer; +{$IFDEF CIL} + s: string; +{$ELSE} + p: Pointer; +{$ENDIF} begin if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then begin + Result := 0; + if TestStopFlag then + Exit; FLastError := 0; DoWriteFilter(Buffer, Length); +{$IFDEF CIL} + s := StringOf(Buffer); repeat - Result := SslWrite(FSsl, Buffer, Length); - err := SslGetError(FSsl, Result); + r := SslWrite(FSsl, s, Length); + err := SslGetError(FSsl, r); until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); if err = SSL_ERROR_ZERO_RETURN then - Result := 0 + r := 0 else if (err <> 0) then FLastError := WSASYSNOTREADY; + Result := r; + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); +{$ELSE} + l := Length; + x := 0; + while x < l do + begin + y := l - x; + if y > FSendMaxChunk then + y := FSendMaxChunk; + if y > 0 then + begin + LimitBandwidth(y, FMaxSendBandwidth, FNextsend); + p := IncPoint(Buffer, x); + repeat + r := SslWrite(FSsl, p, y); + err := SslGetError(FSsl, r); + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + if err = SSL_ERROR_ZERO_RETURN then + r := 0 + else + if (err <> 0) then + FLastError := WSASYSNOTREADY; + if Flasterror <> 0 then + Break; + Inc(x, r); + Inc(Result, r); + Inc(FSendCounter, r); + DoStatus(HR_WriteCount, IntToStr(r)); + end + else + break; + end; +{$ENDIF} ExceptCheck; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); end else Result := inherited SendBuffer(Buffer, Length); @@ -3095,11 +4414,18 @@ begin if not FSSLEnabled then SSLEnabled := True; if (FLastError = 0) then + begin +{$IFDEF CIL} + x := FSocket.Handle.ToInt32; + if sslsetfd(FSsl, x) < 1 then +{$ELSE} if sslsetfd(FSsl, FSocket) < 1 then +{$ENDIF} begin FLastError := WSASYSNOTREADY; SSLCheck; end; + end; if (FLastError = 0) then if sslAccept(FSsl) < 1 then FLastError := WSASYSNOTREADY; @@ -3125,6 +4451,9 @@ function TTCPBlockSocket.SSLGetPeerSubject: string; var cert: PX509; s: string; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} begin if not assigned(FSsl) then begin @@ -3132,8 +4461,13 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := SslX509NameOneline(SslX509GetSubjectName(cert), sb, 4096); +{$ELSE} setlength(s, 4096); - Result := SslX509NameOneline(SslX509GetSubjectName(cert), PChar(s), length(s)); + Result := SslX509NameOneline(SslX509GetSubjectName(cert), s, Length(s)); +{$ENDIF} SslX509Free(cert); end; @@ -3143,13 +4477,16 @@ var begin s := SSLGetPeerSubject; s := SeparateRight(s, '/CN='); - Result := SeparateLeft(s, '/'); + Result := Trim(SeparateLeft(s, '/')); end; function TTCPBlockSocket.SSLGetPeerIssuer: string; var cert: PX509; s: string; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} begin if not assigned(FSsl) then begin @@ -3157,8 +4494,13 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); +{$IFDEF CIL} + sb := StringBuilder.Create(4096); + Result := SslX509NameOneline(SslX509GetIssuerName(cert), sb, 4096); +{$ELSE} setlength(s, 4096); - Result := SslX509NameOneline(SslX509GetIssuerName(cert), PChar(s), length(s)); + Result := SslX509NameOneline(SslX509GetIssuerName(cert), s, Length(s)); +{$ENDIF} SslX509Free(cert); end; @@ -3194,6 +4536,9 @@ function TTCPBlockSocket.SSLGetPeerFingerprint: string; var cert: PX509; x: integer; +{$IFDEF CIL} + sb: StringBuilder; +{$ENDIF} begin if not assigned(FSsl) then begin @@ -3201,9 +4546,16 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); +{$IFDEF CIL} + sb := StringBuilder.Create(EVP_MAX_MD_SIZE); + SslX509Digest(cert, SslEvpMd5, sb, x); + sb.Length := x; + Result := sb.ToString; +{$ELSE} setlength(Result, EVP_MAX_MD_SIZE); - SslX509Digest(cert, SslEvpMd5, PChar(Result), @x); + SslX509Digest(cert, SslEvpMd5, Result, x); SetLength(Result, x); +{$ENDIF} SslX509Free(cert); end; @@ -3212,7 +4564,10 @@ var cert: PX509; x, y: integer; b: PBIO; - s: string; + s: AnsiString; +{$IFDEF CIL} + sb: stringbuilder; +{$ENDIF} begin if not assigned(FSsl) then begin @@ -3224,10 +4579,20 @@ begin try X509Print(b, cert); x := bioctrlpending(b); +{$IFDEF CIL} + sb := StringBuilder.Create(x); + y := bioread(b, sb, x); + if y > 0 then + begin + sb.Length := y; + s := sb.ToString; + end; +{$ELSE} setlength(s,x); - y := bioread(b,PChar(s),x); + y := bioread(b,s,x); if y > 0 then setlength(s, y); +{$ENDIF} Result := ReplaceString(s, LF, CRLF); finally BioFreeAll(b); @@ -3243,11 +4608,13 @@ begin end; function TTCPBlockSocket.SSLGetCipherBits: integer; +var + x: integer; begin if not assigned(FSsl) then Result := 0 else - Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), nil); + Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); end; function TTCPBlockSocket.SSLGetCipherAlgBits: integer; @@ -3255,7 +4622,7 @@ begin if not assigned(FSsl) then Result := 0 else - SSLCipherGetBits(SslGetCurrentCipher(FSsl), @Result); + SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); end; function TTCPBlockSocket.SSLGetVerifyCert: integer; @@ -3268,39 +4635,39 @@ end; function TTCPBlockSocket.GetSocketType: integer; begin - Result := SOCK_STREAM; + Result := integer(SOCK_STREAM); end; function TTCPBlockSocket.GetSocketProtocol: integer; begin - Result := IPPROTO_TCP; + Result := integer(IPPROTO_TCP); end; {======================================================================} function TICMPBlockSocket.GetSocketType: integer; begin - Result := SOCK_RAW; + Result := integer(SOCK_RAW); end; function TICMPBlockSocket.GetSocketProtocol: integer; begin if FIP6Used then - Result := IPPROTO_ICMPV6 + Result := integer(IPPROTO_ICMPV6) else - Result := IPPROTO_ICMP; + Result := integer(IPPROTO_ICMP); end; {======================================================================} function TRAWBlockSocket.GetSocketType: integer; begin - Result := SOCK_RAW; + Result := integer(SOCK_RAW); end; function TRAWBlockSocket.GetSocketProtocol: integer; begin - Result := IPPROTO_RAW; + Result := integer(IPPROTO_RAW); end; {======================================================================} @@ -3312,6 +4679,8 @@ begin FTargetHost := cLocalhost; FTargetPort := cAnyPort; FTimeout := 5000; + FUsername := ''; + FPassword := ''; end; {======================================================================} diff --git a/dnssend.pas b/dnssend.pas index afad187..b8d99c6 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.003.004 | +| Project : Ararat Synapse | 002.005.001 | |==============================================================================| | Content: DNS client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -41,8 +41,12 @@ | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{: @abstract(DNS client by UDP or TCP) +Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone + transfers too! -// RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 +Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 +} {$IFDEF FPC} {$MODE DELPHI} @@ -103,11 +107,15 @@ const QTYPE_ALL = 255; type + {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TDNSSend = class(TSynaClient) private FID: Word; FRCode: Integer; - FBuffer: string; + FBuffer: AnsiString; FSock: TUDPBlockSocket; FTCPSock: TTCPBlockSocket; FUseTCP: Boolean; @@ -115,35 +123,84 @@ type FNameserverInfo: TStringList; FAdditionalInfo: TStringList; FAuthoritative: Boolean; - function ReverseIP(Value: string): string; - function ReverseIP6(Value: string): string; - function CompressName(const Value: string): string; - function CodeHeader: string; - function CodeQuery(const Name: string; QType: Integer): string; - function DecodeLabels(var From: Integer): string; - function DecodeString(var From: Integer): string; + function ReverseIP(Value: AnsiString): AnsiString; + function ReverseIP6(Value: AnsiString): AnsiString; + function CompressName(const Value: AnsiString): AnsiString; + function CodeHeader: AnsiString; + function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; + function DecodeLabels(var From: Integer): AnsiString; + function DecodeString(var From: Integer): AnsiString; function DecodeResource(var i: Integer; const Info: TStringList; - QType: Integer): string; - function RecvTCPResponse(const WorkSock: TBlockSocket): string; - function DecodeResponse(const Buf: string; const Reply: TStrings; + QType: Integer): AnsiString; + function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; + function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; QType: Integer):boolean; public constructor Create; destructor Destroy; override; - function DNSQuery(Name: string; QType: Integer; + + {:Query a DNSHost for QType resources correspond to a name. Supported QType + values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA, + Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO, + Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25, + Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS, + Qtype_KX. + + Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode! + + "Name" is domain name or host name for queried resource. If "name" is + IP address, automatically convert to reverse domain form (.in-addr.arpa). + + If result is @true, Reply contains resource records. One record on one line. + If Resource record have multiple fields, they are stored on line divided by + comma. (example: MX record contains value 'rs.cesnet.cz' with preference + number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address + in resource are converted to string form.} + function DNSQuery(Name: AnsiString; QType: Integer; const Reply: TStrings): Boolean; published + + {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.} property Sock: TUDPBlockSocket read FSock; + + {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.} property TCPSock: TTCPBlockSocket read FTCPSock; + + {:if @true, then is used TCP protocol instead UDP. It is needed for zone + transfers, etc.} property UseTCP: Boolean read FUseTCP Write FUseTCP; + + {:After DNS operation contains ResultCode of DNS operation. + Values are: 0-no error, 1-format error, 2-server failure, 3-name error, + 4-not implemented, 5-refused.} property RCode: Integer read FRCode; + + {:@True, if ansfer is authoritative.} property Authoritative: Boolean read FAuthoritative; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed information about query reply.} property AnsferInfo: TStringList read FAnsferInfo; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed information about nameserver.} property NameserverInfo: TStringList read FNameserverInfo; + + {:Detailed informations from name server reply. One record per line. Record + have comma delimited entries with type number, TTL and data filelds. + This information contains detailed additional information.} property AdditionalInfo: TStringList read FAdditionalInfo; end; -function GetMailServers(const DNSHost, Domain: string; +{:A very useful function, and example of it's use is found in the TDNSSend object. + This function is used to get mail servers for a domain and sort them by + preference numbers. "Servers" contains only the domain names of the mail + servers in the right order (without preference number!). The first domain name + will always be the highest preferenced mail server. Returns boolean @TRUE if + all went well.} +function GetMailServers(const DNSHost, Domain: AnsiString; const Servers: TStrings): Boolean; implementation @@ -172,7 +229,7 @@ begin inherited Destroy; end; -function TDNSSend.ReverseIP(Value: string): string; +function TDNSSend.ReverseIP(Value: AnsiString): AnsiString; var x: Integer; begin @@ -187,7 +244,7 @@ begin Delete(Result, 1, 1); end; -function TDNSSend.ReverseIP6(Value: string): string; +function TDNSSend.ReverseIP6(Value: AnsiString): AnsiString; var ip6: TSockAddrIn6; begin @@ -210,10 +267,10 @@ begin + '.' + ip6.sin6_addr.S_un_b.s_b1; end; -function TDNSSend.CompressName(const Value: string): string; +function TDNSSend.CompressName(const Value: AnsiString): AnsiString; var n: Integer; - s: string; + s: AnsiString; begin Result := ''; if Value = '' then @@ -235,7 +292,7 @@ begin end; end; -function TDNSSend.CodeHeader: string; +function TDNSSend.CodeHeader: AnsiString; begin FID := Random(32767); Result := CodeInt(FID); // ID @@ -246,14 +303,14 @@ begin Result := Result + CodeInt(0); // ARCount end; -function TDNSSend.CodeQuery(const Name: string; QType: Integer): string; +function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; begin Result := CompressName(Name); Result := Result + CodeInt(QType); Result := Result + CodeInt(1); // Type INTERNET end; -function TDNSSend.DecodeString(var From: Integer): string; +function TDNSSend.DecodeString(var From: Integer): AnsiString; var Len: integer; begin @@ -263,7 +320,7 @@ begin Inc(From, Len); end; -function TDNSSend.DecodeLabels(var From: Integer): string; +function TDNSSend.DecodeLabels(var From: Integer): AnsiString; var l, f: Integer; begin @@ -295,11 +352,11 @@ begin end; function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; - QType: Integer): string; + QType: Integer): AnsiString; var - Rname: string; + Rname: AnsiString; RType, Len, j, x, y, z, n: Integer; - R: string; + R: AnsiString; t1, t2, ttl: integer; ip6: TSockAddrIn6; begin @@ -331,24 +388,27 @@ begin end; QTYPE_AAAA: begin - FillChar(ip6, SizeOf(ip6), 0); - ip6.sin6_addr.S_un_b.s_b1 := FBuffer[j]; - ip6.sin6_addr.S_un_b.s_b2 := FBuffer[j + 1]; - ip6.sin6_addr.S_un_b.s_b3 := FBuffer[j + 2]; - ip6.sin6_addr.S_un_b.s_b4 := FBuffer[j + 3]; - ip6.sin6_addr.S_un_b.s_b5 := FBuffer[j + 4]; - ip6.sin6_addr.S_un_b.s_b6 := FBuffer[j + 5]; - ip6.sin6_addr.S_un_b.s_b7 := FBuffer[j + 6]; - ip6.sin6_addr.S_un_b.s_b8 := FBuffer[j + 7]; - ip6.sin6_addr.S_un_b.s_b9 := FBuffer[j + 8]; - ip6.sin6_addr.S_un_b.s_b10 := FBuffer[j + 9]; - ip6.sin6_addr.S_un_b.s_b11 := FBuffer[j + 10]; - ip6.sin6_addr.S_un_b.s_b12 := FBuffer[j + 11]; - ip6.sin6_addr.S_un_b.s_b13 := FBuffer[j + 12]; - ip6.sin6_addr.S_un_b.s_b14 := FBuffer[j + 13]; - ip6.sin6_addr.S_un_b.s_b15 := FBuffer[j + 14]; - ip6.sin6_addr.S_un_b.s_b16 := FBuffer[j + 15]; - ip6.sin6_family := AF_INET6; +// FillChar(ip6, SizeOf(ip6), 0); + ip6.sin6_addr.S_un_b.s_b1 := Char(FBuffer[j]); + ip6.sin6_addr.S_un_b.s_b2 := Char(FBuffer[j + 1]); + ip6.sin6_addr.S_un_b.s_b3 := Char(FBuffer[j + 2]); + ip6.sin6_addr.S_un_b.s_b4 := Char(FBuffer[j + 3]); + ip6.sin6_addr.S_un_b.s_b5 := Char(FBuffer[j + 4]); + ip6.sin6_addr.S_un_b.s_b6 := Char(FBuffer[j + 5]); + ip6.sin6_addr.S_un_b.s_b7 := Char(FBuffer[j + 6]); + ip6.sin6_addr.S_un_b.s_b8 := Char(FBuffer[j + 7]); + ip6.sin6_addr.S_un_b.s_b9 := Char(FBuffer[j + 8]); + ip6.sin6_addr.S_un_b.s_b10 := Char(FBuffer[j + 9]); + ip6.sin6_addr.S_un_b.s_b11 := Char(FBuffer[j + 10]); + ip6.sin6_addr.S_un_b.s_b12 := Char(FBuffer[j + 11]); + ip6.sin6_addr.S_un_b.s_b13 := Char(FBuffer[j + 12]); + ip6.sin6_addr.S_un_b.s_b14 := Char(FBuffer[j + 13]); + ip6.sin6_addr.S_un_b.s_b15 := Char(FBuffer[j + 14]); + ip6.sin6_addr.S_un_b.s_b16 := Char(FBuffer[j + 15]); + ip6.sin6_family := word(AF_INET6); + ip6.sin6_port := 0; + ip6.sin6_flowinfo := 0; + ip6.sin6_scope_id := 0; R := FSock.IP6ToStr(ip6); end; QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, @@ -426,7 +486,7 @@ begin Result := R; end; -function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): string; +function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; var l: integer; begin @@ -436,12 +496,12 @@ begin Result := WorkSock.RecvBufferStr(l, FTimeout); end; -function TDNSSend.DecodeResponse(const Buf: string; const Reply: TStrings; +function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; QType: Integer):boolean; var n, i: Integer; flag, qdcount, ancount, nscount, arcount: Integer; - s: string; + s: AnsiString; begin Result := False; Reply.Clear; @@ -486,7 +546,7 @@ begin end; end; -function TDNSSend.DNSQuery(Name: string; QType: Integer; +function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; const Reply: TStrings): Boolean; var WorkSock: TBlockSocket; @@ -497,7 +557,7 @@ begin if IsIP(Name) then Name := ReverseIP(Name) + '.in-addr.arpa'; if IsIP6(Name) then - Name := ReverseIP6(Name) + '.ip6.int'; + Name := ReverseIP6(Name) + '.ip6.arpa'; FBuffer := CodeHeader + CodeQuery(Name, QType); if FUseTCP then WorkSock := FTCPSock @@ -543,7 +603,7 @@ end; {==============================================================================} -function GetMailServers(const DNSHost, Domain: string; +function GetMailServers(const DNSHost, Domain: AnsiString; const Servers: TStrings): Boolean; var DNS: TDNSSend; diff --git a/ftpsend.pas b/ftpsend.pas index 65d9af6..85cb4de 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.007.000 | +| Project : Ararat Synapse | 003.000.004 | |==============================================================================| | Content: FTP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -43,7 +43,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -// RFC-959, RFC-2228, RFC-2428 +{: @abstract(FTP client protocol) + +Used RFC: RFC-959, RFC-2228, RFC-2428 +} {$IFDEF FPC} {$MODE DELPHI} @@ -59,44 +62,138 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, synautil, synacode; + blcksock, synautil, synsock; const cFtpProtocol = 'ftp'; cFtpDataProtocol = 'ftp-data'; + {:Terminating value for TLogonActions} FTP_OK = 255; + {:Terminating value for TLogonActions} FTP_ERR = 254; type + {:Array for holding definition of logon sequence.} TLogonActions = array [0..17] of byte; + {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object. + Value is FTP command or reply to this comand. (if it is reply, Response + is @True).} TFTPStatus = procedure(Sender: TObject; Response: Boolean; const Value: string) of object; + {: @abstract(Object for holding file information) parsed from directory + listing of FTP server.} TFTPListRec = class(TObject) + private + FFileName: string; + FDirectory: Boolean; + FReadable: Boolean; + FFileSize: Longint; + FFileTime: TDateTime; + FOriginalLine: string; + FMask: string; public - FileName: string; - Directory: Boolean; - Readable: Boolean; - FileSize: Longint; - FileTime: TDateTime; + {: You can assign another TFTPListRec to this object.} + procedure Assign(Value: TFTPListRec); virtual; + published + {:name of file} + property FileName: string read FFileName write FFileName; + {:if name is subdirectory not file.} + property Directory: Boolean read FDirectory write FDirectory; + {:if you have rights to read} + property Readable: Boolean read FReadable write FReadable; + {:size of file in bytes} + property FileSize: Longint read FFileSize write FFileSize; + {:date and time of file. Local server timezone is used. Any timezone + conversions was not done!} + property FileTime: TDateTime read FFileTime write FFileTime; + {:original unparsed line} + property OriginalLine: string read FOriginalLine write FOriginalLine; + {:mask what was used for parsing} + property Mask: string read FMask write FMask; end; + {:@abstract(This is TList of TFTPListRec objects.) + This object is used for holding lististing of all files information in listed + directory on FTP server.} TFTPList = class(TObject) - private + protected FList: TList; + FLines: TStringList; + FMasks: TStringList; + FUnparsedLines: TStringList; + Monthnames: string; + BlockSize: string; + DirFlagValue: string; + FileName: string; + VMSFileName: string; + Day: string; + Month: string; + ThreeMonth: string; + YearTime: string; + Year: string; + Hours: string; + HoursModif: string; + Minutes: string; + Seconds: string; + Size: string; + Permissions: string; + DirFlag: string; + function GetListItem(Index: integer): TFTPListRec; virtual; + function ParseEPLF(Value: string): Boolean; virtual; + procedure ClearStore; virtual; + function ParseByMask(Value, NextValue, Mask: string): Integer; virtual; + function CheckValues: Boolean; virtual; + procedure FillRecord(const Value: TFTPListRec); virtual; public + {:Constructor. You not need create this object, it is created by TFTPSend + class as their property.} constructor Create; destructor Destroy; override; - procedure Clear; - function ParseLine(Value: string): Boolean; - published + + {:Clear list.} + procedure Clear; virtual; + + {:count of holded @link(TFTPListRec) objects} + function Count: integer; virtual; + + {:Assigns one list to another} + procedure Assign(Value: TFTPList); virtual; + + {:try to parse raw directory listing in @link(lines) to list of + @link(TFTPListRec).} + procedure ParseLines; virtual; + + {:By this property you have access to list of @link(TFTPListRec). + This is for compatibility only. Please, use @link(Items) instead.} property List: TList read FList; + + {:By this property you have access to list of @link(TFTPListRec).} + property Items[Index: Integer]: TFTPListRec read GetListItem; default; + + {:Set of lines with RAW directory listing for @link(parseLines)} + property Lines: TStringList read FLines; + + {:Set of masks for directory listing parser. It is predefined by default, + however you can modify it as you need. (for example, you can add your own + definition mask.) Mask is same as mask used in TotalCommander.} + property Masks: TStringList read FMasks; + + {:After @link(ParseLines) it holding lines what was not sucessfully parsed.} + property UnparsedLines: TStringList read FUnparsedLines; end; + {:@abstract(Implementation of FTP protocol.) + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! (Username and Password have default values + for "anonymous" FTP login) + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TFTPSend = class(TSynaClient) - private + protected FOnStatus: TFTPStatus; {$IFDEF STREAMSEC} FSock: TSsTCPBlockSocket; @@ -109,8 +206,6 @@ type FResultCode: Integer; FResultString: string; FFullResult: TStringList; - FUsername: string; - FPassword: string; FAccount: string; FFWHost: string; FFWPort: string; @@ -125,6 +220,7 @@ type FCanResume: Boolean; FPassiveMode: Boolean; FForceDefaultPort: Boolean; + FForceOldPort: Boolean; FFtpList: TFTPList; FBinaryMode: Boolean; FAutoTLS: Boolean; @@ -132,82 +228,234 @@ type FIsDataTLS: Boolean; FTLSonData: Boolean; FFullSSL: Boolean; - function Auth(Mode: integer): Boolean; - function Connect: Boolean; - function InternalStor(const Command: string; RestoreAt: integer): Boolean; - function DataSocket: Boolean; - function AcceptDataSocket: Boolean; - protected - procedure DoStatus(Response: Boolean; const Value: string); + function Auth(Mode: integer): Boolean; virtual; + function Connect: Boolean; virtual; + function InternalStor(const Command: string; RestoreAt: integer): Boolean; virtual; + function DataSocket: Boolean; virtual; + function AcceptDataSocket: Boolean; virtual; + procedure DoStatus(Response: Boolean; const Value: string); virtual; public + {:Custom definition of login sequence. You can use this when you set + @link(FWMode) to value -1.} CustomLogon: TLogonActions; + constructor Create; destructor Destroy; override; - function ReadResult: Integer; - procedure ParseRemote(Value: string); - procedure ParseRemoteEPSV(Value: string); - function FTPCommand(const Value: string): integer; - function Login: Boolean; - procedure Logout; - procedure Abort; - function List(Directory: string; NameList: Boolean): Boolean; - function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; - function StoreFile(const FileName: string; Restore: Boolean): Boolean; - function StoreUniqueFile: Boolean; - function AppendFile(const FileName: string): Boolean; - function RenameFile(const OldName, NewName: string): Boolean; - function DeleteFile(const FileName: string): Boolean; - function FileSize(const FileName: string): integer; - function NoOp: Boolean; - function ChangeWorkingDir(const Directory: string): Boolean; - function ChangeToRootDir: Boolean; - function DeleteDir(const Directory: string): Boolean; - function CreateDir(const Directory: string): Boolean; - function GetCurrentDir: String; - function DataRead(const DestStream: TStream): Boolean; - function DataWrite(const SourceStream: TStream): Boolean; + + {:Waits and read FTP server response. You need this only in special cases!} + function ReadResult: Integer; virtual; + + {:Parse remote side information of data channel from value string (returned + by PASV command). This function you need only in special cases!} + procedure ParseRemote(Value: string); virtual; + + {:Parse remote side information of data channel from value string (returned + by EPSV command). This function you need only in special cases!} + procedure ParseRemoteEPSV(Value: string); virtual; + + {:Send Value as FTP command to FTP server. Returned result code is result of + this function. + This command is good for sending site specific command, or non-standard + commands.} + function FTPCommand(const Value: string): integer; virtual; + + {:Connect and logon to FTP server. If you specify any FireWall, connect to + firewall and throw them connect to FTP server. Login sequence depending on + @link(FWMode).} + function Login: Boolean; virtual; + + {:Logoff and disconnect from FTP server.} + function Logout: Boolean; virtual; + + {:Break current transmission of data. (You can call this method from + Sock.OnStatus event, or from another thread.)} + procedure Abort; virtual; + + {:Download directory listing of Directory on FTP server. If Directory is + empty string, download listing of current working directory. + If NameList is @true, download only names of files in directory. + (internally use NLST command instead LIST command) + If NameList is @false, returned list is also parsed to @link(FTPList) + property.} + function List(Directory: string; NameList: Boolean): Boolean; virtual; + + {:Read data from FileName on FTP server. If Restore is @true and server + supports resume dowloads, download is resumed. (received is only rest + of file)} + function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FileName on FTP server. If Restore is @true and server + supports resume upload, upload is resumed. (send only rest of file) + In this case if remote file is same length as local file, nothing will be + done. If remote file is larger then local, resume is disabled and file is + transfered from begin!} + function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual; + + {:Send data to FTP server and assing unique name for this file.} + function StoreUniqueFile: Boolean; virtual; + + {:Append data to FileName on FTP server.} + function AppendFile(const FileName: string): Boolean; virtual; + + {:Rename on FTP server file with OldName to NewName.} + function RenameFile(const OldName, NewName: string): Boolean; virtual; + + {:Delete file FileName on FTP server.} + function DeleteFile(const FileName: string): Boolean; virtual; + + {:Return size of Filename file on FTP server. If command failed (i.e. not + implemented), return -1.} + function FileSize(const FileName: string): integer; virtual; + + {:Send NOOP command to FTP server for preserve of disconnect by inactivity + timeout.} + function NoOp: Boolean; virtual; + + {:Change currect working directory to Directory on FTP server.} + function ChangeWorkingDir(const Directory: string): Boolean; virtual; + + {:walk to upper directory on FTP server.} + function ChangeToRootDir: Boolean; virtual; + + {:Delete Directory on FTP server.} + function DeleteDir(const Directory: string): Boolean; virtual; + + {:Create Directory on FTP server.} + function CreateDir(const Directory: string): Boolean; virtual; + + {:Return current working directory on FTP server.} + function GetCurrentDir: String; virtual; + + {:Establish data channel to FTP server and retrieve data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command!} + function DataRead(const DestStream: TStream): Boolean; virtual; + + {:Establish data channel to FTP server and send data. + This function you need only in special cases, i.e. when you need to implement + some special unsupported FTP command.} + function DataWrite(const SourceStream: TStream): Boolean; virtual; published + {:After FTP command contains result number of this operation.} property ResultCode: Integer read FResultCode; + + {:After FTP command contains main line of result.} property ResultString: string read FResultString; + + {:After any FTP command it contains all lines of FTP server reply.} property FullResult: TStringList read FFullResult; - property Username: string read FUsername Write FUsername; - property Password: string read FPassword Write FPassword; + + {:Account information used in some cases inside login sequence.} property Account: string read FAccount Write FAccount; + + {:Address of firewall. If empty string (default), firewall not used.} property FWHost: string read FFWHost Write FFWHost; + + {:port of firewall. standard value is same port as ftp server used. (21)} property FWPort: string read FFWPort Write FFWPort; + + {:Username for login to firewall. (if needed)} property FWUsername: string read FFWUsername Write FFWUsername; + + {:password for login to firewall. (if needed)} property FWPassword: string read FFWPassword Write FFWPassword; + + {:Type of Firewall. Used only if you set some firewall address. Supported + predefined firewall login sequences are described by comments in source + file where you can see pseudocode decribing each sequence.} property FWMode: integer read FFWMode Write FFWMode; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property DSock: TSsTCPBlockSocket read FDSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation on control channel. Good for + seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; + + {:Socket object used for TCP/IP operation on data channel. Good for seting + OnStatus hook, etc.} property DSock: TTCPBlockSocket read FDSock; {$ENDIF} + + {:If you not use @link(DirectFile) mode, all data transfers is made to or + from this stream.} property DataStream: TMemoryStream read FDataStream; + + {:After data connection is established, contains remote side IP of this + connection.} property DataIP: string read FDataIP; + + {:After data connection is established, contains remote side port of this + connection.} property DataPort: string read FDataPort; + + {:Mode of data handling by data connection. If @False, all data operations + are made to or from @link(DataStream) TMemoryStream. + If @true, data operations is made directly to file in your disk. (filename + is specified by @link(DirectFileName) property.) Dafault is @False!} property DirectFile: Boolean read FDirectFile Write FDirectFile; + + {:Filename for direct disk data operations.} property DirectFileName: string read FDirectFileName Write FDirectFileName; + + {:Indicate after @link(Login) if remote server support resume downloads and + uploads.} property CanResume: Boolean read FCanResume; + + {:If true (default value), all transfers is made by passive method. + It is safer method for various firewalls.} property PassiveMode: Boolean read FPassiveMode Write FPassiveMode; + + {:Force to listen for dataconnection on standard port (20). Default is @false, + dataconnections will be made to any non-standard port reported by PORT FTP + command. This setting is not used, if you use passive mode.} property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort; + + {:When is @true, then is disabled EPSV and EPRT support. However without this + commands you cannot use IPv6! (Disabling of this commands is needed only + when you are behind some crap firewall/NAT.} + property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort; + + {:You may set this hook for monitoring FTP commands and replies.} property OnStatus: TFTPStatus read FOnStatus write FOnStatus; + + {:After LIST command is here parsed list of files in given directory.} property FtpList: TFTPList read FFtpList; + + {:if @true (default), then data transfers is in binary mode. If this is set + to @false, then ASCII mode is used.} property BinaryMode: Boolean read FBinaryMode Write FBinaryMode; + + {:if is true, then if server support upgrade to SSL/TLS mode, then use them.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:if server listen on SSL/TLS port, then you set this to true.} property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Signalise, if control channel is in SSL/TLS mode.} property IsTLS: Boolean read FIsTLS; + + {:Signalise, if data transfers is in SSL/TLS mode.} property IsDataTLS: Boolean read FIsDataTLS; + + {:If @true (default), then try to use SSL/TLS on data transfers too. + If @false, then SSL/TLS is used only for control connection.} property TLSonData: Boolean read FTLSonData write FTLSonData; end; +{:A very useful function, and example of use can be found in the TFtpSend object. + Dowload specified file from FTP server to LocalFile.} function FtpGetFile(const IP, Port, FileName, LocalFile, User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Upload specified LocalFile to FTP server.} function FtpPutFile(const IP, Port, FileName, LocalFile, User, Pass: string): Boolean; + +{:A very useful function, and example of use can be found in the TFtpSend object. + Initiate transfer of file between two FTP servers.} function FtpInterServerTransfer( const FromIP, FromPort, FromFile, FromUser, FromPass: string; const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; @@ -239,6 +487,7 @@ begin FDirectFile := False; FPassiveMode := True; FForceDefaultPort := False; + FForceOldPort := false; FAccount := ''; FFWHost := ''; FFWPort := cFtpProtocol; @@ -271,23 +520,23 @@ end; function TFTPSend.ReadResult: Integer; var - s,c: string; + s, c: string; begin - Result := 0; FFullResult.Clear; c := ''; repeat s := FSock.RecvString(FTimeout); if c = '' then - c :=Copy(s, 1, 3)+' '; + if length(s) > 3 then + if s[4] in [' ', '-'] then + c :=Copy(s, 1, 3); FResultString := s; FFullResult.Add(s); + DoStatus(True, s); if FSock.LastError <> 0 then Break; - until Pos(c, s) = 1; - s := FFullResult[0]; - if Length(s) >= 3 then - Result := StrToIntDef(Copy(s, 1, 3), 0); + until (c <> '') and (Pos(c + ' ', s) = 1); + Result := StrToIntDef(c, 0); FResultCode := Result; end; @@ -296,7 +545,6 @@ begin FSock.SendString(Value + CRLF); DoStatus(False, Value); Result := ReadResult; - DoStatus(True, FResultString); end; // based on idea by Petr Esner @@ -510,6 +758,8 @@ begin end; function TFTPSend.Login: Boolean; +var + x: integer; begin Result := False; FCanResume := False; @@ -517,7 +767,10 @@ begin Exit; FIsTLS := FFullSSL; FIsDataTLS := False; - if (ReadResult div 100) <> 2 then + repeat + x := ReadResult div 100; + until x <> 1; + if x <> 2 then Exit; if FAutoTLS and not(FIsTLS) then if (FTPCommand('AUTH TLS') div 100) = 2 then @@ -528,9 +781,7 @@ begin Fsock.TLSServer := FTLSServer; Fsock.Connect('',''); FIsTLS := FSock.LastError = 0; - end - else - Result := False; + end; {$ELSE} FSock.SSLDoConnect; FIsTLS := FSock.LastError = 0; @@ -538,16 +789,21 @@ begin FDSock.SSLPrivateKeyFile := FSock.SSLPrivateKeyFile; FDSock.SSLCertCAFile := FSock.SSLCertCAFile; {$ENDIF} + if not FIsTLS then + begin + Result := False; + Exit; + end; end; if not Auth(FFWMode) then Exit; if FIsTLS then begin + FTPCommand('PBSZ 0'); if FTLSonData then FIsDataTLS := (FTPCommand('PROT P') div 100) = 2; if not FIsDataTLS then FTPCommand('PROT C'); - FTPCommand('PBSZ 0'); end; FTPCommand('TYPE I'); FTPCommand('STRU F'); @@ -561,9 +817,9 @@ begin Result := True; end; -procedure TFTPSend.Logout; +function TFTPSend.Logout: Boolean; begin - FTPCommand('QUIT'); + Result := (FTPCommand('QUIT') div 100) = 2; FSock.CloseSocket; end; @@ -602,7 +858,7 @@ var s, v: string; begin s := SeparateRight(Value, '('); - s := SeparateLeft(s, ')'); + s := Trim(SeparateLeft(s, ')')); Delete(s, Length(s), 1); v := ''; for n := Length(s) downto 1 do @@ -625,7 +881,7 @@ begin s := '2' else s := '1'; - if (FTPCommand('EPSV ' + s) div 100) = 2 then + if not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then begin ParseRemoteEPSV(FResultString); end @@ -650,11 +906,8 @@ begin s := cFtpDataProtocol else s := '0'; - //IP cannot be '0.0.0.0'! - if FIPInterface = cAnyHost then - FDSock.Bind(FDSock.LocalName, s) - else - FDSock.Bind(FIPInterface, s); + //data conection from same interface as command connection + FDSock.Bind(FSock.GetLocalSinIP, s); if FDSock.LastError <> 0 then Exit; FDSock.SetLinger(True, 10); @@ -663,12 +916,15 @@ begin FDataIP := FDSock.GetLocalSinIP; FDataIP := FDSock.ResolveName(FDataIP); FDataPort := IntToStr(FDSock.GetLocalSinPort); - if IsIp6(FDataIP) then - s := '2' - else - s := '1'; - s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|'; - Result := (FTPCommand(s) div 100) = 2; + if not FForceOldPort then + begin + if IsIp6(FDataIP) then + s := '2' + else + s := '1'; + s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|'; + Result := (FTPCommand(s) div 100) = 2; + end; if not Result and IsIP(FDataIP) then begin s := ReplaceString(FDataIP, '.', ','); @@ -681,7 +937,7 @@ end; function TFTPSend.AcceptDataSocket: Boolean; var - x: integer; + x: TSocket; begin if FPassiveMode then Result := True @@ -718,17 +974,12 @@ end; function TFTPSend.DataRead(const DestStream: TStream): Boolean; var x: integer; - buf: string; begin Result := False; try if not AcceptDataSocket then Exit; - repeat - buf := FDSock.RecvPacket(FTimeout); - if FDSock.LastError = 0 then - DestStream.Write(Pointer(buf)^, Length(buf)); - until FDSock.LastError <> 0; + FDSock.RecvStreamRaw(DestStream, FTimeout); FDSock.CloseSocket; x := ReadResult; Result := (x div 100) = 2; @@ -738,32 +989,14 @@ begin end; function TFTPSend.DataWrite(const SourceStream: TStream): Boolean; -const - BufSize = 8192; var - Bytes: integer; - bc, lb: integer; - n, x: integer; - Buf: string; + x: integer; begin Result := False; try if not AcceptDataSocket then Exit; - Bytes := SourceStream.Size - SourceStream.Position; - bc := Bytes div BufSize; - lb := Bytes mod BufSize; - SetLength(Buf, BufSize); - for n := 1 to bc do - begin - SourceStream.read(Pointer(buf)^, BufSize); - FDSock.SendBuffer(Pchar(buf), BufSize); - if FDSock.LastError <> 0 then - Exit; - end; - SetLength(Buf, lb); - SourceStream.read(Pointer(buf)^, lb); - FDSock.SendBuffer(Pchar(buf), lb); + FDSock.SendStreamRaw(SourceStream); if FDSock.LastError <> 0 then Exit; FDSock.CloseSocket; @@ -777,16 +1010,15 @@ end; function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; var x: integer; - l: TStringList; begin Result := False; FDataStream.Clear; FFTPList.Clear; if Directory <> '' then Directory := ' ' + Directory; + FTPCommand('TYPE A'); if not DataSocket then Exit; - FTPCommand('TYPE A'); if NameList then x := FTPCommand('NLST' + Directory) else @@ -794,17 +1026,11 @@ begin if (x div 100) <> 1 then Exit; Result := DataRead(FDataStream); - if not NameList then + if (not NameList) and Result then begin - l := TStringList.Create; - try - FDataStream.Seek(0, soFromBeginning); - l.LoadFromStream(FDataStream); - for x := 0 to l.Count - 1 do - FFTPList.ParseLine(l[x]); - finally - l.Free; - end; + FDataStream.Seek(0, soFromBeginning); + FFTPList.Lines.LoadFromStream(FDataStream); + FFTPList.ParseLines; end; FDataStream.Seek(0, soFromBeginning); end; @@ -816,6 +1042,8 @@ begin Result := False; if FileName = '' then Exit; + if not DataSocket then + Exit; Restore := Restore and FCanResume; if FDirectFile then if Restore and FileExists(FDirectFileName) then @@ -827,8 +1055,6 @@ begin else RetrStream := FDataStream; try - if not DataSocket then - Exit; if FBinaryMode then FTPCommand('TYPE I') else @@ -877,7 +1103,7 @@ begin StorSize := SendStream.Size; if not FCanResume then RestoreAt := 0; - if RestoreAt = StorSize then + if (StorSize > 0) and (RestoreAt = StorSize) then begin Result := True; Exit; @@ -954,8 +1180,8 @@ begin Result := -1; if (FTPCommand('SIZE ' + FileName) div 100) = 2 then begin - s := SeparateRight(ResultString, ' '); - s := SeparateLeft(s, ' '); + s := Trim(SeparateRight(ResultString, ' ')); + s := Trim(SeparateLeft(s, ' ')); Result := StrToIntDef(s, -1); end; end; @@ -986,27 +1212,97 @@ begin if (FTPCommand('PWD') div 100) = 2 then begin Result := SeparateRight(FResultString, '"'); - Result := Separateleft(Result, '"'); + Result := Trim(Separateleft(Result, '"')); end; end; procedure TFTPSend.Abort; begin - FDSock.AbortSocket; + FDSock.StopFlag := True; end; {==============================================================================} +procedure TFTPListRec.Assign(Value: TFTPListRec); +begin + FFileName := Value.FileName; + FDirectory := Value.Directory; + FReadable := Value.Readable; + FFileSize := Value.FileSize; + FFileTime := Value.FileTime; + FOriginalLine := Value.OriginalLine; + FMask := Value.Mask; +end; + constructor TFTPList.Create; begin inherited Create; FList := TList.Create; + FLines := TStringList.Create; + FMasks := TStringList.Create; + FUnparsedLines := TStringList.Create; + //various UNIX + FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*'); + FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format + FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*'); + //MacOS + FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*'); + FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*'); + //Novell + FMasks.add('d $!S*$TTT$DD$UUUUU$n*'); + //Windows + FMasks.add('MM DD YY hh mmH !S* n*'); + FMasks.add('MM DD YY hh mmH $ d!n*'); + FMasks.add('MM DD YYYY hh mmH !S* n*'); + FMasks.add('MM DD YYYY hh mmH $ d!n*'); + FMasks.add('DD MM YYYY hh mmH !S* n*'); + FMasks.add('DD MM YYYY hh mmH $ d!n*'); + //VMS + FMasks.add('v*$ DD TTT YYYY hh mm'); + FMasks.add('v*$!DD TTT YYYY hh mm'); + //AS400 + FMasks.add('!S*$MM DD YY hh mm ss !n*'); + FMasks.add('!S*$DD MM YY hh mm ss !n*'); + FMasks.add('n*!S*$MM DD YY hh mm ss d'); + FMasks.add('n*!S*$DD MM YY hh mm ss d'); + //VxWorks + FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d'); + FMasks.add('$S* TTT DD YYYY hh mm ss $n*'); + //Distinct + FMasks.add('d $S*$TTT DD YYYY hh mm$n*'); + FMasks.add('d $S*$TTT DD$hh mm$n*'); + //PC-NFSD + FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH'); + //VOS + FMasks.add('- SSSSS YY MM DD hh mm ss n*'); + FMasks.add('- d= SSSSS YY MM DD hh mm ss n*'); + //Unissys ClearPath + FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm'); + FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm'); + //IBM + FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*'); + //OS9 + FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*'); + //tandem + FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss'); + //MVS + FMasks.add('- YYYY MM DD SSSSS d=O n*'); + //BullGCOS8 + FMasks.add(' $S* MM DD YY hh mm ss !n*'); + FMasks.add('d $S* MM DD YY !n*'); + //BullGCOS7 + FMasks.add(' TTT DD YYYY n*'); + FMasks.add(' d n*'); end; destructor TFTPList.Destroy; begin Clear; FList.Free; + FLines.Free; + FMasks.Free; + FUnparsedLines.Free; inherited Destroy; end; @@ -1018,51 +1314,474 @@ begin if Assigned(FList[n]) then TFTPListRec(FList[n]).Free; FList.Clear; + FLines.Clear; + FUnparsedLines.Clear; end; -// based on idea by D. J. Bernstein, djb@pobox.com -// fixed UNIX style decoding by Alex, akudrin@rosbi.ru -function TFTPList.ParseLine(Value: string): Boolean; +function TFTPList.Count: integer; +begin + Result := FList.Count; +end; + +function TFTPList.GetListItem(Index: integer): TFTPListRec; +begin + Result := nil; + if Index < Count then + Result := TFTPListRec(FList[Index]); +end; + +procedure TFTPList.Assign(Value: TFTPList); var flr: TFTPListRec; + n: integer; +begin + Clear; + for n := 0 to Value.Count - 1 do + begin + flr := TFTPListRec.Create; + flr.Assign(Value[n]); + Flist.Add(flr); + end; + Lines.Assign(Value.Lines); + Masks.Assign(Value.Masks); + UnparsedLines.Assign(Value.UnparsedLines); +end; + +procedure TFTPList.ClearStore; +begin + Monthnames := ''; + BlockSize := ''; + DirFlagValue := ''; + FileName := ''; + VMSFileName := ''; + Day := ''; + Month := ''; + ThreeMonth := ''; + YearTime := ''; + Year := ''; + Hours := ''; + HoursModif := ''; + Minutes := ''; + Seconds := ''; + Size := ''; + Permissions := ''; + DirFlag := ''; +end; + +function TFTPList.ParseByMask(Value, NextValue, Mask: string): Integer; +var + Ivalue, IMask: integer; + MaskC, LastMaskC: Char; + c: char; + s: string; +begin + ClearStore; + Result := 0; + if Value = '' then + Exit; + if Mask = '' then + Exit; + Ivalue := 1; + IMask := 1; + Result := 1; + LastMaskC := ' '; + while Imask <= Length(mask) do + begin + if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then + begin + Result := 0; + Exit; + end; + MaskC := Mask[Imask]; + c := Value[Ivalue]; + case MaskC of + 'n': + FileName := FileName + c; + 'v': + VMSFileName := VMSFileName + c; + '.': + begin + if c in ['.', ' '] then + FileName := TrimSP(FileName) + '.' + else + begin + Result := 0; + Exit; + end; + end; + 'D': + Day := Day + c; + 'M': + Month := Month + c; + 'T': + ThreeMonth := ThreeMonth + c; + 'U': + YearTime := YearTime + c; + 'Y': + Year := Year + c; + 'h': + Hours := Hours + c; + 'H': + HoursModif := HoursModif + c; + 'm': + Minutes := Minutes + c; + 's': + Seconds := Seconds + c; + 'S': + Size := Size + c; + 'p': + Permissions := Permissions + c; + 'd': + DirFlag := DirFlag + c; + 'x': + if c <> ' ' then + begin + Result := 0; + Exit; + end; + '*': + begin + s := ''; + if LastMaskC in ['n', 'v'] then + begin + if Imask = Length(Mask) then + s := Copy(Value, IValue, Maxint) + else + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + if LastMaskC = 'n' then + FileName := FileName + s + else + VMSFileName := VMSFileName + s; + end + else + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in ['0'..'9']) then + break; + s := s + Value[Ivalue]; + Inc(Ivalue); + end; + case LastMaskC of + 'S': + Size := Size + s; + end; + end; + Dec(IValue); + end; + '!': + begin + while IValue <= Length(Value) do + begin + if Value[Ivalue] = ' ' then + break; + Inc(Ivalue); + end; + while IValue <= Length(Value) do + begin + if Value[Ivalue] <> ' ' then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '$': + begin + while IValue <= Length(Value) do + begin + if not(Value[Ivalue] in [' ', #9]) then + break; + Inc(Ivalue); + end; + Dec(IValue); + end; + '=': + begin + s := ''; + case LastmaskC of + 'S': + begin + while Imask <= Length(Mask) do + begin + if not(Mask[Imask] in ['0'..'9']) then + break; + s := s + Mask[Imask]; + Inc(Imask); + end; + Dec(Imask); + BlockSize := s; + end; + 'T': + begin + Monthnames := Copy(Mask, IMask, 12 * 3); + Inc(IMask, 12 * 3); + end; + 'd': + begin + Inc(Imask); + DirFlagValue := Mask[Imask]; + end; + end; + end; + '\': + begin + Value := NextValue; + IValue := 0; + Result := 2; + end; + end; + Inc(Ivalue); + Inc(Imask); + LastMaskC := MaskC; + end; +end; + +function TFTPList.CheckValues: Boolean; +var + x, n: integer; +begin + Result := false; + if FileName <> '' then + begin + if pos('?', VMSFilename) > 0 then + Exit; + if pos('*', VMSFilename) > 0 then + Exit; + end; + if VMSFileName <> '' then + if pos(';', VMSFilename) <= 0 then + Exit; + if (FileName = '') and (VMSFileName = '') then + Exit; + if Permissions <> '' then + begin + if length(Permissions) <> 10 then + Exit; + for n := 1 to 10 do + if not(Permissions[n] in + ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 'w', 'x', 'y', '-']) then + Exit; + end; + if Day <> '' then + begin + Day := TrimSP(Day); + x := StrToIntDef(day, -1); + if (x < 1) or (x > 31) then + Exit; + end; + if Month <> '' then + begin + Month := TrimSP(Month); + x := StrToIntDef(Month, -1); + if (x < 1) or (x > 12) then + Exit; + end; + if Hours <> '' then + begin + Hours := TrimSP(Hours); + x := StrToIntDef(Hours, -1); + if (x < 0) or (x > 24) then + Exit; + end; + if HoursModif <> '' then + begin + if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then + Exit; + end; + if Minutes <> '' then + begin + Minutes := TrimSP(Minutes); + x := StrToIntDef(Minutes, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Seconds <> '' then + begin + Seconds := TrimSP(Seconds); + x := StrToIntDef(Seconds, -1); + if (x < 0) or (x > 59) then + Exit; + end; + if Size <> '' then + begin + Size := TrimSP(Size); + for n := 1 to Length(Size) do + if not (Size[n] in ['0'..'9']) then + Exit; + end; + + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + begin + x := GetMonthNumber(ThreeMonth); + if (x = 0) then + Exit; + end; + if YearTime <> '' then + begin + YearTime := ReplaceString(YearTime, '-', ':'); + if pos(':', YearTime) > 0 then + begin + if (GetTimeFromstr(YearTime) = -1) then + Exit; + end + else + begin + YearTime := TrimSP(YearTime); + x := StrToIntDef(YearTime, -1); + if (x = -1) then + Exit; + if (x < 1900) or (x > 2100) then + Exit; + end; + end; + if Year <> '' then + begin + Year := TrimSP(Year); + x := StrToIntDef(Year, -1); + if (x = -1) then + Exit; + if Length(Year) = 4 then + begin + if not((x > 1900) and (x < 2100)) then + Exit; + end + else + if Length(Year) = 2 then + begin + if not((x >= 0) and (x <= 99)) then + Exit; + end + else + if Length(Year) = 3 then + begin + if not((x >= 100) and (x <= 110)) then + Exit; + end + else + Exit; + end; + Result := True; +end; + +procedure TFTPList.FillRecord(const Value: TFTPListRec); +var s: string; - state: integer; - year: Word; - month: Word; - mday: Word; - t: TDateTime; x: integer; - al_tmp : array[1..2] of string; // alex + myear: Word; + mmonth: Word; + mday: Word; + mhours, mminutes, mseconds: word; + n: integer; +begin + s := DirFlagValue; + if s = '' then + s := 'D'; + s := Uppercase(s); + Value.Directory := s = Uppercase(DirFlag); + if FileName <> '' then + Value.FileName := SeparateLeft(Filename, ' -> '); + if VMSFileName <> '' then + begin + Value.FileName := VMSFilename; + Value.Directory := Pos('.DIR;',VMSFilename) > 0; + end; + Value.FileName := TrimSPRight(Value.FileName); + Value.Readable := not Value.Directory; + if BlockSize <> '' then + x := StrToIntDef(BlockSize, 1) + else + x := 1; + Value.FileSize := x * StrToIntDef(Size, 0); + + DecodeDate(Date,myear,mmonth,mday); + mhours := 0; + mminutes := 0; + mseconds := 0; + + if Day <> '' then + mday := StrToIntDef(day, 1); + if Month <> '' then + mmonth := StrToIntDef(Month, 1); + if length(Monthnames) = (12 * 3) then + for n := 1 to 12 do + CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3); + if ThreeMonth <> '' then + mmonth := GetMonthNumber(ThreeMonth); + if Year <> '' then + begin + myear := StrToIntDef(Year, 0); + if (myear <= 99) and (myear > 50) then + myear := myear + 1900; + if myear <= 50 then + myear := myear + 2000; + end; + if YearTime <> '' then + begin + if pos(':', YearTime) > 0 then + begin + mhours := StrToIntDef(Separateleft(YearTime, ':'), 0); + mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0); + if (Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, 0, 0)) > now then + Dec(mYear); + end + else + myear := StrToIntDef(YearTime, 0); + end; + if Minutes <> '' then + mminutes := StrToIntDef(Minutes, 0); + if Seconds <> '' then + mseconds := StrToIntDef(Seconds, 0); + if Hours <> '' then + begin + mHours := StrToIntDef(Hours, 0); + if HoursModif <> '' then + if Uppercase(HoursModif[1]) = 'P' then + if mHours <> 12 then + mHours := MHours + 12; + end; + Value.FileTime := Encodedate(myear, mmonth, mday) + + EncodeTime(mHours, mminutes, mseconds, 0); + if Permissions <> '' then + begin + Value.Readable := Uppercase(permissions)[2] = 'R'; + if Uppercase(permissions)[1] = 'D' then + begin + Value.Directory := True; + Value.Readable := false; + end + else + if Uppercase(permissions)[1] = 'L' then + Value.Directory := True; + end; +end; + +function TFTPList.ParseEPLF(Value: string): Boolean; +var + s, os: string; + flr: TFTPListRec; begin Result := False; - if Length(Value) < 2 then - Exit; - - year := 0; - month := 0; - mday := 0; - t := 0; - flr := TFTPListRec.Create; - try - flr.FileName := ''; - flr.Directory := False; - flr.Readable := False; - flr.FileSize := 0; - flr.FileTime := 0; - Value := Trim(Value); - {EPLF - See http://pobox.com/~djb/proto/eplf.txt - "+i8388621.29609,m824255902,/," + #9 + "tdev" - "+i8388621.44468,m839956783,r,s10376," + #9 + "RFCEPLF" } + if Value <> '' then if Value[1] = '+' then begin + os := Value; + flr := TFTPListRec.create; s := Fetch(Value, ','); while s <> '' do begin if s[1] = #9 then begin flr.FileName := Copy(s, 2, Length(s) - 1); - Result := True; end; case s[1] of '/': @@ -1077,189 +1796,66 @@ begin end; s := Fetch(Value, ','); end; - Exit; - end; - - {UNIX-style listing, without inum and without blocks - Permissions Owner Group Size Date/Time Name - - "-rw-r--r-- 1 root other 531 Jan 29 03:26 README" - "dr-xr-xr-x 2 root other 512 Apr 8 1994 etc" - "dr-xr-xr-x 2 root 512 Apr 8 1994 etc" - "lrwxrwxrwx 1 root other 7 Jan 25 00:17 bin -> usr/bin" - - Also produced by Microsoft's FTP servers for Windows: - "---------- 1 owner group 1803128 Jul 10 10:18 ls-lR.Z" - - Also WFTPD for MSDOS: - "-rwxrwxrwx 1 noone nogroup 322 Aug 19 1996 message.ftp" - - Also NetWare: - "d [R----F--] supervisor 512 Jan 16 18:53 login" - "- [R----F--] rhesus 214059 Oct 20 15:27 cx.exe" - - Also NetPresenz for the Mac: - "-------r-- 326 1391972 1392298 Nov 22 1995 MegaPhone.sit" - "drwxrwxr-x folder 2 May 10 1996 network" } - - if (Value[1] = 'b') or - (Value[1] = 'c') or - (Value[1] = 'd') or - (Value[1] = 'l') or - (Value[1] = 'p') or - (Value[1] = 's') or - (Value[1] = '-') then - begin - - // alex begin - // default year - DecodeDate(date,year,month,mday); // alex - month:=0; - mday :=0; - - if Value[1] = 'd' then flr.Directory := True - else if Value[1] = '-' then flr.Readable := True - else if Value[1] = 'l' then - begin - flr.Directory := True; - flr.Readable := True; - end; - - state:=1; - s := Fetch(Value, ' '); - while s<>'' do - begin - month:=GetMonthNumber(s); - if month>0 then - break; - al_tmp[state]:=s; - if state=1 then state:=2 - else state:=1; - s := Fetch(Value, ' '); - end; - if month>0 then begin - if state=1 then - flr.FileSize := StrToIntDef(al_tmp[2], 0) - else flr.FileSize := StrToIntDef(al_tmp[1], 0); - - state:=1; - s := Fetch(Value, ' '); - while s <> '' do - begin - case state of - 1 : mday := StrToIntDef(s, 0); - 2 : begin - if (Pos(':', s) > 0) then - t := GetTimeFromStr(s) - else if Length(s) = 4 then - year := StrToIntDef(s, 0) - else Exit; - if (year = 0) or (month = 0) or (mday = 0) then - Exit; - // for date 2-29 find last leap year. (fix for non-existent year) - if (month = 2) and (mday = 29) then - while not IsLeapYear(year) do - Dec(year); - flr.FileTime := t + Encodedate(year, month, mday); - end; - 3 : begin - if Value <> '' then - s := s + ' ' + Value; - s := SeparateLeft(s, ' -> '); - flr.FileName := s; - Result := True; - break; - end; - end; - inc(state); - s := Fetch(Value, ' '); - end; - end; - // alex end - exit; - end; - {Microsoft NT 4.0 FTP Service - 10-20-98 08:57AM 619098 rizrem.zip - 11-12-98 11:54AM test } - if (Value[1] = '1') or (Value[1] = '0') then - begin - if Length(Value) < 8 then - Exit; - if (Ord(Value[2]) < 48) or (Ord(Value[2]) > 57) then - Exit; - if Value[3] <> '-' then - Exit; - s := Fetch(Value, ' '); - t := GetDateMDYFromStr(s); - if t = 0 then - Exit; - if Value = '' then - Exit; - s := Fetch(Value, ' '); - flr.FileTime := t + GetTimeFromStr(s); - if Value = '' then - Exit; - s := Fetch(Value, ' '); - if s[1] = '<' then - flr.Directory := True + if flr.FileName <> '' then + if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..'))) + or (flr.FileName = '') then + flr.free else begin - flr.Readable := true; - flr.FileSize := StrToIntDef(s, 0); + flr.OriginalLine := os; + flr.Mask := 'EPLF'; + Flist.Add(flr); + Result := True; end; - if Value = '' then - Exit; - flr.FileName := Trim(Value); - Result := True; - Exit; end; - {MultiNet - "00README.TXT;1 2 30-DEC-1996 17:44 [SYSTEM] (RWED,RWED,RE,RE)" - "CORE.DIR;1 1 8-SEP-1996 16:09 [SYSTEM] (RWE,RWE,RE,RE)" +end; - and non-MutliNet VMS: - "CII-MANUAL.TEX;1 213/216 29-JAN-1996 03:33:12 [ANONYMOU,ANONYMOUS] (RWED,RWED,,)" } - x := Pos(';', Value); - if x > 0 then - begin - s := Fetch(Value, ';'); - if Uppercase(Copy(s,Length(s) - 4, 4)) = '.DIR' then - begin - flr.FileName := Copy(s, 1, Length(s) - 4); - flr.Directory := True; - end - else - begin - flr.FileName := s; - flr.Readable := True; - end; - s := Fetch(Value, ' '); - s := Fetch(Value, ' '); - if Value = '' then - Exit; - s := Fetch(Value, '-'); - mday := StrToIntDef(s, 0); - s := Fetch(Value, '-'); - month := GetMonthNumber(s); - s := Fetch(Value, ' '); - year := StrToIntDef(s, 0); - s := Fetch(Value, ' '); - if Value = '' then - Exit; - if (year = 0) or (month = 0) or (mday = 0) then - Exit; - flr.FileTime := GetTimeFromStr(s) + EncodeDate(year, month, mday); - Result := True; - Exit; - end; - finally - if Result then - if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then - Result := False; - if Result then - FList.Add(flr) +procedure TFTPList.ParseLines; +var + flr: TFTPListRec; + n, m: Integer; + S: string; + x: integer; + b: Boolean; +begin + n := 0; + while n < Lines.Count do + begin + if n = Lines.Count - 1 then + s := '' else - flr.Free; + s := Lines[n + 1]; + b := False; + x := 0; + if ParseEPLF(Lines[n]) then + begin + b := True; + x := 1; + end + else + for m := 0 to Masks.Count - 1 do + begin + x := ParseByMask(Lines[n], s, Masks[m]); + if x > 0 then + if CheckValues then + begin + flr := TFTPListRec.create; + FillRecord(flr); + flr.OriginalLine := Lines[n]; + flr.Mask := Masks[m]; + if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then + flr.free + else + Flist.Add(flr); + b := True; + Break; + end; + end; + if not b then + FUnparsedLines.Add(Lines[n]); + Inc(n); + if x > 1 then + Inc(n, x - 1); end; end; diff --git a/ftptsend.pas b/ftptsend.pas index 86597cd..9cf7bab 100644 --- a/ftptsend.pas +++ b/ftptsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.002 | +| Project : Ararat Synapse | 001.001.000 | |==============================================================================| | Content: Trivial FTP (TFTP) client and server | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003. | +| Portions created by Lukas Gebauer are Copyright (c)2003-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -// RFC-1350 +{: @abstract(TFTP client and server protocol) + +Used RFC: RFC-1350 +} {$IFDEF FPC} {$MODE DELPHI} @@ -61,7 +64,16 @@ uses const cTFTPProtocol = '69'; + cTFTP_RRQ = word(1); + cTFTP_WRQ = word(2); + cTFTP_DTA = word(3); + cTFTP_ACK = word(4); + cTFTP_ERR = word(5); + type + {:@abstract(Implementation of TFTP client and server) + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TTFTPSend = class(TSynaClient) private FSock: TUDPBlockSocket; @@ -75,17 +87,44 @@ type public constructor Create; destructor Destroy; override; + + {:Upload @link(data) as file to TFTP server.} function SendFile(const Filename: string): Boolean; + + {:Download file from TFTP server to @link(data).} function RecvFile(const Filename: string): Boolean; + + {:Acts as TFTP server and wait for client request. When some request + incoming within Timeout, result is @true and parametres is filled with + information from request. You must handle this request, validate it, and + call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply + to TFTP Client.} function WaitForRequest(var Req: word; var filename: string): Boolean; + + {:send error to TFTP client, when you acts as TFTP server.} procedure ReplyError(Error: word; Description: string); + + {:Accept uploaded file from TFTP client to @link(data), when you acts as + TFTP server.} function ReplyRecv: Boolean; + + {:Accept download request file from TFTP client and send content of + @link(data), when you acts as TFTP server.} function ReplySend: Boolean; published + {:Code of TFTP error.} property ErrorCode: integer read FErrorCode; + + {:Human readable decription of TFTP error. (if is sended by remote side)} property ErrorString: string read FErrorString; + + {:MemoryStream with datas for sending or receiving} property Data: TMemoryStream read FData; + + {:Address of TFTP remote side.} property RequestIP: string read FRequestIP write FRequestIP; + + {:Port of TFTP remote side.} property RequestPort: string read FRequestPort write FRequestPort; end; @@ -197,14 +236,16 @@ begin n2 := FData.Size mod 512; for n := 1 to n1 do begin - SetLength(s, 512); - FData.Read(pointer(s)^, 512); + s := ReadStrFromStream(FData, 512); +// SetLength(s, 512); +// FData.Read(pointer(s)^, 512); if not Sendpacket(3, ser, s) then Exit; inc(ser); end; - SetLength(s, n2); - FData.Read(pointer(s)^, n2); + s := ReadStrFromStream(FData, n2); +// SetLength(s, n2); +// FData.Read(pointer(s)^, n2); if not Sendpacket(3, ser, s) then Exit; Result := True; @@ -237,7 +278,8 @@ begin if not RecvPacket(ser, s) then Exit; inc(ser); - FData.Write(pointer(s)^, length(s)); + WriteStrToStream(FData, s); +// FData.Write(pointer(s)^, length(s)); until length(s) <> 512; FData.Position := 0; Result := true; @@ -266,10 +308,10 @@ begin FRequestPort := IntToStr(FSock.GetRemoteSinPort); Req := DecodeInt(s, 1); delete(s, 1, 2); - filename := SeparateLeft(s, #0); + filename := Trim(SeparateLeft(s, #0)); s := SeparateRight(s, #0); s := SeparateLeft(s, #0); - Result := lowercase(s) = 'octet'; + Result := lowercase(trim(s)) = 'octet'; end; end; end; @@ -304,7 +346,8 @@ begin if not RecvPacket(ser, s) then Exit; inc(ser); - FData.Write(pointer(s)^, length(s)); + WriteStrToStream(FData, s); +// FData.Write(pointer(s)^, length(s)); until length(s) <> 512; FData.Position := 0; Result := true; @@ -331,14 +374,16 @@ begin n2 := FData.Size mod 512; for n := 1 to n1 do begin - SetLength(s, 512); - FData.Read(pointer(s)^, 512); + s := ReadStrFromStream(FData, 512); +// SetLength(s, 512); +// FData.Read(pointer(s)^, 512); if not Sendpacket(3, ser, s) then Exit; inc(ser); end; - SetLength(s, n2); - FData.Read(pointer(s)^, n2); + s := ReadStrFromStream(FData, n2); +// SetLength(s, n2); +// FData.Read(pointer(s)^, n2); if not Sendpacket(3, ser, s) then Exit; Result := True; diff --git a/httpsend.pas b/httpsend.pas index d029d1f..ce269c0 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.006.007 | +| Project : Ararat Synapse | 003.009.003 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-1867, RFC-1947, RFC-2388, RFC-2616 +{:@abstract(HTTP protocol client) + +Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616 +} {$IFDEF FPC} {$MODE DELPHI} @@ -64,10 +67,13 @@ const cHttpProtocol = '80'; type + {:These encoding types are used internally by the THTTPSend object to identify + the transfer data types.} TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED); + {:abstract(Implementation of HTTP protocol.)} THTTPSend = class(TSynaClient) - private + protected {$IFDEF STREAMSEC} FSock: TSsTCPBlockSocket; FTLSServer: TCustomTLSInternalServer; @@ -102,41 +108,151 @@ type public constructor Create; destructor Destroy; override; + + {:Reset headers and document and Mimetype.} procedure Clear; + + {:Decode ResultCode and ResultString from Value.} procedure DecodeStatus(const Value: string); + + {:Connects to host define in URL and access to resource defined in URL by + method. If Document is not empty, send it to server as part of HTTP request. + Server response is in Document and headers. Connection may be authorised + by username and password in URL. If you define proxy properties, connection + is made by this proxy. If all OK, result is @true, else result is @false. + + If you use in URL 'https:' instead only 'http:', then your request is made + by SSL/TLS connection (if you not specify port, then port 443 is used + instead standard port 80). If you use SSL/TLS request and you have defined + HTTP proxy, then HTTP-tunnel mode is automaticly used .} function HTTPMethod(const Method, URL: string): Boolean; + + {:You can call this method from OnStatus event for break current data + transfer. (or from another thread.)} procedure Abort; published + {:Before HTTP operation you may define any non-standard headers for HTTP + request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type', + 'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers. + After HTTP operation contains full headers of returned document.} property Headers: TStringList read FHeaders; + + {:This is stringlist with name-value stringlist pairs. Each this pair is one + cookie. After HTTP request is returned cookies parsed to this stringlist. + You can leave this cookies untouched for next HTTP request. You can also + save this stringlist for later use.} property Cookies: TStringList read FCookies; + + {:Stream with document to send (before request, or with document received + from HTTP server (after request).} property Document: TMemoryStream read FDocument; + + {:If you need download only part of requested document, here specify + possition of subpart begin. If here 0, then is requested full document.} property RangeStart: integer read FRangeStart Write FRangeStart; + + {:If you need download only part of requested document, here specify + possition of subpart end. If here 0, then is requested document from + rangeStart to end of document. (for broken download restoration, + for example.)} property RangeEnd: integer read FRangeEnd Write FRangeEnd; + + {:Mime type of sending data. Default is: 'text/html'.} property MimeType: string read FMimeType Write FMimeType; + + {:Define protocol version. Possible values are: '1.1' (default), + '1.0' and '0.9'.} property Protocol: string read FProtocol Write FProtocol; + + {:If @true (default value), keppalives in HTTP protocol 1.1 is enabled.} property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; + + {:if @true, then server is requested for 100status capability when uploading + data. Default is @false (off).} property Status100: Boolean read FStatus100 Write FStatus100; + + {:Address of proxy server (IP address or domain name) where you want to + connect in @link(HTTPMethod) method.} property ProxyHost: string read FProxyHost Write FProxyHost; + + {:Port number for proxy connection. Default value is 8080.} property ProxyPort: string read FProxyPort Write FProxyPort; + + {:Username for connect to proxy server where you want to connect in + HTTPMethod method.} property ProxyUser: string read FProxyUser Write FProxyUser; + + {:Password for connect to proxy server where you want to connect in + HTTPMethod method.} property ProxyPass: string read FProxyPass Write FProxyPass; + + {:Here you can specify custom User-Agent indentification. By default is + used: 'Mozilla/4.0 (compatible; Synapse)'} property UserAgent: string read FUserAgent Write FUserAgent; + + {:After successful @link(HTTPMethod) method contains result code of + operation.} property ResultCode: Integer read FResultCode; + + {:After successful @link(HTTPMethod) method contains string after result code.} property ResultString: string read FResultString; + + {:if this value is not 0, then data download pending. In this case you have + here total sice of downloaded data. It is good for draw download + progressbar from OnStatus event.} property DownloadSize: integer read FDownloadSize; + + {:if this value is not 0, then data upload pending. In this case you have + here total sice of uploaded data. It is good for draw upload progressbar + from OnStatus event.} property UploadSize: integer read FUploadSize; -{$IFDEF STREAMSEC} +{$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; +{:A very usefull function, and example of use can be found in the THTTPSend + object. It implements the GET method of the HTTP protocol. This function sends + the GET method for URL document to an HTTP server. Returned document is in the + "Response" stringlist (without any headers). Returns boolean TRUE if all went + well.} function HttpGetText(const URL: string; const Response: TStrings): Boolean; + +{:A very usefull function, and example of use can be found in the THTTPSend + object. It implements the GET method of the HTTP protocol. This function sends + the GET method for URL document to an HTTP server. Returned document is in the + "Response" stream. Returns boolean TRUE if all went well.} function HttpGetBinary(const URL: string; const Response: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function sends + the SEND method for a URL document to an HTTP server. The document to be sent + is located in "Data" stream. The returned document is in the "Data" stream. + Returns boolean TRUE if all went well.} function HttpPostBinary(const URL: string; const Data: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function is + good for POSTing form data. It sends the POST method for a URL document to + an HTTP server. You must prepare the form data in the same manner as you would + the URL data, and pass this prepared data to "URLdata". The following is + a sample of how the data would appear: 'name=Lukas&field1=some%20data'. + The information in the field must be encoded by EncodeURLElement function. + The returned document is in the "Data" stream. Returns boolean TRUE if all + went well.} function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; + +{:A very useful function, and example of use can be found in the THTTPSend + object. It implements the POST method of the HTTP protocol. This function sends + the POST method for a URL document to an HTTP server. This function simulate + posting of file by HTML form used method 'multipart/form-data'. Posting file + is in DATA stream. Its name is Filename string. Fieldname is for name of + formular field with file. (simulate HTML INPUT FILE) The returned document is + in the ResultData Stringlist. Returns boolean TRUE if all went well.} function HttpPostFile(const URL, FieldName, FileName: string; const Data: TStream; const ResultData: TStrings): Boolean; @@ -148,16 +264,16 @@ begin FHeaders := TStringList.Create; FCookies := TStringList.Create; FDocument := TMemoryStream.Create; -{$IFDEF STREAMSEC} - FTLSServer := GlobalTLSInternalServer; +{$IFDEF STREAMSEC} + FTLSServer := GlobalTLSInternalServer; FSock := TSsTCPBlockSocket.Create; FSock.BlockingRead := True; {$ELSE} FSock := TTCPBlockSocket.Create; {$ENDIF} FSock.ConvertLineEnd := True; - FSock.SizeRecvBuffer := 65536; - FSock.SizeSendBuffer := 65536; + FSock.SizeRecvBuffer := c64k; + FSock.SizeSendBuffer := c64k; FTimeout := 90000; FTargetPort := cHttpProtocol; FProxyHost := ''; @@ -197,10 +313,10 @@ procedure THTTPSend.DecodeStatus(const Value: string); var s, su: string; begin - s := SeparateRight(Value, ' '); - su := SeparateLeft(s, ' '); + s := Trim(SeparateRight(Value, ' ')); + su := Trim(SeparateLeft(s, ' ')); FResultCode := StrToIntDef(su, 0); - FResultString := SeparateRight(s, ' '); + FResultString := Trim(SeparateRight(s, ' ')); if FResultString = s then FResultString := ''; end; @@ -225,6 +341,11 @@ begin FUploadSize := 0; URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); + if User = '' then + begin + User := FUsername; + Pass := FPassword; + end; if UpperCase(Prot) = 'HTTPS' then begin HttpTunnel := FProxyHost <> ''; @@ -247,9 +368,10 @@ begin status100 := FStatus100 and Sending and (FProtocol = '1.1'); if status100 then FHeaders.Insert(0, 'Expect: 100-continue'); + FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); if Sending then begin - FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); +// FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); if FMimeType <> '' then FHeaders.Insert(0, 'Content-Type: ' + FMimeType); end; @@ -260,14 +382,21 @@ begin if FRangeEnd > 0 then FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)); { setting Cookies } + s := ''; for n := 0 to FCookies.Count - 1 do - FHeaders.Insert(0, 'Cookie: ' + FCookies[n]); + begin + if s <> '' then + s := s + '; '; + s := s + FCookies[n]; + end; + if s <> '' then + FHeaders.Insert(0, 'Cookie: ' + s); { setting KeepAlives } if not FKeepAlive then FHeaders.Insert(0, 'Connection: close'); { set target servers/proxy, authorizations, etc... } if User <> '' then - FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass)); + FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass)); if (FProxyHost <> '') and (FProxyUser <> '') and not(HttpTunnel) then FHeaders.Insert(0, 'Proxy-Authorization: Basic ' + EncodeBase64(FProxyUser + ':' + FProxyPass)); @@ -416,7 +545,8 @@ begin begin { old HTTP 0.9 and some buggy servers not send result } s := s + CRLF; - FDocument.Write(Pointer(s)^, Length(s)); + WriteStrToStream(FDocument, s); +// FDocument.Write(Pointer(s)^, Length(s)); FResultCode := 0; end; end @@ -434,21 +564,22 @@ begin su := UpperCase(s); if Pos('CONTENT-LENGTH:', su) = 1 then begin - Size := StrToIntDef(SeparateRight(s, ' '), -1); + Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1); if Size <> -1 then FTransferEncoding := TE_IDENTITY; end; if Pos('CONTENT-TYPE:', su) = 1 then - FMimeType := SeparateRight(s, ' '); + FMimeType := Trim(SeparateRight(s, ' ')); if Pos('TRANSFER-ENCODING:', su) = 1 then begin - s := SeparateRight(su, ' '); + s := Trim(SeparateRight(su, ' ')); if Pos('CHUNKED', s) > 0 then FTransferEncoding := TE_CHUNKED; end; if Pos('CONNECTION: CLOSE', su) = 1 then ToClose := True; until FSock.LastError <> 0; + Result := FSock.LastError = 0; {if need receive response body, read it} Receiving := Method <> 'HEAD'; @@ -457,13 +588,12 @@ begin if Receiving then case FTransferEncoding of TE_UNKNOWN: - ReadUnknown; + Result := ReadUnknown; TE_IDENTITY: - ReadIdentity(Size); + Result := ReadIdentity(Size); TE_CHUNKED: - ReadChunked; + Result := ReadChunked; end; - Result := True; FDocument.Seek(0, soFromBeginning); if ToClose then @@ -482,20 +612,22 @@ begin repeat s := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then - FDocument.Write(Pointer(s)^, Length(s)); + WriteStrToStream(FDocument, s); until FSock.LastError <> 0; Result := True; end; function THTTPSend.ReadIdentity(Size: Integer): Boolean; -var - x: integer; begin - FDownloadSize := Size; - FDocument.SetSize(FDocument.Position + Size); - x := FSock.RecvBufferEx(IncPoint(FDocument.Memory, FDocument.Position), Size, FTimeout); - FDocument.SetSize(FDocument.Position + x); - Result := FSock.LastError = 0; + if Size > 0 then + begin + FDownloadSize := Size; + FSock.RecvStreamSize(FDocument, FTimeout, Size); + FDocument.Seek(0, soFromEnd); + Result := FSock.LastError = 0; + end + else + Result := true; end; function THTTPSend.ReadChunked: Boolean; @@ -506,14 +638,16 @@ begin repeat repeat s := FSock.RecvString(FTimeout); - until s <> ''; + until (s <> '') or (FSock.LastError <> 0); if FSock.LastError <> 0 then Break; - s := SeparateLeft(s, ' '); + s := Trim(SeparateLeft(s, ' ')); + s := Trim(SeparateLeft(s, ';')); Size := StrToIntDef('$' + s, 0); if Size = 0 then Break; - ReadIdentity(Size); + if not ReadIdentity(Size) then + break; until False; Result := FSock.LastError = 0; end; @@ -537,7 +671,7 @@ end; procedure THTTPSend.Abort; begin - FSock.AbortSocket; + FSock.StopFlag := True; end; {==============================================================================} @@ -591,7 +725,8 @@ var begin HTTP := THTTPSend.Create; try - HTTP.Document.Write(Pointer(URLData)^, Length(URLData)); + WriteStrToStream(HTTP.Document, URLData); +// HTTP.Document.Write(Pointer(URLData)^, Length(URLData)); HTTP.MimeType := 'application/x-www-form-urlencoded'; Result := HTTP.HTTPMethod('POST', URL); Data.CopyFrom(HTTP.Document, 0); @@ -613,10 +748,12 @@ begin s := s + 'content-disposition: form-data; name="' + FieldName + '";'; s := s + ' filename="' + FileName +'"' + CRLF; s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; - HTTP.Document.Write(Pointer(s)^, Length(s)); + WriteStrToStream(HTTP.Document, s); +// HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.Document.CopyFrom(Data, 0); s := CRLF + '--' + Bound + '--' + CRLF; - HTTP.Document.Write(Pointer(s)^, Length(s)); + WriteStrToStream(HTTP.Document, s); +// HTTP.Document.Write(Pointer(s)^, Length(s)); HTTP.MimeType := 'multipart/form-data; boundary=' + Bound; Result := HTTP.HTTPMethod('POST', URL); ResultData.LoadFromStream(HTTP.Document); diff --git a/imapsend.pas b/imapsend.pas index da737f8..8cff691 100644 --- a/imapsend.pas +++ b/imapsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.004.002 | +| Project : Ararat Synapse | 002.005.000 | |==============================================================================| | Content: IMAP4rev1 client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-2060, RFC-2595 +{:@abstract(IMAP4 rev1 protocol client) + +Used RFC: RFC-2060, RFC-2595 +} {$IFDEF FPC} {$MODE DELPHI} @@ -58,14 +61,20 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, synautil, synacode; + blcksock, synautil; const cIMAPProtocol = '143'; type + {:@abstract(Implementation of IMAP4 protocol.) + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TIMAPSend = class(TSynaClient) - private + protected {$IFDEF STREAMSEC} FSock: TSsTCPBlockSocket; FTLSServer: TCustomTLSInternalServer; @@ -76,8 +85,6 @@ type FResultString: string; FFullResult: TStringList; FIMAPcap: TStringList; - FUsername: string; - FPassword: string; FAuthDone: Boolean; FSelectedFolder: string; FSelectedCount: integer; @@ -97,57 +104,171 @@ type public constructor Create; destructor Destroy; override; + + {:By this function you can call any IMAP command. Result of this command is + in adequate properties.} function IMAPcommand(Value: string): string; + + {:By this function you can call any IMAP command what need upload any data. + Result of this command is in adequate properties.} function IMAPuploadCommand(Value: string; const Data:TStrings): string; + + {:Call CAPABILITY command and fill IMAPcap property by new values.} function Capability: Boolean; + + {:Connect to IMAP server and do login to this server. This command begin + session.} function Login: Boolean; - procedure Logout; + + {:Disconnect from IMAP server and terminate session session. If exists some + deleted and non-purged messages, these messages are not deleted!} + function Logout: Boolean; + + {:Do NOOP. It is for prevent disconnect by timeout.} function NoOp: Boolean; + + {:Lists folder names. You may specify level of listing. If you specify + FromFolder as empty string, return is all folders in system.} function List(FromFolder: string; const FolderList: TStrings): Boolean; + + {:Lists folder names what match search criteria. You may specify level of + listing. If you specify FromFolder as empty string, return is all folders + in system.} + function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; + + {:Lists subscribed folder names. You may specify level of listing. If you + specify FromFolder as empty string, return is all subscribed folders in + system.} function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; + + {:Lists subscribed folder names what matching search criteria. You may + specify level of listing. If you specify FromFolder as empty string, return + is all subscribed folders in system.} + function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; + + {:Create a new folder.} function CreateFolder(FolderName: string): Boolean; + + {:Delete a folder.} function DeleteFolder(FolderName: string): Boolean; + + {:Rename folder names.} function RenameFolder(FolderName, NewFolderName: string): Boolean; + + {:Subscribe folder.} function SubscribeFolder(FolderName: string): Boolean; + + {:Unsubscribe folder.} function UnsubscribeFolder(FolderName: string): Boolean; + + {:Select folder.} function SelectFolder(FolderName: string): Boolean; + + {:Select folder, but only for reading. Any changes are not allowed!} function SelectROFolder(FolderName: string): Boolean; + + {:Close a folder. (end of Selected state)} function CloseFolder: Boolean; + + {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN', + result is number of unseen messages in folder. For another status + indentificator check IMAP documentation and documentation of your IMAP + server (each IMAP server can have their own statuses.)} function StatusFolder(FolderName, Value: string): integer; + + {:Hardly delete all messages marked as 'deleted' in current selected folder.} function ExpungeFolder: Boolean; + + {:Touch to folder. (use as update status of folder, etc.)} function CheckFolder: Boolean; + + {:Append given message to specified folder.} function AppendMess(ToFolder: string; const Mess: TStrings): Boolean; + + {:'Delete' message from currect selected folder. It mark message as Deleted. + Real deleting waill be done after sucessfull @link(CloseFolder) or + @link(ExpungeFolder)} function DeleteMess(MessID: integer): boolean; + + {:Get full message from specified message in selected folder.} function FetchMess(MessID: integer; const Mess: TStrings): Boolean; + + {:Get message headers only from specified message in selected folder.} function FetchHeader(MessID: integer; const Headers: TStrings): Boolean; + + {:Return message size of specified message from current selected folder.} function MessageSize(MessID: integer): integer; + + {:Copy message from current selected folder to another folder.} function CopyMess(MessID: integer; ToFolder: string): Boolean; + + {:Return message numbers from currently selected folder as result + of searching. Search criteria is very complex language (see to IMAP + specification) similar to SQL (but not same syntax!).} function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; + + {:Sets flags of message from current selected folder.} function SetFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Gets flags of message from current selected folder.} function GetFlagsMess(MessID: integer; var Flags: string): Boolean; + + {:Add flags to message's flags.} function AddFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Remove flags from message's flags.} function DelFlagsMess(MessID: integer; Flags: string): Boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} function StartTLS: Boolean; + + {:return UID of requested message ID.} function GetUID(MessID: integer; var UID : Integer): Boolean; + + {:Try to find given capabily in capabilty string returned from IMAP server.} function FindCap(const Value: string): string; published + {:Status line with result of last operation.} property ResultString: string read FResultString; + + {:Full result of last IMAP operation.} property FullResult: TStringList read FFullResult; + + {:List of server capabilites.} property IMAPcap: TStringList read FIMAPcap; - property Username: string read FUsername Write FUsername; - property Password: string read FPassword Write FPassword; + + {:Authorization is successful done.} property AuthDone: Boolean read FAuthDone; + + {:Turn on or off usage of UID (unicate identificator) of messages instead + only sequence numbers.} property UID: Boolean read FUID Write FUID; + + {:Name of currently selected folder.} property SelectedFolder: string read FSelectedFolder; + + {:Count of messages in currently selected folder.} property SelectedCount: integer read FSelectedCount; + + {:Count of not-visited messages in currently selected folder.} property SelectedRecent: integer read FSelectedRecent; + + {:This number with name of folder is unique indentificator of folder. + (If someone delete folder and next create new folder with exactly same name + of folder, this number is must be different!)} property SelectedUIDvalidity: integer read FSelectedUIDvalidity; + + {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} property FullSSL: Boolean read FFullSSL Write FFullSSL; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; @@ -160,7 +281,7 @@ begin FFullResult := TStringList.Create; FIMAPcap := TStringList.Create; {$IFDEF STREAMSEC} - FTLSServer := GlobalTLSInternalServer; + FTLSServer := GlobalTLSInternalServer; FSock := TSsTCPBlockSocket.Create; FSock.BlockingRead := True; {$ELSE} @@ -171,8 +292,6 @@ begin FSock.SizeSendBuffer := 32768; FTimeout := 60000; FTargetPort := cIMAPProtocol; - FUsername := ''; - FPassword := ''; FTagCommand := 0; FSelectedFolder := ''; FSelectedCount := 0; @@ -222,8 +341,8 @@ begin end; end; until FSock.LastError <> 0; - s := separateright(FResultString, ' '); - Result:=uppercase(separateleft(s, ' ')); + s := Trim(separateright(FResultString, ' ')); + Result:=uppercase(Trim(separateleft(s, ' '))); end; procedure TIMAPSend.ProcessLiterals; @@ -338,20 +457,20 @@ begin s := uppercase(FFullResult[n]); if Pos(' EXISTS', s) > 0 then begin - t := separateleft(s, ' EXISTS'); - t := separateright(t, '* '); + t := Trim(separateleft(s, ' EXISTS')); + t := Trim(separateright(t, '* ')); FSelectedCount := StrToIntDef(t, 0); end; if Pos(' RECENT', s) > 0 then begin - t := separateleft(s, ' RECENT'); - t := separateright(t, '* '); + t := Trim(separateleft(s, ' RECENT')); + t := Trim(separateright(t, '* ')); FSelectedRecent := StrToIntDef(t, 0); end; if Pos('UIDVALIDITY', s) > 0 then begin - t := separateright(s, 'UIDVALIDITY '); - t := separateleft(t, ']'); + t := Trim(separateright(s, 'UIDVALIDITY ')); + t := Trim(separateleft(t, ']')); FSelectedUIDvalidity := StrToIntDef(t, 0); end; end; @@ -369,7 +488,7 @@ begin s := uppercase(FFullResult[n]); if Pos('* SEARCH', s) = 1 then begin - s := SeparateRight(s, '* SEARCH'); + s := Trim(SeparateRight(s, '* SEARCH')); while s <> '' do Value.Add(Fetch(s, ' ')); end; @@ -436,11 +555,11 @@ begin for n := 0 to FFullResult.Count - 1 do if Pos('* CAPABILITY ', FFullResult[n]) = 1 then begin - s := SeparateRight(FFullResult[n], '* CAPABILITY '); + s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY ')); while not (s = '') do begin - t := separateleft(s, ' '); - s := separateright(s, ' '); + t := Trim(separateleft(s, ' ')); + s := Trim(separateright(s, ' ')); if s = t then s := ''; FIMAPcap.Add(t); @@ -481,9 +600,9 @@ begin Result := AuthLogin; end; -procedure TIMAPSend.Logout; +function TIMAPSend.Logout: Boolean; begin - IMAPcommand('LOGOUT'); + Result := IMAPcommand('LOGOUT') = 'OK'; FSelectedFolder := ''; FSock.CloseSocket; end; @@ -499,12 +618,24 @@ begin ParseFolderList(FolderList); end; +function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK'; + ParseFolderList(FolderList); +end; + function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean; begin Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK'; ParseFolderList(FolderList); end; +function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean; +begin + Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK'; + ParseFolderList(FolderList); +end; + function TIMAPSend.CreateFolder(FolderName: string): Boolean; begin Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK'; @@ -641,8 +772,7 @@ begin if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then begin t := SeparateRight(s, 'RFC822.SIZE '); - t := SeparateLeft(t, ')'); - t := trim(t); + t := Trim(SeparateLeft(t, ')')); Result := StrToIntDef(t, -1); Break; end; @@ -719,7 +849,7 @@ begin begin s := SeparateRight(s, 'FLAGS'); s := Separateright(s, '('); - Flags := SeparateLeft(s, ')'); + Flags := Trim(SeparateLeft(s, ')')); end; end; end; @@ -760,7 +890,7 @@ begin if Pos('FETCH (UID', s) >= 1 then begin s := Separateright(s, '(UID '); - sUID := SeparateLeft(s, ')'); + sUID := Trim(SeparateLeft(s, ')')); end; end; UID := StrToIntDef(sUID, 0); diff --git a/ldapsend.pas b/ldapsend.pas index f0c6680..add3fe0 100644 --- a/ldapsend.pas +++ b/ldapsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.011 | +| Project : Ararat Synapse | 001.002.001 | |==============================================================================| | Content: LDAP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003. | +| Portions created by Lukas Gebauer are Copyright (c)2003-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-2251, RFC-2254, RFC-2829, RFC-2830 +{:@abstract(LDAP client) + +Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830 +} {$IFDEF FPC} {$MODE DELPHI} @@ -54,7 +57,7 @@ unit ldapsend; interface uses - Classes, SysUtils, + SysUtils, Classes, {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} @@ -87,6 +90,9 @@ const type + {:@abstract(LDAP attribute with list of their values) + This class holding name of LDAP attribute and list of their values. This is + descendant of TStringList class enhanced by some new properties.} TLDAPAttribute = class(TStringList) private FAttributeName: string; @@ -96,10 +102,14 @@ type procedure Put(Index: integer; const Value: string); override; procedure SetAttributeName(Value: string); published + {:Name of LDAP attribute.} property AttributeName: string read FAttributeName Write SetAttributeName; + {:Return @true when attribute contains binary data.} property IsBinary: Boolean read FIsBinary; end; + {:@abstract(List of @link(TLDAPAttribute)) + This object can hold list of TLDAPAttribute objects.} TLDAPAttributeList = class(TObject) private FAttributeList: TList; @@ -107,12 +117,19 @@ type public constructor Create; destructor Destroy; override; + {:Clear list.} procedure Clear; + {:Return count of TLDAPAttribute objects in list.} function Count: integer; + {:Add new TLDAPAttribute object to list.} function Add: TLDAPAttribute; + {:List of TLDAPAttribute objects.} property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default; end; + {:@abstract(LDAP result object) + This object can hold LDAP object. (their name and all their attributes with + values)} TLDAPResult = class(TObject) private FObjectName: string; @@ -121,10 +138,14 @@ type constructor Create; destructor Destroy; override; published + {:Name of this LDAP object.} property ObjectName: string read FObjectName write FObjectName; + {:Here is list of object attributes.} property Attributes: TLDAPAttributeList read FAttributes; end; + {:@abstract(List of LDAP result objects) + This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)} TLDAPResultList = class(TObject) private FResultList: TList; @@ -132,24 +153,31 @@ type public constructor Create; destructor Destroy; override; + {:Clear all TLDAPResult objects in list.} procedure Clear; + {:Return count of TLDAPResult objects in list.} function Count: integer; + {:Create and add new TLDAPResult object to list.} function Add: TLDAPResult; + {:List of TLDAPResult objects.} property Items[Index: Integer]: TLDAPResult read GetResult; default; end; + {:Define possible operations for LDAP MODIFY operations.} TLDAPModifyOp = ( MO_Add, MO_Delete, MO_Replace ); + {:Specify possible values for search scope.} TLDAPSearchScope = ( SS_BaseObject, SS_SingleLevel, SS_WholeSubtree ); + {:Specify possible values about alias dereferencing.} TLDAPSearchAliases = ( SA_NeverDeref, SA_InSearching, @@ -157,6 +185,14 @@ type SA_Always ); + {:@abstract(Implementation of LDAP client) + (version 2 and 3) + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TLDAPSend = class(TSynaClient) private {$IFDEF STREAMSEC} @@ -168,8 +204,6 @@ type FResultCode: Integer; FResultString: string; FFullResult: string; - FUsername: string; - FPassword: string; FAutoTLS: Boolean; FFullSSL: Boolean; FSeq: integer; @@ -194,46 +228,114 @@ type public constructor Create; destructor Destroy; override; + + {:Try to connect to LDAP server and start secure channel, when it is required.} function Login: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using plaintext transport of password! It is not secure!} function Bind: Boolean; + + {:Try to bind to LDAP server with @link(TSynaClient.Username) and + @link(TSynaClient.Password). If this is empty strings, then it do annonymous + Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous + mode. + + This method using SASL with DIGEST-MD5 method for secure transfer of your + password.} function BindSasl: Boolean; - procedure Logout; + + {:Close connection to LDAP server.} + function Logout: Boolean; + + {:Modify content of LDAP attribute on this object.} function Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; + + {:Add list of attributes to specified object.} function Add(obj: string; const Value: TLDAPAttributeList): Boolean; + + {:Delete this LDAP object from server.} function Delete(obj: string): Boolean; + + {:Modify object name of this LDAP object.} function ModifyDN(obj, newRDN, newSuperior: string; DeleteoldRDN: Boolean): Boolean; + + {:Try to compare Attribute value with this LDAP object.} function Compare(obj, AttributeValue: string): Boolean; + + {:Search LDAP base for LDAP objects by Filter.} function Search(obj: string; TypesOnly: Boolean; Filter: string; const Attributes: TStrings): Boolean; + + {:Call any LDAPv3 extended command.} function Extended(const Name, Value: string): Boolean; + {:Try to start SSL/TLS connection to LDAP server.} function StartTLS: Boolean; published + {:Specify version of used LDAP protocol. Default value is 3.} property Version: integer read FVersion Write FVersion; + + {:Result code of last LDAP operation.} property ResultCode: Integer read FResultCode; + + {:Human readable description of result code of last LDAP operation.} property ResultString: string read FResultString; + + {:Binary string with full last response of LDAP server. This string is + encoded by ASN.1 BER encoding! You need this only for debugging.} property FullResult: string read FFullResult; - property Username: string read FUsername Write FUsername; - property Password: string read FPassword Write FPassword; + + {:If @true, then try to start TSL mode in Login procedure.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:If @true, then use connection to LDAP server through SSL/TLS tunnel.} property FullSSL: Boolean read FFullSSL Write FFullSSL; + + {:Sequence number of last LDAp command. It is incremented by any LDAP command.} property Seq: integer read FSeq; + + {:Specify what search scope is used in search command.} property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope; + + {:Specify how to handle aliases in search command.} property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases; + + {:Specify result size limit in search command. Value 0 means without limit.} property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit; + + {:Specify search time limit in search command (seconds). Value 0 means + without limit.} property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit; + + {:Here is result of search command.} property SearchResult: TLDAPResultList read FSearchResult; + + {:On each LDAP operation can LDAP server return some referals URLs. Here is + their list.} property Referals: TStringList read FReferals; + + {:When you call @link(Extended) operation, then here is result Name returned + by server.} property ExtName: string read FExtName; + + {:When you call @link(Extended) operation, then here is result Value returned + by server.} property ExtValue: string read FExtValue; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:TCP socket used by all LDAP operations.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; +{:Dump result of LDAP SEARCH into human readable form. Good for debugging.} function LDAPResultDump(const Value: TLDAPResultList): string; implementation @@ -382,8 +484,6 @@ begin {$ENDIF} FTimeout := 60000; FTargetPort := cLDAPProtocol; - FUsername := ''; - FPassword := ''; FAutoTLS := False; FFullSSL := False; FSeq := 0; @@ -625,10 +725,10 @@ begin l.CommaText := Value; n := IndexByBegin('nonce=', l); if n >= 0 then - nonce := UnQuoteStr(SeparateRight(l[n], 'nonce='), '"'); + nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"'); n := IndexByBegin('realm=', l); if n >= 0 then - realm := UnQuoteStr(SeparateRight(l[n], 'realm='), '"'); + realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"'); cnonce := IntToHex(GetTick, 8); nc := '00000001'; qop := 'auth'; @@ -671,17 +771,17 @@ begin '!': // NOT rule (recursive call) begin - Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $82); + Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2); end; '&': // AND rule (recursive call) begin repeat t := GetBetween('(', ')', s); - s := SeparateRight(s, t); + s := Trim(SeparateRight(s, t)); if s <> '' then if s[1] = ')' then - System.Delete(s, 1, 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); Result := Result + TranslateFilter(t); until s = ''; Result := ASNOBject(Result, $A0); @@ -691,18 +791,18 @@ begin begin repeat t := GetBetween('(', ')', s); - s := SeparateRight(s, t); + s := Trim(SeparateRight(s, t)); if s <> '' then if s[1] = ')' then - System.Delete(s, 1, 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); Result := Result + TranslateFilter(t); until s = ''; Result := ASNOBject(Result, $A1); end; else begin - l := SeparateLeft(s, '='); - r := SeparateRight(s, '='); + l := Trim(SeparateLeft(s, '=')); + r := Trim(SeparateRight(s, '=')); if l <> '' then begin c := l[Length(l)]; @@ -710,7 +810,7 @@ begin ':': // Extensible match begin - System.Delete(l, Length(l), 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); dn := False; attr := ''; rule := ''; @@ -719,8 +819,8 @@ begin dn := True; l := ReplaceString(l, ':dn', ''); end; - attr := SeparateLeft(l, ':'); - rule := SeparateRight(l, ':'); + attr := Trim(SeparateLeft(l, ':')); + rule := Trim(SeparateRight(l, ':')); if rule = l then rule := ''; if rule <> '' then @@ -737,7 +837,7 @@ begin '~': // Approx match begin - System.Delete(l, Length(l), 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); Result := ASNOBject(l, ASN1_OCTSTR) + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); Result := ASNOBject(Result, $a8); @@ -745,7 +845,7 @@ begin '>': // Greater or equal match begin - System.Delete(l, Length(l), 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); Result := ASNOBject(l, ASN1_OCTSTR) + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); Result := ASNOBject(Result, $a5); @@ -753,7 +853,7 @@ begin '<': // Less or equal match begin - System.Delete(l, Length(l), 1); + {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); Result := ASNOBject(l, ASN1_OCTSTR) + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); Result := ASNOBject(Result, $a6); @@ -802,7 +902,7 @@ begin Exit; Result := True; if FAutoTLS then - StartTLS; + Result := StartTLS; end; function TLDAPSend.Bind: Boolean; @@ -861,10 +961,11 @@ begin end; end; -procedure TLDAPSend.Logout; +function TLDAPSend.Logout: Boolean; begin Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); FSock.CloseSocket; + Result := True; end; function TLDAPSend.Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; @@ -942,8 +1043,8 @@ function TLDAPSend.Compare(obj, AttributeValue: string): Boolean; var s: string; begin - s := ASNObject(SeparateLeft(AttributeValue, '='), ASN1_OCTSTR) - + ASNObject(SeparateRight(AttributeValue, '='), ASN1_OCTSTR); + s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR) + + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR); s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST); Fsock.SendString(BuildPacket(s)); diff --git a/mimeinln.pas b/mimeinln.pas index 4f741dc..7407233 100644 --- a/mimeinln.pas +++ b/mimeinln.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.002 | +| Project : Ararat Synapse | 001.001.008 | |==============================================================================| | Content: Inline MIME support procedures and functions | |==============================================================================| @@ -42,7 +42,11 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-1522 +{:@abstract(Utilities for inline MIME) +Support for Inline MIME encoding and decoding. + +Used RFC: RFC-2047, RFC-2231 +} {$IFDEF FPC} {$MODE DELPHI} @@ -57,12 +61,30 @@ uses SysUtils, Classes, synachar, synacode, synautil; +{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} function InlineDecode(const Value: string; CP: TMimeChar): string; + +{:Encodes string to MIME inline encoding. The source characterset is "CP", and + the target charset is "MimeP".} function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; -function NeedInline(const Value: string): boolean; + +{:Returns @true, if "Value" contains characters needed for inline coding.} +function NeedInline(const Value: AnsiString): boolean; + +{:Inline mime encoding similar to @link(InlineEncode), but you can specify + source charset, and the target characterset is automatically assigned.} function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; + +{:Inline MIME encoding similar to @link(InlineEncode), but the source charset + is automatically set to the system default charset, and the target charset is + automatically assigned from set of allowed encoding for MIME.} function InlineCode(const Value: string): string; + +{:Converts e-mail address to canonical mime form. You can specify source charset.} function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; + +{:Converts e-mail address to canonical mime form. Source charser it system + default charset.} function InlineEmail(const Value: string): string; implementation @@ -110,10 +132,10 @@ begin s := Copy(v, x, y - x + 2); Delete(v, 1, y + 1); su := Copy(s, 3, Length(s) - 4); - ichar := GetCPFromID(su); z := Pos('?', su); if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then begin + ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); c := UpperCase(su)[z + 1]; su := Copy(su, z + 3, Length(su) - z - 2); if c = 'B' then @@ -144,29 +166,46 @@ end; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; var - s, s1: string; + s, s1, e: string; n: Integer; begin s := CharsetConversion(Value, CP, MimeP); - s := EncodeQuotedPrintable(s); + s := EncodeSafeQuotedPrintable(s); + e := GetIdFromCP(MimeP); s1 := ''; + Result := ''; for n := 1 to Length(s) do if s[n] = ' ' then - s1 := s1 + '=20' + begin +// s1 := s1 + '=20'; + s1 := s1 + '_'; + if Length(s1) > 32 then + begin + if Result <> '' then + Result := Result + ' '; + Result := Result + '=?' + e + '?Q?' + s1 + '?='; + s1 := ''; + end; + end else s1 := s1 + s[n]; - Result := '=?' + GetIdFromCP(MimeP) + '?Q?' + s1 + '?='; + if s1 <> '' then + begin + if Result <> '' then + Result := Result + ' '; + Result := Result + '=?' + e + '?Q?' + s1 + '?='; + end; end; {==============================================================================} -function NeedInline(const Value: string): boolean; +function NeedInline(const Value: AnsiString): boolean; var n: Integer; begin Result := False; for n := 1 to Length(Value) do - if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then + if Value[n] in (SpecialChar + NonAsciiChar) then begin Result := True; Break; @@ -183,7 +222,12 @@ begin begin c := IdealCharsetCoding(Value, FromCP, [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, - ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]); + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, + KOI8_R, KOI8_U + {$IFNDEF CIL} //error URW778 ??? :-O + , GB2312, EUC_KR, ISO_2022_JP, EUC_TW + {$ENDIF} + ]); Result := InlineEncode(Value, FromCP, c); end else diff --git a/mimemess.pas b/mimemess.pas index 555f346..21f1995 100644 --- a/mimemess.pas +++ b/mimemess.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.002.003 | +| Project : Ararat Synapse | 002.004.003 | |==============================================================================| | Content: MIME message object | |==============================================================================| @@ -42,6 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(MIME message handling) +Classes for easy handling with e-mail message. +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -56,6 +60,11 @@ uses mimepart, synachar, synautil, mimeinln; type + + {:Possible values for message priority} + TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high); + + {:@abstract(Object for basic e-mail header fields.)} TMessHeader = class(TObject) private FFrom: string; @@ -67,26 +76,87 @@ type FDate: TDateTime; FXMailer: string; FCharsetCode: TMimeChar; + FReplyTo: string; + FMessageID: string; + FPriority: TMessPriority; + Fpri: TMessPriority; + Fxpri: TMessPriority; + Fxmspri: TMessPriority; + protected + function ParsePriority(value: string): TMessPriority; + function DecodeHeader(value: string): boolean; virtual; public - constructor Create; + constructor Create; virtual; destructor Destroy; override; + + {:Clears all data fields.} procedure Clear; - procedure EncodeHeaders(const Value: TStrings); + + {Add headers from from this object to Value.} + procedure EncodeHeaders(const Value: TStrings); virtual; + + {:Parse header from Value to this object.} procedure DecodeHeaders(const Value: TStrings); + + {:Try find specific header in CustomHeader. Search is case insensitive. + This is good for reading any non-parsed header.} function FindHeader(Value: string): string; + + {:Try find specific headers in CustomHeader. This metod is for repeatly used + headers like 'received' header, etc. Search is case insensitive. + This is good for reading ano non-parsed header.} procedure FindHeaderList(Value: string; const HeaderList: TStrings); published + {:Sender of message.} property From: string read FFrom Write FFrom; + + {:Stringlist with receivers of message. (one per line)} property ToList: TStringList read FToList; + + {:Stringlist with Carbon Copy receivers of message. (one per line)} property CCList: TStringList read FCCList; + + {:Subject of message.} property Subject: string read FSubject Write FSubject; + + {:Organization string.} property Organization: string read FOrganization Write FOrganization; + + {:After decoding contains all headers lines witch not have parsed to any + other structures in this object. It mean: this conatins all other headers + except: + + X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION, + CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID, + CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY, + X-PRIORITY, PRIORITY + + When you encode headers, all this lines is added as headers. Be carefull + for duplicites!} property CustomHeaders: TStringList read FCustomHeaders; + + {:Date and time of message.} property Date: TDateTime read FDate Write FDate; + + {:Mailer identification.} property XMailer: string read FXMailer Write FXMailer; + + {:Address for replies} + property ReplyTo: string read FReplyTo Write FReplyTo; + + {:message indetifier} + property MessageID: string read FMessageID Write FMessageID; + + {:message priority} + property Priority: TMessPriority read FPriority Write FPriority; + + {:Specify base charset. By default is used system charset.} property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; end; + TMessHeaderClass = class of TMessHeader; + + {:@abstract(Object for handling of e-mail message.)} TMimeMess = class(TObject) private FMessagePart: TMimePart; @@ -94,23 +164,111 @@ type FHeader: TMessHeader; public constructor Create; + {:create this object and assign your own descendant of @link(TMessHeader) + object to @link(header) property. So, you can create your own message + headers parser and use it by this object.} + constructor CreateAltHeaders(HeadClass: TMessHeaderClass); destructor Destroy; override; + + {:Reset component to default state.} procedure Clear; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then one subpart, + you must have PartParent of multipart type!} function AddPart(const PartParent: TMimePart): TMimePart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + This part is marked as multipart with secondary MIME type specified by + MultipartType parameter. (typical value is 'mixed') + + This part can be used as PartParent for another parts (include next + multipart). If you need only one part, then you not need Multipart part.} function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to text part and set all necessary + properties. Content of part is readed from value stringlist.} function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to text part to HTML type and set all + necessary properties. Content of HTML part is readed from Value stringlist.} function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartText), but content is readed from file} function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartHTML), but content is readed from file} function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, + you must have PartParent of multipart type! + + After creation of part set type to binary and set all necessary properties. + MIME primary and secondary types defined automaticly by filename extension. + Content of binary part is readed from Stream. This binary part is encoded + as file attachment.} function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartBinary), but content is readed from file} function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to binary and set all necessary properties. + MIME primary and secondary types defined automaticly by filename extension. + Content of binary part is readed from Stream. + + This binary part is encoded as inline data with given Conten ID (cid). + Content ID can be used as reference ID in HTML source in HTML part.} function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartHTMLBinary), but content is readed from file} function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; + + {:Add MIME part as subpart of PartParent. If you need set root MIME part, + then set as PartParent @NIL value. If you need set more then 1 subpart, you + must have PartParent of multipart type! + + After creation of part set type to message and set all necessary properties. + MIME primary and secondary types are setted to 'message/rfc822'. + Content of raw RFC-822 message is readed from Stream.} + function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; + + {:Same as @link(AddPartMess), but content is readed from file} + function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; + + {:Compose message from @link(MessagePart) to @link(Lines). Headers from + @link(Header) object is added also.} procedure EncodeMessage; + + {:Decode message from @link(Lines) to @link(MessagePart). Massage headers + are parsed into @link(Header) object.} procedure DecodeMessage; published + {:@link(TMimePart) object with decoded MIME message. This object can handle + any number of nested @link(TMimePart) objects itself. It is used for handle + any tree of MIME subparts.} property MessagePart: TMimePart read FMessagePart; + + {:Raw MIME encoded message.} property Lines: TStringList read FLines; + + {:Object for e-mail header fields. This object is created automaticly. + Do not free this object!} property Header: TMessHeader read FHeader; end; @@ -147,6 +305,9 @@ begin FCustomHeaders.Clear; FDate := 0; FXMailer := ''; + FReplyTo := ''; + FMessageID := ''; + FPriority := MP_unknown; end; procedure TMessHeader.EncodeHeaders(const Value: TStrings); @@ -159,8 +320,27 @@ begin for n := FCustomHeaders.Count - 1 downto 0 do if FCustomHeaders[n] <> '' then Value.Insert(0, FCustomHeaders[n]); + if FPriority <> MP_unknown then + case FPriority of + MP_high: + begin + Value.Insert(0, 'X-MSMAIL-Priority: High'); + Value.Insert(0, 'X-Priority: 1'); + Value.Insert(0, 'Priority: urgent'); + end; + MP_low: + begin + Value.Insert(0, 'X-MSMAIL-Priority: low'); + Value.Insert(0, 'X-Priority: 5'); + Value.Insert(0, 'Priority: non-urgent'); + end; + end; + if FReplyTo <> '' then + Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo)); + if FMessageID <> '' then + Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>'); if FXMailer = '' then - Value.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer') + Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer') else Value.Insert(0, 'X-mailer: ' + FXMailer); Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); @@ -188,79 +368,156 @@ begin Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); end; -procedure TMessHeader.DecodeHeaders(const Value: TStrings); +function TMessHeader.ParsePriority(value: string): TMessPriority; +var + s: string; + x: integer; +begin + Result := MP_unknown; + s := Trim(separateright(value, ':')); + s := Separateleft(s, ' '); + x := StrToIntDef(s, -1); + if x >= 0 then + case x of + 1, 2: + Result := MP_High; + 3: + Result := MP_Normal; + 4, 5: + Result := MP_Low; + end + else + begin + s := lowercase(s); + if (s = 'urgent') or (s = 'high') or (s = 'highest') then + Result := MP_High; + if (s = 'normal') or (s = 'medium') then + Result := MP_Normal; + if (s = 'low') or (s = 'lowest') + or (s = 'no-priority') or (s = 'non-urgent') then + Result := MP_Low; + end; +end; + +function TMessHeader.DecodeHeader(value: string): boolean; var s, t: string; - x: Integer; cp: TMimeChar; begin + Result := True; cp := FCharsetCode; + s := uppercase(value); + if Pos('X-MAILER:', s) = 1 then + begin + FXMailer := Trim(SeparateRight(Value, ':')); + Exit; + end; + if Pos('FROM:', s) = 1 then + begin + FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('SUBJECT:', s) = 1 then + begin + FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('ORGANIZATION:', s) = 1 then + begin + FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('TO:', s) = 1 then + begin + s := Trim(SeparateRight(Value, ':')); + repeat + t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); + if t <> '' then + FToList.Add(t); + until s = ''; + Exit; + end; + if Pos('CC:', s) = 1 then + begin + s := Trim(SeparateRight(Value, ':')); + repeat + t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp); + if t <> '' then + FCCList.Add(t); + until s = ''; + Exit; + end; + if Pos('DATE:', s) = 1 then + begin + FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':'))); + Exit; + end; + if Pos('REPLY-TO:', s) = 1 then + begin + FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp); + Exit; + end; + if Pos('MESSAGE-ID:', s) = 1 then + begin + FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':'))); + Exit; + end; + if Pos('PRIORITY:', s) = 1 then + begin + FPri := ParsePriority(value); + Exit; + end; + if Pos('X-PRIORITY:', s) = 1 then + begin + FXPri := ParsePriority(value); + Exit; + end; + if Pos('X-MSMAIL-PRIORITY:', s) = 1 then + begin + FXmsPri := ParsePriority(value); + Exit; + end; + if Pos('MIME-VERSION:', s) = 1 then + Exit; + if Pos('CONTENT-TYPE:', s) = 1 then + Exit; + if Pos('CONTENT-DESCRIPTION:', s) = 1 then + Exit; + if Pos('CONTENT-DISPOSITION:', s) = 1 then + Exit; + if Pos('CONTENT-ID:', s) = 1 then + Exit; + if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then + Exit; + Result := False; +end; + +procedure TMessHeader.DecodeHeaders(const Value: TStrings); +var + s: string; + x: Integer; +begin Clear; + Fpri := MP_unknown; + Fxpri := MP_unknown; + Fxmspri := MP_unknown; x := 0; while Value.Count > x do begin s := NormalizeHeader(Value, x); if s = '' then Break; - if Pos('X-MAILER:', UpperCase(s)) = 1 then - begin - FXMailer := SeparateRight(s, ':'); - continue; - end; - if Pos('FROM:', UpperCase(s)) = 1 then - begin - FFrom := InlineDecode(SeparateRight(s, ':'), cp); - continue; - end; - if Pos('SUBJECT:', UpperCase(s)) = 1 then - begin - FSubject := InlineDecode(SeparateRight(s, ':'), cp); - continue; - end; - if Pos('ORGANIZATION:', UpperCase(s)) = 1 then - begin - FOrganization := InlineDecode(SeparateRight(s, ':'), cp); - continue; - end; - if Pos('TO:', UpperCase(s)) = 1 then - begin - s := SeparateRight(s, ':'); - repeat - t := InlineDecode(FetchEx(s, ',', '"'), cp); - if t <> '' then - FToList.Add(t); - until s = ''; - continue; - end; - if Pos('CC:', UpperCase(s)) = 1 then - begin - s := SeparateRight(s, ':'); - repeat - t := InlineDecode(FetchEx(s, ',', '"'), cp); - if t <> '' then - FCCList.Add(t); - until s = ''; - continue; - end; - if Pos('DATE:', UpperCase(s)) = 1 then - begin - FDate := DecodeRfcDateTime(SeparateRight(s, ':')); - continue; - end; - if Pos('MIME-VERSION:', UpperCase(s)) = 1 then - continue; - if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then - continue; - if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then - continue; - if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then - continue; - if Pos('CONTENT-ID:', UpperCase(s)) = 1 then - continue; - if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then - continue; - FCustomHeaders.Add(s); + if not DecodeHeader(s) then + FCustomHeaders.Add(s); end; + if Fpri <> MP_unknown then + FPriority := Fpri + else + if Fxpri <> MP_unknown then + FPriority := Fxpri + else + if Fxmspri <> MP_unknown then + FPriority := Fxmspri end; function TMessHeader.FindHeader(Value: string): string; @@ -271,7 +528,7 @@ begin for n := 0 to FCustomHeaders.Count - 1 do if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then begin - Result := SeparateRight(FCustomHeaders[n], ':'); + Result := Trim(SeparateRight(FCustomHeaders[n], ':')); break; end; end; @@ -284,18 +541,23 @@ begin for n := 0 to FCustomHeaders.Count - 1 do if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then begin - HeaderList.Add(SeparateRight(FCustomHeaders[n], ':')); + HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':'))); end; end; {==============================================================================} constructor TMimeMess.Create; +begin + CreateAltHeaders(TMessHeader); +end; + +constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass); begin inherited Create; FMessagePart := TMimePart.Create; FLines := TStringList.Create; - FHeader := TMessHeader.Create; + FHeader := HeadClass.Create; end; destructor TMimeMess.Destroy; @@ -353,7 +615,12 @@ begin Disposition := 'inline'; CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, - ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]); + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, + KOI8_R, KOI8_U + {$IFNDEF CIL} //error URW778 ??? :-O + , GB2312, EUC_KR, ISO_2022_JP, EUC_TW + {$ENDIF} + ]); EncodingCode := ME_QUOTED_PRINTABLE; EncodePart; EncodePartHeader; @@ -456,6 +723,37 @@ begin end; end; +function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart; +var + part: Tmimepart; +begin + Result := AddPart(PartParent); + part := AddPart(result); + part.lines.addstrings(Value); + part.DecomposeParts; + with Result do + begin + Primary := 'message'; + Secondary := 'rfc822'; + Description := 'E-mail Message'; + EncodePart; + EncodePartHeader; + end; +end; + +function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; +var + tmp: TStrings; +begin + tmp := TStringList.Create; + try + tmp.LoadFromFile(FileName); + Result := AddPartMess(tmp, PartParent); + Finally + tmp.Free; + end; +end; + {==============================================================================} procedure TMimeMess.EncodeMessage; diff --git a/mimepart.pas b/mimepart.pas index 5e4c3ac..7949e8e 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.004.008 | +| Project : Ararat Synapse | 002.006.002 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,10 +42,18 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(MIME part handling) +Handling with MIME parts. + +Used RFC: RFC-2045 +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} {$H+} +{$Q-} +{$R-} unit mimepart; @@ -65,14 +73,41 @@ uses type TMimePart = class; + + {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for + easy walking through MIME subparts.} THookWalkPart = procedure(const Sender: TMimePart) of object; - TMimePrimary = (MP_TEXT, MP_MULTIPART, - MP_MESSAGE, MP_BINARY); + {:The four types of MIME parts. (textual, multipart, message or any other + binary data.)} + TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY); + {:The various types of possible part encodings.} TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE, ME_BASE64, ME_UU, ME_XX); + {:@abstract(Object for working with parts of MIME e-mail.) + Each TMimePart object can handle any number of nested subparts as new + TMimepart objects. It can handle any tree hierarchy structure of nested MIME + subparts itself. + + Basic tasks are: + + Decoding of MIME message: + - store message into Lines property + - call DecomposeParts. Now you have decomposed MIME parts in all nested levels! + - now you can explore all properties and subparts. (You can use WalkPart method) + - if you need decode part, call DecodePart. + + Encoding of MIME message: + + - if you need multipart message, you must create subpart by AddSubPart. + - set all properties of all parts. + - set content of part into DecodedLines stream + - encode this stream by EncodePart. + - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!) + - encoded MIME message is stored in Lines property. + } TMimePart = class(TObject) private FPrimary: string; @@ -108,48 +143,171 @@ type public constructor Create; destructor Destroy; override; + + {:Assign content of another object to this object. (Only this part, + not subparts!)} procedure Assign(Value: TMimePart); + + {:Assign content of another object to this object. (With all subparts!)} procedure AssignSubParts(Value: TMimePart); + + {:Clear all data values to default values. It also call @link(ClearSubparts).} procedure Clear; + + {:Decode Mime part from @link(Lines) to @link(DecodedLines).} procedure DecodePart; + + {:Parse header lines from Headers property into another properties.} procedure DecodePartHeader; + + {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime + headers.} procedure EncodePart; + + {:Build header lines in Headers property from another properties.} procedure EncodePartHeader; + + {:generate primary and secondary mime type from filename extension in value. + If type not recognised, it return 'Application/octet-string' type.} procedure MimeTypeFromExt(Value: string); + + {:Return number of decomposed subparts. (On this level! Each of this + subparts can hold any number of their own nested subparts!)} function GetSubPartCount: integer; + + {:Get nested subpart object as new TMimePart. For getting maximum possible + index you can use @link(GetSubPartCount) method.} function GetSubPart(index: integer): TMimePart; + + {:delete subpart on given index.} procedure DeleteSubPart(index: integer); + + {:Clear and destroy all subpart TMimePart objects.} procedure ClearSubParts; + + {:Add and create new subpart.} function AddSubPart: TMimePart; + + {:E-mail message in @link(Lines) property is parsed into this object. + E-mail headers are stored in @link(Headers) property and is parsed into + another properties automaticly. Not need call @link(DecodePartHeader)! + Content of message (part) is stored into @link(PartBody) property. This + part is in undecoded form! If you need decode it, then you must call + @link(DecodePart) method by your hands. Lot of another properties is filled + also. + + Decoding of parts you must call separately due performance reasons. (Not + needed to decode all parts in all reasons.) + + For each MIME subpart is created new TMimepart object (accessible via + method @link(GetSubPart)).} procedure DecomposeParts; + + {:This part and all subparts is composed into one MIME message stored in + @link(Lines) property.} procedure ComposeParts; + + {:By calling this method is called @link(OnWalkPart) event for each part + and their subparts. It is very good for calling some code for each part in + MIME message} procedure WalkPart; + + {:Return @true when is possible create next subpart. (@link(maxSublevel) + is still not reached)} function CanSubPart: boolean; published + {:Primary Mime type of part. (i.e. 'application') Writing to this property + automaticly generate value of @link(PrimaryCode).} property Primary: string read FPrimary write SetPrimary; + + {:String representation of used Mime encoding in part. (i.e. 'base64') + Writing to this property automaticly generate value of @link(EncodingCode).} property Encoding: string read FEncoding write SetEncoding; + + {:String representation of used Mime charset in part. (i.e. 'iso-8859-1') + Writing to this property automaticly generate value of @link(CharsetCode). + Charset is used only for text parts.} property Charset: string read FCharset write SetCharset; + + {:Define default charset for decoding text MIME parts without charset + specification. Default value is 'ISO-8859-1' by RCF documents. + But Microsoft Outlook use windows codings as default. This property allows + properly decode textual parts from some broken versions of Microsoft + Outlook. (this is bad software!)} property DefaultCharset: string read FDefaultCharset write FDefaultCharset; + + {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART, + MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.} property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode; + + {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT, + ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is + ME_7BIT.} property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode; + + {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.} property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode; + + {:System charset type. Default value is charset used by default in your + operating system.} property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset; + + {:Secondary Mime type of part. (i.e. 'mixed')} property Secondary: string read FSecondary Write FSecondary; + + {:Description of Mime part.} property Description: string read FDescription Write FDescription; + + {:Value of content disposition field. (i.e. 'inline' or 'attachment')} property Disposition: string read FDisposition Write FDisposition; + + {:Content ID.} property ContentID: string read FContentID Write FContentID; + + {:Boundary delimiter of multipart Mime part. Used only in multipart part.} property Boundary: string read FBoundary Write FBoundary; + + {:Filename of file in binary part.} property FileName: string read FFileName Write FFileName; + + {:String list with lines contains mime part (It can be a full message).} property Lines: TStringList read FLines; + + {:Encoded form of MIME part data.} property PartBody: TStringList read FPartBody; + + {:All header lines of MIME part.} property Headers: TStringList read FHeaders; + + {:On multipart this contains part of message between first line of message + and first boundary.} property PrePart: TStringList read FPrePart; + + {:On multipart this contains part of message between last boundary and end + of message.} property PostPart: TStringList read FPostPart; + + {:Stream with decoded form of budy part.} property DecodedLines: TMemoryStream read FDecodedLines; + + {:Show nested level in subpart tree. Value 0 means root part. 1 means + subpart from this root. etc.} property SubLevel: integer read FSubLevel write FSubLevel; + + {:Specify maximum sublevel value for decomposing.} property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel; + + {:When is @true, then this part maybe(!) have included some uuencoded binary + data.} property AttachInside: boolean read FAttachInside; + + {:Here you can assign hook procedure for walking through all part and their + subparts.} property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart; + + {:Here you can specify maximum line length for encoding of MIME part. + If line is longer, then is splitted by standard of MIME. Correct MIME + mailers can de-split this line into original length.} property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength; end; @@ -185,7 +343,11 @@ const ('ZIP', 'application', 'ZIP') ); +{:Read header from "Value" stringlist beginning at "Index" position. If header + is Splitted into multiple lines, then this procedure de-split it into one line.} function NormalizeHeader(Value: TStrings; var Index: Integer): string; + +{:Generates a unique boundary string.} function GenerateBoundary: string; implementation @@ -206,7 +368,7 @@ begin for n := 1 to Length(t) do if t[n] = #9 then t[n] := ' '; - if t[1] <> ' ' then + if not(t[1] in [' ', '"', ':', '=']) then Break else begin @@ -401,12 +563,11 @@ begin //extract prepart if FPrimaryCode = MP_MULTIPART then begin - SkipEmpty; while FLines.Count > x do begin - s := TrimRight(FLines[x]); + s := FLines[x]; Inc(x); - if s = '--' + FBoundary then + if TrimRight(s) = '--' + FBoundary then Break; FPrePart.Add(s); if not FAttachInside then @@ -428,7 +589,6 @@ begin Break; Mime.Lines.Add(s); end; - StringsTrim(Mime.Lines); Mime.DecomposeParts; end else @@ -451,26 +611,22 @@ begin Inc(x); Mime.Lines.Add(s); end; - StringsTrim(Mime.Lines); Mime.DecomposeParts; end else begin - SkipEmpty; while FLines.Count > x do begin - s := TrimRight(FLines[x]); + s := FLines[x]; Inc(x); FPartBody.Add(s); if not FAttachInside then FAttachInside := IsUUcode(s); end; - StringsTrim(FPartBody); end; //extract postpart if FPrimaryCode = MP_MULTIPART then begin - SkipEmpty; while FLines.Count > x do begin s := TrimRight(FLines[x]); @@ -479,7 +635,6 @@ begin if not FAttachInside then FAttachInside := IsUUcode(s); end; - StringsTrim(FPostPart); end; end; @@ -570,7 +725,8 @@ end; procedure TMIMEPart.DecodePart; var n: Integer; - s: string; + s, t: string; + b: Boolean; begin FDecodedLines.Clear; case FEncodingCode of @@ -591,8 +747,27 @@ begin s := FPartBody.Text; end; if FPrimaryCode = MP_TEXT then - s := CharsetConversion(s, FCharsetCode, FTargetCharset); - FDecodedLines.Write(Pointer(s)^, Length(s)); + if uppercase(FSecondary) = 'HTML' then + begin + b := False; + for n := 0 to FPartBody.Count - 1 do + begin + t := uppercase(FPartBody[n]); + if Pos('HTTP-EQUIV', t) > 0 then + if Pos('CONTENT-TYPE', t) > 0 then + begin + b := True; + Break; + end; + if Pos('', t) > 0 then + Break; + end; + if not b then + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + end + else + s := CharsetConversion(s, FCharsetCode, FTargetCharset); + WriteStrToStream(FDecodedLines, s); FDecodedLines.Seek(0, soFromBeginning); end; @@ -620,39 +795,39 @@ begin su := UpperCase(s); if Pos('CONTENT-TYPE:', su) = 1 then begin - st := SeparateRight(su, ':'); - st2 := SeparateLeft(st, ';'); - Primary := SeparateLeft(st2, '/'); - FSecondary := SeparateRight(st2, '/'); + st := Trim(SeparateRight(su, ':')); + st2 := Trim(SeparateLeft(st, ';')); + Primary := Trim(SeparateLeft(st2, '/')); + FSecondary := Trim(SeparateRight(st2, '/')); if (FSecondary = Primary) and (Pos('/', st2) < 1) then FSecondary := ''; case FPrimaryCode of MP_TEXT: begin - Charset := UpperCase(GetParameter(s, 'charset=')); - FFileName := GetParameter(s, 'name='); + Charset := UpperCase(GetParameter(s, 'charset')); + FFileName := GetParameter(s, 'name'); end; MP_MULTIPART: - FBoundary := GetParameter(s, 'Boundary='); + FBoundary := GetParameter(s, 'Boundary'); MP_MESSAGE: begin end; MP_BINARY: - FFileName := GetParameter(s, 'name='); + FFileName := GetParameter(s, 'name'); end; end; if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then - Encoding := SeparateRight(su, ':'); + Encoding := Trim(SeparateRight(su, ':')); if Pos('CONTENT-DESCRIPTION:', su) = 1 then - FDescription := SeparateRight(s, ':'); + FDescription := Trim(SeparateRight(s, ':')); if Pos('CONTENT-DISPOSITION:', su) = 1 then begin FDisposition := SeparateRight(su, ':'); FDisposition := Trim(SeparateLeft(FDisposition, ';')); - fn := GetParameter(s, 'FileName='); + fn := GetParameter(s, 'FileName'); end; if Pos('CONTENT-ID:', su) = 1 then - FContentID := SeparateRight(s, ':'); + FContentID := Trim(SeparateRight(s, ':')); end; if FFileName = '' then FFileName := fn; @@ -668,6 +843,7 @@ var s, t: string; n, x: Integer; d1, d2: integer; + NeedBOM: Boolean; begin if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then Encoding := 'base64'; @@ -675,6 +851,7 @@ begin FPartBody.Clear; FDecodedLines.Seek(0, soFromBeginning); try + NeedBOM := True; case FPrimaryCode of MP_MULTIPART, MP_MESSAGE: FPartBody.LoadFromStream(FDecodedLines); @@ -683,11 +860,19 @@ begin begin while FDecodedLines.Position < FDecodedLines.Size do begin - Setlength(s, 54); - x := FDecodedLines.Read(pointer(s)^, 54); - Setlength(s, x); + s := ReadStrFromStream(FDecodedLines, 54); +// Setlength(s, 54); +// x := FDecodedLines.Read(pointer(s)^, 54); +// Setlength(s, x); if FPrimaryCode = MP_TEXT then + begin s := CharsetConversion(s, FTargetCharset, FCharsetCode); + if NeedBOM then + begin + s := GetBOM(FCharSetCode) + s; + NeedBOM := False; + end; + end; s := EncodeBase64(s); FPartBody.Add(s); end; @@ -696,9 +881,10 @@ begin begin if FPrimaryCode = MP_BINARY then begin - SetLength(s, FDecodedLines.Size); - x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size); - Setlength(s, x); + s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size); +// SetLength(s, FDecodedLines.Size); +// x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size); +// Setlength(s, x); l.Add(s); end else @@ -707,13 +893,17 @@ begin begin s := l[n]; if (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then + begin s := CharsetConversion(s, FTargetCharset, FCharsetCode); + if NeedBOM then + begin + s := GetBOM(FCharSetCode) + s; + NeedBOM := False; + end; + end; if FEncodingCode = ME_QUOTED_PRINTABLE then begin - if FPrimaryCode = MP_BINARY then - s := EncodeQuotedPrintable(s) - else - s := EncodeTriplet(s, '=', [Char(0)..Char(31), '=', Char(127)..Char(255)]); + s := EncodeQuotedPrintable(s); repeat if Length(s) < FMaxLineLength then begin @@ -908,7 +1098,7 @@ end; function TMIMEPart.IsUUcode(Value: string): boolean; begin Value := UpperCase(Value); - Result := (pos('BEGIN ', Value) = 1) and (SeparateRight(Value, ' ') <> ''); + Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> ''); end; {==============================================================================} diff --git a/nntpsend.pas b/nntpsend.pas index 3c14a33..89fa100 100644 --- a/nntpsend.pas +++ b/nntpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.003.003 | +| Project : Ararat Synapse | 001.004.000 | |==============================================================================| | Content: NNTP client | |==============================================================================| @@ -42,7 +42,11 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-977, RFC-2980 +{:@abstract(NNTP client) +NNTP (network news transfer protocol) + +Used RFC: RFC-977, RFC-2980 +} {$IFDEF FPC} {$MODE DELPHI} @@ -58,12 +62,20 @@ uses {$IFDEF STREAMSEC} TlsInternalServer, TlsSynaSock, {$ENDIF} - blcksock, synautil, synacode; + blcksock, synautil; const cNNTPProtocol = 'nntp'; type + + {:abstract(Implementation of Network News Transfer Protocol. + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TNNTPSend = class(TSynaClient) private {$IFDEF STREAMSEC} @@ -76,8 +88,6 @@ type FResultString: string; FData: TStringList; FDataToSend: TStringList; - FUsername: string; - FPassword: string; FAutoTLS: Boolean; FFullSSL: Boolean; FNNTPcap: TStringList; @@ -88,40 +98,105 @@ type public constructor Create; destructor Destroy; override; + + {:Connects to NNTP server and begin session.} function Login: Boolean; - procedure Logout; + + {:Logout from NNTP server and terminate session.} + function Logout: Boolean; + + {:By this you can call any NNTP command.} function DoCommand(const Command: string): boolean; + + {:by this you can call any NNTP command. This variant is used for commands + for download information from server.} function DoCommandRead(const Command: string): boolean; + + {:by this you can call any NNTP command. This variant is used for commands + for upload information to server.} function DoCommandWrite(const Command: string): boolean; + + {:Download full message to @link(data) property. Value can be number of + message or message-id (in brackets).} function GetArticle(const Value: string): Boolean; + + {:Download only body of message to @link(data) property. Value can be number + of message or message-id (in brackets).} function GetBody(const Value: string): Boolean; + + {:Download only headers of message to @link(data) property. Value can be + number of message or message-id (in brackets).} function GetHead(const Value: string): Boolean; + + {:Get message status. Value can be number of message or message-id + (in brackets).} function GetStat(const Value: string): Boolean; + + {:Select given group.} function SelectGroup(const Value: string): Boolean; + + {:Tell to server 'I have mesage with given message-ID.' If server need this + message, message is uploaded to server.} function IHave(const MessID: string): Boolean; + + {:Move message pointer to last item in group.} function GotoLast: Boolean; + + {:Move message pointer to next item in group.} function GotoNext: Boolean; + + {:Download to @link(data) property list of all groups on NNTP server.} function ListGroups: Boolean; + + {:Download to @link(data) property list of all groups created after given time.} function ListNewGroups(Since: TDateTime): Boolean; + + {:Download to @link(data) property list of message-ids in given group since + given time.} function NewArticles(const Group: string; Since: TDateTime): Boolean; + + {:Upload new article to server. (for new messages by you)} function PostArticle: Boolean; + + {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP + server'.} function SwitchToSlave: Boolean; + + {:Call NNTP XOVER command.} function Xover(xoStart, xoEnd: string): boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} function StartTLS: Boolean; + + {:Try to find given capability in extension list. This list is getted after + successful login to NNTP server. If extension capability is not found, + then return is empty string.} function FindCap(const Value: string): string; + + {:Try get list of server extensions. List is returned in @link(data) property.} function ListExtensions: Boolean; published - property Username: string read FUsername write FUsername; - property Password: string read FPassword write FPassword; + {:Result code number of last operation.} property ResultCode: Integer read FResultCode; + + {:String description of last result code from NNTP server.} property ResultString: string read FResultString; + + {:Readed data. (message, etc.)} property Data: TStringList read FData; + + {:If is set to @true, then upgrade to SSL/TLS mode after login if remote + server support it.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} property FullSSL: Boolean read FFullSSL Write FFullSSL; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; @@ -144,8 +219,6 @@ begin FSock.ConvertLineEnd := True; FTimeout := 60000; FTargetPort := cNNTPProtocol; - FUsername := ''; - FPassword := ''; FAutoTLS := False; FFullSSL := False; end; @@ -246,9 +319,9 @@ begin Result := (ReadResult div 100) = 2; ListExtensions; FNNTPcap.Assign(Fdata); - if result then + if Result then if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then - result := StartTLS; + Result := StartTLS; if (FUsername <> '') and Result then begin FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); @@ -260,10 +333,10 @@ begin end; end; -procedure TNNTPSend.Logout; +function TNNTPSend.Logout: Boolean; begin FSock.SendString('QUIT' + CRLF); - ReadResult; + Result := (ReadResult div 100) = 2; FSock.CloseSocket; end; diff --git a/pingsend.pas b/pingsend.pas index a0077b6..2ab07c3 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 003.001.005 | +| Project : Ararat Synapse | 003.001.006 | |==============================================================================| | Content: PING sender | |==============================================================================| @@ -42,6 +42,16 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(ICMP PING implementation.) +Allows create PING and TRACEROUTE. Or you can diagnose your network. + +Warning: this unit using RAW sockets. On some systems you must have special + rights for using this sort of sockets. So, it working allways when you have + administator/root rights. Otherwise you can have problems! + +Note: IPv6 not working under .NET. It is lack of Microsoft's .NET framework. +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -74,6 +84,7 @@ const ICMP6_TIME_EXCEEDED = 3; type + {:Record for ICMP ECHO packet header.} TIcmpEchoHeader = record i_type: Byte; i_code: Byte; @@ -83,6 +94,8 @@ type TimeStamp: ULong; end; + {:record used internally by TPingSend for compute checksum of ICMPv6 packet + pseudoheader.} TICMP6Packet = record in_source: TInAddr6; in_dest: TInAddr6; @@ -93,6 +106,7 @@ type proto: Byte; end; + {:List of possible ICMP reply packet types.} TICMPError = ( IE_NoError, IE_Other, @@ -104,6 +118,10 @@ type IE_UnreachPort ); + {:@abstract(Implementation of ICMP PING and ICMPv6 PING.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TPINGSend = class(TSynaClient) private FSock: TICMPBlockSocket; @@ -125,21 +143,49 @@ type function ReadPacket: Boolean; procedure TranslateError; public + {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is + @true.} function Ping(const Host: string): Boolean; constructor Create; destructor Destroy; override; published + {:Size of PING packet. Default size is 32 bytes.} property PacketSize: Integer read FPacketSize Write FPacketSize; + + {:Time between request and reply.} property PingTime: Integer read FPingTime; + + {:From this address is sended reply for your PING request. It maybe not your + requested destination, when some error occured!} property ReplyFrom: string read FReplyFrom; + + {:ICMP type of PING reply. Each protocol using another values! For IPv4 and + IPv6 are used different values!} property ReplyType: byte read FReplyType; + + {:ICMP code of PING reply. Each protocol using another values! For IPv4 and + IPv6 are used different values! For protocol independent value look to + @link(ReplyError)} property ReplyCode: byte read FReplyCode; + + {:Return type of returned ICMP message. This value is independent on used + protocol!} property ReplyError: TICMPError read FReplyError; + + {:Return human readable description of returned packet type.} property ReplyErrorDesc: string read FReplyErrorDesc; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TICMPBlockSocket read FSock; end; +{:A very useful function and example of its use would be found in the TPINGSend + object. Use it to ping to any host. If successful, returns the ping time in + milliseconds. Returns -1 if an error occurred.} function PingHost(const Host: string): Integer; + +{:A very useful function and example of its use would be found in the TPINGSend + object. Use it to TraceRoute to any host.} function TraceRouteHost(const Host: string): string; implementation @@ -175,6 +221,7 @@ var IcmpEchoHeaderPtr: ^TICMPEchoHeader; t: Boolean; x: cardinal; + IcmpReqHead: string; begin Result := False; FPingTime := -1; @@ -218,6 +265,8 @@ begin i_CheckSum := CheckSum(FBuffer); end; FSock.SendString(FBuffer); + // remember first 8 bytes of ICMP packet + IcmpReqHead := Copy(FBuffer, 1, 8); x := GetTick; repeat t := ReadPacket; @@ -228,9 +277,10 @@ begin {$IFDEF LINUX} IcmpEchoHeaderPtr := Pointer(FBuffer); {$ELSE} - FBuffer := StringOfChar(#0, 4) + FBuffer; +//WinXP SP1 with networking update doing this think by another way ;-O +// FBuffer := StringOfChar(#0, 4) + FBuffer; IcmpEchoHeaderPtr := Pointer(FBuffer); - IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply; +// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply; {$ENDIF} end else @@ -239,9 +289,11 @@ begin IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; end; + //it discard sometimes possible 'echoes' of previosly sended packet + //or other unwanted ICMP packets... until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) - and ((IcmpEchoHeaderPtr^.i_id = FId) or (IcmpEchoHeaderPtr^.i_id = 0)); - //it discard sometimes possible 'echoes' of previosly sended packet... + and ((IcmpEchoHeaderPtr^.i_id = FId) + or (Pos(IcmpReqHead, FBuffer) > 0)); if t then begin FPingTime := TickDelta(x, GetTick); diff --git a/pop3send.pas b/pop3send.pas index 19eca41..c814075 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.001.010 | +| Project : Ararat Synapse | 002.003.000 | |==============================================================================| | Content: POP3 client | |==============================================================================| @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 +{:@abstract(POP3 protocol client) + +Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 +} {$IFDEF FPC} {$MODE DELPHI} @@ -64,8 +67,18 @@ const cPop3Protocol = 'pop3'; type + + {:The three types of possible authorization methods for "logging in" to a POP3 + server.} TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); + {:@abstract(Implementation of POP3 client protocol.) + + Note: Are you missing properties for setting Username and Password? Look to + parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TPOP3Send = class(TSynaClient) private {$IFDEF STREAMSEC} @@ -77,8 +90,6 @@ type FResultCode: Integer; FResultString: string; FFullResult: TStringList; - FUsername: string; - FPassword: string; FStatCount: Integer; FStatSize: Integer; FTimeStamp: string; @@ -93,35 +104,93 @@ type public constructor Create; destructor Destroy; override; + + {:Call CAPA command for get POP3 server capabilites. + note: not all servers support this command!} function Capability: Boolean; + + {:Connect to remote POP3 host. If all OK, result is @true.} function Login: Boolean; - procedure Logout; + + {:Disconnects from POP3 server.} + function Logout: Boolean; + + {:Send RSET command. If all OK, result is @true.} function Reset: Boolean; + + {:Send NOOP command. If all OK, result is @true.} function NoOp: Boolean; + + {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. + If all OK, result is @true.} function Stat: Boolean; + + {:Send LIST command. If Value is 0, LIST is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} function List(Value: Integer): Boolean; + + {:Send RETR command. After successful operation dowloaded message in + @link(FullResult). If all OK, result is @true.} function Retr(Value: Integer): Boolean; + + {:Send DELE command for delete specified message. If all OK, result is @true.} function Dele(Value: Integer): Boolean; + + {:Send TOP command. After successful operation dowloaded headers of message + and maxlines count of message in @link(FullResult). If all OK, result is + @true.} function Top(Value, Maxlines: Integer): Boolean; + + {:Send UIDL command. If Value is 0, UIDL is for all messages. After + successful operation is listing in FullResult. If all OK, result is @True.} function Uidl(Value: Integer): Boolean; + + {:Call STLS command for upgrade connection to SSL/TLS mode.} function StartTLS: Boolean; + + {:Try to find given capabily in capabilty string returned from POP3 server + by CAPA command.} function FindCap(const Value: string): string; published + {:Result code of last POP3 operation. 0 - error, 1 - OK.} property ResultCode: Integer read FResultCode; + + {:Result string of last POP3 operation.} property ResultString: string read FResultString; + + {:Stringlist with full lines returned as result of POP3 operation. I.e. if + operation is LIST, this property is filled by list of messages. If + operation is RETR, this property have downloaded message.} property FullResult: TStringList read FFullResult; - property Username: string read FUsername Write FUsername; - property Password: string read FPassword Write FPassword; + + {:After STAT command is there count of messages in inbox.} property StatCount: Integer read FStatCount; + + {:After STAT command is there size of all messages in inbox.} property StatSize: Integer read FStatSize; + + {:If server support this, after comnnect is in this property timestamp of + remote server.} property TimeStamp: string read FTimeStamp; + + {:Type of authorisation for login to POP3 server. Dafault is autodetect one + of possible authorisation. Autodetect do this: + + If remote POP3 server support APOP, try login by APOP method. If APOP is + not supported, or if APOP login failed, try classic USER+PASS login method.} property AuthType: TPOP3AuthType read FAuthType Write FAuthType; + + {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} property FullSSL: Boolean read FFullSSL Write FFullSSL; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; @@ -143,8 +212,6 @@ begin FSock.ConvertLineEnd := true; FTimeout := 60000; FTargetPort := cPop3Protocol; - FUsername := ''; - FPassword := ''; FStatCount := 0; FStatSize := 0; FAuthType := POP3AuthAll; @@ -254,7 +321,7 @@ begin s := SeparateRight(FResultString, '<'); if s <> FResultString then begin - s1 := SeparateLeft(s, '>'); + s1 := Trim(SeparateLeft(s, '>')); if s1 <> s then FTimeStamp := '<' + s1 + '>'; end; @@ -262,7 +329,12 @@ begin if Capability then if FAutoTLS and (Findcap('STLS') <> '') then if StartTLS then - Capability; + Capability + else + begin + Result := False; + Exit; + end; if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then begin Result := AuthApop; @@ -278,10 +350,10 @@ begin Result := AuthLogin; end; -procedure TPOP3Send.Logout; +function TPOP3Send.Logout: Boolean; begin FSock.SendString('QUIT' + CRLF); - ReadResult(False); + Result := ReadResult(False) = 1; FSock.CloseSocket; end; @@ -306,8 +378,8 @@ begin if ReadResult(False) <> 1 then Exit; s := SeparateRight(ResultString, '+OK '); - FStatCount := StrToIntDef(SeparateLeft(s, ' '), 0); - FStatSize := StrToIntDef(SeparateRight(s, ' '), 0); + FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); + FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); Result := True; end; diff --git a/slogsend.pas b/slogsend.pas index cf9b665..0e520af 100644 --- a/slogsend.pas +++ b/slogsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.006 | +| Project : Ararat Synapse | 001.002.000 | |==============================================================================| | Content: SysLog client | |==============================================================================| @@ -37,12 +37,16 @@ | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Christian Brosius | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -// RFC-3164 +{:@abstract(BSD SYSLOG protocol) + +Used RFC: RFC-3164 +} {$IFDEF FPC} {$MODE DELPHI} @@ -87,78 +91,214 @@ const FCL_Local7 = 23; type + {:@abstract(Define possible priority of Syslog message)} TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, Debug); + {:@abstract(encoding or decoding of SYSLOG message)} + TSyslogMessage = class(TObject) + private + FFacility:Byte; + FSeverity:TSyslogSeverity; + FDateTime:TDateTime; + FTag:String; + FMessage:String; + FLocalIP:String; + function GetPacketBuf:String; + procedure SetPacketBuf(Value:String); + public + {:Reset values to defaults} + procedure Clear; + published + {:Define facilicity of Syslog message. For specify you may use predefined + FCL_* constants. Default is "FCL_Local0".} + property Facility:Byte read FFacility write FFacility; + + {:Define possible priority of Syslog message. Default is "Debug".} + property Severity:TSyslogSeverity read FSeverity write FSeverity; + + {:date and time of Syslog message} + property DateTime:TDateTime read FDateTime write FDateTime; + + {:This is used for identify process of this message. Default is filename + of your executable file.} + property Tag:String read FTag write FTag; + + {:Text of your message for log.} + property LogMessage:String read FMessage write FMessage; + + {:IP address of message sender.} + property LocalIP:String read FLocalIP write FLocalIP; + + {:This property holds encoded binary SYSLOG packet} + property PacketBuf:String read GetPacketBuf write SetPacketBuf; + end; + + {:@abstract(This object implement BSD SysLog client) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TSyslogSend = class(TSynaClient) private FSock: TUDPBlockSocket; - FFacility: Byte; - FSeverity: TSyslogSeverity; - FTag: string; - FMessage: string; + FSysLogMessage: TSysLogMessage; public constructor Create; destructor Destroy; override; + {:Send Syslog UDP packet defined by @link(SysLogMessage).} function DoIt: Boolean; published - property Facility: Byte read FFacility Write FFacility; - property Severity: TSyslogSeverity read FSeverity Write FSeverity; - property Tag: string read FTag Write FTag; - property LogMessage: string read FMessage Write FMessage; + {:Syslog message for send} + property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; end; +{:Simply send packet to specified Syslog server.} function ToSysLog(const SyslogServer: string; Facil: Byte; Sever: TSyslogSeverity; const Content: string): Boolean; implementation -constructor TSyslogSend.Create; +function TSyslogMessage.GetPacketBuf:String; +begin + Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; + Result := Result + CDateTime(FDateTime) + ' '; + Result := Result + FLocalIP + ' '; + Result := Result + FTag + ': ' + FMessage; +end; + +procedure TSyslogMessage.SetPacketBuf(Value:String); +var StrBuf:String; + IntBuf,Pos:Integer; +begin + if Length(Value) < 1 then exit; + Pos := 1; + if Value[Pos] <> '<' then exit; + Inc(Pos); + // Facility and Severity + StrBuf := ''; + while (Value[Pos] <> '>')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + IntBuf := StrToInt(StrBuf); + FFacility := IntBuf div 8; + case (IntBuf mod 8)of + 0:FSeverity := Emergency; + 1:FSeverity := Alert; + 2:FSeverity := Critical; + 3:FSeverity := Error; + 4:FSeverity := Warning; + 5:FSeverity := Notice; + 6:FSeverity := Info; + 7:FSeverity := Debug; + end; + // DateTime + Inc(Pos); + StrBuf := ''; + // Month + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Day + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + // Time + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FDateTime := DecodeRFCDateTime(StrBuf); + Inc(Pos); + + // LocalIP + StrBuf := ''; + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FLocalIP := StrBuf; + Inc(Pos); + // Tag + StrBuf := ''; + while (Value[Pos] <> ' ')do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FTag := StrBuf; + // LogMessage + Inc(Pos); + StrBuf := ''; + while (Pos <= Length(Value))do + begin + StrBuf := StrBuf + Value[Pos]; + Inc(Pos); + end; + FMessage := StrBuf; +end; + +procedure TSysLogMessage.Clear; begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FTargetPort := cSysLogProtocol; FFacility := FCL_Local0; FSeverity := Debug; FTag := ExtractFileName(ParamStr(0)); FMessage := ''; + FLocalIP := '0.0.0.0'; +end; + +//------------------------------------------------------------------------------ + +constructor TSyslogSend.Create; +begin + inherited Create; + FSock := TUDPBlockSocket.Create; + FSysLogMessage := TSysLogMessage.Create; + FTargetPort := cSysLogProtocol; end; destructor TSyslogSend.Destroy; begin FSock.Free; + FSysLogMessage.Free; inherited Destroy; end; function TSyslogSend.DoIt: Boolean; var - Buf: string; - S: string; L: TStringList; begin Result := False; - Buf := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; - Buf := Buf + CDateTime(now) + ' '; L := TStringList.Create; try FSock.ResolveNameToIP(FSock.Localname, L); if L.Count < 1 then - S := '0.0.0.0' + FSysLogMessage.LocalIP := '0.0.0.0' else - S := L[0]; + FSysLogMessage.LocalIP := L[0]; finally L.Free; end; - Buf := Buf + S + ' '; - Buf := Buf + Tag + ': ' + FMessage; - if Length(Buf) <= 1024 then + FSysLogMessage.DateTime := Now; + if Length(FSysLogMessage.PacketBuf) <= 1024 then begin FSock.EnableReuse(True); Fsock.Bind(FIPInterface, FTargetPort); if FSock.LastError <> 0 then FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(FTargetHost, FTargetPort); - FSock.SendString(Buf); + FSock.SendString(FSysLogMessage.PacketBuf); Result := FSock.LastError = 0; end; end; @@ -171,9 +311,9 @@ begin with TSyslogSend.Create do try TargetHost :=SyslogServer; - Facility := Facil; - Severity := Sever; - LogMessage := Content; + SysLogMessage.Facility := Facil; + SysLogMessage.Severity := Sever; + SysLogMessage.LogMessage := Content; Result := DoIt; finally Free; diff --git a/smtpsend.pas b/smtpsend.pas index 4f82434..f0ce4d1 100644 --- a/smtpsend.pas +++ b/smtpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.002.011 | +| Project : Ararat Synapse | 003.003.001 | |==============================================================================| | Content: SMTP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,8 +42,11 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, -//RFC-2554, RFC-2821 +{:@abstract(SMTP client) + +Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487, + RFC-2554, RFC-2821 +} {$IFDEF FPC} {$MODE DELPHI} @@ -65,6 +68,14 @@ const cSmtpProtocol = 'smtp'; type + {:@abstract(Implementation of SMTP and ESMTP procotol), + include some ESMTP extensions, include SSL/TLS too. + + Note: Are you missing properties for setting Username and Password for ESMTP? + Look to parent @link(TSynaClient) object! + + Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TSMTPSend = class(TSynaClient) private {$IFDEF STREAMSEC} @@ -78,8 +89,6 @@ type FFullResult: TStringList; FESMTPcap: TStringList; FESMTP: Boolean; - FUsername: string; - FPassword: string; FAuthDone: Boolean; FESMTPSize: Boolean; FMaxSize: Integer; @@ -99,47 +108,159 @@ type public constructor Create; destructor Destroy; override; + + {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and + begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses + ESMTP capabilites and if you specified Username and password and remote + server can handle AUTH command, try login by AUTH command. Preffered login + method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is + @false.} function Login: Boolean; - procedure Logout; + + {:Close SMTP session (QUIT command) and disconnect from SMTP server.} + function Logout: Boolean; + + {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true, + else result is @false.} function Reset: Boolean; + + {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true, + else result is @false.} function NoOp: Boolean; + + {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's + e-mail address is empty string, transmited message is error message. + + If size not 0 and remote server can handle SIZE parameter, append SIZE + parameter to request. If all OK, result is @true, else result is @false.} function MailFrom(const Value: string; Size: Integer): Boolean; + + {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an + empty string. If all OK, result is @true, else result is @false.} function MailTo(const Value: string): Boolean; + + {:Send DATA SMTP command and transmit message data. If all OK, result is + @true, else result is @false.} function MailData(const Value: Tstrings): Boolean; + + {:Send ETRN SMTP command for start sending of remote queue for domain in + Value. If all OK, result is @true, else result is @false.} function Etrn(const Value: string): Boolean; + + {:Send VRFY SMTP command for check receiver e-mail address. It cannot be + an empty string. If all OK, result is @true, else result is @false.} function Verify(const Value: string): Boolean; + + {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} function StartTLS: Boolean; + + {:Return string descriptive text for enhanced result codes stored in + @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).} function EnhCodeString: string; + + {:Try to find specified capability in ESMTP response.} function FindCap(const Value: string): string; published + {:result code of last SMTP command.} property ResultCode: Integer read FResultCode; + + {:result string of last SMTP command (begin with string representation of + result code).} property ResultString: string read FResultString; + + {:All result strings of last SMTP command (result is maybe multiline!).} property FullResult: TStringList read FFullResult; + + {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP + server only!).} property ESMTPcap: TStringList read FESMTPcap; + + {:@TRUE if you successfuly logged to ESMTP server.} property ESMTP: Boolean read FESMTP; - property Username: string read FUsername Write FUsername; - property Password: string read FPassword Write FPassword; + + {:@TRUE if you successfuly pass authorisation to remote server.} property AuthDone: Boolean read FAuthDone; + + {:@TRUE if remote server can handle SIZE parameter.} property ESMTPSize: Boolean read FESMTPSize; + + {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote + server can handle.} property MaxSize: Integer read FMaxSize; + + {:First digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} property EnhCode1: Integer read FEnhCode1; + + {:Second digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} property EnhCode2: Integer read FEnhCode2; + + {:Third digit of Enhanced result code. If last operation does not have + enhanced result code, values is 0.} property EnhCode3: Integer read FEnhCode3; + + {:name of our system used in HELO and EHLO command. Implicit value is + internet address of your machine.} property SystemName: string read FSystemName Write FSystemName; + + {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.} property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; + + {:SSL/TLS mode is used from first contact to server. Servers with full + SSL/TLS mode usualy using non-standard TCP port!} property FullSSL: Boolean read FFullSSL Write FFullSSL; {$IFDEF STREAMSEC} property Sock: TSsTCPBlockSocket read FSock; property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; {$ELSE} + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; {$ENDIF} end; +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send maildata (text of e-mail with all SMTP headers! For example when + text of message is created by @link(TMimemess) object) from "MailFrom" e-mail + address to "MailTo" e-mail address (If you need more then one receiver, then + separate their addresses by comma). + + Function sends e-mail to a SMTP server defined in "SMTPhost" parameter. + Username and password are used for authorization to the "SMTPhost". If you + don't want authorization, set "Username" and "Password" to empty strings. If + e-mail message is successfully sent, the result returns @true. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} function SendToRaw(const MailFrom, MailTo, SMTPHost: string; const MailData: TStrings; const Username, Password: string): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Send "Maildata" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you + need more then one receiver, then separate their addresses by comma). + + This function constructs all needed SMTP headers (with DATE header) and sends + the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the + e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; const MailData: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSMTPsend + object. Sends "MailData" (text of e-mail without any SMTP headers!) from + "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one + receiver, then separate their addresses by comma). + + This function sends the e-mail to the SMTP server defined in the "SMTPhost" + parameter. Username and password are used for authorization to the "SMTPhost". + If you dont want authorization, set "Username" and "Password" to empty Strings. + If the e-mail message is successfully sent, the result will be @TRUE. + + If you need use different port number then standard, then add this port number + to SMTPhost after colon. (i.e. '127.0.0.1:1025')} function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; const MailData: TStrings; const Username, Password: string): Boolean; @@ -150,8 +271,8 @@ begin inherited Create; FFullResult := TStringList.Create; FESMTPcap := TStringList.Create; -{$IFDEF STREAMSEC} - FTLSServer := GlobalTLSInternalServer; +{$IFDEF STREAMSEC} + FTLSServer := GlobalTLSInternalServer; FSock := TSsTCPBlockSocket.Create; FSock.BlockingRead := True; {$ELSE} @@ -160,8 +281,6 @@ begin FSock.ConvertLineEnd := true; FTimeout := 60000; FTargetPort := cSmtpProtocol; - FUsername := ''; - FPassword := ''; FSystemName := FSock.LocalName; FAutoTLS := False; FFullSSL := False; @@ -184,8 +303,8 @@ begin FEnhCode2 := 0; FEnhCode3 := 0; s := Copy(Value, 5, Length(Value) - 4); - t := SeparateLeft(s, '.'); - s := SeparateRight(s, '.'); + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); if t = '' then Exit; if Length(t) > 1 then @@ -193,14 +312,14 @@ begin e1 := StrToIntDef(t, 0); if e1 = 0 then Exit; - t := SeparateLeft(s, '.'); - s := SeparateRight(s, '.'); + t := Trim(SeparateLeft(s, '.')); + s := Trim(SeparateRight(s, '.')); if t = '' then Exit; if Length(t) > 3 then Exit; e2 := StrToIntDef(t, 0); - t := SeparateLeft(s, ' '); + t := Trim(SeparateLeft(s, ' ')); if t = '' then Exit; if Length(t) > 3 then @@ -338,6 +457,11 @@ begin FESMTPcap.Clear; for n := 1 to FFullResult.Count - 1 do FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); + end + else + begin + Result := False; + Exit; end; if not ((FUsername = '') and (FPassword = '')) then begin @@ -362,10 +486,10 @@ begin end; end; -procedure TSMTPSend.Logout; +function TSMTPSend.Logout: Boolean; begin FSock.SendString('QUIT' + CRLF); - ReadResult; + Result := ReadResult = 221; FSock.CloseSocket; end; @@ -557,8 +681,8 @@ begin // SMTP.AutoTLS := True; // if you need support for TSL/SSL tunnel, uncomment next lines: // SMTP.FullSSL := True; - SMTP.TargetHost := SeparateLeft(SMTPHost, ':'); - s := SeparateRight(SMTPHost, ':'); + SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':')); + s := Trim(SeparateRight(SMTPHost, ':')); if (s <> '') and (s <> SMTPHost) then SMTP.TargetPort := s; SMTP.Username := Username; @@ -569,7 +693,7 @@ begin begin s := MailTo; repeat - t := GetEmailAddr(FetchEx(s, ',', '"')); + t := GetEmailAddr(Trim(FetchEx(s, ',', '"'))); if t <> '' then Result := SMTP.MailTo(t); if not Result then diff --git a/snmpsend.pas b/snmpsend.pas index 11057e7..8826f5a 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 002.006.004 | +| Project : Ararat Synapse | 003.000.007 | |==============================================================================| | Content: SNMP client | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -43,6 +43,13 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(SNMP client) +Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization + (encryption not yet supported!) + +Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416 +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -55,17 +62,27 @@ interface uses Classes, SysUtils, - blcksock, synautil, asn1util; + blcksock, synautil, asn1util, synacode; const cSnmpProtocol = '161'; + cSnmpTrapProtocol = '162'; + + SNMP_V1 = 0; + SNMP_V2C = 1; + SNMP_V3 = 3; //PDU type PDUGetRequest = $A0; PDUGetNextRequest = $A1; PDUGetResponse = $A2; PDUSetRequest = $A3; - PDUTrap = $A4; + PDUTrap = $A4; //Obsolete + //for SNMPv2 + PDUGetBulkRequest = $A5; + PDUInformRequest = $A6; + PDUTrapV2 = $A7; + PDUReport = $A8; //errors ENoError = 0; @@ -74,72 +91,317 @@ const EBadValue = 3; EReadOnly = 4; EGenErr = 5; + //errors SNMPv2 + ENoAccess = 6; + EWrongType = 7; + EWrongLength = 8; + EWrongEncoding = 9; + EWrongValue = 10; + ENoCreation = 11; + EInconsistentValue = 12; + EResourceUnavailable = 13; + ECommitFailed = 14; + EUndoFailed = 15; + EAuthorizationError = 16; + ENotWritable = 17; + EInconsistentName = 18; type + + {:@abstract(Possible values for SNMPv3 flags.) + This flags specify level of authorization and encryption.} + TV3Flags = ( + NoAuthNoPriv, + AuthNoPriv, + AuthPriv); + + {:@abstract(Type of SNMPv3 authorization)} + TV3Auth = ( + AuthMD5, + AuthSHA1); + + {:@abstract(Data object with one record of MIB OID and corresponding values.)} TSNMPMib = class(TObject) - private - FOID: string; - FValue: string; + protected + FOID: AnsiString; + FValue: AnsiString; FValueType: Integer; published - property OID: string read FOID write FOID; - property Value: string read FValue write FValue; + {:OID number in string format.} + property OID: AnsiString read FOID write FOID; + + {:Value of OID object in string format.} + property Value: AnsiString read FValue write FValue; + + {:Define type of Value. Supported values are defined in @link(asn1util). + For queries use ASN1_NULL, becouse you don't know type in response!} property ValueType: Integer read FValueType write FValueType; end; + {:@abstract(It holding all information for SNMPv3 agent synchronization) + Used internally.} + TV3Sync = record + EngineID: AnsiString; + EngineBoots: integer; + EngineTime: integer; + EngineStamp: Cardinal; + end; + + {:@abstract(Data object abstracts SNMP data packet)} TSNMPRec = class(TObject) - private + protected FVersion: Integer; - FCommunity: string; FPDUType: Integer; FID: Integer; FErrorStatus: Integer; FErrorIndex: Integer; + FCommunity: AnsiString; FSNMPMibList: TList; + FMaxSize: Integer; + FFlags: TV3Flags; + FFlagReportable: Boolean; + FContextEngineID: AnsiString; + FContextName: AnsiString; + FAuthMode: TV3Auth; + FAuthEngineID: AnsiString; + FAuthEngineBoots: integer; + FAuthEngineTime: integer; + FAuthEngineTimeStamp: cardinal; + FUserName: AnsiString; + FPassword: AnsiString; + FAuthKey: AnsiString; + FPrivKey: AnsiString; + FOldTrapEnterprise: AnsiString; + FOldTrapHost: AnsiString; + FOldTrapGen: Integer; + FOldTrapSpec: Integer; + FOldTrapTimeTicks: Integer; + function Pass2Key(const Value: AnsiString): AnsiString; public constructor Create; destructor Destroy; override; - function DecodeBuf(const Buffer: string): Boolean; - function EncodeBuf: string; + + {:Decode SNMP packet in buffer to object properties.} + function DecodeBuf(const Buffer: AnsiString): Boolean; + + {:Encode obeject properties to SNMP packet.} + function EncodeBuf: AnsiString; + + {:Clears all object properties to default values.} procedure Clear; - procedure MIBAdd(const MIB, Value: string; ValueType: Integer); + + {:Add entry to @link(SNMPMibList). For queries use value as empty string, + and ValueType as ASN1_NULL.} + procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); + + {:Delete entry from @link(SNMPMibList).} procedure MIBDelete(Index: Integer); - function MIBGet(const MIB: string): string; + + {:Search @link(SNMPMibList) list for MIB and return correspond value.} + function MIBGet(const MIB: AnsiString): AnsiString; + + {:return number of entries in MIB array.} function MIBCount: integer; + + {:Return MIB information from given row of MIB array.} function MIBByIndex(Index: Integer): TSNMPMib; - published - property Version: Integer read FVersion write FVersion; - property Community: string read FCommunity write FCommunity; - property PDUType: Integer read FPDUType write FPDUType; - property ID: Integer read FID write FID; - property ErrorStatus: Integer read FErrorStatus write FErrorStatus; - property ErrorIndex: Integer read FErrorIndex write FErrorIndex; + + {:List of @link(TSNMPMib) objects.} property SNMPMibList: TList read FSNMPMibList; + published + {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use + value 1 for SNMPv2c or value 3 for SNMPv3.} + property Version: Integer read FVersion write FVersion; + + {:Community string for autorize access to SNMP server. (Case sensitive!) + Community string is not used in SNMPv3! Use @link(Username) and + @link(password) instead!} + property Community: AnsiString read FCommunity write FCommunity; + + {:Define type of SNMP operation.} + property PDUType: Integer read FPDUType write FPDUType; + + {:Contains ID number. Not need to use.} + property ID: Integer read FID write FID; + + {:When packet is reply, contains error code. Supported values are defined by + E* constants.} + property ErrorStatus: Integer read FErrorStatus write FErrorStatus; + + {:Point to error position in reply packet. Not usefull for users. It only + good for debugging!} + property ErrorIndex: Integer read FErrorIndex write FErrorIndex; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property NonRepeaters: Integer read FErrorStatus write FErrorStatus; + + {:special value for GetBulkRequest of SNMPv2 and v3.} + property MaxRepetitions: Integer read FErrorIndex write FErrorIndex; + + {:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.} + property MaxSize: Integer read FMaxSize write FMaxSize; + + {:Specify if message is authorised or encrypted. Used only in SNMPv3, and + encryption is not yet supported!} + property Flags: TV3Flags read FFlags write FFlags; + + {:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some + error).} + property FlagReportable: Boolean read FFlagReportable write FFlagReportable; + + {:For SNMPv3. If not specified, is used value from @link(AuthEngineID)} + property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID; + + {:For SNMPv3.} + property ContextName: AnsiString read FContextName write FContextName; + + {:For SNMPv3. Specify Authorization mode. (specify used hash for + authorization)} + property AuthMode: TV3Auth read FAuthMode write FAuthMode; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime; + + {:value used by SNMPv3 authorisation for synchronization with SNMP agent.} + property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp; + + {:SNMPv3 authorization username} + property UserName: AnsiString read FUserName write FUserName; + + {:SNMPv3 authorization password} + property Password: AnsiString read FPassword write FPassword; + + {:For SNMPv3. Computed Athorization key from @link(password).} + property AuthKey: AnsiString read FAuthKey write FAuthKey; + + {:For SNMPv3. Encryption key for message encryption. Not yet used!} + property PrivKey: AnsiString read FPrivKey write FPrivKey; + + {:MIB value to identify the object that sent the TRAPv1.} + property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise; + + {:Address of TRAPv1 sender (IP address).} + property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost; + + {:Generic TRAPv1 identification.} + property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen; + + {:Specific TRAPv1 identification.} + property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec; + + {:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)} + property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks; end; + {:@abstract(Implementation of SNMP protocol.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TSNMPSend = class(TSynaClient) - private + protected FSock: TUDPBlockSocket; - FBuffer: string; - FHostIP: string; + FBuffer: AnsiString; + FHostIP: AnsiString; FQuery: TSNMPRec; FReply: TSNMPRec; + function InternalSendSnmp(const Value: TSNMPRec): Boolean; + function InternalRecvSnmp(const Value: TSNMPRec): Boolean; + function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; + function GetV3EngineID: AnsiString; + function GetV3Sync: TV3Sync; public constructor Create; destructor Destroy; override; + + {:Connects to a Host and send there query. If in timeout SNMP server send + back query, result is @true. If is used SNMPv3, then it synchronize self + with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)} + function SendRequest: Boolean; + + {:Send SNMP packet only, but not waits for reply. Good for sending traps.} + function SendTrap: Boolean; + + {:Receive SNMP packet only. Good for receiving traps.} + function RecvTrap: Boolean; + + {:Mapped to @link(SendRequest) internally. This function is only for + backward compatibility.} function DoIt: Boolean; published - property HostIP: string read FHostIP; + {:contains raw binary form of SNMP packet. Good for debugging.} + property Buffer: AnsiString read FBuffer write FBuffer; + + {:After SNMP operation hold IP address of remote side.} + property HostIP: AnsiString read FHostIP; + + {:Data object contains SNMP query.} property Query: TSNMPRec read FQuery; + + {:Data object contains SNMP reply.} property Reply: TSNMPRec read FReply; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TUDPBlockSocket read FSock; end; -function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean; -function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; -function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean; -function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean; -function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean; +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GET method of the SNMP protocol. The MIB value is + located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:This is useful function and example of use TSNMPSend object. It implements + the basic SET method of the SNMP protocol. If the SNMP operation is successful, + the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community" + access identifier. You must specify "ValueType" too.} +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic GETNEXT method of the SNMP protocol. The MIB value + is located in the "OID" variable, and is sent to the requested "SNMPHost" with + the proper "Community" access identifier. Upon a successful retrieval, "Value" + will contain the information requested. If the SNMP operation is successful, + the result returns @true.} +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB tables. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + Table is readed into stringlist, where each string is comma delimited string. + + Warning: this function is not have best performance. For better performance + you must write your own function. best performace you can get by knowledge + of structuture of table and by more then one MIB on one query. } +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements basic read of SNMP MIB table element. As BaseOID you must + specify basic MIB OID of requested table (base IOD is OID without row and + column specificator!) + As next you must specify identificator of row and column for specify of needed + field of table.} +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It implements a TRAPv1 to send with all data in the parameters.} +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; + +{:A very useful function and example of its use would be found in the TSNMPSend + object. It receives a TRAPv1 and returns all the data that comes with it.} +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; const MIBName, + MIBValue: TStringList): Integer; implementation @@ -149,7 +411,9 @@ constructor TSNMPRec.Create; begin inherited Create; FSNMPMibList := TList.Create; + Clear; FID := 1; + FMaxSize := 1472; end; destructor TSNMPRec.Destroy; @@ -163,13 +427,38 @@ begin inherited Destroy; end; -function TSNMPRec.DecodeBuf(const Buffer: string): Boolean; +function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString; +var + key: AnsiString; +begin + case FAuthMode of + AuthMD5: + begin + key := MD5LongHash(Value, 1048576); + Result := MD5(key + FAuthEngineID + key); + end; + AuthSHA1: + begin + key := SHA1LongHash(Value, 1048576); + Result := SHA1(key + FAuthEngineID + key); + end; + else + Result := ''; + end; +end; + + +function TSNMPRec.DecodeBuf(const Buffer: AnsiString): Boolean; var Pos: Integer; EndPos: Integer; - sm, sv: string; + sm, sv: AnsiString; Svt: Integer; + s: AnsiString; + Spos: integer; + x: Byte; begin + Clear; Result := False; if Length(Buffer) < 2 then Exit; @@ -180,11 +469,73 @@ begin if Length(Buffer) < (EndPos + 2) then Exit; Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FCommunity := ASNItem(Pos, Buffer, Svt); - Self.FPDUType := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); - Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + + if FVersion = 3 then + begin + ASNItem(Pos, Buffer, Svt); //header data seq + ASNItem(Pos, Buffer, Svt); //ID + FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); + x := 0; + if s <> '' then + x := Ord(s[1]); + FFlagReportable := (x and 4) > 0; + x := x and 3; + case x of + 1: + FFlags := AuthNoPriv; + 3: + FFlags := AuthPriv; + else + FFlags := NoAuthNoPriv; + end; + + x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + s := ASNItem(Pos, Buffer, Svt); //SecurityParameters + //if SecurityModel is USM, then try to decode SecurityParameters + if (x = 3) and (s <> '') then + begin + spos := 1; + ASNItem(SPos, s, Svt); + FAuthEngineID := ASNItem(SPos, s, Svt); + FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0); + FAuthEngineTimeStamp := GetTick; + FUserName := ASNItem(SPos, s, Svt); + FAuthKey := ASNItem(SPos, s, Svt); + FPrivKey := ASNItem(SPos, s, Svt); + end; + //scopedPDU + s := ASNItem(Pos, Buffer, Svt); + if Svt = ASN1_OCTSTR then + begin + //decrypt! + end; + FContextEngineID := ASNItem(Pos, Buffer, Svt); + FContextName := ASNItem(Pos, Buffer, Svt); + end + else + begin + //old packet + Self.FCommunity := ASNItem(Pos, Buffer, Svt); + end; + + ASNItem(Pos, Buffer, Svt); + Self.FPDUType := Svt; + if Self.FPDUType = PDUTrap then + begin + FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt); + FOldTrapHost := ASNItem(Pos, Buffer, Svt); + FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end + else + begin + Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0); + end; ASNItem(Pos, Buffer, Svt); while Pos < EndPos do begin @@ -196,16 +547,18 @@ begin Result := True; end; -function TSNMPRec.EncodeBuf: string; +function TSNMPRec.EncodeBuf: AnsiString; var - data, s: string; + s: AnsiString; SNMPMib: TSNMPMib; n: Integer; + pdu, head, auth, authbeg: AnsiString; + x: Byte; begin - data := ''; + pdu := ''; for n := 0 to FSNMPMibList.Count - 1 do begin - SNMPMib := FSNMPMibList[n]; + SNMPMib := TSNMPMib(FSNMPMibList[n]); case SNMPMib.ValueType of ASN1_INT: s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + @@ -226,35 +579,141 @@ begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + ASNObject(SNMPMib.Value, SNMPMib.ValueType); end; - data := data + ASNObject(s, ASN1_SEQ); + pdu := pdu + ASNObject(s, ASN1_SEQ); + end; + pdu := ASNObject(pdu, ASN1_SEQ); + + if Self.FPDUType = PDUTrap then + pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) + + ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) + + ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) + + ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) + + ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) + + pdu + else + pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) + + ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) + + pdu; + pdu := ASNObject(pdu, Self.FPDUType); + + if FVersion = 3 then + begin + if FContextEngineID = '' then + FContextEngineID := FAuthEngineID; + //complete PDUv3... + pdu := ASNObject(FContextEngineID, ASN1_OCTSTR) + + ASNObject(FContextName, ASN1_OCTSTR) + + pdu; + //maybe encrypt pdu... in future + pdu := ASNObject(pdu, ASN1_SEQ); + + //prepare flags + case FFlags of + AuthNoPriv: + x := 1; + AuthPriv: + x := 3; + else + x := 0; + end; + if FFlagReportable then + x := x or 4; + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT); + s := ASNObject(ASNEncInt(FID), ASN1_INT) + + ASNObject(ASNEncInt(FMaxSize), ASN1_INT) + + ASNObject(AnsiChar(x), ASN1_OCTSTR) + //encode security model USM + + ASNObject(ASNEncInt(3), ASN1_INT); + head := head + ASNObject(s, ASN1_SEQ); + + //compute engine time difference + x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000; + + authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR) + + ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT) + + ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT) + + ASNObject(FUserName, ASN1_OCTSTR); + + + case FFlags of + AuthNoPriv, + AuthPriv: + begin + s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR) + + ASNObject(FPrivKey, ASN1_OCTSTR); + s := ASNObject(s, ASN1_SEQ); + s := head + ASNObject(s, ASN1_OCTSTR); + s := ASNObject(s + pdu, ASN1_SEQ); + //in s is entire packet without auth info... + case FAuthMode of + AuthMD5: + begin + s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48)); + //strip to HMAC-MD5-96 + delete(s, 13, 4); + end; + AuthSHA1: + begin + s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44)); + //strip to HMAC-SHA-96 + delete(s, 13, 8); + end; + else + s := ''; + end; + FAuthKey := s; + end; + end; + + auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR) + + ASNObject(FPrivKey, ASN1_OCTSTR); + auth := ASNObject(auth, ASN1_SEQ); + + head := head + ASNObject(auth, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); + end + else + begin + head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) + + ASNObject(Self.FCommunity, ASN1_OCTSTR); + Result := ASNObject(head + pdu, ASN1_SEQ); end; - data := ASNObject(data, ASN1_SEQ); - data := ASNObject(ASNEncInt(Self.FID), ASN1_INT) + - ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) + - ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) + - data; - data := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) + - ASNObject(Self.FCommunity, ASN1_OCTSTR) + - ASNObject(data, Self.FPDUType); - data := ASNObject(data, ASN1_SEQ); - Result := data; end; procedure TSNMPRec.Clear; var i: Integer; begin - FVersion := 0; - FCommunity := ''; + FVersion := SNMP_V1; + FCommunity := 'public'; + FUserName := ''; + FPassword := ''; FPDUType := 0; FErrorStatus := 0; FErrorIndex := 0; for i := 0 to FSNMPMibList.Count - 1 do TSNMPMib(FSNMPMibList[i]).Free; FSNMPMibList.Clear; + FOldTrapEnterprise := ''; + FOldTrapHost := ''; + FOldTrapGen := 0; + FOldTrapSpec := 0; + FOldTrapTimeTicks := 0; + FFlags := NoAuthNoPriv; + FFlagReportable := false; + FContextEngineID := ''; + FContextName := ''; + FAuthMode := AuthMD5; + FAuthEngineID := ''; + FAuthEngineBoots := 0; + FAuthEngineTime := 0; + FAuthEngineTimeStamp := 0; + FAuthKey := ''; + FPrivKey := ''; end; -procedure TSNMPRec.MIBAdd(const MIB, Value: string; ValueType: Integer); +procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); var SNMPMib: TSNMPMib; begin @@ -286,7 +745,7 @@ begin Result := TSNMPMib(FSNMPMibList[Index]); end; -function TSNMPRec.MIBGet(const MIB: string): string; +function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString; var i: Integer; begin @@ -324,27 +783,125 @@ begin inherited Destroy; end; -function TSNMPSend.DoIt: Boolean; +function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean; begin - FReply.Clear; - FBuffer := FQuery.EncodeBuf; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - FHostIP := cAnyHost; + FBuffer := Value.EncodeBuf; FSock.SendString(FBuffer); + Result := FSock.LastError = 0; +end; + +function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean; +begin + Result := False; + FReply.Clear; + FHostIP := cAnyHost; FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then begin FHostIP := FSock.GetRemoteSinIP; - Result := FReply.DecodeBuf(FBuffer); - end - else - Result := False; + Result := Value.DecodeBuf(FBuffer); + end; +end; + +function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; +begin + Result := False; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + if InternalSendSnmp(QValue) then + Result := InternalRecvSnmp(RValue); +end; + +function TSNMPSend.SendRequest: Boolean; +var + sync: TV3Sync; +begin + Result := False; + if FQuery.FVersion = 3 then + begin + sync := GetV3Sync; + FQuery.AuthEngineBoots := Sync.EngineBoots; + FQuery.AuthEngineTime := Sync.EngineTime; + FQuery.AuthEngineTimeStamp := Sync.EngineStamp; + FQuery.AuthEngineID := Sync.EngineID; + end; + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + if InternalSendSnmp(FQuery) then + Result := InternalRecvSnmp(FReply); +end; + +function TSNMPSend.SendTrap: Boolean; +begin + FSock.Bind(FIPInterface, cAnyPort); + FSock.Connect(FTargetHost, FTargetPort); + Result := InternalSendSnmp(FQuery); +end; + +function TSNMPSend.RecvTrap: Boolean; +begin + FSock.Bind(FIPInterface, FTargetPort); + Result := InternalRecvSnmp(FReply); +end; + +function TSNMPSend.DoIt: Boolean; +begin + Result := SendRequest; +end; + +function TSNMPSend.GetV3EngineID: AnsiString; +var + DisQuery: TSNMPRec; +begin + Result := ''; + DisQuery := TSNMPRec.Create; + try + DisQuery.Version := 3; + DisQuery.UserName := ''; + DisQuery.FlagReportable := True; + DisQuery.PDUType := PDUGetRequest; + if InternalSendRequest(DisQuery, FReply) then + Result := FReply.FAuthEngineID; + finally + DisQuery.Free; + end; +end; + +function TSNMPSend.GetV3Sync: TV3Sync; +var + SyncQuery: TSNMPRec; +begin + Result.EngineID := GetV3EngineID; + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + if Result.EngineTime = 0 then + begin + //still not have sync... + SyncQuery := TSNMPRec.Create; + try + SyncQuery.Version := 3; + SyncQuery.UserName := FQuery.UserName; + SyncQuery.Password := FQuery.Password; + SyncQuery.FlagReportable := True; + SyncQuery.Flags := FQuery.Flags; + SyncQuery.PDUType := PDUGetRequest; + SyncQuery.AuthEngineID := FReply.FAuthEngineID; + if InternalSendRequest(SyncQuery, FReply) then + begin + Result.EngineBoots := FReply.AuthEngineBoots; + Result.EngineTime := FReply.AuthEngineTime; + Result.EngineStamp := FReply.AuthEngineTimeStamp; + end; + finally + SyncQuery.Free; + end; + end; end; {==============================================================================} -function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean; +function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; var SNMPSend: TSNMPSend; begin @@ -355,7 +912,7 @@ begin SNMPSend.Query.PDUType := PDUGetRequest; SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.DoIt; + Result := SNMPSend.SendRequest; Value := ''; if Result then Value := SNMPSend.Reply.MIBGet(OID); @@ -364,7 +921,7 @@ begin end; end; -function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean; +function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; var SNMPSend: TSNMPSend; begin @@ -375,21 +932,21 @@ begin SNMPSend.Query.PDUType := PDUSetRequest; SNMPSend.Query.MIBAdd(OID, Value, ValueType); SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.DoIt = True; + Result := SNMPSend.Sendrequest = True; finally SNMPSend.Free; end; end; -function InternalGetNext(const SNMPSend: TSNMPSend; var OID: string; - const Community: string; var Value: string): Boolean; +function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString; + const Community: AnsiString; var Value: AnsiString): Boolean; begin SNMPSend.Query.Clear; SNMPSend.Query.ID := SNMPSend.Query.ID + 1; SNMPSend.Query.Community := Community; SNMPSend.Query.PDUType := PDUGetNextRequest; SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); - Result := SNMPSend.DoIt; + Result := SNMPSend.Sendrequest; Value := ''; if Result then if SNMPSend.Reply.SNMPMibList.Count > 0 then @@ -399,7 +956,7 @@ begin end; end; -function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean; +function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; var SNMPSend: TSNMPSend; begin @@ -412,11 +969,11 @@ begin end; end; -function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean; +function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; var - OID: string; - s: string; - col,row: string; + OID: AnsiString; + s: AnsiString; + col,row: String; x: integer; SNMPSend: TSNMPSend; RowList: TStringList; @@ -452,14 +1009,73 @@ begin end; end; -function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean; +function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; var - s: string; + s: AnsiString; begin s := BaseOID + '.' + ColID + '.' + RowID; Result := SnmpGet(s, Community, SNMPHost, Value); end; +function SendTrap(const Dest, Source, Enterprise, Community: AnsiString; + Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString; + MIBtype: Integer): Integer; +var + SNMPSend: TSNMPSend; +begin + SNMPSend := TSNMPSend.Create; + try + SNMPSend.TargetHost := Dest; + SNMPSend.TargetPort := cSnmpTrapProtocol; + SNMPSend.Query.Community := Community; + SNMPSend.Query.Version := SNMP_V1; + SNMPSend.Query.PDUType := PDUTrap; + SNMPSend.Query.OldTrapHost := Source; + SNMPSend.Query.OldTrapEnterprise := Enterprise; + SNMPSend.Query.OldTrapGen := Generic; + SNMPSend.Query.OldTrapSpec := Specific; + SNMPSend.Query.OldTrapTimeTicks := Seconds; + SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType); + Result := Ord(SNMPSend.SendTrap); + finally + SNMPSend.Free; + end; +end; + +function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString; + var Generic, Specific, Seconds: Integer; + const MIBName, MIBValue: TStringList): Integer; +var + SNMPSend: TSNMPSend; + i: Integer; +begin + SNMPSend := TSNMPSend.Create; + try + Result := 0; + SNMPSend.TargetPort := cSnmpTrapProtocol; + if SNMPSend.RecvTrap then + begin + Dest := SNMPSend.HostIP; + Community := SNMPSend.Reply.Community; + Source := SNMPSend.Reply.OldTrapHost; + Enterprise := SNMPSend.Reply.OldTrapEnterprise; + Generic := SNMPSend.Reply.OldTrapGen; + Specific := SNMPSend.Reply.OldTrapSpec; + Seconds := SNMPSend.Reply.OldTrapTimeTicks; + MIBName.Clear; + MIBValue.Clear; + for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do + begin + MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID); + MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value); + end; + end; + finally + SNMPSend.Free; + end; +end; + + end. diff --git a/snmptrap.pas b/snmptrap.pas deleted file mode 100644 index 30f4e51..0000000 --- a/snmptrap.pas +++ /dev/null @@ -1,361 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.003.004 | -|==============================================================================| -| Content: SNMP traps | -|==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | -| All rights reserved. | -| | -| Redistribution and use in source and binary forms, with or without | -| modification, are permitted provided that the following conditions are met: | -| | -| Redistributions of source code must retain the above copyright notice, this | -| list of conditions and the following disclaimer. | -| | -| Redistributions in binary form must reproduce the above copyright notice, | -| this list of conditions and the following disclaimer in the documentation | -| and/or other materials provided with the distribution. | -| | -| Neither the name of Lukas Gebauer nor the names of its contributors may | -| be used to endorse or promote products derived from this software without | -| specific prior written permission. | -| | -| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | -| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | -| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | -| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | -| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | -| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | -| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | -| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | -| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | -| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | -| DAMAGE. | -|==============================================================================| -| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Hernan Sanchez are Copyright (c)2000-2003. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Hernan Sanchez (hernan.sanchez@iname.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -unit snmptrap; - -interface - -uses - Classes, SysUtils, - blcksock, synautil, asn1util, snmpsend; - -const - cSnmpTrapProtocol = '162'; - - SNMP_VERSION = 0; - - PDU_GET = $A0; - PDU_GETN = $A1; - PDU_RESP = $A2; - PDU_SET = $A3; - PDU_TRAP = $A4; - -type - TTrapPDU = class(TObject) - private - FBuffer: string; - FVersion: Integer; - FPDUType: Integer; - FCommunity: string; - FEnterprise: string; - FTrapHost: string; - FGenTrap: Integer; - FSpecTrap: Integer; - FTimeTicks: Integer; - FSNMPMibList: TList; - public - constructor Create; - destructor Destroy; override; - procedure Clear; - procedure MIBAdd(const MIB, Value: string; ValueType: Integer); - procedure MIBDelete(Index: Integer); - function MIBGet(const MIB: string): string; - function EncodeTrap: Integer; - function DecodeTrap: Boolean; - published - property Version: Integer read FVersion Write FVersion; - property Community: string read FCommunity Write FCommunity; - property PDUType: Integer read FPDUType Write FPDUType; - property Enterprise: string read FEnterprise Write FEnterprise; - property TrapHost: string read FTrapHost Write FTrapHost; - property GenTrap: Integer read FGenTrap Write FGenTrap; - property SpecTrap: Integer read FSpecTrap Write FSpecTrap; - property TimeTicks: Integer read FTimeTicks Write FTimeTicks; - property SNMPMibList: TList read FSNMPMibList; - end; - - TTrapSNMP = class(TSynaClient) - private - FSock: TUDPBlockSocket; - FTrap: TTrapPDU; - public - constructor Create; - destructor Destroy; override; - function Send: Integer; - function Recv: Integer; - published - property Trap: TTrapPDU read FTrap; - property Sock: TUDPBlockSocket read FSock; - end; - -function SendTrap(const Dest, Source, Enterprise, Community: string; - Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string; - MIBtype: Integer): Integer; -function RecvTrap(var Dest, Source, Enterprise, Community: string; - var Generic, Specific, Seconds: Integer; const MIBName, - MIBValue: TStringList): Integer; - -implementation - -constructor TTrapPDU.Create; -begin - inherited Create; - FSNMPMibList := TList.Create; - FVersion := SNMP_VERSION; - FPDUType := PDU_TRAP; - FCommunity := 'public'; -end; - -destructor TTrapPDU.Destroy; -var - i: Integer; -begin - for i := 0 to FSNMPMibList.Count - 1 do - TSNMPMib(FSNMPMibList[i]).Free; - FSNMPMibList.Free; - inherited Destroy; -end; - -procedure TTrapPDU.Clear; -var - i: Integer; -begin - for i := 0 to FSNMPMibList.Count - 1 do - TSNMPMib(FSNMPMibList[i]).Free; - FSNMPMibList.Clear; - FVersion := SNMP_VERSION; - FPDUType := PDU_TRAP; - FCommunity := 'public'; -end; - -procedure TTrapPDU.MIBAdd(const MIB, Value: string; ValueType: Integer); -var - SNMPMib: TSNMPMib; -begin - SNMPMib := TSNMPMib.Create; - SNMPMib.OID := MIB; - SNMPMib.Value := Value; - SNMPMib.ValueType := ValueType; - FSNMPMibList.Add(SNMPMib); -end; - -procedure TTrapPDU.MIBDelete(Index: Integer); -begin - if (Index >= 0) and (Index < FSNMPMibList.Count) then - begin - TSNMPMib(FSNMPMibList[Index]).Free; - FSNMPMibList.Delete(Index); - end; -end; - -function TTrapPDU.MIBGet(const MIB: string): string; -var - i: Integer; -begin - Result := ''; - for i := 0 to FSNMPMibList.Count - 1 do - begin - if TSNMPMib(FSNMPMibList[i]).OID = MIB then - begin - Result := TSNMPMib(FSNMPMibList[i]).Value; - Break; - end; - end; -end; - -function TTrapPDU.EncodeTrap: Integer; -var - s: string; - n: Integer; - SNMPMib: TSNMPMib; -begin - FBuffer := ''; - for n := 0 to FSNMPMibList.Count - 1 do - begin - SNMPMib := FSNMPMibList[n]; - case SNMPMib.ValueType of - ASN1_INT: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); - ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType); - ASN1_OBJID: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType); - ASN1_IPADDR: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType); - ASN1_NULL: - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject('', ASN1_NULL); - else - s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) + - ASNObject(SNMPMib.Value, SNMPMib.ValueType); - end; - FBuffer := FBuffer + ASNObject(s, ASN1_SEQ); - end; - FBuffer := ASNObject(FBuffer, ASN1_SEQ); - FBuffer := ASNObject(ASNEncInt(FGenTrap), ASN1_INT) + - ASNObject(ASNEncInt(FSpecTrap), ASN1_INT) + - ASNObject(ASNEncUInt(FTimeTicks), ASN1_TIMETICKS) + - FBuffer; - FBuffer := ASNObject(MibToID(FEnterprise), ASN1_OBJID) + - ASNObject(IPToID(FTrapHost), ASN1_IPADDR) + - FBuffer; - FBuffer := ASNObject(ASNEncInt(FVersion), ASN1_INT) + - ASNObject(FCommunity, ASN1_OCTSTR) + - ASNObject(FBuffer, Self.FPDUType); - FBuffer := ASNObject(FBuffer, ASN1_SEQ); - Result := 1; -end; - -function TTrapPDU.DecodeTrap: Boolean; -var - Pos, EndPos: Integer; - Sm, Sv: string; - Svt: Integer; -begin - Clear; - Result := False; - if Length(FBuffer) < 2 then - Exit; - if (Ord(FBuffer[1]) and $20) = 0 then - Exit; - Pos := 2; - EndPos := ASNDecLen(Pos, FBuffer); - FVersion := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0); - FCommunity := ASNItem(Pos, FBuffer, Svt); - FPDUType := StrToIntDef(ASNItem(Pos, FBuffer, Svt), PDU_TRAP); - FEnterprise := ASNItem(Pos, FBuffer, Svt); - FTrapHost := ASNItem(Pos, FBuffer, Svt); - FGenTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0); - FSpecTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0); - FTimeTicks := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0); - ASNItem(Pos, FBuffer, Svt); - while Pos < EndPos do - begin - ASNItem(Pos, FBuffer, Svt); - Sm := ASNItem(Pos, FBuffer, Svt); - Sv := ASNItem(Pos, FBuffer, Svt); - MIBAdd(Sm, Sv, Svt); - end; - Result := True; -end; - -constructor TTrapSNMP.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FTrap := TTrapPDU.Create; - FTimeout := 5000; - FTargetPort := cSnmpTrapProtocol; -end; - -destructor TTrapSNMP.Destroy; -begin - FTrap.Free; - FSock.Free; - inherited Destroy; -end; - -function TTrapSNMP.Send: Integer; -begin - FTrap.EncodeTrap; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - FSock.SendString(FTrap.FBuffer); - Result := 1; -end; - -function TTrapSNMP.Recv: Integer; -begin - Result := 0; - FSock.Bind(FIPInterface, FTargetPort); - FTrap.FBuffer := FSock.RecvPacket(FTimeout); - if Fsock.Lasterror = 0 then - if FTrap.DecodeTrap then - Result := 1; -end; - -function SendTrap(const Dest, Source, Enterprise, Community: string; - Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string; - MIBtype: Integer): Integer; -begin - with TTrapSNMP.Create do - try - TargetHost := Dest; - Trap.TrapHost := Source; - Trap.Enterprise := Enterprise; - Trap.Community := Community; - Trap.GenTrap := Generic; - Trap.SpecTrap := Specific; - Trap.TimeTicks := Seconds; - Trap.MIBAdd(MIBName, MIBValue, MIBType); - Result := Send; - finally - Free; - end; -end; - -function RecvTrap(var Dest, Source, Enterprise, Community: string; - var Generic, Specific, Seconds: Integer; - const MIBName, MIBValue: TStringList): Integer; -var - i: Integer; -begin - with TTrapSNMP.Create do - try - TargetHost := Dest; - Result := Recv; - if Result <> 0 then - begin - Dest := TargetHost; - Source := Trap.TrapHost; - Enterprise := Trap.Enterprise; - Community := Trap.Community; - Generic := Trap.GenTrap; - Specific := Trap.SpecTrap; - Seconds := Trap.TimeTicks; - MIBName.Clear; - MIBValue.Clear; - for i := 0 to Trap.SNMPMibList.Count - 1 do - begin - MIBName.Add(TSNMPMib(Trap.SNMPMibList[i]).OID); - MIBValue.Add(TSNMPMib(Trap.SNMPMibList[i]).Value); - end; - end; - finally - Free; - end; -end; - -end. diff --git a/sntpsend.pas b/sntpsend.pas index 0e32de0..4cc4021 100644 --- a/sntpsend.pas +++ b/sntpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.002.007 | +| Project : Ararat Synapse | 003.000.000 | |==============================================================================| | Content: SNTP client | |==============================================================================| @@ -43,6 +43,11 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract( NTP and SNTP client) + +Used RFC: RFC-1305, RFC-2030 +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -61,7 +66,8 @@ const cNtpProtocol = 'ntp'; type - PNtp = ^TNtp; + + {:@abstract(Record containing the NTP packet.)} TNtp = packed record mode: Byte; stratum: Byte; @@ -80,6 +86,12 @@ type Xmit2: Longint; end; + {:@abstract(Implementation of NTP and SNTP client protocol), + include time synchronisation. It can send NTP or SNTP time queries, or it + can receive NTP broadcasts too. + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TSNTPSend = class(TSynaClient) private FNTPReply: TNtp; @@ -91,21 +103,56 @@ type FSock: TUDPBlockSocket; FBuffer: string; FLi, FVn, Fmode : byte; + function StrToNTP(const Value: AnsiString): TNtp; + function NTPtoStr(const Value: Tntp): AnsiString; + procedure ClearNTP(var Value: Tntp); public constructor Create; destructor Destroy; override; + + {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} function DecodeTs(Nsec, Nfrac: Longint): TDateTime; + + {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid.} function GetSNTP: Boolean; + + {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all + is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are + valid. Result time is after all needed corrections.} function GetNTP: Boolean; + + {:Wait for broadcast NTP packet. If all OK, result is @true and + @link(NTPReply) and @link(NTPTime) are valid.} function GetBroadcastNTP: Boolean; + + {:Holds last received NTP packet.} property NTPReply: TNtp read FNTPReply; published + {:Date and time of remote NTP or SNTP server. (UTC time!!!)} property NTPTime: TDateTime read FNTPTime; + + {:Offset between your computer and remote NTP or SNTP server.} property NTPOffset: Double read FNTPOffset; + + {:Delay between your computer and remote NTP or SNTP server.} property NTPDelay: Double read FNTPDelay; + + {:Define allowed maximum difference between your time and remote time for + synchronising time. If difference is bigger, your system time is not + changed!} property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; + + {:If @true, after successfull getting time is local computer clock + synchronised to given time. + For synchronising time you must have proper rights! (Usually Administrator)} property SyncTime: Boolean read FSyncTime write FSyncTime; + + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TUDPBlockSocket read FSock; end; @@ -127,14 +174,74 @@ begin inherited Destroy; end; +function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; +begin + if length(FBuffer) >= SizeOf(Result) then + begin + Result.mode := ord(Value[1]); + Result.stratum := ord(Value[2]); + Result.poll := ord(Value[3]); + Result.Precision := ord(Value[4]); + Result.RootDelay := DecodeLongInt(value, 5); + Result.RootDisperson := DecodeLongInt(value, 9); + Result.RefID := DecodeLongInt(value, 13); + Result.Ref1 := DecodeLongInt(value, 17); + Result.Ref2 := DecodeLongInt(value, 21); + Result.Org1 := DecodeLongInt(value, 25); + Result.Org2 := DecodeLongInt(value, 29); + Result.Rcv1 := DecodeLongInt(value, 33); + Result.Rcv2 := DecodeLongInt(value, 37); + Result.Xmit1 := DecodeLongInt(value, 41); + Result.Xmit2 := DecodeLongInt(value, 45); + end; + +end; + +function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; +begin + SetLength(Result, 4); + Result[1] := AnsiChar(Value.mode); + Result[2] := AnsiChar(Value.stratum); + Result[3] := AnsiChar(Value.poll); + Result[4] := AnsiChar(Value.precision); + Result := Result + CodeLongInt(Value.RootDelay); + Result := Result + CodeLongInt(Value.RootDisperson); + Result := Result + CodeLongInt(Value.RefID); + Result := Result + CodeLongInt(Value.Ref1); + Result := Result + CodeLongInt(Value.Ref2); + Result := Result + CodeLongInt(Value.Org1); + Result := Result + CodeLongInt(Value.Org2); + Result := Result + CodeLongInt(Value.Rcv1); + Result := Result + CodeLongInt(Value.Rcv2); + Result := Result + CodeLongInt(Value.Xmit1); + Result := Result + CodeLongInt(Value.Xmit2); +end; + +procedure TSNTPSend.ClearNTP(var Value: Tntp); +begin + Value.mode := 0; + Value.stratum := 0; + Value.poll := 0; + Value.Precision := 0; + Value.RootDelay := 0; + Value.RootDisperson := 0; + Value.RefID := 0; + Value.Ref1 := 0; + Value.Ref2 := 0; + Value.Org1 := 0; + Value.Org2 := 0; + Value.Rcv1 := 0; + Value.Rcv2 := 0; + Value.Xmit1 := 0; + Value.Xmit2 := 0; +end; + function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; const maxi = 4294967295.0; var d, d1: Double; begin - Nsec := synsock.htonl(Nsec); - Nfrac := synsock.htonl(Nfrac); d := Nsec; if d < 0 then d := maxi + d + 1; @@ -165,13 +272,10 @@ begin d1 := d1 - maxi - 1; Nsec:=trunc(d); Nfrac:=trunc(d1); - Nsec := synsock.htonl(Nsec); - Nfrac := synsock.htonl(Nfrac); end; function TSNTPSend.GetBroadcastNTP: Boolean; var - NtpPtr: PNtp; x: Integer; begin Result := False; @@ -183,8 +287,7 @@ begin if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then if x >= SizeOf(NTPReply) then begin - NtpPtr := Pointer(FBuffer); - FNTPReply := NtpPtr^; + FNTPReply := StrToNTP(FBuffer); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then SetUTTime(FNTPTime); @@ -196,23 +299,22 @@ end; function TSNTPSend.GetSNTP: Boolean; var q: TNtp; - NtpPtr: PNtp; x: Integer; begin Result := False; FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(FTargetHost, FTargetPort); - FillChar(q, SizeOf(q), 0); + ClearNtp(q); q.mode := $1B; - FSock.SendBuffer(@q, SizeOf(q)); + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then begin x := Length(FBuffer); if x >= SizeOf(NTPReply) then begin - NtpPtr := Pointer(FBuffer); - FNTPReply := NtpPtr^; + FNTPReply := StrToNTP(FBuffer); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then SetUTTime(FNTPTime); @@ -224,18 +326,18 @@ end; function TSNTPSend.GetNTP: Boolean; var q: TNtp; - NtpPtr: PNtp; x: Integer; t1, t2, t3, t4 : TDateTime; begin Result := False; FSock.Bind(FIPInterface, cAnyPort); FSock.Connect(FTargetHost, FTargetPort); - FillChar(q, SizeOf(q), 0); + ClearNtp(q); q.mode := $1B; t1 := GetUTTime; EncodeTs(t1, q.org1, q.org2); - FSock.SendBuffer(@q, SizeOf(q)); + FBuffer := NTPtoStr(q); + FSock.SendString(FBuffer); FBuffer := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then begin @@ -243,8 +345,7 @@ begin t4 := GetUTTime; if x >= SizeOf(NTPReply) then begin - NtpPtr := Pointer(FBuffer); - FNTPReply := NtpPtr^; + FNTPReply := StrToNTP(FBuffer); FLi := (NTPReply.mode and $C0) shr 6; FVn := (NTPReply.mode and $38) shr 3; Fmode := NTPReply.mode and $07; diff --git a/ssdotnet.pas b/ssdotnet.pas new file mode 100644 index 0000000..799ea28 --- /dev/null +++ b/ssdotnet.pas @@ -0,0 +1,1013 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.002 | +|==============================================================================| +| Content: Socket Independent Platform Layer - .NET definition include | +|==============================================================================| +| Copyright (c)2004, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2004. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF CIL} + +interface + +uses + SyncObjs, SysUtils, + System.Net, + System.Net.Sockets; + +const + DLLStackName = ''; + WinsockLevel = $0202; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + PSockAddr = IPEndPoint; + DWORD = integer; + ULong = cardinal; + TMemory = Array of byte; + TLinger = LingerOption; + TSocket = socket; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; +// lpVendorInfo: PChar; + end; + + SunB6 = packed record + s_b1, s_b2, s_b3, s_b4, + s_b5, s_b6, s_b7, s_b8, + s_b9, s_b10, s_b11, s_b12, + s_b13, s_b14, s_b15, s_b16: u_char; + end; + + S6_Bytes = SunB6; + S6_Addr = SunB6; + + TInAddr6 = packed record + S_un_b: SunB6; + end; + + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + +const + MSG_NOSIGNAL = 0; + INVALID_SOCKET = nil; + AF_INET = AddressFamily.InterNetwork; + AF_INET6 = AddressFamily.InterNetworkV6; + SOCKET_ERROR = integer(-1); + + FIONREAD = integer($4004667f); + FIONBIO = integer($8004667e); + FIOASYNC = integer($8004667d); + + SOMAXCONN = integer($7fffffff); + + IPPROTO_IP = ProtocolType.IP; + IPPROTO_ICMP = ProtocolType.Icmp; + IPPROTO_IGMP = ProtocolType.Igmp; + IPPROTO_TCP = ProtocolType.Tcp; + IPPROTO_UDP = ProtocolType.Udp; + IPPROTO_RAW = ProtocolType.Raw; + IPPROTO_IPV6 = ProtocolType.IPV6; +// + IPPROTO_ICMPV6 = ProtocolType.Icmp; //?? + + SOCK_STREAM = SocketType.Stream; + SOCK_DGRAM = SocketType.Dgram; + SOCK_RAW = SocketType.Raw; + SOCK_RDM = SocketType.Rdm; + SOCK_SEQPACKET = SocketType.Seqpacket; + + SOL_SOCKET = SocketOptionLevel.Socket; + SOL_IP = SocketOptionLevel.Ip; + + + IP_OPTIONS = SocketOptionName.IPOptions; + IP_HDRINCL = SocketOptionName.HeaderIncluded; + IP_TOS = SocketOptionName.TypeOfService; { set/get IP Type Of Service } + IP_TTL = SocketOptionName.IpTimeToLive; { set/get IP Time To Live } + IP_MULTICAST_IF = SocketOptionName.MulticastInterface; { set/get IP multicast interface } + IP_MULTICAST_TTL = SocketOptionName.MulticastTimeToLive; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = SocketOptionName.MulticastLoopback; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = SocketOptionName.AddMembership; { add an IP group membership } + IP_DROP_MEMBERSHIP = SocketOptionName.DropMembership; { drop an IP group membership } + IP_DONTFRAGMENT = SocketOptionName.DontFragment; { set/get IP Don't Fragment flag } + + IPV6_UNICAST_HOPS = 8; // TTL + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + SO_DEBUG = SocketOptionName.Debug; { turn on debugging info recording } + SO_ACCEPTCONN = SocketOptionName.AcceptConnection; { socket has had listen() } + SO_REUSEADDR = SocketOptionName.ReuseAddress; { allow local address reuse } + SO_KEEPALIVE = SocketOptionName.KeepAlive; { keep connections alive } + SO_DONTROUTE = SocketOptionName.DontRoute; { just use interface addresses } + SO_BROADCAST = SocketOptionName.Broadcast; { permit sending of broadcast msgs } + SO_USELOOPBACK = SocketOptionName.UseLoopback; { bypass hardware when possible } + SO_LINGER = SocketOptionName.Linger; { linger on close if data present } + SO_OOBINLINE = SocketOptionName.OutOfBandInline; { leave received OOB data in line } + SO_DONTLINGER = SocketOptionName.DontLinger; +{ Additional options. } + SO_SNDBUF = SocketOptionName.SendBuffer; { send buffer size } + SO_RCVBUF = SocketOptionName.ReceiveBuffer; { receive buffer size } + SO_SNDLOWAT = SocketOptionName.SendLowWater; { send low-water mark } + SO_RCVLOWAT = SocketOptionName.ReceiveLowWater; { receive low-water mark } + SO_SNDTIMEO = SocketOptionName.SendTimeout; { send timeout } + SO_RCVTIMEO = SocketOptionName.ReceiveTimeout; { receive timeout } + SO_ERROR = SocketOptionName.Error; { get error status and clear } + SO_TYPE = SocketOptionName.Type; { get socket type } + +{ WinSock 2 extension -- new options } +// SO_GROUP_ID = $2001; { ID of a socket group} +// SO_GROUP_PRIORITY = $2002; { the relative priority within a group} +// SO_MAX_MSG_SIZE = $2003; { maximum message size } +// SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } +// SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } +// SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; +// PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } +// SO_OPENTYPE = $7008; +// SO_SYNCHRONOUS_ALERT = $10; +// SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } +// SO_MAXDG = $7009; +// SO_MAXPATHDG = $700A; +// SO_UPDATE_ACCEPT_CONTEXT = $700B; +// SO_CONNECT_TIME = $700C; + + + { All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + +type + TVarSin = IPEndpoint; + +{ function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; +} + +{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); +} +{=============================================================================} + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function WSAGetLastErrorDesc: String; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; +// function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar; +// optlen: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; +// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; +// tolen: Integer): Integer; +/// function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +/// function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +/// function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +/// function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; + function ntohs(netshort: u_short): u_short; + function ntohl(netlong: u_long): u_long; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + function htons(hostshort: u_short): u_short; + function htonl(hostlong: u_long): u_long; +// function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetSockName(s: TSocket; var name: TVarSin): Integer; +// function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; +// function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; +// function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; +// function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; +// Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; +// timeout: PTimeVal): Longint; +// {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF}; + +// TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; +// cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; +// lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; +// lpCompletionRoutine: pointer): u_int; +// stdcall; + + function GetPortService(value: string): integer; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +{==============================================================================} +implementation + +threadvar + WSALastError: integer; + WSALastErrorDesc: string; + +var + services: Array [0..139, 0..1] of string = + ( + ('echo', '7'), + ('discard', '9'), + ('sink', '9'), + ('null', '9'), + ('systat', '11'), + ('users', '11'), + ('daytime', '13'), + ('qotd', '17'), + ('quote', '17'), + ('chargen', '19'), + ('ttytst', '19'), + ('source', '19'), + ('ftp-data', '20'), + ('ftp', '21'), + ('telnet', '23'), + ('smtp', '25'), + ('mail', '25'), + ('time', '37'), + ('timeserver', '37'), + ('rlp', '39'), + ('nameserver', '42'), + ('name', '42'), + ('nickname', '43'), + ('whois', '43'), + ('domain', '53'), + ('bootps', '67'), + ('dhcps', '67'), + ('bootpc', '68'), + ('dhcpc', '68'), + ('tftp', '69'), + ('gopher', '70'), + ('finger', '79'), + ('http', '80'), + ('www', '80'), + ('www-http', '80'), + ('kerberos', '88'), + ('hostname', '101'), + ('hostnames', '101'), + ('iso-tsap', '102'), + ('rtelnet', '107'), + ('pop2', '109'), + ('postoffice', '109'), + ('pop3', '110'), + ('sunrpc', '111'), + ('rpcbind', '111'), + ('portmap', '111'), + ('auth', '113'), + ('ident', '113'), + ('tap', '113'), + ('uucp-path', '117'), + ('nntp', '119'), + ('usenet', '119'), + ('ntp', '123'), + ('epmap', '135'), + ('loc-srv', '135'), + ('netbios-ns', '137'), + ('nbname', '137'), + ('netbios-dgm', '138'), + ('nbdatagram', '138'), + ('netbios-ssn', '139'), + ('nbsession', '139'), + ('imap', '143'), + ('imap4', '143'), + ('pcmail-srv', '158'), + ('snmp', '161'), + ('snmptrap', '162'), + ('snmp-trap', '162'), + ('print-srv', '170'), + ('bgp', '179'), + ('irc', '194'), + ('ipx', '213'), + ('ldap', '389'), + ('https', '443'), + ('mcom', '443'), + ('microsoft-ds', '445'), + ('kpasswd', '464'), + ('isakmp', '500'), + ('ike', '500'), + ('exec', '512'), + ('biff', '512'), + ('comsat', '512'), + ('login', '513'), + ('who', '513'), + ('whod', '513'), + ('cmd', '514'), + ('shell', '514'), + ('syslog', '514'), + ('printer', '515'), + ('spooler', '515'), + ('talk', '517'), + ('ntalk', '517'), + ('efs', '520'), + ('router', '520'), + ('route', '520'), + ('routed', '520'), + ('timed', '525'), + ('timeserver', '525'), + ('tempo', '526'), + ('newdate', '526'), + ('courier', '530'), + ('rpc', '530'), + ('conference', '531'), + ('chat', '531'), + ('netnews', '532'), + ('readnews', '532'), + ('netwall', '533'), + ('uucp', '540'), + ('uucpd', '540'), + ('klogin', '543'), + ('kshell', '544'), + ('krcmd', '544'), + ('new-rwho', '550'), + ('new-who', '550'), + ('remotefs', '556'), + ('rfs', '556'), + ('rfs_server', '556'), + ('rmonitor', '560'), + ('rmonitord', '560'), + ('monitor', '561'), + ('ldaps', '636'), + ('sldap', '636'), + ('doom', '666'), + ('kerberos-adm', '749'), + ('kerberos-iv', '750'), + ('kpop', '1109'), + ('phone', '1167'), + ('ms-sql-s', '1433'), + ('ms-sql-m', '1434'), + ('wins', '1512'), + ('ingreslock', '1524'), + ('ingres', '1524'), + ('l2tp', '1701'), + ('pptp', '1723'), + ('radius', '1812'), + ('radacct', '1813'), + ('nfsd', '2049'), + ('nfs', '2049'), + ('knetd', '2053'), + ('gds_db', '3050'), + ('man', '9535') + ); + +{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and + (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and + (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.s_un_b.s_b1 = char($FF)); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s_un_b.s_b16 := char(1); +end; +} + +{=============================================================================} + +procedure NullErr; +begin + WSALastError := 0; + WSALastErrorDesc := ''; +end; + +procedure GetErrCode(E: System.Exception); +var + SE: System.Net.Sockets.SocketException; +begin + if E is System.Net.Sockets.SocketException then + begin + SE := E as System.Net.Sockets.SocketException; + WSALastError := SE.ErrorCode; + WSALastErrorDesc := SE.Message; + end +end; + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + NullErr; + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on .NET'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + NullErr; + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := WSALastError; +end; + +function WSAGetLastErrorDesc: String; +begin + Result := WSALastErrorDesc; +end; + +function GetHostName: string; +begin + Result := System.Net.DNS.GetHostName; +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.ShutDown(SocketShutdown(how)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer; +begin + Result := 0; + NullErr; + try + s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer; +begin + NullErr; + try + result := s.SendTo(Buf, len, SocketFlags(flags), addrto); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Send(s: TSocket; const Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Send(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +//function Recv(s: TSocket; var Buf; len, flags: Integer): Integer; +begin + NullErr; + try + result := s.Receive(Buf, len, SocketFlags(flags)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; +// var fromlen: Integer): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +//function RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer; +var + EP: EndPoint; +begin + NullErr; + try + EP := from; + result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP)); + from := EP as IPEndPoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function ntohs(netshort: u_short): u_short; +begin + Result := IPAddress.NetworkToHostOrder(NetShort); +end; + +function ntohl(netlong: u_long): u_long; +begin + Result := IPAddress.NetworkToHostOrder(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + Result := 0; + NullErr; + try + s.Listen(backlog); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; +var + inv, outv: TMemory; +begin + Result := 0; + NullErr; + try + if cmd = DWORD(FIONBIO) then + s.Blocking := arg = 0 + else + begin + inv := BitConverter.GetBytes(arg); + outv := BitConverter.GetBytes(integer(0)); + s.IOControl(cmd, inv, outv); + arg := BitConverter.ToUInt32(outv, 0); + end; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function htons(hostshort: u_short): u_short; +begin + Result := IPAddress.HostToNetworkOrder(Hostshort); +end; + +function htonl(hostlong: u_long): u_long; +begin + Result := IPAddress.HostToNetworkOrder(HostLong); +end; + +//function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.localEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + Name := s.RemoteEndPoint as IPEndpoint; + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Connect(name); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := 0; + NullErr; + try + s.Close; + except + on e: System.Net.Sockets.SocketException do + begin + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := 0; + NullErr; + try + s.Bind(addr); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := integer(SOCKET_ERROR); + end; + end; +end; + +//function Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; +function Accept(s: TSocket; var addr: TVarSin): TSocket; +begin + NullErr; + try + result := s.Accept(); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + NullErr; + try + result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol)); + except + on e: System.Net.Sockets.SocketException do + begin + GetErrCode(e); + Result := nil; + end; + end; +end; + +{=============================================================================} +function GetPortService(value: string): integer; +var + n: integer; +begin + Result := 0; + value := Lowercase(value); + for n := 0 to High(Services) do + if services[n, 0] = value then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + if Result = 0 then + Result := StrToIntDef(value, 0); +end; + +{=============================================================================} +function InitSocketInterface(stack: string): Boolean; +begin + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + NullErr; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; +// SET_IN6_IF_ADDR_ANY (@in6addr_any); +// SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + NullErr; + SynSockCS.Free; +end; + +{$ENDIF} diff --git a/sslinux.pas b/sslinux.pas new file mode 100644 index 0000000..60a71a0 --- /dev/null +++ b/sslinux.pas @@ -0,0 +1,963 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.002 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Linux definition include | +|==============================================================================| +| Copyright (c)1999-2003, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF LINUX} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +interface + +uses + SyncObjs, SysUtils, + {$IFDEF FPC} + synafpc, + {$ENDIF} + Libc; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + WinsockLevel = $0202; + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + TSocket = u_int; + + TMemory = pointer; + + +const + DLLStackName = 'libc.so.6'; + +type + DWORD = Integer; + __fd_mask = LongWord; +const + __FD_SETSIZE = 1024; + __NFDBITS = 8 * sizeof(__fd_mask); +type + __fd_set = {packed} record + fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask; + end; + TFDSet = __fd_set; + PFDSet = ^TFDSet; + +const + FIONREAD = $541B; + FIONBIO = $5421; + FIOASYNC = $5452; + +type + PTimeVal = ^TTimeVal; + TTimeVal = packed record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + SunB = packed record + s_b1, s_b2, s_b3, s_b4: u_char; + end; + + SunW = packed record + s_w1, s_w2: u_short; + end; + + PInAddr = ^TInAddr; + TInAddr = packed record + case integer of + 0: (S_un_b: SunB); + 1: (S_un_w: SunW); + 2: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = packed record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + 1: (sa_family: u_short; + sa_data: array[0..13] of Char) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + SunB6 = packed record + s_b1, s_b2, s_b3, s_b4, + s_b5, s_b6, s_b7, s_b8, + s_b9, s_b10, s_b11, s_b12, + s_b13, s_b14, s_b15, s_b16: u_char; + end; + + SunW6 = packed record + s_w1, s_w2, s_w3, s_w4, + s_w5, s_w6, s_w7, s_w8: u_short; + end; + + SunDW6 = packed record + s_dw1, s_dw2, s_dw3, s_dw4: longint; + end; + + S6_Bytes = SunB6; + S6_Words = SunW6; + S6_DWords = SunDW6; + S6_Addr = SunB6; + + PInAddr6 = ^TInAddr6; + TInAddr6 = packed record + case integer of + 0: (S_un_b: SunB6); + 1: (S_un_w: SunW6); + 2: (S_un_dw: SunDW6); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: u_long; // Interface index. + padding: u_long; + end; + + hostent = record + h_name: PChar; + h_aliases: PPChar; + h_addrtype: Integer; + h_length: Cardinal; + case Byte of + 0: (h_addr_list: PPChar); + 1: (h_addr: PPChar); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PChar; + n_aliases: PPChar; + n_addrtype: Integer; + n_net: uint32_t; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PChar; + s_aliases: PPChar; + s_port: Integer; + s_proto: PChar; + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PChar; + p_aliases: ^PChar; + p_proto: u_short; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + IP_TOS = 1; { int; IP type of service and precedence. } + IP_TTL = 2; { int; IP time to live. } + IP_HDRINCL = 3; { int; Header is included with data. } + IP_OPTIONS = 4; { ip_opts; IP per-packet options. } + IP_ROUTER_ALERT = 5; { bool } + IP_RECVOPTS = 6; { bool } + IP_RETOPTS = 7; { bool } + IP_PKTINFO = 8; { bool } + IP_PKTOPTIONS = 9; + IP_PMTUDISC = 10; { obsolete name? } + IP_MTU_DISCOVER = 10; { int; see below } + IP_RECVERR = 11; { bool } + IP_RECVTTL = 12; { bool } + IP_RECVTOS = 13; { bool } + IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = 1; + + SO_DEBUG = 1; + SO_REUSEADDR = 2; + SO_TYPE = 3; + SO_ERROR = 4; + SO_DONTROUTE = 5; + SO_BROADCAST = 6; + SO_SNDBUF = 7; + SO_RCVBUF = 8; + SO_KEEPALIVE = 9; + SO_OOBINLINE = 10; + SO_NO_CHECK = 11; + SO_PRIORITY = 12; + SO_LINGER = 13; + SO_BSDCOMPAT = 14; + SO_REUSEPORT = 15; + SO_PASSCRED = 16; + SO_PEERCRED = 17; + SO_RCVLOWAT = 18; + SO_SNDLOWAT = 19; + SO_RCVTIMEO = 20; + SO_SNDTIMEO = 21; +{ Security levels - as per NRL IPv6 - don't actually do anything } + SO_SECURITY_AUTHENTICATION = 22; + SO_SECURITY_ENCRYPTION_TRANSPORT = 23; + SO_SECURITY_ENCRYPTION_NETWORK = 24; + SO_BINDTODEVICE = 25; +{ Socket filtering } + SO_ATTACH_FILTER = 26; + SO_DETACH_FILTER = 27; + + SOMAXCONN = 128; + + IPV6_UNICAST_HOPS = 16; + IPV6_MULTICAST_IF = 17; + IPV6_MULTICAST_HOPS = 18; + IPV6_MULTICAST_LOOP = 19; + IPV6_JOIN_GROUP = 20; + IPV6_LEAVE_GROUP = 21; + + MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $4; + NI_NUMERICHOST = $1; + NI_NAMEREQD = $8; + NI_NUMERICSERV = $2; + NI_DGRAM = $10; + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 10; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = packed record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_addr: PSockAddr; // Binary address. + ai_canonname: PChar; // Canonical name for nodename. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: u_short; + l_linger: u_short; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + WSAEINTR = EINTR; + WSAEBADF = EBADF; + WSAEACCES = EACCES; + WSAEFAULT = EFAULT; + WSAEINVAL = EINVAL; + WSAEMFILE = EMFILE; + WSAEWOULDBLOCK = EWOULDBLOCK; + WSAEINPROGRESS = EINPROGRESS; + WSAEALREADY = EALREADY; + WSAENOTSOCK = ENOTSOCK; + WSAEDESTADDRREQ = EDESTADDRREQ; + WSAEMSGSIZE = EMSGSIZE; + WSAEPROTOTYPE = EPROTOTYPE; + WSAENOPROTOOPT = ENOPROTOOPT; + WSAEPROTONOSUPPORT = EPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; + WSAEOPNOTSUPP = EOPNOTSUPP; + WSAEPFNOSUPPORT = EPFNOSUPPORT; + WSAEAFNOSUPPORT = EAFNOSUPPORT; + WSAEADDRINUSE = EADDRINUSE; + WSAEADDRNOTAVAIL = EADDRNOTAVAIL; + WSAENETDOWN = ENETDOWN; + WSAENETUNREACH = ENETUNREACH; + WSAENETRESET = ENETRESET; + WSAECONNABORTED = ECONNABORTED; + WSAECONNRESET = ECONNRESET; + WSAENOBUFS = ENOBUFS; + WSAEISCONN = EISCONN; + WSAENOTCONN = ENOTCONN; + WSAESHUTDOWN = ESHUTDOWN; + WSAETOOMANYREFS = ETOOMANYREFS; + WSAETIMEDOUT = ETIMEDOUT; + WSAECONNREFUSED = ECONNREFUSED; + WSAELOOP = ELOOP; + WSAENAMETOOLONG = ENAMETOOLONG; + WSAEHOSTDOWN = EHOSTDOWN; + WSAEHOSTUNREACH = EHOSTUNREACH; + WSAENOTEMPTY = ENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = EUSERS; + WSAEDQUOT = EDQUOT; + WSAESTALE = ESTALE; + WSAEREMOTE = EREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = HOST_NOT_FOUND; + WSATRY_AGAIN = TRY_AGAIN; + WSANO_RECOVERY = NO_RECOVERY; + WSANO_DATA = -6; + + EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. } + EAI_NONAME = -2; { NAME or SERVICE is unknown. } + EAI_AGAIN = -3; { Temporary failure in name resolution. } + EAI_FAIL = -4; { Non-recoverable failure in name res. } + EAI_NODATA = -5; { No address associated with NAME. } + EAI_FAMILY = -6; { `ai_family' not supported. } + EAI_SOCKTYPE = -7; { `ai_socktype' not supported. } + EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. } + EAI_ADDRFAMILY = -9; { Address family for NAME not supported. } + EAI_MEMORY = -10; { Memory allocation failure. } + EAI_SYSTEM = -11; { System error returned in `errno'. } + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + cdecl; + TWSACleanup = function: Integer; + cdecl; + TWSAGetLastError = function: Integer; + cdecl; + TGetServByName = function(name, proto: PChar): PServEnt; + cdecl; + TGetServByPort = function(port: Integer; proto: PChar): PServEnt; + cdecl; + TGetProtoByName = function(name: PChar): PProtoEnt; + cdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + cdecl; + TGetHostByName = function(name: PChar): PHostEnt; + cdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + cdecl; + TGetHostName = function(name: PChar; len: Integer): Integer; + cdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + cdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + optlen: Integer): Integer; + cdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + var optlen: Integer): Integer; + cdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + cdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + cdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + cdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + cdecl; + Tntohs = function(netshort: u_short): u_short; + cdecl; + Tntohl = function(netlong: u_long): u_long; + cdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + cdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + cdecl; + TInet_ntoa = function(inaddr: TInAddr): PChar; + cdecl; + TInet_addr = function(cp: PChar): u_long; + cdecl; + Thtons = function(hostshort: u_short): u_short; + cdecl; + Thtonl = function(hostlong: u_long): u_long; + cdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + cdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + cdecl; + TCloseSocket = function(s: TSocket): Integer; + cdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + cdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + cdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + cdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + cdecl; + + TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + cdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + cdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar; + hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer; + cdecl; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl; +function LSWSACleanup: Integer; cdecl; +function LSWSAGetLastError: Integer; cdecl; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: string; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and + (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and + (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.s_un_b.s_b1 = char($FF)); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s_un_b.s_b16 := char(1); +end; + +{=============================================================================} +var +{$IFNDEF FPC} + errno_loc: function: PInteger cdecl = nil; +{$ELSE} + errno_loc: function: PInteger = nil; cdecl; +{$ENDIF} + +function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Linux'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function LSWSACleanup: Integer; +begin + Result := 0; +end; + +function LSWSAGetLastError: Integer; +var + p: PInteger; +begin + p := errno_loc; + Result := p^; +end; + +function __FDELT(Socket: TSocket): Integer; +begin + Result := Socket div __NFDBITS; +end; + +function __FDMASK(Socket: TSocket): __fd_mask; +begin + Result := 1 shl (Socket mod __NFDBITS); +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket)); +end; + +procedure FD_ZERO(var fdset: TFDSet); +var + I: Integer; +begin + with fdset do + for I := Low(fds_bits) to High(fds_bits) do + fds_bits[I] := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: string; +var + s: string; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pchar(s), Length(s) - 1); + Result := Pchar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + Result := False; + SockEnhancedApi := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + errno_loc := GetProcAddress(LibHandle, PChar('__errno_location')); + CloseSocket := GetProcAddress(LibHandle, PChar('close')); + IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl')); + WSAGetLastError := LSWSAGetLastError; + WSAStartup := LSWSAStartup; + WSACleanup := LSWSACleanup; + ssAccept := GetProcAddress(LibHandle, PChar('accept')); + ssBind := GetProcAddress(LibHandle, PChar('bind')); + ssConnect := GetProcAddress(LibHandle, PChar('connect')); + ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); + ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname')); + GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); + Htonl := GetProcAddress(LibHandle, PChar('htonl')); + Htons := GetProcAddress(LibHandle, PChar('htons')); + Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); + Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); + Listen := GetProcAddress(LibHandle, PChar('listen')); + Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); + Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); + ssRecv := GetProcAddress(LibHandle, PChar('recv')); + ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); + Select := GetProcAddress(LibHandle, PChar('select')); + ssSend := GetProcAddress(LibHandle, PChar('send')); + ssSendTo := GetProcAddress(LibHandle, PChar('sendto')); + SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); + ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); + Socket := GetProcAddress(LibHandle, PChar('socket')); + GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); + GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); + GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); + GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); + GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); + GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); + ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname')); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); + FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); + GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/sswin32.pas b/sswin32.pas new file mode 100644 index 0000000..6964718 --- /dev/null +++ b/sswin32.pas @@ -0,0 +1,1234 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.001 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Win32 definition include | +|==============================================================================| +| Copyright (c)1999-2003, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF WIN32} + +//{$DEFINE WINSOCK1} +{Note about define WINSOCK1: +If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install update. +} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT '/* EDE 2003-02-19 */' *) + (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) + (*$HPPEMIT '#undef h_addr' *) + (*$HPPEMIT '#undef IOCPARM_MASK' *) + (*$HPPEMIT '#undef FD_SETSIZE' *) + (*$HPPEMIT '#undef IOC_VOID' *) + (*$HPPEMIT '#undef IOC_OUT' *) + (*$HPPEMIT '#undef IOC_IN' *) + (*$HPPEMIT '#undef IOC_INOUT' *) + (*$HPPEMIT '#undef FIONREAD' *) + (*$HPPEMIT '#undef FIONBIO' *) + (*$HPPEMIT '#undef FIOASYNC' *) + (*$HPPEMIT '#undef IPPROTO_IP' *) + (*$HPPEMIT '#undef IPPROTO_ICMP' *) + (*$HPPEMIT '#undef IPPROTO_IGMP' *) + (*$HPPEMIT '#undef IPPROTO_TCP' *) + (*$HPPEMIT '#undef IPPROTO_UDP' *) + (*$HPPEMIT '#undef IPPROTO_RAW' *) + (*$HPPEMIT '#undef IPPROTO_MAX' *) + (*$HPPEMIT '#undef INADDR_ANY' *) + (*$HPPEMIT '#undef INADDR_LOOPBACK' *) + (*$HPPEMIT '#undef INADDR_BROADCAST' *) + (*$HPPEMIT '#undef INADDR_NONE' *) + (*$HPPEMIT '#undef INVALID_SOCKET' *) + (*$HPPEMIT '#undef SOCKET_ERROR' *) + (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) + (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) + (*$HPPEMIT '#undef IP_OPTIONS' *) + (*$HPPEMIT '#undef IP_TOS' *) + (*$HPPEMIT '#undef IP_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_IF' *) + (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) + (*$HPPEMIT '#undef SOL_SOCKET' *) + (*$HPPEMIT '#undef SO_DEBUG' *) + (*$HPPEMIT '#undef SO_ACCEPTCONN' *) + (*$HPPEMIT '#undef SO_REUSEADDR' *) + (*$HPPEMIT '#undef SO_KEEPALIVE' *) + (*$HPPEMIT '#undef SO_DONTROUTE' *) + (*$HPPEMIT '#undef SO_BROADCAST' *) + (*$HPPEMIT '#undef SO_USELOOPBACK' *) + (*$HPPEMIT '#undef SO_LINGER' *) + (*$HPPEMIT '#undef SO_OOBINLINE' *) + (*$HPPEMIT '#undef SO_DONTLINGER' *) + (*$HPPEMIT '#undef SO_SNDBUF' *) + (*$HPPEMIT '#undef SO_RCVBUF' *) + (*$HPPEMIT '#undef SO_SNDLOWAT' *) + (*$HPPEMIT '#undef SO_RCVLOWAT' *) + (*$HPPEMIT '#undef SO_SNDTIMEO' *) + (*$HPPEMIT '#undef SO_RCVTIMEO' *) + (*$HPPEMIT '#undef SO_ERROR' *) + (*$HPPEMIT '#undef SO_OPENTYPE' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) + (*$HPPEMIT '#undef SO_MAXDG' *) + (*$HPPEMIT '#undef SO_MAXPATHDG' *) + (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) + (*$HPPEMIT '#undef SO_CONNECT_TIME' *) + (*$HPPEMIT '#undef SO_TYPE' *) + (*$HPPEMIT '#undef SOCK_STREAM' *) + (*$HPPEMIT '#undef SOCK_DGRAM' *) + (*$HPPEMIT '#undef SOCK_RAW' *) + (*$HPPEMIT '#undef SOCK_RDM' *) + (*$HPPEMIT '#undef SOCK_SEQPACKET' *) + (*$HPPEMIT '#undef TCP_NODELAY' *) + (*$HPPEMIT '#undef AF_UNSPEC' *) + (*$HPPEMIT '#undef SOMAXCONN' *) + (*$HPPEMIT '#undef AF_INET' *) + (*$HPPEMIT '#undef AF_MAX' *) + (*$HPPEMIT '#undef PF_UNSPEC' *) + (*$HPPEMIT '#undef PF_INET' *) + (*$HPPEMIT '#undef PF_MAX' *) + (*$HPPEMIT '#undef MSG_OOB' *) + (*$HPPEMIT '#undef MSG_PEEK' *) + (*$HPPEMIT '#undef WSABASEERR' *) + (*$HPPEMIT '#undef WSAEINTR' *) + (*$HPPEMIT '#undef WSAEBADF' *) + (*$HPPEMIT '#undef WSAEACCES' *) + (*$HPPEMIT '#undef WSAEFAULT' *) + (*$HPPEMIT '#undef WSAEINVAL' *) + (*$HPPEMIT '#undef WSAEMFILE' *) + (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) + (*$HPPEMIT '#undef WSAEINPROGRESS' *) + (*$HPPEMIT '#undef WSAEALREADY' *) + (*$HPPEMIT '#undef WSAENOTSOCK' *) + (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) + (*$HPPEMIT '#undef WSAEMSGSIZE' *) + (*$HPPEMIT '#undef WSAEPROTOTYPE' *) + (*$HPPEMIT '#undef WSAENOPROTOOPT' *) + (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) + (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) + (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEADDRINUSE' *) + (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) + (*$HPPEMIT '#undef WSAENETDOWN' *) + (*$HPPEMIT '#undef WSAENETUNREACH' *) + (*$HPPEMIT '#undef WSAENETRESET' *) + (*$HPPEMIT '#undef WSAECONNABORTED' *) + (*$HPPEMIT '#undef WSAECONNRESET' *) + (*$HPPEMIT '#undef WSAENOBUFS' *) + (*$HPPEMIT '#undef WSAEISCONN' *) + (*$HPPEMIT '#undef WSAENOTCONN' *) + (*$HPPEMIT '#undef WSAESHUTDOWN' *) + (*$HPPEMIT '#undef WSAETOOMANYREFS' *) + (*$HPPEMIT '#undef WSAETIMEDOUT' *) + (*$HPPEMIT '#undef WSAECONNREFUSED' *) + (*$HPPEMIT '#undef WSAELOOP' *) + (*$HPPEMIT '#undef WSAENAMETOOLONG' *) + (*$HPPEMIT '#undef WSAEHOSTDOWN' *) + (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) + (*$HPPEMIT '#undef WSAENOTEMPTY' *) + (*$HPPEMIT '#undef WSAEPROCLIM' *) + (*$HPPEMIT '#undef WSAEUSERS' *) + (*$HPPEMIT '#undef WSAEDQUOT' *) + (*$HPPEMIT '#undef WSAESTALE' *) + (*$HPPEMIT '#undef WSAEREMOTE' *) + (*$HPPEMIT '#undef WSASYSNOTREADY' *) + (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) + (*$HPPEMIT '#undef WSANOTINITIALISED' *) + (*$HPPEMIT '#undef WSAEDISCON' *) + (*$HPPEMIT '#undef WSAENOMORE' *) + (*$HPPEMIT '#undef WSAECANCELLED' *) + (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) + (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) + (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) + (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) + (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSA_E_NO_MORE' *) + (*$HPPEMIT '#undef WSA_E_CANCELLED' *) + (*$HPPEMIT '#undef WSAEREFUSED' *) + (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) + (*$HPPEMIT '#undef HOST_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATRY_AGAIN' *) + (*$HPPEMIT '#undef TRY_AGAIN' *) + (*$HPPEMIT '#undef WSANO_RECOVERY' *) + (*$HPPEMIT '#undef NO_RECOVERY' *) + (*$HPPEMIT '#undef WSANO_DATA' *) + (*$HPPEMIT '#undef NO_DATA' *) + (*$HPPEMIT '#undef WSANO_ADDRESS' *) + (*$HPPEMIT '#undef ENAMETOOLONG' *) + (*$HPPEMIT '#undef ENOTEMPTY' *) + (*$HPPEMIT '#undef FD_CLR' *) + (*$HPPEMIT '#undef FD_ISSET' *) + (*$HPPEMIT '#undef FD_SET' *) + (*$HPPEMIT '#undef FD_ZERO' *) + (*$HPPEMIT '#undef NO_ADDRESS' *) + (*$HPPEMIT '#undef ADDR_ANY' *) + (*$HPPEMIT '#undef SO_GROUP_ID' *) + (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) + (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) + (*$HPPEMIT '#undef PVD_CONFIG' *) + (*$HPPEMIT '#undef AF_INET6' *) + (*$HPPEMIT '#undef PF_INET6' *) +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, + Windows; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type + u_char = Char; + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + TSocket = u_int; + + TMemory = pointer; + +const + {$IFDEF WINSOCK1} + DLLStackName = 'wsock32.dll'; + {$ELSE} + DLLStackName = 'ws2_32.dll'; + {$ENDIF} + DLLwship6 = 'wship6.dll'; + +const + FD_SETSIZE = 64; +type + PFDSet = ^TFDSet; + TFDSet = packed record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = packed record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + SunB = packed record + s_b1, s_b2, s_b3, s_b4: u_char; + end; + + SunW = packed record + s_w1, s_w2: u_short; + end; + + PInAddr = ^TInAddr; + TInAddr = packed record + case integer of + 0: (S_un_b: SunB); + 1: (S_un_w: SunW); + 2: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = packed record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + 1: (sa_family: u_short; + sa_data: array[0..13] of Char) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + SunB6 = packed record + s_b1, s_b2, s_b3, s_b4, + s_b5, s_b6, s_b7, s_b8, + s_b9, s_b10, s_b11, s_b12, + s_b13, s_b14, s_b15, s_b16: u_char; + end; + + SunW6 = packed record + s_w1, s_w2, s_w3, s_w4, + s_w5, s_w6, s_w7, s_w8: u_short; + end; + + SunDW6 = packed record + s_dw1, s_dw2, s_dw3, s_dw4: longint; + end; + + S6_Bytes = SunB6; + S6_Words = SunW6; + S6_DWords = SunDW6; + S6_Addr = SunB6; + + PInAddr6 = ^TInAddr6; + TInAddr6 = packed record + case integer of + 0: (S_un_b: SunB6); + 1: (S_un_w: SunW6); + 2: (S_un_dw: SunDW6); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: u_long; // Interface index. + padding: u_long; + end; + + PHostEnt = ^THostEnt; + THostEnt = packed record + h_name: PChar; + h_aliases: ^PChar; + h_addrtype: Smallint; + h_length: Smallint; + case integer of + 0: (h_addr_list: ^PChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = packed record + n_name: PChar; + n_aliases: ^PChar; + n_addrtype: Smallint; + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = packed record + s_name: PChar; + s_aliases: ^PChar; + s_port: Smallint; + s_proto: PChar; + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = packed record + p_name: PChar; + p_aliases: ^Pchar; + p_proto: Smallint; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$IFDEF WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$ENDIF} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = packed record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: u_short; + l_linger: u_short; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + stdcall; + TWSACleanup = function: Integer; + stdcall; + TWSAGetLastError = function: Integer; + stdcall; + TGetServByName = function(name, proto: PChar): PServEnt; + stdcall; + TGetServByPort = function(port: Integer; proto: PChar): PServEnt; + stdcall; + TGetProtoByName = function(name: PChar): PProtoEnt; + stdcall; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + stdcall; + TGetHostByName = function(name: PChar): PHostEnt; + stdcall; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + stdcall; + TGetHostName = function(name: PChar; len: Integer): Integer; + stdcall; + TShutdown = function(s: TSocket; how: Integer): Integer; + stdcall; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + optlen: Integer): Integer; + stdcall; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar; + var optlen: Integer): Integer; + stdcall; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + stdcall; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + stdcall; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + stdcall; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + stdcall; + Tntohs = function(netshort: u_short): u_short; + stdcall; + Tntohl = function(netlong: u_long): u_long; + stdcall; + TListen = function(s: TSocket; backlog: Integer): Integer; + stdcall; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + stdcall; + TInet_ntoa = function(inaddr: TInAddr): PChar; + stdcall; + TInet_addr = function(cp: PChar): u_long; + stdcall; + Thtons = function(hostshort: u_short): u_short; + stdcall; + Thtonl = function(hostlong: u_long): u_long; + stdcall; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + stdcall; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + stdcall; + TCloseSocket = function(s: TSocket): Integer; + stdcall; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + stdcall; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + stdcall; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + stdcall; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + stdcall; + + TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + stdcall; + TFreeAddrInfo = procedure(ai: PAddrInfo); + stdcall; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar; + hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer; + stdcall; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + stdcall; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + stdcall; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; + CloseSocket: TCloseSocket = nil; + ssBind: TBind = nil; + ssAccept: TAccept = nil; + Socket: TTSocket = nil; + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: string; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and + (a^.s_un_dw.s_dw3 = 0) and + (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and + (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.s_un_b.s_b1 = char($FF)); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.s_un_b.s_b16 := char(1); +end; + +{=============================================================================} +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + I: Integer; +begin + I := 0; + while I < FDSet.fd_count do + begin + if FDSet.fd_array[I] = Socket then + begin + while I < FDSet.fd_count - 1 do + begin + FDSet.fd_array[I] := FDSet.fd_array[I + 1]; + Inc(I); + end; + Dec(FDSet.fd_count); + Break; + end; + Inc(I); + end; +end; + +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +begin + Result := __WSAFDIsSet(Socket, FDSet); +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin + if FDSet.fd_count < FD_SETSIZE then + begin + FDSet.fd_array[FDSet.fd_count] := Socket; + Inc(FDSet.fd_count); + end; +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: string; +var + s: string; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pchar(s), Length(s) - 1); + Result := Pchar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := ssAccept(s, @addr, x); +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + Result := False; + SockEnhancedApi := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin + WSAIoctl := GetProcAddress(LibHandle, PChar('WSAIoctl')); + __WSAFDIsSet := GetProcAddress(LibHandle, PChar('__WSAFDIsSet')); + CloseSocket := GetProcAddress(LibHandle, PChar('closesocket')); + IoctlSocket := GetProcAddress(LibHandle, PChar('ioctlsocket')); + WSAGetLastError := GetProcAddress(LibHandle, PChar('WSAGetLastError')); + WSAStartup := GetProcAddress(LibHandle, PChar('WSAStartup')); + WSACleanup := GetProcAddress(LibHandle, PChar('WSACleanup')); + ssAccept := GetProcAddress(LibHandle, PChar('accept')); + ssBind := GetProcAddress(LibHandle, PChar('bind')); + ssConnect := GetProcAddress(LibHandle, PChar('connect')); + ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); + ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname')); + GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); + Htonl := GetProcAddress(LibHandle, PChar('htonl')); + Htons := GetProcAddress(LibHandle, PChar('htons')); + Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); + Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); + Listen := GetProcAddress(LibHandle, PChar('listen')); + Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); + Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); + ssRecv := GetProcAddress(LibHandle, PChar('recv')); + ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); + Select := GetProcAddress(LibHandle, PChar('select')); + ssSend := GetProcAddress(LibHandle, PChar('send')); + ssSendTo := GetProcAddress(LibHandle, PChar('sendto')); + SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); + ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); + Socket := GetProcAddress(LibHandle, PChar('socket')); + GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); + GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); + GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); + GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); + GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); + GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); + ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname')); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); + FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); + GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + if not SockEnhancedApi then + begin + LibWship6Handle := LoadLibrary(PChar(DLLWship6)); + if LibWship6Handle <> 0 then + begin + GetAddrInfo := GetProcAddress(LibWship6Handle, PChar('getaddrinfo')); + FreeAddrInfo := GetProcAddress(LibWship6Handle, PChar('freeaddrinfo')); + GetNameInfo := GetProcAddress(LibWship6Handle, PChar('getnameinfo')); + SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + end; + end; +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; + +{$ENDIF} + diff --git a/synachar.pas b/synachar.pas index 165569b..2951890 100644 --- a/synachar.pas +++ b/synachar.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 004.000.008 | +| Project : Ararat Synapse | 005.000.001 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2000-2003. | +| Portions created by Lukas Gebauer are Copyright (c)2000-2004. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -42,6 +42,18 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{: @abstract(Charset conversion support) +This unit contains a routines for lot of charset conversions. + +It using built-in conversion tables or external Iconv library. Iconv is used + when needed conversion is known by Iconv library. When Iconv library is not + found or Iconv not know requested conversion, then are internal routines used + for conversion. (You can disable Iconv support from your program too!) + +Internal routines knows all major charsets for Europe or America. For East-Asian + charsets you must use Iconv library! +} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -53,15 +65,138 @@ unit synachar; interface type - TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, - ISO_8859_4, ISO_8859_5, ISO_8859_6, ISO_8859_7, - ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13, - ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, - CP1253, CP1254, CP1255, CP1256, CP1257, CP1258, - KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7); + {:Type with all supported charsets.} + TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, + ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13, + ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255, + CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7, + UTF_7mod, UCS_2LE, UCS_4LE, + //next is supported by Iconv only... + UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, + CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, + MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, + KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, + JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, + SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, + GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, + EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, + CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125); + {:Set of any charsets.} TMimeSetChar = set of TMimeChar; +const + {:Set of charsets supported by Iconv library only.} + IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE, + C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE, + MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8, + NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133, + TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212, + GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932, + ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030, + ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR, + CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858, + CP860, CP861, CP863, CP864, CP865, CP869, CP1125]; + + {:Set of charsets supported by internal routines only.} + NoIconvChars: set of TMimeChar = [CP895, UTF_7mod]; + + {:null character replace table. (Usable for disable charater replacing.)} + Replace_None: array[0..0] of Word = + (0); + + {:Character replace table for remove Czech diakritics.} + Replace_Czech: array[0..59] of Word = + ( + $00E1, $0061, + $010D, $0063, + $010F, $0064, + $010E, $0044, + $00E9, $0065, + $011B, $0065, + $00ED, $0069, + $0148, $006E, + $00F3, $006F, + $0159, $0072, + $0161, $0073, + $0165, $0074, + $00FA, $0075, + $016F, $0075, + $00FD, $0079, + $017E, $007A, + $00C1, $0041, + $010C, $0043, + $00C9, $0045, + $011A, $0045, + $00CD, $0049, + $0147, $004E, + $00D3, $004F, + $0158, $0052, + $0160, $0053, + $0164, $0054, + $00DA, $0055, + $016E, $0055, + $00DD, $0059, + $017D, $005A + ); + +var + {:By this you can generally disable/enable Iconv support.} + DisableIconv: Boolean = False; + +{==============================================================================} +{:Convert Value from one charset to another. See: @link(CharsetConversionEx)} +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. +see: @link(Replace_None) and @link(Replace_Czech)} +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; + +{:Convert Value from one charset to another with additional character conversion. + This funtion is similar to @link(CharsetConversionEx), but you can disable + transliteration of unconvertible characters.} +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; + +{:Returns charset used by operating system.} +function GetCurCP: TMimeChar; + +{:Returns charset used by operating system as OEM charset. (in Windows DOS box, + for example)} +function GetCurOEMCP: TMimeChar; + +{:Converting string with charset name to TMimeChar.} +function GetCPFromID(Value: AnsiString): TMimeChar; + +{:Converting TMimeChar to string with name of charset.} +function GetIDFromCP(Value: TMimeChar): AnsiString; + +{:return @true when value need to be converted. (It is not 7-bit ASCII)} +function NeedCharsetConversion(const Value: AnsiString): Boolean; + +{:Finding best target charset from set of TMimeChars with minimal count of + unconvertible characters.} +function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeSetChar): TMimeChar; + +{:Return BOM (Byte Order Mark) for given unicode charset.} +function GetBOM(Value: TMimeChar): AnsiString; + +{==============================================================================} +implementation + +uses +{$IFDEF LINUX} + Libc, +{$ELSE} + Windows, +{$ENDIF} + SysUtils, + synautil, synacode, synaicnv; + + //character transcoding tables X to UCS-2 { //dummy table @@ -555,7 +690,7 @@ const $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9 ); -{?? +{Vietnamese } CharCP_1258: array[128..255] of Word = ( @@ -643,78 +778,74 @@ const $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0 ); - // nothing fr replace - Replace_None: array[0..0] of Word = - (0); - - //remove diakritics from Czech - Replace_Czech: array[0..59] of Word = - ( - $00E1, $0061, - $010D, $0063, - $010F, $0064, - $010E, $0044, - $00E9, $0065, - $011B, $0065, - $00ED, $0069, - $0148, $006E, - $00F3, $006F, - $0159, $0072, - $0161, $0073, - $0165, $0074, - $00FA, $0075, - $016F, $0075, - $00FD, $0079, - $017E, $007A, - $00C1, $0041, - $010C, $0043, - $00C9, $0045, - $011A, $0045, - $00CD, $0049, - $0147, $004E, - $00D3, $004F, - $0158, $0052, - $0160, $0053, - $0164, $0054, - $00DA, $0055, - $016E, $0055, - $00DD, $0059, - $017D, $005A - ); - {==============================================================================} -function UTF8toUCS4(const Value: string): string; -function UCS4toUTF8(const Value: string): string; -function UTF7toUCS2(const Value: string): string; -function UCS2toUTF7(const Value: string): string; -function CharsetConversion(Value: string; CharFrom: TMimeChar; - CharTo: TMimeChar): string; -function CharsetConversionEx(Value: string; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word): string; -function GetCurCP: TMimeChar; -function GetCPFromID(Value: string): TMimeChar; -function GetIDFromCP(Value: TMimeChar): string; -function NeedCharsetConversion(const Value: string): Boolean; -function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar; - CharTo: TMimeSetChar): TMimeChar; - -implementation - -uses -{$IFDEF LINUX} - Libc, -{$ELSE} - Windows, -{$ENDIF} - SysUtils, - synautil, synacode; +type + TIconvChar = record + Charset: TMimeChar; + CharName: string; + end; + TIconvArr = array [0..112] of TIconvChar; const NotFoundChar = '_'; var - SetTwo: set of TMimeChar = [UCS_2, UTF_7]; - SetFour: set of TMimeChar = [UCS_4, UTF_8]; + SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod]; + SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8]; + SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE]; + + IconvArr: TIconvArr; + +{==============================================================================} +function FindIconvID(const Value, Charname: string): Boolean; +var + s: string; +begin + Result := True; + //exact match + if Value = Charname then + Exit; + //Value is on begin of charname + s := Value + ' '; + if s = Copy(Charname, 1, Length(s)) then + Exit; + //Value is on end of charname + s := ' ' + Value; + if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then + Exit; + //value is somewhere inside charname + if Pos( s + ' ', Charname) > 0 then + Exit; + Result := False; +end; + +function GetCPFromIconvID(Value: AnsiString): TMimeChar; +var + n: integer; +begin + Result := ISO_8859_1; + Value := UpperCase(Value); + for n := 0 to High(IconvArr) do + if FindIconvID(Value, IconvArr[n].Charname) then + begin + Result := IconvArr[n].Charset; + Break; + end; +end; + +{==============================================================================} +function GetIconvIDFromCP(Value: TMimeChar): AnsiString; +var + n: integer; +begin + Result := 'ISO-8859-1'; + for n := 0 to High(IconvArr) do + if IconvArr[n].Charset = Value then + begin + Result := Separateleft(IconvArr[n].Charname, ' '); + Break; + end; +end; {==============================================================================} function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word; @@ -746,8 +877,6 @@ end; procedure GetArray(CharSet: TMimeChar; var Result: array of Word); begin case CharSet of - ISO_8859_1: - CopyArray(CharISO_8859_1, Result); ISO_8859_2: CopyArray(CharISO_8859_2, Result); ISO_8859_3: @@ -796,12 +925,14 @@ begin CopyArray(CharCP_895, Result); CP852: CopyArray(CharCP_852, Result); + else + CopyArray(CharISO_8859_1, Result); end; end; {==============================================================================} -procedure ReadMulti(const Value: string; var Index: Integer; mb: Byte; - var b1, b2, b3, b4: Byte); +procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; + var b1, b2, b3, b4: Byte; le: boolean); Begin b1 := 0; b2 := 0; @@ -813,67 +944,115 @@ Begin mb := 1; if (Index + mb - 1) <= Length(Value) then begin - Case mb Of - 1: - b1 := Ord(Value[Index]); - 2: - Begin + if le then + Case mb Of + 1: b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - End; - 3: - Begin + 2: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + End; + 3: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + End; + 4: + Begin + b1 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b3 := Ord(Value[Index + 2]); + b4 := Ord(Value[Index + 3]); + End; + end + else + Case mb Of + 1: b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - b3 := Ord(Value[Index + 2]); - End; - 4: - Begin - b1 := Ord(Value[Index]); - b2 := Ord(Value[Index + 1]); - b3 := Ord(Value[Index + 2]); - b4 := Ord(Value[Index + 3]); - End; - end; + 2: + Begin + b2 := Ord(Value[Index]); + b1 := Ord(Value[Index + 1]); + End; + 3: + Begin + b3 := Ord(Value[Index]); + b2 := Ord(Value[Index + 1]); + b1 := Ord(Value[Index + 2]); + End; + 4: + Begin + b4 := Ord(Value[Index]); + b3 := Ord(Value[Index + 1]); + b2 := Ord(Value[Index + 2]); + b1 := Ord(Value[Index + 3]); + End; + end; Inc(Index, mb); End; End; {==============================================================================} -function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte): string; +function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString; begin if mb > 4 then mb := 1; SetLength(Result, mb); - case mb Of - 1: - Result[1] := Char(b1); - 2: - begin - Result[1] := Char(b1); - Result[2] := Char(b2); - end; - 3: - begin - Result[1] := Char(b1); - Result[2] := Char(b2); - Result[3] := Char(b3); - end; - 4: - begin - Result[1] := Char(b1); - Result[2] := Char(b2); - Result[3] := Char(b3); - Result[4] := Char(b4); - end; - end; + if le then + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + end; + 3: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + end; + 4: + begin + Result[1] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[3] := AnsiChar(b3); + Result[4] := AnsiChar(b4); + end; + end + else + case mb Of + 1: + Result[1] := AnsiChar(b1); + 2: + begin + Result[2] := AnsiChar(b1); + Result[1] := AnsiChar(b2); + end; + 3: + begin + Result[3] := AnsiChar(b1); + Result[2] := AnsiChar(b2); + Result[1] := AnsiChar(b3); + end; + 4: + begin + Result[4] := AnsiChar(b1); + Result[3] := AnsiChar(b2); + Result[2] := AnsiChar(b3); + Result[1] := AnsiChar(b4); + end; + end; end; {==============================================================================} -function UTF8toUCS4(const Value: string): string; +function UTF8toUCS4(const Value: AnsiString): AnsiString; var n, x, ul, m: Integer; - s: string; + s: AnsiString; w1, w2: Word; begin Result := ''; @@ -883,7 +1062,7 @@ begin x := Ord(Value[n]); Inc(n); if x < 128 then - Result := Result + WriteMulti(x, 0, 0, 0, 4) + Result := Result + WriteMulti(x, 0, 0, 0, 4, false) else begin m := 0; @@ -914,15 +1093,15 @@ begin ul := BinToInt(s); w1 := ul div 65536; w2 := ul mod 65536; - Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4); + Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false); end; end; end; {==============================================================================} -function UCS4toUTF8(const Value: string): string; +function UCS4toUTF8(const Value: AnsiString): AnsiString; var - s, l, k: string; + s, l, k: AnsiString; b1, b2, b3, b4: Byte; n, m, x, y: Integer; b: Byte; @@ -931,9 +1110,9 @@ begin n := 1; while Length(Value) >= n do begin - ReadMulti(Value, n, 4, b1, b2, b3, b4); + ReadMulti(Value, n, 4, b1, b2, b3, b4, false); if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then - Result := Result + Char(b1) + Result := Result + AnsiChar(b1) else begin x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536; @@ -945,7 +1124,7 @@ begin k := Copy(l, Length(l) - 5, 6); l := Copy(l, 1, Length(l) - 6); b := BinToInt(k) or $80; - s := Char(b) + s; + s := AnsiChar(b) + s; end; b := BinToInt(l); case y of @@ -960,27 +1139,39 @@ begin 1: b := b or $C0; end; - s := Char(b) + s; + s := AnsiChar(b) + s; Result := Result + s; end; end; end; {==============================================================================} -function UTF7toUCS2(const Value: string): string; +function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString; var n, i: Integer; - c: Char; - s, t: string; + c: AnsiChar; + s, t: AnsiString; + shift: AnsiChar; + table: String; begin Result := ''; n := 1; + if modified then + begin + shift := '&'; + table := TableBase64mod; + end + else + begin + shift := '+'; + table := TableBase64; + end; while Length(Value) >= n do begin c := Value[n]; Inc(n); - if c <> '+' then - Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2) + if c <> shift then + Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false) else begin s := ''; @@ -990,7 +1181,7 @@ begin Inc(n); if c = '-' then Break; - if (c = '=') or (Pos(c, TableBase64) < 1) then + if (c = '=') or (Pos(c, table) < 1) then begin Dec(n); Break; @@ -998,18 +1189,21 @@ begin s := s + c; end; if s = '' then - s := WriteMulti(Ord('+'), 0, 0, 0, 2) + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false) else begin - t := DecodeBase64(s); + if modified then + t := DecodeBase64mod(s) + else + t := DecodeBase64(s); if not odd(length(t)) then s := t else begin //ill-formed sequence t := s; - s := WriteMulti(Ord('+'), 0, 0, 0, 2); + s := WriteMulti(Ord(shift), 0, 0, 0, 2, false); for i := 1 to length(t) do - s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2); + s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false); end; end; Result := Result + s; @@ -1018,54 +1212,69 @@ begin end; {==============================================================================} -function UCS2toUTF7(const Value: string): string; +function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString; var - s: string; + s: AnsiString; b1, b2, b3, b4: Byte; n, m: Integer; + shift: AnsiChar; begin Result := ''; n := 1; + if modified then + shift := '&' + else + shift := '+'; while Length(Value) >= n do begin - ReadMulti(Value, n, 2, b1, b2, b3, b4); + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); if (b2 = 0) and (b1 < 128) then - if Char(b1) = '+' then - Result := Result + '+-' + if AnsiChar(b1) = shift then + Result := Result + shift + '-' else - Result := Result + Char(b1) + Result := Result + AnsiChar(b1) else begin - s := Char(b2) + Char(b1); + s := AnsiChar(b2) + AnsiChar(b1); while Length(Value) >= n do begin - ReadMulti(Value, n, 2, b1, b2, b3, b4); + ReadMulti(Value, n, 2, b1, b2, b3, b4, false); if (b2 = 0) and (b1 < 128) then begin Dec(n, 2); Break; end; - s := s + Char(b2) + Char(b1); + s := s + AnsiChar(b2) + AnsiChar(b1); end; - s := EncodeBase64(s); + if modified then + s := EncodeBase64mod(s) + else + s := EncodeBase64(s); m := Pos('=', s); if m > 0 then s := Copy(s, 1, m - 1); - Result := Result + '+' + s + '-'; + Result := Result + shift + s + '-'; end; end; end; {==============================================================================} -function CharsetConversion(Value: string; CharFrom: TMimeChar; - CharTo: TMimeChar): string; +function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar): AnsiString; begin Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None); end; {==============================================================================} -function CharsetConversionEx(Value: string; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word): string; +function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word): AnsiString; +begin + Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True); +end; + +{==============================================================================} +function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; + CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; var uni: Word; n, m: Integer; @@ -1073,71 +1282,177 @@ var b1, b2, b3, b4: Byte; SourceTable, TargetTable: array[128..255] of Word; mbf, mbt: Byte; + lef, let: Boolean; + ucsstring, s, t: AnsiString; + cd: iconv_t; + f: Boolean; + NotNeedTransform: Boolean; + FromID, ToID: string; begin - GetArray(CharFrom, SourceTable); - GetArray(CharTo, TargetTable); - mbf := 1; - if CharFrom in SetTwo then - mbf := 2; - if CharFrom in SetFour then - mbf := 4; - mbt := 1; - if CharTo in SetTwo then - mbt := 2; - if CharTo in SetFour then - mbt := 4; - - if CharFrom = UTF_8 then - Value := UTF8toUCS4(Value); - if CharFrom = UTF_7 then - Value := UTF7toUCS2(Value); - Result := ''; - - n := 1; - while Length(Value) >= n do + NotNeedTransform := (High(TransformTable) = 0); + if (CharFrom = CharTo) and NotNeedTransform then begin - ReadMulti(Value, n, mbf, b1, b2, b3, b4); - if mbf = 1 then - if b1 > 127 then + Result := Value; + Exit; + end; + FromID := GetIDFromCP(CharFrom); + ToID := GetIDFromCP(CharTo); + cd := Iconv_t(-1); + //do two-pass conversion. Transform to UCS-2 first. + if CharFrom = UCS_2 then + ucsstring := Value + else + begin + if not DisableIconv then + cd := SynaIconvOpenIgnore('UCS-2BE', FromID); + try + if cd <> iconv_t(-1) then + SynaIconv(cd, Value, ucsstring) + else begin - uni := SourceTable[b1]; - uni := ReplaceUnicode(uni, TransformTable); - b1 := Lo(uni); - b2 := Hi(uni); + s := Value; + if CharFrom = UTF_8 then + s := UTF8toUCS4(Value) + else + if CharFrom = UTF_7 then + s := UTF7toUCS2(Value, False) + else + if CharFrom = UTF_7mod then + s := UTF7toUCS2(Value, True); + GetArray(CharFrom, SourceTable); + mbf := 1; + if CharFrom in SetTwo then + mbf := 2; + if CharFrom in SetFour then + mbf := 4; + lef := CharFrom in SetLe; + ucsstring := ''; + n := 1; + while Length(s) >= n do + begin + ReadMulti(s, n, mbf, b1, b2, b3, b4, lef); + //handle BOM + if (b3 = 0) and (b4 = 0) then + begin + if (b1 = $FE) and (b2 = $FF) then + begin + lef := not lef; + continue; + end; + if (b1 = $FF) and (b2 = $FE) then + continue; + end; + if mbf = 1 then + if b1 > 127 then + begin + uni := SourceTable[b1]; + b1 := Lo(uni); + b2 := Hi(uni); + end; + ucsstring := ucsstring + WriteMulti(b1, b2, b3, b4, 2, False); + end; end; - // b1..b4 - Unicode Char - uni := b2 * 256 + b1; - if (b3 <> 0) or (b4 <> 0) then + finally + SynaIconvClose(cd); + end; + end; + //here we allways have ucstring with UCS-2 encoding + //second pass... from UCS-2 to target encoding. + if not DisableIconv then + if translit then + cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE') + else + cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE'); + try + if (cd <> iconv_t(-1)) and NotNeedTransform then begin - b1 := Ord(NotFoundChar); - b2 := 0; - b3 := 0; - b4 := 0; + if CharTo = UTF_7 then + ucsstring := ucsstring + #0 + '-'; + //when transformtable is not needed and Iconv know target charset, + //do it fast by one call. + SynaIconv(cd, ucsstring, Result); + if CharTo = UTF_7 then + Delete(Result, Length(Result), 1); end else - if mbt = 1 then - if uni > 127 then + begin + GetArray(CharTo, TargetTable); + mbt := 1; + if CharTo in SetTwo then + mbt := 2; + if CharTo in SetFour then + mbt := 4; + let := CharTo in SetLe; + b3 := 0; + b4 := 0; + Result := ''; + for n:= 0 to (Length(ucsstring) div 2) - 1 do + begin + s := Copy(ucsstring, n * 2 + 1, 2); + b2 := Ord(s[1]); + b1 := Ord(s[2]); + uni := b2 * 256 + b1; + if not NotNeedTransform then begin - b := Ord(NotFoundChar); - for m := 128 to 255 do - if TargetTable[m] = uni then - begin - b := m; - Break; - end; - b1 := b; - b2 := 0; + uni := ReplaceUnicode(uni, TransformTable); + b1 := Lo(uni); + b2 := Hi(uni); + s[1] := AnsiChar(b2); + s[2] := AnsiChar(b1); + end; + if cd <> iconv_t(-1) then + begin + if CharTo = UTF_7 then + s := s + #0 + '-'; + SynaIconv(cd, s, t); + if CharTo = UTF_7 then + Delete(t, Length(t), 1); + Result := Result + t; end else - b1 := Lo(uni); - Result := Result + WriteMulti(b1, b2, b3, b4, mbt) + begin + f := True; + if mbt = 1 then + if uni > 127 then + begin + f := False; + b := 0; + for m := 128 to 255 do + if TargetTable[m] = uni then + begin + b := m; + f := True; + Break; + end; + b1 := b; + b2 := 0; + end + else + b1 := Lo(uni); + if not f then + if translit then + begin + b1 := Ord(NotFoundChar); + b2 := 0; + f := True; + end; + if f then + Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let) + end; + end; + if cd = iconv_t(-1) then + begin + if CharTo = UTF_7 then + Result := UCS2toUTF7(Result, false); + if CharTo = UTF_7mod then + Result := UCS2toUTF7(Result, true); + if CharTo = UTF_8 then + Result := UCS4toUTF8(Result); + end; + end; + finally + SynaIconvClose(cd); end; - - if CharTo = UTF_7 then - Result := UCS2toUTF7(Result); - if CharTo = UTF_8 then - Result := UCS4toUTF8(Result); - end; {==============================================================================} @@ -1148,11 +1463,62 @@ begin Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); end; +function GetCurOEMCP: TMimeChar; +begin + Result := GetCurCP; +end; + {$ELSE} -function GetCurCP: TMimeChar; +function CPToMimeChar(Value: Integer): TMimeChar; begin - case GetACP of + case Value of + 437, 850, 20127: + Result := ISO_8859_1; //I know, it is not ideal! + 737: + Result := CP737; + 775: + Result := CP775; + 852: + Result := CP852; + 855: + Result := CP855; + 857: + Result := CP857; + 858: + Result := CP858; + 860: + Result := CP860; + 861: + Result := CP861; + 862: + Result := CP862; + 863: + Result := CP863; + 864: + Result := CP864; + 865: + Result := CP865; + 866: + Result := CP866; + 869: + Result := CP869; + 874: + Result := ISO_8859_15; + 895: + Result := CP895; + 932: + Result := CP932; + 936: + Result := CP936; + 949: + Result := CP949; + 950: + Result := CP950; + 1200: + Result := UCS_2LE; + 1201: + Result := UCS_2; 1250: Result := CP1250; 1251: @@ -1169,179 +1535,116 @@ begin Result := CP1257; 1258: Result := CP1258; + 1361: + Result := CP1361; + 10000: + Result := MAC; + 10004: + Result := MACAR; + 10005: + Result := MACHEB; + 10006: + Result := MACGR; + 10007: + Result := MACCYR; + 10010: + Result := MACRO; + 10017: + Result := MACUK; + 10021: + Result := MACTH; + 10029: + Result := MACCE; + 10079: + Result := MACICE; + 10081: + Result := MACTU; + 10082: + Result := MACCRO; + 12000: + Result := UCS_4LE; + 12001: + Result := UCS_4; + 20866: + Result := KOI8_R; + 20932: + Result := JIS_X0208; + 20936: + Result := GB2312; + 21866: + Result := KOI8_U; + 28591: + Result := ISO_8859_1; + 28592: + Result := ISO_8859_2; + 28593: + Result := ISO_8859_3; + 28594: + Result := ISO_8859_4; + 28595: + Result := ISO_8859_5; + 28596, 708: + Result := ISO_8859_6; + 28597: + Result := ISO_8859_7; + 28598, 38598: + Result := ISO_8859_8; + 28599: + Result := ISO_8859_9; + 28605: + Result := ISO_8859_15; + 50220: + Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana + 50221: + Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana + 50222: + Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989 + 50225: + Result := ISO_2022_KR; + 50227: + Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese + 50229: + Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese + 51932: + Result := EUC_JP; + 51936: + Result := GB2312; + 51949: + Result := EUC_KR; + 52936: + Result := HZ; + 54936: + Result := GB18030; + 65000: + Result := UTF_7; + 65001: + Result := UTF_8; + 0: + Result := UCS_2LE; else Result := CP1252; end; end; +function GetCurCP: TMimeChar; +begin + Result := CPToMimeChar(GetACP); +end; + +function GetCurOEMCP: TMimeChar; +begin + Result := CPToMimeChar(GetOEMCP); +end; {$ENDIF} {==============================================================================} -function GetCPFromID(Value: string): TMimeChar; -begin - Value := UpperCase(Value); - Result := ISO_8859_1; - if Pos('ISO-8859-10', Value) = 1 then - Result := ISO_8859_10 - else - if Pos('ISO-8859-13', Value) = 1 then - Result := ISO_8859_13 - else - if Pos('ISO-8859-14', Value) = 1 then - Result := ISO_8859_14 - else - if Pos('ISO-8859-15', Value) = 1 then - Result := ISO_8859_15 - else - if Pos('ISO-8859-2', Value) = 1 then - Result := ISO_8859_2 - else - if Pos('ISO-8859-3', Value) = 1 then - Result := ISO_8859_3 - else - if Pos('ISO-8859-4', Value) = 1 then - Result := ISO_8859_4 - else - if Pos('ISO-8859-5', Value) = 1 then - Result := ISO_8859_5 - else - if Pos('ISO-8859-6', Value) = 1 then - Result := ISO_8859_6 - else - if Pos('ISO-8859-7', Value) = 1 then - Result := ISO_8859_7 - else - if Pos('ISO-8859-8', Value) = 1 then - Result := ISO_8859_8 - else - if Pos('ISO-8859-9', Value) = 1 then - Result := ISO_8859_9 - else - if (Pos('WINDOWS-1250', Value) = 1) or (Pos('X-CP1250', Value) = 1) then - Result := CP1250 - else - if (Pos('WINDOWS-1251', Value) = 1) or (Pos('X-CP1251', Value) = 1) then - Result := CP1251 - else - if (Pos('WINDOWS-1252', Value) = 1) or (Pos('X-CP1252', Value) = 1) then - Result := CP1252 - else - if (Pos('WINDOWS-1253', Value) = 1) or (Pos('X-CP1253', Value) = 1) then - Result := CP1253 - else - if (Pos('WINDOWS-1254', Value) = 1) or (Pos('X-CP1254', Value) = 1) then - Result := CP1254 - else - if (Pos('WINDOWS-1255', Value) = 1) or (Pos('X-CP1255', Value) = 1) then - Result := CP1255 - else - if (Pos('WINDOWS-1256', Value) = 1) or (Pos('X-CP1256', Value) = 1) then - Result := CP1256 - else - if (Pos('WINDOWS-1257', Value) = 1) or (Pos('X-CP1257', Value) = 1) then - Result := CP1257 - else - if (Pos('WINDOWS-1258', Value) = 1) or (Pos('X-CP1258', Value) = 1) then - Result := CP1258 - else - if Pos('KOI8-R', Value) = 1 then - Result := KOI8_R - else - if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then - Result := CP895 - else - if (Pos('LATIN-2', Value) > 0) or (Pos('852', Value) > 0) then - Result := CP852 - else - if Pos('UTF-7', Value) = 1 then - Result := UTF_7 - else - if Pos('UTF-8', Value) > 0 then - Result := UTF_8 - else - if Pos('UCS-4', Value) > 0 then - Result := UCS_4 - else - if Pos('UCS-2', Value) > 0 then - Result := UCS_2 - else - if Pos('UNICODE', Value) = 1 then - Result := UCS_2 -end; - -{==============================================================================} -function GetIDFromCP(Value: TMimeChar): string; -begin - case Value of - ISO_8859_2: - Result := 'ISO-8859-2'; - ISO_8859_3: - Result := 'ISO-8859-3'; - ISO_8859_4: - Result := 'ISO-8859-4'; - ISO_8859_5: - Result := 'ISO-8859-5'; - ISO_8859_6: - Result := 'ISO-8859-6'; - ISO_8859_7: - Result := 'ISO-8859-7'; - ISO_8859_8: - Result := 'ISO-8859-8'; - ISO_8859_9: - Result := 'ISO-8859-9'; - ISO_8859_10: - Result := 'ISO-8859-10'; - ISO_8859_13: - Result := 'ISO-8859-13'; - ISO_8859_14: - Result := 'ISO-8859-14'; - ISO_8859_15: - Result := 'ISO-8859-15'; - CP1250: - Result := 'WINDOWS-1250'; - CP1251: - Result := 'WINDOWS-1251'; - CP1252: - Result := 'WINDOWS-1252'; - CP1253: - Result := 'WINDOWS-1253'; - CP1254: - Result := 'WINDOWS-1254'; - CP1255: - Result := 'WINDOWS-1255'; - CP1256: - Result := 'WINDOWS-1256'; - CP1257: - Result := 'WINDOWS-1257'; - CP1258: - Result := 'WINDOWS-1258'; - KOI8_R: - Result := 'KOI8-R'; - CP895: - Result := 'CP-895'; - CP852: - Result := 'CP-852'; - UCS_2: - Result := 'Unicode-1-1-UCS-2'; - UCS_4: - Result := 'Unicode-1-1-UCS-4'; - UTF_8: - Result := 'UTF-8'; - UTF_7: - Result := 'UTF-7'; - else - Result := 'ISO-8859-1'; - end; -end; - -{==============================================================================} -function NeedCharsetConversion(const Value: string): Boolean; +function NeedCharsetConversion(const Value: AnsiString): Boolean; var n: Integer; begin Result := False; for n := 1 to Length(Value) do - if Ord(Value[n]) > 127 then + if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then begin Result := True; Break; @@ -1349,35 +1652,311 @@ begin end; {==============================================================================} -function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar; +function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; CharTo: TMimeSetChar): TMimeChar; var - n, m: Integer; - min, x: Integer; - s, t: string; + n: Integer; + max: Integer; + s, t, u: AnsiString; + CharSet: TMimeChar; begin Result := ISO_8859_1; - s := ''; - for n := 1 to Length(Value) do - if Ord(Value[n]) > 127 then - s := s + Value[n]; - min := 128; + s := Copy(Value, 1, 1024); //max first 1KB for next procedure + max := 0; for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do - if TMimeChar(n) in CharTo then + begin + CharSet := TMimeChar(n); + if CharSet in CharTo then begin - t := CharsetConversion(s, CharFrom, TMimeChar(n)); - x := 0; - for m := 1 to Length(t) do - if t[m] = NotFoundChar then - Inc(x); - if x < min then + t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False); + u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False); + if s = u then begin - min := x; - Result := TMimeChar(n); - if x = 0 then - Break; + Result := CharSet; + Exit; + end; + if Length(u) > max then + begin + Result := CharSet; + max := Length(u); end; end; + end; +end; + +{==============================================================================} +function GetBOM(Value: TMimeChar): AnsiString; +begin + Result := ''; + case Value of + UCS_2: + Result := #$fe + #$ff; + UCS_4: + Result := #$00 + #$00 + #$fe + #$ff; + UCS_2LE: + Result := #$ff + #$fe; + UCS_4LE: + Result := #$ff + #$fe + #$00 + #$00; + UTF_8: + Result := #$ef + #$bb + #$bf; + end; +end; + +{==============================================================================} +function GetCPFromID(Value: AnsiString): TMimeChar; +begin + Value := UpperCase(Value); + if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then + Result := CP895 + else + if Pos('MUTF-7', Value) > 0 then + Result := UTF_7mod + else + Result := GetCPFromIconvID(Value); +end; + +{==============================================================================} +function GetIDFromCP(Value: TMimeChar): AnsiString; +begin + case Value of + CP895: + Result := 'CP-895'; + UTF_7mod: + Result := 'mUTF-7'; + else + Result := GetIconvIDFromCP(Value); + end; +end; + +{==============================================================================} +initialization +begin + IconvArr[0].Charset := ISO_8859_1; + IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1'; + IconvArr[1].Charset := UTF_8; + IconvArr[1].Charname := 'UTF-8'; + IconvArr[2].Charset := UCS_2; + IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE'; + IconvArr[3].Charset := UCS_2; + IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11'; + IconvArr[4].Charset := UCS_2LE; + IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE'; + IconvArr[5].Charset := UCS_4; + IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4'; + IconvArr[6].Charset := UCS_4; + IconvArr[6].Charname := 'UCS-4BE'; + IconvArr[7].Charset := UCS_2LE; + IconvArr[7].Charname := 'UCS-4LE'; + IconvArr[8].Charset := UTF_16; + IconvArr[8].Charname := 'UTF-16'; + IconvArr[9].Charset := UTF_16; + IconvArr[9].Charname := 'UTF-16BE'; + IconvArr[10].Charset := UTF_16LE; + IconvArr[10].Charname := 'UTF-16LE'; + IconvArr[11].Charset := UTF_32; + IconvArr[11].Charname := 'UTF-32'; + IconvArr[12].Charset := UTF_32; + IconvArr[12].Charname := 'UTF-32BE'; + IconvArr[13].Charset := UTF_32; + IconvArr[13].Charname := 'UTF-32LE'; + IconvArr[14].Charset := UTF_7; + IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7'; + IconvArr[15].Charset := C99; + IconvArr[15].Charname := 'C99'; + IconvArr[16].Charset := JAVA; + IconvArr[16].Charname := 'JAVA'; + IconvArr[17].Charset := ISO_8859_1; + IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII'; + IconvArr[18].Charset := ISO_8859_2; + IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2'; + IconvArr[19].Charset := ISO_8859_3; + IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3'; + IconvArr[20].Charset := ISO_8859_4; + IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4'; + IconvArr[21].Charset := ISO_8859_5; + IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC'; + IconvArr[22].Charset := ISO_8859_6; + IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC'; + IconvArr[23].Charset := ISO_8859_7; + IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK'; + IconvArr[24].Charset := ISO_8859_8; + IconvArr[24].Charname := 'ISO_8859-8 HEBREW ISO-8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW'; + IconvArr[25].Charset := ISO_8859_9; + IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5'; + IconvArr[26].Charset := ISO_8859_10; + IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6'; + IconvArr[27].Charset := ISO_8859_13; + IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7'; + IconvArr[28].Charset := ISO_8859_14; + IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8'; + IconvArr[29].Charset := ISO_8859_15; + IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998'; + IconvArr[30].Charset := ISO_8859_16; + IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000'; + IconvArr[31].Charset := KOI8_R; + IconvArr[31].Charname := 'KOI8-R CSKOI8R'; + IconvArr[32].Charset := KOI8_U; + IconvArr[32].Charname := 'KOI8-U'; + IconvArr[33].Charset := KOI8_RU; + IconvArr[33].Charname := 'KOI8-RU'; + IconvArr[34].Charset := CP1250; + IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE'; + IconvArr[35].Charset := CP1251; + IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL'; + IconvArr[36].Charset := CP1252; + IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI'; + IconvArr[37].Charset := CP1253; + IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK'; + IconvArr[38].Charset := CP1254; + IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK'; + IconvArr[39].Charset := CP1255; + IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR'; + IconvArr[40].Charset := CP1256; + IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB'; + IconvArr[41].Charset := CP1257; + IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM'; + IconvArr[42].Charset := CP1258; + IconvArr[42].Charname := 'WINDOWS-1258 CP1258'; + IconvArr[43].Charset := ISO_8859_1; + IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL'; + IconvArr[44].Charset := CP862; + IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW'; + IconvArr[45].Charset := CP866; + IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866'; + IconvArr[46].Charset := MAC; + IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH'; + IconvArr[47].Charset := MACCE; + IconvArr[47].Charname := 'MACCENTRALEUROPE'; + IconvArr[48].Charset := MACICE; + IconvArr[48].Charname := 'MACICELAND'; + IconvArr[49].Charset := MACCRO; + IconvArr[49].Charname := 'MACCROATIAN'; + IconvArr[50].Charset := MACRO; + IconvArr[50].Charname := 'MACROMANIA'; + IconvArr[51].Charset := MACCYR; + IconvArr[51].Charname := 'MACCYRILLIC'; + IconvArr[52].Charset := MACUK; + IconvArr[52].Charname := 'MACUKRAINE'; + IconvArr[53].Charset := MACGR; + IconvArr[53].Charname := 'MACGREEK'; + IconvArr[54].Charset := MACTU; + IconvArr[54].Charname := 'MACTURKISH'; + IconvArr[55].Charset := MACHEB; + IconvArr[55].Charname := 'MACHEBREW'; + IconvArr[56].Charset := MACAR; + IconvArr[56].Charname := 'MACARABIC'; + IconvArr[57].Charset := MACTH; + IconvArr[57].Charname := 'MACTHAI'; + IconvArr[58].Charset := ROMAN8; + IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8'; + IconvArr[59].Charset := NEXTSTEP; + IconvArr[59].Charname := 'NEXTSTEP'; + IconvArr[60].Charset := ARMASCII; + IconvArr[60].Charname := 'ARMSCII-8'; + IconvArr[61].Charset := GEORGIAN_AC; + IconvArr[61].Charname := 'GEORGIAN-ACADEMY'; + IconvArr[62].Charset := GEORGIAN_PS; + IconvArr[62].Charname := 'GEORGIAN-PS'; + IconvArr[63].Charset := KOI8_T; + IconvArr[63].Charname := 'KOI8-T'; + IconvArr[64].Charset := MULELAO; + IconvArr[64].Charname := 'MULELAO-1'; + IconvArr[65].Charset := CP1133; + IconvArr[65].Charname := 'CP1133 IBM-CP1133'; + IconvArr[66].Charset := TIS620; + IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1'; + IconvArr[67].Charset := CP874; + IconvArr[67].Charname := 'CP874 WINDOWS-874'; + IconvArr[68].Charset := VISCII; + IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII'; + IconvArr[69].Charset := TCVN; + IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993'; + IconvArr[70].Charset := ISO_IR_14; + IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO'; + IconvArr[71].Charset := JIS_X0201; + IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA'; + IconvArr[72].Charset := JIS_X0208; + IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208'; + IconvArr[73].Charset := JIS_X0212; + IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990'; + IconvArr[74].Charset := GB1988_80; + IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988'; + IconvArr[75].Charset := GB2312_80; + IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280'; + IconvArr[76].Charset := ISO_IR_165; + IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165'; + IconvArr[77].Charset := ISO_IR_149; + IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987'; + IconvArr[78].Charset := EUC_JP; + IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE'; + IconvArr[79].Charset := SHIFT_JIS; + IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS'; + IconvArr[80].Charset := CP932; + IconvArr[80].Charname := 'CP932'; + IconvArr[81].Charset := ISO_2022_JP; + IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP'; + IconvArr[82].Charset := ISO_2022_JP1; + IconvArr[82].Charname := 'ISO-2022-JP-1'; + IconvArr[83].Charset := ISO_2022_JP2; + IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2'; + IconvArr[84].Charset := GB2312; + IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312'; + IconvArr[85].Charset := CP936; + IconvArr[85].Charname := 'CP936 GBK'; + IconvArr[86].Charset := GB18030; + IconvArr[86].Charname := 'GB18030'; + IconvArr[87].Charset := ISO_2022_CN; + IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN'; + IconvArr[88].Charset := ISO_2022_CNE; + IconvArr[88].Charname := 'ISO-2022-CN-EXT'; + IconvArr[89].Charset := HZ; + IconvArr[89].Charname := 'HZ HZ-GB-2312'; + IconvArr[90].Charset := EUC_TW; + IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW'; + IconvArr[91].Charset := BIG5; + IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5'; + IconvArr[92].Charset := CP950; + IconvArr[92].Charname := 'CP950'; + IconvArr[93].Charset := BIG5_HKSCS; + IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS'; + IconvArr[94].Charset := EUC_KR; + IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR'; + IconvArr[95].Charset := CP949; + IconvArr[95].Charname := 'CP949 UHC'; + IconvArr[96].Charset := CP1361; + IconvArr[96].Charname := 'CP1361 JOHAB'; + IconvArr[97].Charset := ISO_2022_KR; + IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR'; + IconvArr[98].Charset := ISO_8859_1; + IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437'; + IconvArr[99].Charset := CP737; + IconvArr[99].Charname := 'CP737'; + IconvArr[100].Charset := CP775; + IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC'; + IconvArr[101].Charset := CP852; + IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852'; + IconvArr[102].Charset := CP853; + IconvArr[102].Charname := 'CP853'; + IconvArr[103].Charset := CP855; + IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855'; + IconvArr[104].Charset := CP857; + IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857'; + IconvArr[105].Charset := CP858; + IconvArr[105].Charname := 'CP858'; + IconvArr[106].Charset := CP860; + IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860'; + IconvArr[107].Charset := CP861; + IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861'; + IconvArr[108].Charset := CP863; + IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863'; + IconvArr[109].Charset := CP864; + IconvArr[109].Charname := 'CP864 IBM864 CSIBM864'; + IconvArr[110].Charset := CP865; + IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865'; + IconvArr[111].Charset := CP869; + IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869'; + IconvArr[112].Charset := CP1125; + IconvArr[112].Charname := 'CP1125'; end; end. diff --git a/synacode.pas b/synacode.pas index 50fe271..c2b85eb 100644 --- a/synacode.pas +++ b/synacode.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.008.007 | +| Project : Ararat Synapse | 002.001.001 | |==============================================================================| | Content: Coding and decoding support | |==============================================================================| @@ -42,6 +42,7 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(Various encoding and decoding support)} {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -57,13 +58,15 @@ uses SysUtils; type - TSpecials = set of Char; + TSpecials = set of AnsiChar; const SpecialChar: TSpecials = - ['=', '(', ')', '[', ']', '<', '>', ':', ';', '.', ',', '@', '/', '?', '\', + ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', '"', '_']; + NonAsciiChar: TSpecials = + [Char(0)..Char(31), Char(127)..Char(255)]; URLFullSpecialChar: TSpecials = [';', '/', '?', ':', '@', '=', '&', '#']; URLSpecialChar: TSpecials = @@ -71,10 +74,12 @@ const '`', #$7F..#$FF]; TableBase64 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; + TableBase64mod = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; TableUU = '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; TableXX = - '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_'; + '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; ReTablebase64 = #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C @@ -103,29 +108,109 @@ const +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; -function DecodeTriplet(const Value: string; Delimiter: Char): string; -function DecodeQuotedPrintable(const Value: string): string; -function DecodeURL(const Value: string): string; -function EncodeTriplet(const Value: string; Delimiter: Char; - Specials: TSpecials): string; -function EncodeQuotedPrintable(const Value: string): string; -function EncodeURLElement(const Value: string): string; -function EncodeURL(const Value: string): string; -function Decode4to3(const Value, Table: string): string; -function Decode4to3Ex(const Value, Table: string): string; -function Encode3to4(const Value, Table: string): string; -function DecodeBase64(const Value: string): string; -function EncodeBase64(const Value: string): string; -function DecodeUU(const Value: string): string; -function EncodeUU(const Value: string): string; -function DecodeXX(const Value: string): string; -function DecodeYEnc(const Value: string): string; +{:Decodes triplet encoding with a given character delimiter. It is used for + decoding quoted-printable or URL encoding.} +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; + +{:Decodes a string from quoted printable form. (also decodes triplet sequences + like '=7F')} +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} +function DecodeURL(const Value: AnsiString): AnsiString; + +{:Performs triplet encoding with a given character delimiter. Used for encoding + quoted-printable or URL encoding.} +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) + are encoded.} +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and + @link(SpecialChar) are encoded.} +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used for encoding data from a form field in + HTTP, etc. (Encodes all critical characters including characters used as URL + delimiters ('/',':', etc.)} +function EncodeURLElement(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used to encode critical characters in all + URLs.} +function EncodeURL(const Value: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given table. If some element is not found in table, + first item from table is used. This is good for buggy coded items by Microsoft + Outlook. This software sometimes using wrong table for UUcode, where is used + ' ' instead '`'.} +function Decode4to3(const Value, Table: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given REVERSE table. Using this function with +reverse table is much faster then @link(Decode4to3). This function is used +internally for Base64, UU or XX decoding.} +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; + +{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} +function Encode3to4(const Value, Table: AnsiString): AnsiString; + +{:Decode string from base64 format.} +function DecodeBase64(const Value: AnsiString): AnsiString; + +{:Encodes a string to base64 format.} +function EncodeBase64(const Value: AnsiString): AnsiString; + +{:Decode string from modified base64 format. (used in IMAP, for example.)} +function DecodeBase64mod(const Value: AnsiString): AnsiString; + +{:Encodes a string to modified base64 format. (used in IMAP, for example.)} +function EncodeBase64mod(const Value: AnsiString): AnsiString; + +{:Decodes a string from UUcode format.} +function DecodeUU(const Value: AnsiString): AnsiString; + +{:encode UUcode. it encode only datas, you must also add header and footer for + proper encode.} +function EncodeUU(const Value: AnsiString): AnsiString; + +{:Decodes a string from XXcode format.} +function DecodeXX(const Value: AnsiString): AnsiString; + +{:decode line with Yenc code. This code is sometimes used in newsgroups.} +function DecodeYEnc(const Value: AnsiString): AnsiString; + +{:Returns a new CRC32 value after adding a new byte of data.} function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; -function Crc32(const Value: string): Integer; + +{:return CRC32 from a value string.} +function Crc32(const Value: AnsiString): Integer; + +{:Returns a new CRC16 value after adding a new byte of data.} function UpdateCrc16(Value: Byte; Crc16: Word): Word; -function Crc16(const Value: string): Word; -function MD5(const Value: string): string; -function HMAC_MD5(Text, Key: string): string; + +{:return CRC16 from a value string.} +function Crc16(const Value: AnsiString): Word; + +{:Returns a binary string with a RSA-MD5 hashing of "Value" string.} +function MD5(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-MD5 hash.} +function HMAC_MD5(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a RSA-MD5 hashing of string what is constructed + by repeating "value" until length is "Len".} +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of "Value" string.} +function SHA1(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-SHA1 hash.} +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of string what is constructed + by repeating "value" until length is "Len".} +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; implementation @@ -233,21 +318,73 @@ const $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 ); +procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to ((high(ArByte) + 1) div 4) - 1 do + ArLong[n] := ArByte[n * 4 + 0] + + (ArByte[n * 4 + 1] shl 8) + + (ArByte[n * 4 + 2] shl 16) + + (ArByte[n * 4 + 3] shl 24); + {$ELSE} + Move(ArByte[0], ArLong[0], High(ArByte) + 1); + {$ENDIF} +end; + +procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to high(ArLong) do + begin + ArByte[n * 4 + 0] := ArLong[n] and $000000FF; + ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; + ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; + ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; + end; + {$ELSE} + Move(ArLong[0], ArByte[0], High(ArByte) + 1); + {$ENDIF} +end; + type TMD5Ctx = record State: array[0..3] of Integer; Count: array[0..1] of Integer; - case Integer of - 0: (BufChar: array[0..63] of Byte); - 1: (BufLong: array[0..15] of Integer); + BufAnsiChar: array[0..63] of Byte; + BufLong: array[0..15] of Integer; +// case Integer of +// 0: (BufAnsiChar: array[0..63] of Byte); +// 1: (BufLong: array[0..15] of Integer); + end; + TSHA1Ctx= record + Hi, Lo: integer; + Buffer: array[0..63] of byte; + Index: integer; + Hash: array[0..4] of Integer; + HashByte: array[0..19] of byte; +// case Integer of +// 0: (Hash: array[0..4] of Integer); +// 1: (HashByte: array[0..19] of byte); end; {==============================================================================} -function DecodeTriplet(const Value: string; Delimiter: Char): string; +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; var x, l, lv: Integer; - c: Char; + c: AnsiChar; b: Byte; bad: Boolean; begin @@ -304,7 +441,7 @@ begin else begin Inc(x, 2); - Result[l] := Char(b); + Result[l] := AnsiChar(b); Inc(l); end; end; @@ -319,26 +456,26 @@ end; {==============================================================================} -function DecodeQuotedPrintable(const Value: string): string; +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; begin Result := DecodeTriplet(Value, '='); end; {==============================================================================} -function DecodeURL(const Value: string): string; +function DecodeURL(const Value: AnsiString): AnsiString; begin Result := DecodeTriplet(Value, '%'); end; {==============================================================================} -function EncodeTriplet(const Value: string; Delimiter: Char; - Specials: TSpecials): string; +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; var n, l: Integer; - s: string; - c: char; + s: AnsiString; + c: AnsiChar; begin SetLength(Result, Length(Value) * 3); l := 1; @@ -367,29 +504,35 @@ end; {==============================================================================} -function EncodeQuotedPrintable(const Value: string): string; +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; begin - Result := EncodeTriplet(Value, '=', SpecialChar + - [Char(0)..Char(31), Char(127)..Char(255)]); + Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); end; {==============================================================================} -function EncodeURLElement(const Value: string): string; +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeURLElement(const Value: AnsiString): AnsiString; begin Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); end; {==============================================================================} -function EncodeURL(const Value: string): string; +function EncodeURL(const Value: AnsiString): AnsiString; begin Result := EncodeTriplet(Value, '%', URLSpecialChar); end; {==============================================================================} -function Decode4to3(const Value, Table: string): string; +function Decode4to3(const Value, Table: AnsiString): AnsiString; var x, y, n, l: Integer; d: array[0..3] of Byte; @@ -412,15 +555,15 @@ begin end; Inc(x); end; - Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); Inc(l); if d[2] <> 64 then begin - Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); Inc(l); if d[3] <> 64 then begin - Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F)); + Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); Inc(l); end; end; @@ -430,26 +573,20 @@ begin end; {==============================================================================} -function Decode4to3Ex(const Value, Table: string): string; -type - TDconvert = record - case byte of - 0: (a0, a1, a2, a3: char); - 1: (i: integer); - end; +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; var - x, y, l, lv: Integer; - d: TDconvert; + x, y, lv: Integer; + d: integer; dl: integer; c: byte; - p: ^char; + p: integer; begin lv := Length(Value); SetLength(Result, lv); x := 1; dl := 4; - d.i := 0; - p := pointer(result); + d := 0; + p := 1; while x <= lv do begin y := Ord(Value[x]); @@ -460,42 +597,41 @@ begin Inc(x); if c > 63 then continue; - d.i := (d.i shl 6) or c; + d := (d shl 6) or c; dec(dl); if dl <> 0 then continue; - p^ := d.a2; + Result[p] := AnsiChar((d shr 16) and $ff); inc(p); - p^ := d.a1; + Result[p] := AnsiChar((d shr 8) and $ff); inc(p); - p^ := d.a0; + Result[p] := AnsiChar(d and $ff); inc(p); - d.i := 0; + d := 0; dl := 4; end; case dl of 1: begin - d.i := d.i shr 2; - p^ := d.a1; + d := d shr 2; + Result[p] := AnsiChar((d shr 8) and $ff); inc(p); - p^ := d.a0; + Result[p] := AnsiChar(d and $ff); inc(p); end; 2: begin - d.i := d.i shr 4; - p^ := d.a0; + d := d shr 4; + Result[p] := AnsiChar(d and $ff); inc(p); end; end; - l := integer(p) - integer(pointer(result)); - SetLength(Result, l); + SetLength(Result, p - 1); end; {==============================================================================} -function Encode3to4(const Value, Table: string): string; +function Encode3to4(const Value, Table: AnsiString): AnsiString; var c: Byte; n, l: Integer; @@ -536,32 +672,50 @@ begin end; for n := 0 to 3 do begin - Result[l] := Table[DOut[n] + 1]; - Inc(l); + if (DOut[n] + 1) <= Length(Table) then + begin + Result[l] := Table[DOut[n] + 1]; + Inc(l); + end; end; end; + SetLength(Result, l - 1); end; {==============================================================================} -function DecodeBase64(const Value: string): string; +function DecodeBase64(const Value: AnsiString): AnsiString; begin Result := Decode4to3Ex(Value, ReTableBase64); end; {==============================================================================} -function EncodeBase64(const Value: string): string; +function EncodeBase64(const Value: AnsiString): AnsiString; begin Result := Encode3to4(Value, TableBase64); end; {==============================================================================} -function DecodeUU(const Value: string): string; +function DecodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Decode4to3(Value, TableBase64mod); +end; + +{==============================================================================} + +function EncodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Encode3to4(Value, TableBase64mod); +end; + +{==============================================================================} + +function DecodeUU(const Value: AnsiString): AnsiString; var - s: string; - uut: string; + s: AnsiString; + uut: AnsiString; x: Integer; begin Result := ''; @@ -591,7 +745,7 @@ end; {==============================================================================} -function EncodeUU(const Value: string): string; +function EncodeUU(const Value: AnsiString): AnsiString; begin Result := ''; if Length(Value) < Length(TableUU) then @@ -600,9 +754,9 @@ end; {==============================================================================} -function DecodeXX(const Value: string): string; +function DecodeXX(const Value: AnsiString): AnsiString; var - s: string; + s: AnsiString; x: Integer; begin Result := ''; @@ -630,7 +784,7 @@ end; {==============================================================================} -function DecodeYEnc(const Value: string): string; +function DecodeYEnc(const Value: AnsiString): AnsiString; var C : Byte; i: integer; @@ -648,7 +802,7 @@ begin Dec(c, 64); end; Dec(C, 42); - Result := Result + Char(C); + Result := Result + AnsiChar(C); end; end; @@ -662,7 +816,7 @@ end; {==============================================================================} -function Crc32(const Value: string): Integer; +function Crc32(const Value: AnsiString): Integer; var n: Integer; begin @@ -681,7 +835,7 @@ end; {==============================================================================} -function Crc16(const Value: string): Word; +function Crc16(const Value: AnsiString): Word; var n: Integer; begin @@ -693,15 +847,19 @@ end; {==============================================================================} procedure MD5Init(var MD5Context: TMD5Ctx); +var + n: integer; begin - FillChar(MD5Context, SizeOf(TMD5Ctx), #0); - with MD5Context do - begin - State[0] := Integer($67452301); - State[1] := Integer($EFCDAB89); - State[2] := Integer($98BADCFE); - State[3] := Integer($10325476); - end; + MD5Context.Count[0] := 0; + MD5Context.Count[1] := 0; + for n := 0 to high(MD5Context.BufAnsiChar) do + MD5Context.BufAnsiChar[n] := 0; + for n := 0 to high(MD5Context.BufLong) do + MD5Context.BufLong[n] := 0; + MD5Context.State[0] := Integer($67452301); + MD5Context.State[1] := Integer($EFCDAB89); + MD5Context.State[2] := Integer($98BADCFE); + MD5Context.State[3] := Integer($10325476); end; procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); @@ -815,84 +973,116 @@ begin Inc(Buf[3], D); end; -procedure MD5Update(var MD5Context: TMD5Ctx; const Data: string); +//fixed by James McAdams +procedure MD5Update(var MD5Context: TMD5Ctx; const Data: AnsiString); var - Index, t, len: Integer; + Index, partLen, InputLen, I: integer; +{$IFDEF CIL} + n: integer; +{$ENDIF} begin - len := Length(Data); + InputLen := Length(Data); with MD5Context do begin - T := Count[0]; - Inc(Count[0], Len shl 3); - if Count[0] < T then + Index := (Count[0] shr 3) and $3F; + Inc(Count[0], InputLen shl 3); + if Count[0] < (InputLen shl 3) then Inc(Count[1]); - Inc(Count[1], Len shr 29); - T := (T shr 3) and $3F; - Index := 0; - if T <> 0 then + Inc(Count[1], InputLen shr 29); + partLen := 64 - Index; + if InputLen >= partLen then begin - Index := T; - T := 64 - T; - if Len < T then + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to partLen do + BufAnsiChar[index - 1 + n] := Ord(Data[n]); + {$ELSE} + Move(Data[1], BufAnsiChar[Index], partLen); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + MD5Transform(State, Buflong); + I := partLen; + while I + 63 < InputLen do begin - Move(Data, Bufchar[Index], Len); - Exit; - end; - Move(Data, Bufchar[Index], T); - MD5Transform(State, Buflong); - Dec(Len, T); - Index := T; - end; - while Len > 64 do - begin - Move(Data[Index + 1], Bufchar, 64); - MD5Transform(State, Buflong); - Inc(Index, 64); - Dec(Len, 64); - end; - Move(Data[Index + 1], Bufchar, Len); + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to 64 do + BufAnsiChar[n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar, 64); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + MD5Transform(State, Buflong); + inc(I, 64); + end; + Index := 0; + end + else + I := 0; + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to InputLen-I do + BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar[Index], InputLen-I); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); end end; -function MD5Final(var MD5Context: TMD5Ctx): string; +function MD5Final(var MD5Context: TMD5Ctx): AnsiString; var Cnt: Word; P: Byte; - digest: array[0..15] of Char; + digest: array[0..15] of Byte; i: Integer; + n: integer; begin for I := 0 to 15 do - Byte(Digest[I]) := I + 1; + Digest[I] := I + 1; with MD5Context do begin Cnt := (Count[0] shr 3) and $3F; P := Cnt; - BufChar[P] := $80; + BufAnsiChar[P] := $80; Inc(P); Cnt := 64 - 1 - Cnt; if Cnt > 0 then if Cnt < 8 then begin - FillChar(BufChar[P], Cnt, #0); + for n := 0 to cnt - 1 do + BufAnsiChar[P + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt, #0); MD5Transform(State, BufLong); - FillChar(BufChar, 56, #0); + ArrLongToByte(BufLong, BufAnsiChar); + for n := 0 to 55 do + BufAnsiChar[n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar, 56, #0); end else - FillChar(BufChar[P], Cnt - 8, #0); + begin + for n := 0 to Cnt - 8 - 1 do + BufAnsiChar[p + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt - 8, #0); + end; BufLong[14] := Count[0]; BufLong[15] := Count[1]; MD5Transform(State, BufLong); - Move(State, Digest, 16); + ArrLongToByte(State, Digest); +// Move(State, Digest, 16); Result := ''; for i := 0 to 15 do - Result := Result + Char(digest[i]); + Result := Result + AnsiChar(digest[i]); end; - FillChar(MD5Context, SizeOf(TMD5Ctx), #0) +// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) end; {==============================================================================} -function MD5(const Value: string): string; +function MD5(const Value: AnsiString): AnsiString; var MD5Context: TMD5Ctx; begin @@ -903,24 +1093,20 @@ end; {==============================================================================} -function HMAC_MD5(Text, Key: string): string; +function HMAC_MD5(Text, Key: AnsiString): AnsiString; var - ipad, opad, s: string; + ipad, opad, s: AnsiString; n: Integer; MD5Context: TMD5Ctx; begin if Length(Key) > 64 then Key := md5(Key); - ipad := ''; - for n := 1 to 64 do - ipad := ipad + #$36; - opad := ''; - for n := 1 to 64 do - opad := opad + #$5C; + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); for n := 1 to Length(Key) do begin - ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n])); - opad[n] := Char(Byte(opad[n]) xor Byte(Key[n])); + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); end; MD5Init(MD5Context); MD5Update(MD5Context, ipad); @@ -932,4 +1118,255 @@ begin Result := MD5Final(MD5Context); end; +{==============================================================================} + +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + MD5Context: TMD5Ctx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + MD5Init(MD5Context); + for n := 1 to cnt do + MD5Update(MD5Context, Value); + if rest > 0 then + MD5Update(MD5Context, Copy(Value, 1, rest)); + Result := MD5Final(MD5Context); +end; + +{==============================================================================} +// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) + +procedure SHA1init( var SHA1Context: TSHA1Ctx ); +var + n: integer; +begin + SHA1Context.Hi := 0; + SHA1Context.Lo := 0; + SHA1Context.Index := 0; + for n := 0 to High(SHA1Context.Buffer) do + SHA1Context.Buffer[n] := 0; + for n := 0 to High(SHA1Context.HashByte) do + SHA1Context.HashByte[n] := 0; +// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); + SHA1Context.Hash[0] := integer($67452301); + SHA1Context.Hash[1] := integer($EFCDAB89); + SHA1Context.Hash[2] := integer($98BADCFE); + SHA1Context.Hash[3] := integer($10325476); + SHA1Context.Hash[4] := integer($C3D2E1F0); +end; + +//****************************************************************************** +function RB(A: integer): integer; +begin + Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); +end; + +procedure SHA1Compress(var Data: TSHA1Ctx); +var + A, B, C, D, E, T: integer; + W: array[0..79] of integer; + i: integer; + n: integer; + + function F1(x, y, z: integer): integer; + begin + Result := z xor (x and (y xor z)); + end; + function F2(x, y, z: integer): integer; + begin + Result := x xor y xor z; + end; + function F3(x, y, z: integer): integer; + begin + Result := (x and y) or (z and (x or y)); + end; + function LRot32(X: integer; c: integer): integer; + begin + result := (x shl c) or (x shr (32 - c)); + end; +begin + ArrByteToLong(Data.Buffer, W); +// Move(Data.Buffer, W, Sizeof(Data.Buffer)); + for i := 0 to 15 do + W[i] := RB(W[i]); + for i := 16 to 79 do + W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + for i := 0 to 19 do + begin + T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 20 to 39 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 40 to 59 do + begin + T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 60 to 79 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + Data.Hash[0] := Data.Hash[0] + A; + Data.Hash[1] := Data.Hash[1] + B; + Data.Hash[2] := Data.Hash[2] + C; + Data.Hash[3] := Data.Hash[3] + D; + Data.Hash[4] := Data.Hash[4] + E; + for n := 0 to high(w) do + w[n] := 0; +// FillChar(W, Sizeof(W), 0); + for n := 0 to high(Data.Buffer) do + Data.Buffer[n] := 0; +// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); +end; + +//****************************************************************************** +procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString); +var + Len: integer; + n: integer; + i, k: integer; +begin + Len := Length(data); + for k := 0 to 7 do + begin + i := Context.Lo; + Inc(Context.Lo, Len); + if Context.Lo < i then + Inc(Context.Hi); + end; + for n := 1 to len do + begin + Context.Buffer[Context.Index] := byte(Data[n]); + Inc(Context.Index); + if Context.Index = 64 then + begin + Context.Index := 0; + SHA1Compress(Context); + end; + end; +end; + +//****************************************************************************** +function SHA1Final(var Context: TSHA1Ctx): AnsiString; +type + Pinteger = ^integer; +var + i: integer; + procedure ItoArr(var Ar: Array of byte; I, value: Integer); + begin + Ar[i + 0] := Value and $000000FF; + Ar[i + 1] := (Value shr 8) and $000000FF; + Ar[i + 2] := (Value shr 16) and $000000FF; + Ar[i + 3] := (Value shr 24) and $000000FF; + end; +begin + Context.Buffer[Context.Index] := $80; + if Context.Index >= 56 then + SHA1Compress(Context); + ItoArr(Context.Buffer, 56, RB(Context.Hi)); + ItoArr(Context.Buffer, 60, RB(Context.Lo)); +// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); +// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); + SHA1Compress(Context); + Context.Hash[0] := RB(Context.Hash[0]); + Context.Hash[1] := RB(Context.Hash[1]); + Context.Hash[2] := RB(Context.Hash[2]); + Context.Hash[3] := RB(Context.Hash[3]); + Context.Hash[4] := RB(Context.Hash[4]); + ArrLongToByte(Context.Hash, Context.HashByte); + Result := ''; + for i := 0 to 19 do + Result := Result + AnsiChar(Context.HashByte[i]); +end; + +function SHA1(const Value: AnsiString): AnsiString; +var + SHA1Context: TSHA1Ctx; +begin + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, Value); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; +var + ipad, opad, s: AnsiString; + n: Integer; + SHA1Context: TSHA1Ctx; +begin + if Length(Key) > 64 then + Key := SHA1(Key); + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); + end; + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, ipad); + SHA1Update(SHA1Context, Text); + s := SHA1Final(SHA1Context); + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, opad); + SHA1Update(SHA1Context, s); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + SHA1Context: TSHA1Ctx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + SHA1Init(SHA1Context); + for n := 1 to cnt do + SHA1Update(SHA1Context, Value); + if rest > 0 then + SHA1Update(SHA1Context, Copy(Value, 1, rest)); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + + end. diff --git a/synafpc.pas b/synafpc.pas index b17ad70..c31f01e 100644 --- a/synafpc.pas +++ b/synafpc.pas @@ -42,6 +42,8 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@exclude} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} diff --git a/synaicnv.pas b/synaicnv.pas new file mode 100644 index 0000000..78b6b2a --- /dev/null +++ b/synaicnv.pas @@ -0,0 +1,351 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: ICONV support for Win32, Linux and .NET | +|==============================================================================| +| Copyright (c)2004, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2004. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +{:@exclude} +unit synaicnv; + +interface + +uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} +{$IFDEF LINUX} + {$IFDEF FPC} + synafpc, + {$ENDIF} + Libc, SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +const + {$IFDEF LINUX} + DLLIconvName = 'libiconv.so'; + {$ELSE} + DLLIconvName = 'iconv.dll'; + {$ENDIF} + +type + size_t = Cardinal; +{$IFDEF CIL} + iconv_t = IntPtr; +{$ELSE} + iconv_t = Pointer; +{$ENDIF} + argptr = iconv_t; + +var + iconvLibHandle: Integer = 0; + +function SynaIconvOpen(const tocode, fromcode: string): iconv_t; +function SynaIconvOpenTranslit(const tocode, fromcode: string): iconv_t; +function SynaIconvOpenIgnore(const tocode, fromcode: string): iconv_t; +function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +function SynaIconvClose(var cd: iconv_t): integer; +function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; + +function IsIconvloaded: Boolean; +function InitIconvInterface: Boolean; +function DestroyIconvInterface: Boolean; + +const + ICONV_TRIVIALP = 0; // int *argument + ICONV_GET_TRANSLITERATE = 1; // int *argument + ICONV_SET_TRANSLITERATE = 2; // const int *argument + ICONV_GET_DISCARD_ILSEQ = 3; // int *argument + ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument + + +implementation + +uses SyncObjs; + +{$IFDEF CIL} + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_open')] + function _iconv_open(tocode: string; fromcode: string): iconv_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv')] + function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; + var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconv_close')] + function _iconv_close(cd: iconv_t): integer; external; + + [DllImport(DLLIconvName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'libiconvctl')] + function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; + +{$ELSE} +type + Ticonv_open = function(tocode: pchar; fromcode: pchar): iconv_t; cdecl; + Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; + var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; + Ticonv_close = function(cd: iconv_t): integer; cdecl; + Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; +var + _iconv_open: Ticonv_open = nil; + _iconv: Ticonv = nil; + _iconv_close: Ticonv_close = nil; + _iconvctl: Ticonvctl = nil; +{$ENDIF} + + +var + IconvCS: TCriticalSection; + Iconvloaded: boolean = false; + +function SynaIconvOpen (const tocode, fromcode: string): iconv_t; +begin +{$IFDEF CIL} + try + Result := _iconv_open(tocode, fromcode); + except + on Exception do + Result := iconv_t(-1); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv_open) then + Result := _iconv_open(PChar(tocode), PChar(fromcode)) + else + Result := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvOpenTranslit (const tocode, fromcode: string): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//TRANSLIT', fromcode); +end; + +function SynaIconvOpenIgnore (const tocode, fromcode: string): iconv_t; +begin + Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); +end; + +function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; +var +{$IFDEF CIL} + ib, ob: IntPtr; + ibsave, obsave: IntPtr; + l: integer; +{$ELSE} + ib, ob: Pointer; +{$ENDIF} + ix, ox: size_t; +begin +{$IFDEF CIL} + l := Length(inbuf) * 4; + ibsave := IntPtr.Zero; + obsave := IntPtr.Zero; + try + ibsave := Marshal.StringToHGlobalAnsi(inbuf); + obsave := Marshal.AllocHGlobal(l); + ib := ibsave; + ob := obsave; + ix := Length(inbuf); + ox := l; + _iconv(cd, ib, ix, ob, ox); + Outbuf := Marshal.PtrToStringAnsi(obsave, l); + setlength(Outbuf, l - ox); + Result := Length(inbuf) - ix; + finally + Marshal.FreeCoTaskMem(ibsave); + Marshal.FreeHGlobal(obsave); + end; +{$ELSE} + if InitIconvInterface and Assigned(_iconv) then + begin + setlength(Outbuf, Length(inbuf) * 4); + ib := Pointer(inbuf); + ob := Pointer(Outbuf); + ix := Length(inbuf); + ox := Length(Outbuf); + _iconv(cd, ib, ix, ob, ox); + setlength(Outbuf, Length(Outbuf) - ox); + Result := Length(inbuf) - ix; + end + else + begin + Outbuf := ''; + Result := 0; + end; +{$ENDIF} +end; + +function SynaIconvClose(var cd: iconv_t): integer; +begin + if cd = iconv_t(-1) then + begin + Result := 0; + Exit; + end; +{$IFDEF CIL} + try; + Result := _iconv_close(cd) + except + on Exception do + Result := -1; + end; + cd := iconv_t(-1); +{$ELSE} + if InitIconvInterface and Assigned(_iconv_close) then + Result := _iconv_close(cd) + else + Result := -1; + cd := iconv_t(-1); +{$ENDIF} +end; + +function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; +begin +{$IFDEF CIL} + Result := _iconvctl(cd, request, argument) +{$ELSE} + if InitIconvInterface and Assigned(_iconvctl) then + Result := _iconvctl(cd, request, argument) + else + Result := 0; +{$ENDIF} +end; + +function InitIconvInterface: Boolean; +begin + IconvCS.Enter; + try + if not IsIconvloaded then + begin +{$IFDEF CIL} + IconvLibHandle := 1; +{$ELSE} + IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); +{$ENDIF} + if (IconvLibHandle <> 0) then + begin +{$IFNDEF CIL} + _iconv_open := GetProcAddress(IconvLibHandle, Pchar('libiconv_open')); + _iconv := GetProcAddress(IconvLibHandle, Pchar('libiconv')); + _iconv_close := GetProcAddress(IconvLibHandle, Pchar('libiconv_close')); + _iconvctl := GetProcAddress(IconvLibHandle, Pchar('libiconvctl')); +{$ENDIF} + Result := True; + Iconvloaded := True; + end + else + begin + //load failed! + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + IconvCS.Leave; + end; +end; + +function DestroyIconvInterface: Boolean; +begin + IconvCS.Enter; + try + Iconvloaded := false; + if IconvLibHandle <> 0 then + begin +{$IFNDEF CIL} + FreeLibrary(IconvLibHandle); +{$ENDIF} + IconvLibHandle := 0; + end; +{$IFNDEF CIL} + _iconv_open := nil; + _iconv := nil; + _iconv_close := nil; + _iconvctl := nil; +{$ENDIF} + finally + IconvCS.Leave; + end; + Result := True; +end; + +function IsIconvloaded: Boolean; +begin + Result := IconvLoaded; +end; + +initialization +begin + IconvCS:= TCriticalSection.Create; +end; + +finalization +begin +{$IFNDEF CIL} + DestroyIconvInterface; +{$ENDIF} + IconvCS.Free; +end; + +end. diff --git a/synamisc.pas b/synamisc.pas index f0ffbf0..312d834 100644 --- a/synamisc.pas +++ b/synamisc.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.002 | +| Project : Ararat Synapse | 001.001.003 | |==============================================================================| | Content: misc. procedures and functions | |==============================================================================| @@ -42,6 +42,8 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(Misc. network based utilities)} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -67,21 +69,33 @@ uses {$ELSE} {$IFDEF FPC} winver, -{$ELSE} - Wininet, {$ENDIF} Windows; {$ENDIF} Type + {:@abstract(This record contains information about proxy setting.)} TProxySetting = record Host: string; Port: string; Bypass: string; end; +{:By this function you can turn-on computer on network, if this computer + supporting Wake-on-lan feature. You need MAC number (network card indentifier) + of computer for turn-on. You can also assign target IP addres. If you not + specify it, then is used broadcast for delivery magic wake-on packet. However + broadcasts workinh only on your local network. When you need to wake-up + computer on another network, you must specify any existing IP addres on same + network segment as targeting computer.} procedure WakeOnLan(MAC, IP: string); + +{:Autodetect current DNS servers used by system. If is defined more then one DNS + server, then result is comma-delimited.} function GetDNS: string; + +{:Autodetect InternetExplorer proxy setting for given protocol. This function +working only on windows!} function GetIEProxy(protocol: string): TProxySetting; implementation @@ -267,14 +281,19 @@ begin Result.Bypass := ''; end; {$ELSE} -{$IFDEF FPC} -begin - Result.Host := ''; - Result.Port := ''; - Result.Bypass := ''; -end; -{$ELSE} +type + PInternetProxyInfo = ^TInternetProxyInfo; + TInternetProxyInfo = packed record + dwAccessType: DWORD; + lpszProxy: LPCSTR; + lpszProxyBypass: LPCSTR; + end; +const + INTERNET_OPTION_PROXY = 38; + INTERNET_OPEN_TYPE_PROXY = 3; + WininetDLL = 'WININET.DLL'; var + WininetModule: THandle; ProxyInfo: PInternetProxyInfo; Err: Boolean; Len: DWORD; @@ -282,49 +301,61 @@ var DefProxy: string; ProxyList: TStringList; n: integer; + InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; + lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; begin Result.Host := ''; Result.Port := ''; Result.Bypass := ''; - if protocol = '' then - protocol := 'http'; - Len := 4096; - GetMem(ProxyInfo, Len); - ProxyList := TStringList.Create; + WininetModule := LoadLibrary(WininetDLL); + if WininetModule = 0 then + exit; try - Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); - if Err then - if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then - begin - ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); - Proxy := ''; - DefProxy := ''; - for n := 0 to ProxyList.Count -1 do + InternetQueryOption := GetProcAddress(WininetModule,'InternetQueryOptionA'); + if @InternetQueryOption = nil then + Exit; + + if protocol = '' then + protocol := 'http'; + Len := 4096; + GetMem(ProxyInfo, Len); + ProxyList := TStringList.Create; + try + Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); + if Err then + if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then begin - if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then + ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); + Proxy := ''; + DefProxy := ''; + for n := 0 to ProxyList.Count -1 do begin - Proxy := SeparateRight(ProxyList[n], '='); - break; + if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then + begin + Proxy := SeparateRight(ProxyList[n], '='); + break; + end; + if Pos('=', ProxyList[n]) < 1 then + DefProxy := ProxyList[n]; end; - if Pos('=', ProxyList[n]) < 1 then - DefProxy := ProxyList[n]; + if Proxy = '' then + Proxy := DefProxy; + if Proxy <> '' then + begin + Result.Host := Trim(SeparateLeft(Proxy, ':')); + Result.Port := Trim(SeparateRight(Proxy, ':')); + end; + Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); end; - if Proxy = '' then - Proxy := DefProxy; - if Proxy <> '' then - begin - Result.Host := SeparateLeft(Proxy, ':'); - Result.Port := SeparateRight(Proxy, ':'); - end; - Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); - end; + finally + ProxyList.Free; + FreeMem(ProxyInfo); + end; finally - ProxyList.Free; - FreeMem(ProxyInfo); + FreeLibrary(WininetModule); end; end; {$ENDIF} -{$ENDIF} {==============================================================================} diff --git a/synassl.pas b/synassl.pas index e5cbcea..87e9f26 100644 --- a/synassl.pas +++ b/synassl.pas @@ -1,7 +1,7 @@ {==============================================================================| -| Project : Ararat Synapse | 002.001.002 | +| Project : Ararat Synapse | 003.000.000 | |==============================================================================| -| Content: SSL support | +| Content: SSL support by OpenSSL | |==============================================================================| | Copyright (c)1999-2003, Lukas Gebauer | | All rights reserved. | @@ -41,6 +41,7 @@ | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} + { Special thanks to Gregor Ibic (Intelicom d.o.o., http://www.intelicom.si) @@ -59,11 +60,16 @@ Special thanks to Gregor Ibic (*$HPPEMIT 'namespace Synassl { using System::Shortint; }' *) {$ENDIF} +{:@exclude} unit synassl; interface uses +{$IFDEF CIL} + System.Runtime.InteropServices, + System.Text, +{$ENDIF} {$IFDEF LINUX} {$IFDEF FPC} synafpc, @@ -73,26 +79,53 @@ uses Windows; {$ENDIF} + +{$IFDEF CIL} +const + {$IFDEF LINUX} + DLLSSLName = 'libssl.so'; + DLLUtilName = 'libcrypto.so'; + {$ELSE} + DLLSSLName = 'ssleay32.dll'; + DLLUtilName = 'libeay32.dll'; + {$ENDIF} +{$ELSE} var -{$IFDEF LINUX} + {$IFDEF LINUX} DLLSSLName: string = 'libssl.so'; DLLUtilName: string = 'libcrypto.so'; -{$ELSE} + {$ELSE} DLLSSLName: string = 'ssleay32.dll'; DLLSSLName2: string = 'libssl32.dll'; DLLUtilName: string = 'libeay32.dll'; + {$ENDIF} {$ENDIF} type - PSSL_CTX = Pointer; - PSSL = Pointer; - PSSL_METHOD = Pointer; - PX509 = Pointer; - PX509_NAME = Pointer; - PEVP_MD = Pointer; +{$IFDEF CIL} + SslPtr = IntPtr; +{$ELSE} + SslPtr = Pointer; +{$ENDIF} + PSSL_CTX = SslPtr; + PSSL = SslPtr; + PSSL_METHOD = SslPtr; + PX509 = SslPtr; + PX509_NAME = SslPtr; + PEVP_MD = SslPtr; PInteger = ^Integer; - PBIO_METHOD = Pointer; - PBIO = Pointer; + PBIO_METHOD = SslPtr; + PBIO = SslPtr; + PPasswdCb = SslPtr; + PFunction = procedure; + + DES_cblock = array[0..7] of Byte; + PDES_cblock = ^DES_cblock; + des_ks_struct = packed record + ks: DES_cblock; + weak_key: Integer; + end; + des_key_schedule = array[1..16] of des_ks_struct; const EVP_MAX_MD_SIZE = 16 + 20; @@ -114,6 +147,9 @@ const SSL_VERIFY_NONE = $00; SSL_VERIFY_PEER = $01; + OPENSSL_DES_DECRYPT = 0; + OPENSSL_DES_ENCRYPT = 1; + X509_V_OK = 0; X509_V_ILLEGAL = 1; X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2; @@ -159,11 +195,306 @@ var SSLLibFile: string = ''; SSLUtilFile: string = ''; +{$IFDEF CIL} + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_error')] + function SslGetError(s: PSSL; ret_code: Integer): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_library_init')] + function SslLibraryInit: Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_load_error_strings')] + procedure SslLoadErrorStrings; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_cipher_list')] + function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String): Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_new')] + function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_free')] + procedure SslCtxFree (arg0: PSSL_CTX); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_set_fd')] + function SslSetFd(s: PSSL; fd: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv2_method')] + function SslMethodV2 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv3_method')] + function SslMethodV3 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'TLSv1_method')] + function SslMethodTLSV1:PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSLv23_method')] + function SslMethodV23 : PSSL_METHOD; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_PrivateKey_file')] + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_use_certificate_chain_file')] //TODO: See if this is really correct + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_check_private_key')] + function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb')] + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')] + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_load_verify_locations')] + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: String):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_new')] + function SslNew(ctx: PSSL_CTX):PSSL; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_free')] + procedure SslFree(ssl: PSSL); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_accept')] + function SslAccept(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_connect')] + function SslConnect(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_shutdown')] + function SslShutdown(s: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_read')] + function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_peek')] + function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_write')] + function SslWrite(ssl: PSSL; buf: String; num: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_pending')] + function SslPending(ssl: PSSL):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_version')] + function SslGetVersion(ssl: PSSL):String; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_peer_certificate')] + function SslGetPeerCertificate(s: PSSL):PX509; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CTX_set_verify')] + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_current_cipher')] + function SSLGetCurrentCipher(s: PSSL): SslPtr; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_name')] + function SSLCipherGetName(c: SslPtr):String; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_CIPHER_get_bits')] + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; external; + + [DllImport(DLLSSLName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'SSL_get_verify_result')] + function SSLGetVerifyResult(ssl: PSSL):Integer;external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_free')] + procedure SslX509Free(x: PX509); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_oneline')] + function SslX509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): String; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_subject_name')] + function SslX509GetSubjectName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_get_issuer_name')] + function SslX509GetIssuerName(a: PX509):PX509_NAME; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_NAME_hash')] + function SslX509NameHash(x: PX509_NAME):Cardinal; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_digest')] + function SslX509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_md5')] + function SslEvpMd5:PEVP_MD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_error_string')] + function ErrErrorString(e: integer; buf: String): String; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_get_error')] + function ErrGetError: integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_clean_error')] + procedure ErrClearError; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_free_strings')] + procedure ErrFreeStrings; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'ERR_remove_state')] + procedure ErrRemoveState(pid: integer); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'EVP_cleanup')] + procedure EVPcleanup; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'CRYPTO_cleanup_all_ex_data')] + procedure CRYPTOcleanupAllExData; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'RAND_screen')] + procedure RandScreen; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_new')] + function BioNew(b: PBIO_METHOD): PBIO; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_free_all')] + procedure BioFreeAll(b: PBIO); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_s_mem')] + function BioSMem: PBIO_METHOD; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_ctrl_pending')] + function BioCtrlPending(b: PBIO): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_read')] + function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'BIO_write')] + function BioWrite(b: PBIO; var Buf: String; Len: integer): integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'X509_print')] + function X509print(b: PBIO; a: PX509): integer; external; + + // 3DES functions + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_odd_parity')] + procedure DESsetoddparity(Key: des_cblock); external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_set_key_checked')] + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external; + + [DllImport(DLLUtilName, CharSet = CharSet.Ansi, + SetLastError = False, CallingConvention= CallingConvention.cdecl, + EntryPoint = 'DES_ecb_encrypt')] + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external; + + +{$ELSE} // libssl.dll function SslGetError(s: PSSL; ret_code: Integer):Integer; function SslLibraryInit:Integer; procedure SslLoadErrorStrings; - function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; +// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; + function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String):Integer; function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; procedure SslCtxFree(arg0: PSSL_CTX); function SslSetFd(s: PSSL; fd: Integer):Integer; @@ -171,38 +502,43 @@ var function SslMethodV3:PSSL_METHOD; function SslMethodTLSV1:PSSL_METHOD; function SslMethodV23:PSSL_METHOD; - function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; - function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; + function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; +// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; + function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer; function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; - procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: Pointer); - procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: Pointer); - function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; + procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); + procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); +// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; + function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: String; const CApath: String):Integer; function SslNew(ctx: PSSL_CTX):PSSL; procedure SslFree(ssl: PSSL); function SslAccept(ssl: PSSL):Integer; function SslConnect(ssl: PSSL):Integer; function SslShutdown(ssl: PSSL):Integer; - function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; - function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; - function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; + function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; + function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; function SslPending(ssl: PSSL):Integer; - function SslGetVersion(ssl: PSSL):PChar; + function SslGetVersion(ssl: PSSL):String; function SslGetPeerCertificate(ssl: PSSL):PX509; - procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); - function SSLGetCurrentCipher(s: PSSL):pointer; - function SSLCipherGetName(c: pointer):PChar; - function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; + procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); + function SSLGetCurrentCipher(s: PSSL):SslPtr; + function SSLCipherGetName(c: SslPtr): String; + function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; function SSLGetVerifyResult(ssl: PSSL):Integer; // libeay.dll procedure SslX509Free(x: PX509); - function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; + function SslX509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; function SslX509GetSubjectName(a: PX509):PX509_NAME; function SslX509GetIssuerName(a: PX509):PX509_NAME; function SslX509NameHash(x: PX509_NAME):Cardinal; - function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; + function SslX509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; function SslEvpMd5:PEVP_MD; - function ErrErrorString(e: integer; buf: PChar): PChar; +// function ErrErrorString(e: integer; buf: PChar): PChar; + function ErrErrorString(e: integer; buf: String): String; function ErrGetError: integer; procedure ErrClearError; procedure ErrFreeStrings; @@ -214,9 +550,15 @@ var procedure BioFreeAll(b: PBIO); function BioSMem: PBIO_METHOD; function BioCtrlPending(b: PBIO): integer; - function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; - function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; + function BioRead(b: PBIO; var Buf: String; Len: integer): integer; + function BioWrite(b: PBIO; Buf: String; Len: integer): integer; function X509print(b: PBIO; a: PX509): integer; + // 3DES functions + procedure DESsetoddparity(Key: des_cblock); + function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; + procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); + +{$ENDIF} function IsSSLloaded: Boolean; function InitSSLInterface: Boolean; @@ -226,6 +568,7 @@ implementation uses SyncObjs; +{$IFNDEF CIL} type // libssl.dll TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; @@ -285,6 +628,11 @@ type TBioRead = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; TBioWrite = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl; TX509print = function(b: PBIO; a: PX509): integer; cdecl; + // 3DES functions + TDESsetoddparity = procedure(Key: des_cblock); cdecl; + TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl; + TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl; + var // libssl.dll @@ -345,11 +693,17 @@ var _BioRead: TBioRead = nil; _BioWrite: TBioWrite = nil; _X509print: TX509print = nil; + // 3DES functions + _DESsetoddparity: TDESsetoddparity = nil; + _DESsetkeychecked: TDESsetkeychecked = nil; + _DESecbencrypt: TDESecbencrypt = nil; +{$ENDIF} var SSLCS: TCriticalSection; SSLloaded: boolean = false; +{$IFNDEF CIL} // libssl.dll function SslGetError(s: PSSL; ret_code: Integer):Integer; begin @@ -373,10 +727,11 @@ begin _SslLoadErrorStrings; end; -function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; +//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; +function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String):Integer; begin if InitSSLInterface and Assigned(_SslCtxSetCipherList) then - Result := _SslCtxSetCipherList(arg0, str) + Result := _SslCtxSetCipherList(arg0, PChar(str)) else Result := 0; end; @@ -435,18 +790,20 @@ begin Result := nil; end; -function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; +//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; +function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer; begin if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then - Result := _SslCtxUsePrivateKeyFile(ctx, _file, _type) + Result := _SslCtxUsePrivateKeyFile(ctx, PChar(_file), _type) else Result := 0; end; -function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; +function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer; begin if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then - Result := _SslCtxUseCertificateChainFile(ctx, _file) + Result := _SslCtxUseCertificateChainFile(ctx, PChar(_file)) else Result := 0; end; @@ -459,22 +816,23 @@ begin Result := 0; end; -procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: Pointer); +procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); begin if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then _SslCtxSetDefaultPasswdCb(ctx, cb); end; -procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: Pointer); +procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); begin if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then _SslCtxSetDefaultPasswdCbUserdata(ctx, u); end; -function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; +//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; +function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: String; const CApath: String):Integer; begin if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then - Result := _SslCtxLoadVerifyLocations(ctx, CAfile, CApath) + Result := _SslCtxLoadVerifyLocations(ctx, PChar(CAfile), PChar(CApath)) else Result := 0; end; @@ -517,26 +875,29 @@ begin Result := -1; end; -function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; +//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer; begin if InitSSLInterface and Assigned(_SslRead) then - Result := _SslRead(ssl, buf, num) + Result := _SslRead(ssl, PChar(buf), num) else Result := -1; end; -function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; +//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer; +function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer; begin if InitSSLInterface and Assigned(_SslPeek) then - Result := _SslPeek(ssl, buf, num) + Result := _SslPeek(ssl, PChar(buf), num) else Result := -1; end; -function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; +//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer; +function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer; begin if InitSSLInterface and Assigned(_SslWrite) then - Result := _SslWrite(ssl, buf, num) + Result := _SslWrite(ssl, PChar(buf), num) else Result := -1; end; @@ -549,12 +910,13 @@ begin Result := 0; end; -function SslGetVersion(ssl: PSSL):PChar; +//function SslGetVersion(ssl: PSSL):PChar; +function SslGetVersion(ssl: PSSL):String; begin if InitSSLInterface and Assigned(_SslGetVersion) then Result := _SslGetVersion(ssl) else - Result := nil; + Result := ''; end; function SslGetPeerCertificate(ssl: PSSL):PX509; @@ -565,32 +927,38 @@ begin Result := nil; end; -procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); +//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: Pointer); +procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); begin if InitSSLInterface and Assigned(_SslCtxSetVerify) then - _SslCtxSetVerify(ctx, mode, arg2); + _SslCtxSetVerify(ctx, mode, @arg2); end; -function SSLGetCurrentCipher(s: PSSL):pointer; +function SSLGetCurrentCipher(s: PSSL):SslPtr; begin if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then +{$IFDEF CIL} +{$ELSE} Result := _SSLGetCurrentCipher(s) +{$ENDIF} else Result := nil; end; -function SSLCipherGetName(c: pointer):PChar; +//function SSLCipherGetName(c: pointer):PChar; +function SSLCipherGetName(c: SslPtr):String; begin if InitSSLInterface and Assigned(_SSLCipherGetName) then Result := _SSLCipherGetName(c) else - Result := nil; + Result := ''; end; -function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; +//function SSLCipherGetBits(c: pointer; alg_bits: PInteger):Integer; +function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; begin if InitSSLInterface and Assigned(_SSLCipherGetBits) then - Result := _SSLCipherGetBits(c, alg_bits) + Result := _SSLCipherGetBits(c, @alg_bits) else Result := 0; end; @@ -610,12 +978,13 @@ begin _SslX509Free(x); end; -function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; +//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; +function SslX509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String; begin if InitSSLInterface and Assigned(_SslX509NameOneline) then - Result := _SslX509NameOneline(a, buf,size) + Result := _SslX509NameOneline(a, PChar(buf),size) else - Result := nil; + Result := ''; end; function SslX509GetSubjectName(a: PX509):PX509_NAME; @@ -642,10 +1011,11 @@ begin Result := 0; end; -function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; +function SslX509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer; begin if InitSSLInterface and Assigned(_SslX509Digest) then - Result := _SslX509Digest(data, _type, md, len) + Result := _SslX509Digest(data, _type, PChar(md), @len) else Result := 0; end; @@ -658,12 +1028,13 @@ begin Result := nil; end; -function ErrErrorString(e: integer; buf: PChar): PChar; +//function ErrErrorString(e: integer; buf: PChar): PChar; +function ErrErrorString(e: integer; buf: String): String; begin if InitSSLInterface and Assigned(_ErrErrorString) then - Result := _ErrErrorString(e, buf) + Result := _ErrErrorString(e, PChar(buf)) else - Result := nil; + Result := ''; end; function ErrGetError: integer; @@ -740,18 +1111,20 @@ begin Result := 0; end; -function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; +//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; +function BioRead(b: PBIO; var Buf: String; Len: integer): integer; begin if InitSSLInterface and Assigned(_BioRead) then - Result := _BioRead(b, Buf, Len) + Result := _BioRead(b, PChar(Buf), Len) else Result := -2; end; -function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; +//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; +function BioWrite(b: PBIO; Buf: String; Len: integer): integer; begin if InitSSLInterface and Assigned(_BioWrite) then - Result := _BioWrite(b, Buf, Len) + Result := _BioWrite(b, PChar(Buf), Len) else Result := -2; end; @@ -764,6 +1137,45 @@ begin Result := 0; end; +// 3DES functions +procedure DESsetoddparity(Key: des_cblock); +begin + if InitSSLInterface and Assigned(_DESsetoddparity) then + _DESsetoddparity(Key); +end; + +function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; +begin + if InitSSLInterface and Assigned(_DESsetkeychecked) then + Result := _DESsetkeychecked(key, schedule) + else + Result := -1; +end; + +procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); +begin + if InitSSLInterface and Assigned(_DESecbencrypt) then + _DESecbencrypt(Input, output, ks, enc); +end; +{$ENDIF} + +function LoadLib(const Value: String): HModule; +begin +{$IFDEF CIL} + Result := LoadLibrary(Value); +{$ELSE} + Result := LoadLibrary(PChar(Value)); +{$ENDIF} +end; + +function GetProcAddr(module: HModule; const ProcName: string): SslPtr; +begin +{$IFDEF CIL} + Result := GetProcAddress(module, ProcName); +{$ELSE} + Result := GetProcAddress(module, PChar(ProcName)); +{$ENDIF} +end; function InitSSLInterface: Boolean; var @@ -774,71 +1186,86 @@ begin try if not IsSSLloaded then begin - SSLLibHandle := LoadLibrary(PChar(DLLSSLName)); - SSLUtilHandle := LoadLibrary(PChar(DLLUtilName)); -{$IFNDEF LINUX} +{$IFDEF CIL} + SSLLibHandle := 1; + SSLUtilHandle := 1; +{$ELSE} + SSLLibHandle := LoadLib(DLLSSLName); + SSLUtilHandle := LoadLib(DLLUtilName); + {$IFNDEF LINUX} if (SSLLibHandle = 0) then - SSLLibHandle := LoadLibrary(PChar(DLLSSLName2)); + SSLLibHandle := LoadLib(DLLSSLName2); + {$ENDIF} {$ENDIF} if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then begin - _SslGetError := GetProcAddress(SSLLibHandle, PChar('SSL_get_error')); - _SslLibraryInit := GetProcAddress(SSLLibHandle, PChar('SSL_library_init')); - _SslLoadErrorStrings := GetProcAddress(SSLLibHandle, PChar('SSL_load_error_strings')); - _SslCtxSetCipherList := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_cipher_list')); - _SslCtxNew := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_new')); - _SslCtxFree := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_free')); - _SslSetFd := GetProcAddress(SSLLibHandle, PChar('SSL_set_fd')); - _SslMethodV2 := GetProcAddress(SSLLibHandle, PChar('SSLv2_method')); - _SslMethodV3 := GetProcAddress(SSLLibHandle, PChar('SSLv3_method')); - _SslMethodTLSV1 := GetProcAddress(SSLLibHandle, PChar('TLSv1_method')); - _SslMethodV23 := GetProcAddress(SSLLibHandle, PChar('SSLv23_method')); - _SslCtxUsePrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_PrivateKey_file')); - _SslCtxUseCertificateChainFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_use_certificate_chain_file')); - _SslCtxCheckPrivateKeyFile := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_check_private_key')); - _SslCtxSetDefaultPasswdCb := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb')); - _SslCtxSetDefaultPasswdCbUserdata := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_default_passwd_cb_userdata')); - _SslCtxLoadVerifyLocations := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_load_verify_locations')); - _SslNew := GetProcAddress(SSLLibHandle, PChar('SSL_new')); - _SslFree := GetProcAddress(SSLLibHandle, PChar('SSL_free')); - _SslAccept := GetProcAddress(SSLLibHandle, PChar('SSL_accept')); - _SslConnect := GetProcAddress(SSLLibHandle, PChar('SSL_connect')); - _SslShutdown := GetProcAddress(SSLLibHandle, PChar('SSL_shutdown')); - _SslRead := GetProcAddress(SSLLibHandle, PChar('SSL_read')); - _SslPeek := GetProcAddress(SSLLibHandle, PChar('SSL_peek')); - _SslWrite := GetProcAddress(SSLLibHandle, PChar('SSL_write')); - _SslPending := GetProcAddress(SSLLibHandle, PChar('SSL_pending')); - _SslGetPeerCertificate := GetProcAddress(SSLLibHandle, PChar('SSL_get_peer_certificate')); - _SslGetVersion := GetProcAddress(SSLLibHandle, PChar('SSL_get_version')); - _SslCtxSetVerify := GetProcAddress(SSLLibHandle, PChar('SSL_CTX_set_verify')); - _SslGetCurrentCipher := GetProcAddress(SSLLibHandle, PChar('SSL_get_current_cipher')); - _SslCipherGetName := GetProcAddress(SSLLibHandle, PChar('SSL_CIPHER_get_name')); - _SslCipherGetBits := GetProcAddress(SSLLibHandle, PChar('SSL_CIPHER_get_bits')); - _SslGetVerifyResult := GetProcAddress(SSLLibHandle, PChar('SSL_get_verify_result')); - - _SslX509Free := GetProcAddress(SSLUtilHandle, PChar('X509_free')); - _SslX509NameOneline := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_oneline')); - _SslX509GetSubjectName := GetProcAddress(SSLUtilHandle, PChar('X509_get_subject_name')); - _SslX509GetIssuerName := GetProcAddress(SSLUtilHandle, PChar('X509_get_issuer_name')); - _SslX509NameHash := GetProcAddress(SSLUtilHandle, PChar('X509_NAME_hash')); - _SslX509Digest := GetProcAddress(SSLUtilHandle, PChar('X509_digest')); - _SslEvpMd5 := GetProcAddress(SSLUtilHandle, PChar('EVP_md5')); - _ErrErrorString := GetProcAddress(SSLUtilHandle, PChar('ERR_error_string')); - _ErrGetError := GetProcAddress(SSLUtilHandle, PChar('ERR_get_error')); - _ErrClearError := GetProcAddress(SSLUtilHandle, PChar('ERR_clear_error')); - _ErrFreeStrings := GetProcAddress(SSLUtilHandle, PChar('ERR_free_strings')); - _ErrRemoveState := GetProcAddress(SSLUtilHandle, PChar('ERR_remove_state')); - _EVPCleanup := GetProcAddress(SSLUtilHandle, PChar('EVP_cleanup')); - _CRYPTOcleanupAllExData := GetProcAddress(SSLUtilHandle, PChar('CRYPTO_cleanup_all_ex_data')); - _RandScreen := GetProcAddress(SSLUtilHandle, PChar('RAND_screen')); - _BioNew := GetProcAddress(SSLUtilHandle, PChar('BIO_new')); - _BioFreeAll := GetProcAddress(SSLUtilHandle, PChar('BIO_free_all')); - _BioSMem := GetProcAddress(SSLUtilHandle, PChar('BIO_s_mem')); - _BioCtrlPending := GetProcAddress(SSLUtilHandle, PChar('BIO_ctrl_pending')); - _BioRead := GetProcAddress(SSLUtilHandle, PChar('BIO_read')); - _BioWrite := GetProcAddress(SSLUtilHandle, PChar('BIO_write')); - _X509print := GetProcAddress(SSLUtilHandle, PChar('X509_print')); +{$IFNDEF CIL} + _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); + _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init'); + _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings'); + _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list'); + _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new'); + _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free'); + _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd'); + _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method'); + _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method'); + _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method'); + _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method'); + _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_file'); + _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file'); + _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key'); + _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb'); + _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata'); + _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations'); + _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new'); + _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free'); + _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept'); + _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect'); + _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown'); + _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read'); + _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek'); + _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write'); + _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending'); + _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate'); + _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version'); + _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify'); + _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher'); + _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name'); + _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits'); + _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result'); + _SslX509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); + _SslX509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); + _SslX509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); + _SslX509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); + _SslX509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); + _SslX509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); + _SslEvpMd5 := GetProcAddr(SSLUtilHandle, 'EVP_md5'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string'); + _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); + _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); + _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); + _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); + _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); + _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data'); + _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen'); + _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new'); + _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all'); + _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem'); + _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending'); + _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read'); + _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write'); + _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); + // 3DES functions + _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); + _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); + _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); +{$ENDIF} +{$IFDEF CIL} + SslLibraryInit; + SslLoadErrorStrings; + RandScreen; +{$ELSE} SetLength(s, 1024); x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); SetLength(s, x); @@ -847,7 +1274,6 @@ begin x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); SetLength(s, x); SSLUtilFile := s; - Result := True; //init library if assigned(_SslLibraryInit) then _SslLibraryInit; @@ -855,6 +1281,8 @@ begin _SslLoadErrorStrings; if assigned(_RandScreen) then _RandScreen; +{$ENDIF} + Result := True; SSLloaded := True; end else @@ -862,12 +1290,16 @@ begin //load failed! if SSLLibHandle <> 0 then begin +{$IFNDEF CIL} FreeLibrary(SSLLibHandle); +{$ENDIF} SSLLibHandle := 0; end; if SSLUtilHandle <> 0 then begin +{$IFNDEF CIL} FreeLibrary(SSLUtilHandle); +{$ENDIF} SSLLibHandle := 0; end; Result := False; @@ -895,15 +1327,20 @@ begin SSLloaded := false; if SSLLibHandle <> 0 then begin +{$IFNDEF CIL} FreeLibrary(SSLLibHandle); +{$ENDIF} SSLLibHandle := 0; end; if SSLUtilHandle <> 0 then begin +{$IFNDEF CIL} FreeLibrary(SSLUtilHandle); +{$ENDIF} SSLLibHandle := 0; end; +{$IFNDEF CIL} _SslGetError := nil; _SslLibraryInit := nil; _SslLoadErrorStrings := nil; @@ -960,6 +1397,11 @@ begin _BioRead := nil; _BioWrite := nil; _X509print := nil; + // 3DES functions + _DESsetoddparity := nil; + _DESsetkeychecked := nil; + _DESecbencrypt := nil; +{$ENDIF} finally SSLCS.Leave; end; @@ -978,7 +1420,9 @@ end; finalization begin +{$IFNDEF CIL} DestroySSLInterface; +{$ENDIF} SSLCS.Free; end; diff --git a/synautil.pas b/synautil.pas index 8f55cd0..8501c94 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 004.000.002 | +| Project : Ararat Synapse | 004.006.004 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2004, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | All Rights Reserved. | |==============================================================================| @@ -44,6 +44,8 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} +{:@abstract(Support procedures and functions)} + {$IFDEF FPC} {$MODE DELPHI} {$ENDIF} @@ -56,73 +58,275 @@ unit synautil; interface uses - SysUtils, Classes, {$IFDEF LINUX} - Libc; + Libc, {$ELSE} - Windows; + Windows, {$ENDIF} + SysUtils, Classes; +{:Return your timezone bias from UTC time in minutes.} function TimeZoneBias: integer; + +{:Return your timezone bias from UTC time in string representation like "+0200".} function TimeZone: string; + +{:Returns current time in format defined in RFC-822. Useful for SMTP messages, + but other protocols use this time format as well. Results contains the timezone + specification. Four digit year is used to break any Y2K concerns. (Example + 'Fri, 15 Oct 1999 21:14:56 +0200')} function Rfc822DateTime(t: TDateTime): string; + +{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"} function CDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in format 'yymmdd hhnnss'} function SimpleDateTime(t: TDateTime): string; + +{:Returns date and time in format defined in ANSI C compilers in format + "ddd mmm d hh:nn:ss yyyy" } function AnsiCDateTime(t: TDateTime): string; -function GetMonthNumber(Value: string): integer; + +{:Decode three-letter string with name of month to their month number. If string + not match any month name, then is returned 0. For parsing are used predefined + names for English, French and German and names from system locale too.} +function GetMonthNumber(Value: AnsiString): integer; + +{:Return decoded time from given string. Time must be witch separator ':'. You + can use "hh:mm" or "hh:mm:ss".} function GetTimeFromStr(Value: string): TDateTime; + +{:Decode string in format "m-d-y" to TDateTime type.} function GetDateMDYFromStr(Value: string): TDateTime; + +{:Decode various string representations of date and time to Tdatetime type. + This function do all timezone corrections too! This function can decode lot of + formats like: + @longcode(# + ddd, d mmm yyyy hh:mm:ss + ddd, d mmm yy hh:mm:ss + ddd, mmm d yyyy hh:mm:ss + ddd mmm dd hh:mm:ss yyyy #) + +and more with lot of modifications, include: +@longcode(# +Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format +#) +Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.) +or numeric representation (like +0200). By convention defined in RFC timezone + +0000 is GMT and -0000 is current your system timezone.} function DecodeRfcDateTime(Value: string): TDateTime; + +{:Return current system date and time in UTC timezone.} function GetUTTime: TDateTime; + +{:Set Newdt as current system date and time in UTC timezone. This function work + only if you have administrator rights!} function SetUTTime(Newdt: TDateTime): Boolean; + +{:Return current value of system timer with precizion 1 millisecond. Good for + measure time difference.} function GetTick: ULong; + +{:Return difference between two timestamps. It working fine only for differences + smaller then maxint. (difference must be smaller then 24 days.)} function TickDelta(TickOld, TickNew: ULong): ULong; -function CodeInt(Value: Word): string; -function DecodeInt(const Value: string; Index: Integer): Word; + +{:Return two characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeInt(Value: Word): Ansistring; + +{:Decodes two characters located at "Index" offset position of the "Value" + string to Word values.} +function DecodeInt(const Value: Ansistring; Index: Integer): Word; + +{:Return four characters, which ordinal values represents the value in byte + format. (High-endian)} +function CodeLongInt(Value: LongInt): Ansistring; + +{:Decodes four characters located at "Index" offset position of the "Value" + string to LongInt values.} +function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; + +{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} function IsIP(const Value: string): Boolean; + +{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} function IsIP6(const Value: string): Boolean; + +{:Returns a string with the "Host" ip address converted to binary form.} function IPToID(Host: string): string; -function DumpStr(const Buffer: string): string; -function DumpExStr(const Buffer: string): string; -procedure Dump(const Buffer, DumpFile: string); -procedure DumpEx(const Buffer, DumpFile: string); + +{:Dump binary buffer stored in a string to a result string.} +function DumpStr(const Buffer: Ansistring): string; + +{:Dump binary buffer stored in a string to a result string. All bytes with code + of character is written as character, not as hexadecimal value.} +function DumpExStr(const Buffer: Ansistring): string; + +{:Dump binary buffer stored in a string to a file with DumpFile filename.} +procedure Dump(const Buffer: AnsiString; DumpFile: string); + +{:Dump binary buffer stored in a string to a file with DumpFile filename. All + bytes with code of character is written as character, not as hexadecimal value.} +procedure DumpEx(const Buffer: AnsiString; DumpFile: string); + +{:Like TrimLeft, but remove only spaces, not control characters!} +function TrimSPLeft(const S: string): string; + +{:Like TrimRight, but remove only spaces, not control characters!} +function TrimSPRight(const S: string): string; + +{:Like Trim, but remove only spaces, not control characters!} +function TrimSP(const S: string): string; + +{:Returns a portion of the "Value" string located to the left of the "Delimiter" + string. If a delimiter is not found, results is original string.} function SeparateLeft(const Value, Delimiter: string): string; + +{:Returns the portion of the "Value" string located to the right of the + "Delimiter" string. If a delimiter is not found, results is original string.} function SeparateRight(const Value, Delimiter: string): string; + +{:Returns parameter value from string in format: + parameter1="value1"; parameter2=value2} function GetParameter(const Value, Parameter: string): string; + +{:parse value string with elements differed by Delimiter into stringlist.} procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); + +{:parse value string with elements differed by ';' into stringlist.} procedure ParseParameters(Value: string; const Parameters: TStrings); + +{:Index of string in stringlist with same beginning as Value is returned.} function IndexByBegin(Value: string; const List: TStrings): integer; + +{:Returns only the e-mail portion of an address from the full address format. + i.e. returns 'nobody@@somewhere.com' from '"someone" '} function GetEmailAddr(const Value: string): string; + +{:Returns only the description part from a full address format. i.e. returns + 'someone' from '"someone" '} function GetEmailDesc(Value: string): string; -function StrToHex(const Value: string): string; + +{:Returns a string with hexadecimal digits representing the corresponding values + of the bytes found in "Value" string.} +function StrToHex(const Value: Ansistring): string; + +{:Returns a string of binary "Digits" representing "Value".} function IntToBin(Value: Integer; Digits: Byte): string; + +{:Returns an integer equivalent of the binary string in "Value". + (i.e. ('10001010') returns 138)} function BinToInt(const Value: string): Integer; + +{:Parses a URL to its various components.} function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, Para: string): string; + +{:Replaces all "Search" string values found within "Value" string, with the + "Replace" string value.} function ReplaceString(Value, Search, Replace: string): string; + +{:It is like RPos, but search is from specified possition.} function RPosEx(const Sub, Value: string; From: integer): Integer; + +{:It is like POS function, but from right side of Value string.} function RPos(const Sub, Value: String): Integer; + +{:Like @link(fetch), but working with binary strings, not with text.} +function FetchBin(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string.} function Fetch(var Value: string; const Delimiter: string): string; + +{:Fetch string from left of Value string. This function ignore delimitesr inside + quotations.} function FetchEx(var Value: string; const Delimiter, Quotation: string): string; + +{:If string is binary string (contains non-printable characters), then is + returned true.} function IsBinaryString(const Value: string): Boolean; -function PosCRLF(const Value: string; var Terminator: string): integer; + +{:return position of string terminator in string. If terminator found, then is + returned in terminator parameter. + Possible line terminators are: CRLF, LFCR, CR, LF} +function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; + +{:Delete empty strings from end of stringlist.} Procedure StringsTrim(const value: TStrings); + +{:Like Pos function, buf from given string possition.} function PosFrom(const SubStr, Value: String; From: integer): integer; + +{$IFNDEF CIL} +{:Increase pointer by value.} function IncPoint(const p: pointer; Value: integer): pointer; +{$ENDIF} + +{:Get string between PairBegin and PairEnd. This function respect nesting. + For example: + @longcode(# + Value is: 'Hi! (hello(yes!))' + pairbegin is: '(' + pairend is: ')' + In this case result is: 'hello(yes!)'#)} function GetBetween(const PairBegin, PairEnd, Value: string): string; + +{:Return count of Chr in Value string.} function CountOfChar(const Value: string; Chr: char): integer; -function UnquoteStr(const Value: string; Quote: Char): string; + +{:Remove quotation from Value string. If Value is not quoted, then return same + string without any modification. } +function UnquoteStr(Value: string; Quote: Char): string; + +{:Convert lines in stringlist from 'name: value' form to 'name=value' form.} +procedure HeadersToList(const Value: TStrings); + +{:Convert lines in stringlist from 'name=value' form to 'name: value' form.} +procedure ListToHeaders(const Value: TStrings); + +{:swap bytes in integer.} +function SwapBytes(Value: integer): integer; + +{:read string with requested length form stream.} +function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; + +{:write string to stream.} +procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); + +var + {:can be used for your own months strings for @link(getmonthnumber)} + CustomMonthNames: array[1..12] of string; implementation {==============================================================================} const - MyDayNames: array[1..7] of string = + MyDayNames: array[1..7] of AnsiString = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); - MyMonthNames: array[1..12] of string = - ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', - 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); +var + MyMonthNames: array[0..6, 1..12] of AnsiString = + ( + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English + 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'), + ('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French + 'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'), + ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2 + 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'), + ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', //German#2 + 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'), + ('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen', //Czech + 'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro') + ); + {==============================================================================} @@ -183,7 +387,7 @@ var begin DecodeDate(t, wYear, wMonth, wDay); Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, - MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]); + MyMonthNames[1, wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]); end; {==============================================================================} @@ -193,7 +397,7 @@ var wYear, wMonth, wDay: word; begin DecodeDate(t, wYear, wMonth, wDay); - Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay, + Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay, FormatDateTime('hh:nn:ss', t)]); end; @@ -211,7 +415,7 @@ var wYear, wMonth, wDay: word; begin DecodeDate(t, wYear, wMonth, wDay); - Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth], + Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth], wDay, FormatDateTime('hh:nn:ss yyyy ', t)]); end; @@ -304,14 +508,26 @@ end; {==============================================================================} -function GetMonthNumber(Value: string): integer; +function GetMonthNumber(Value: AnsiString): integer; var n: integer; + function TestMonth(Value: AnsiString; Index: Integer): Boolean; + var + n: integer; + begin + Result := False; + for n := 0 to 6 do + if Value = AnsiUppercase(MyMonthNames[n, Index]) then + begin + Result := True; + Break; + end; + end; begin Result := 0; - Value := Uppercase(Value); + Value := AnsiUppercase(Value); for n := 1 to 12 do - if Value = uppercase(MyMonthNames[n]) then + if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then begin Result := n; Break; @@ -328,7 +544,7 @@ begin if (x > 0) and ((Length(Value) - x) > 2) then Value := Copy(Value, 1, x + 2); Value := ReplaceString(Value, ':', TimeSeparator); - Result := 0; + Result := -1; try Result := StrToTime(Value); except @@ -423,7 +639,7 @@ begin if rpos(':', s) > Pos(':', s) then begin t := GetTimeFromStr(s); - if t <> 0 then + if t <> -1 then Result := t; continue; end; @@ -574,14 +790,17 @@ end; {==============================================================================} -function CodeInt(Value: Word): string; +function CodeInt(Value: Word): Ansistring; begin - Result := Chr(Hi(Value)) + Chr(Lo(Value)) + setlength(result, 2); + result[1] := AnsiChar(Value div 256); + result[2] := AnsiChar(Value mod 256); +// Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256) end; {==============================================================================} -function DecodeInt(const Value: string; Index: Integer): Word; +function DecodeInt(const Value: Ansistring; Index: Integer): Word; var x, y: Byte; begin @@ -598,6 +817,48 @@ end; {==============================================================================} +function CodeLongInt(Value: Longint): Ansistring; +var + x, y: word; +begin + // this is fix for negative numbers on systems where longint = integer + x := (Value shr 16) and integer($ffff); + y := Value and integer($ffff); + setlength(result, 4); + result[1] := AnsiChar(x div 256); + result[2] := AnsiChar(x mod 256); + result[3] := AnsiChar(y div 256); + result[4] := AnsiChar(y mod 256); +end; + +{==============================================================================} + +function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; +var + x, y: Byte; + xl, yl: Byte; +begin + if Length(Value) > Index then + x := Ord(Value[Index]) + else + x := 0; + if Length(Value) >= (Index + 1) then + y := Ord(Value[Index + 1]) + else + y := 0; + if Length(Value) >= (Index + 2) then + xl := Ord(Value[Index + 2]) + else + xl := 0; + if Length(Value) >= (Index + 3) then + yl := Ord(Value[Index + 3]) + else + yl := 0; + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + function IsIP(const Value: string): Boolean; var TempIP: string; @@ -686,10 +947,8 @@ begin for x := 1 to 3 do begin t := ''; - s := StrScan(PChar(Host), '.'); - t := Copy(Host, 1, (Length(Host) - Length(s))); - Delete(Host, 1, (Length(Host) - Length(s) + 1)); - i := StrToIntDef(t, 0); + s := Fetch(Host, '.'); + i := StrToIntDef(s, 0); Result := Result + Chr(i); end; i := StrToIntDef(Host, 0); @@ -698,7 +957,7 @@ end; {==============================================================================} -function DumpStr(const Buffer: string): string; +function DumpStr(const Buffer: Ansistring): string; var n: Integer; begin @@ -709,7 +968,7 @@ end; {==============================================================================} -function DumpExStr(const Buffer: string): string; +function DumpExStr(const Buffer: Ansistring): string; var n: Integer; x: Byte; @@ -727,13 +986,13 @@ end; {==============================================================================} -procedure Dump(const Buffer, DumpFile: string); +procedure Dump(const Buffer: AnsiString; DumpFile: string); var f: Text; begin AssignFile(f, DumpFile); if FileExists(DumpFile) then - DeleteFile(PChar(DumpFile)); + DeleteFile(DumpFile); Rewrite(f); try Writeln(f, DumpStr(Buffer)); @@ -744,13 +1003,13 @@ end; {==============================================================================} -procedure DumpEx(const Buffer, DumpFile: string); +procedure DumpEx(const Buffer: AnsiString; DumpFile: string); var f: Text; begin AssignFile(f, DumpFile); if FileExists(DumpFile) then - DeleteFile(PChar(DumpFile)); + DeleteFile(DumpFile); Rewrite(f); try Writeln(f, DumpExStr(Buffer)); @@ -761,15 +1020,48 @@ end; {==============================================================================} +function TrimSPLeft(const S: string): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] = ' ') do + Inc(I); + Result := Copy(S, I, Maxint); +end; + +{==============================================================================} + +function TrimSPRight(const S: string): string; +var + I: Integer; +begin + I := Length(S); + while (I > 0) and (S[I] = ' ') do + Dec(I); + Result := Copy(S, 1, I); +end; + +{==============================================================================} + +function TrimSP(const S: string): string; +begin + Result := TrimSPLeft(s); + Result := TrimSPRight(Result); +end; + +{==============================================================================} + function SeparateLeft(const Value, Delimiter: string): string; var x: Integer; begin x := Pos(Delimiter, Value); if x < 1 then - Result := Trim(Value) + Result := Value else - Result := Trim(Copy(Value, 1, x - 1)); + Result := Copy(Value, 1, x - 1); end; {==============================================================================} @@ -781,29 +1073,33 @@ begin x := Pos(Delimiter, Value); if x > 0 then x := x + Length(Delimiter) - 1; - Result := Trim(Copy(Value, x + 1, Length(Value) - x)); + Result := Copy(Value, x + 1, Length(Value) - x); end; {==============================================================================} function GetParameter(const Value, Parameter: string): string; var - x: Integer; s: string; + v: string; begin - x := Pos(UpperCase(Parameter), UpperCase(Value)); Result := ''; - if x > 0 then + v := Value; + while v <> '' do begin - s := Copy(Value, x + Length(Parameter), Length(Value) - - (x + Length(Parameter)) + 1); - s := Trim(s); - if Length(s) > 1 then + s := Trim(FetchEx(v, ';', '"')); + if Pos(Uppercase(parameter), Uppercase(s)) = 1 then begin - x := pos(';', s); - if x > 0 then - s := Copy(s, 1, x - 1); - Result := UnquoteStr(s, '"'); + Delete(s, 1, Length(Parameter)); + s := Trim(s); + if s = '' then + Break; + if s[1] = '=' then + begin + Result := Trim(SeparateRight(s, '=')); + Result := UnquoteStr(Result, '"'); + break; + end; end; end; end; @@ -817,7 +1113,7 @@ begin Parameters.Clear; while Value <> '' do begin - s := Fetch(Value, Delimiter); + s := Trim(FetchEx(Value, Delimiter, '"')); Parameters.Add(s); end; end; @@ -887,7 +1183,7 @@ end; {==============================================================================} -function StrToHex(const Value: string): string; +function StrToHex(const Value: Ansistring): string; var n: Integer; begin @@ -1040,14 +1336,20 @@ begin x := Pos(Search, Value); while x > 0 do begin + {$IFNDEF CIL} l := Length(Result); SetLength(Result, l + x - 1); Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1); -// Result:=Result+Copy(Value,1,x-1); + {$ELSE} + Result:=Result+Copy(Value,1,x-1); + {$ENDIF} + {$IFNDEF CIL} l := Length(Result); SetLength(Result, l + lr); Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr); -// Result:=Result+Replace; + {$ELSE} + Result:=Result+Replace; + {$ENDIF} Delete(Value, 1, x - 1 + ls); x := Pos(Search, Value); end; @@ -1082,7 +1384,7 @@ end; {==============================================================================} -function Fetch(var Value: string; const Delimiter: string): string; +function FetchBin(var Value: string; const Delimiter: string): string; var s: string; begin @@ -1091,8 +1393,16 @@ begin if s = Value then Value := '' else - Value := Trim(s); - Result := Trim(Result); + Value := s; +end; + +{==============================================================================} + +function Fetch(var Value: string; const Delimiter: string): string; +begin + Result := FetchBin(Value, Delimiter); + Result := TrimSP(Result); + Value := TrimSP(Value); end; {==============================================================================} @@ -1126,7 +1436,7 @@ begin Delete(Value, 1, 1); end; end; - Result := Trim(Result); + Result := Result; end; {==============================================================================} @@ -1146,7 +1456,7 @@ end; {==============================================================================} -function PosCRLF(const Value: string; var Terminator: string): integer; +function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; var p1, p2, p3, p4: integer; const @@ -1211,7 +1521,11 @@ begin From := 1; while (ls + from - 1) <= (lv) do begin + {$IFNDEF CIL} if CompareMem(@SubStr[1],@Value[from],ls) then + {$ELSE} + if SubStr = copy(Value, from, ls) then + {$ENDIF} begin result := from; break; @@ -1223,10 +1537,12 @@ end; {==============================================================================} +{$IFNDEF CIL} function IncPoint(const p: pointer; Value: integer): pointer; begin Result := pointer(integer(p) + Value); end; +{$ENDIF} {==============================================================================} @@ -1267,16 +1583,124 @@ end; {==============================================================================} -function UnquoteStr(const Value: string; Quote: Char): string; +function UnquoteStr(Value: string; Quote: Char): string; + {$IFNDEF CIL} var - LText: PChar; + LText: PChar; + {$ENDIF} begin + //workaround for bug in AnsiExtractQuotedStr + //...if string begin by Quote, but not ending by Quote, then it eat last char. + if length(Value) > 1 then + if (Value[1] = Quote) and (Value[Length(value)] <> Quote) then + Value := Value + Quote; + {$IFNDEF CIL} LText := PChar(Value); - Result := AnsiExtractQuotedStr(LText, Quote); - if Result = '' then + Result := AnsiExtractQuotedStr(LText, Quote); + {$ELSE} + Result := DequotedStr(Value, Quote); + {$ENDIF} + if Result = '' then Result := Value; end; {==============================================================================} +procedure HeadersToList(const Value: TStrings); +var + n, x: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos(':', s); + if x > 0 then + begin + s[x] := '='; + Value[n] := s; + end; + end; +end; + +{==============================================================================} + +procedure ListToHeaders(const Value: TStrings); +var + n, x: integer; + s: string; +begin + for n := 0 to Value.Count -1 do + begin + s := Value[n]; + x := Pos('=', s); + if x > 0 then + begin + s[x] := ':'; + Value[n] := s; + end; + end; +end; + +{==============================================================================} + +function SwapBytes(Value: integer): integer; +var + s: string; + x, y, xl, yl: Byte; +begin + s := CodeLongInt(Value); + x := Ord(s[4]); + y := Ord(s[3]); + xl := Ord(s[2]); + yl := Ord(s[1]); + Result := ((x * 256 + y) * 65536) + (xl * 256 + yl); +end; + +{==============================================================================} + +function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString; +var + x: integer; +{$IFDEF CIL} + buf: Array of Byte; +{$ENDIF} +begin +{$IFDEF CIL} + Setlength(buf, Len); + x := Stream.read(buf, Len); + SetLength(buf, x); + Result := StringOf(Buf); +{$ELSE} + Setlength(Result, Len); + x := Stream.read(Pchar(Result)^, Len); + SetLength(Result, x); +{$ENDIF} +end; + +{==============================================================================} + +procedure WriteStrToStream(const Stream: TStream; Value: AnsiString); +{$IFDEF CIL} +var + buf: Array of Byte; +{$ENDIF} +begin +{$IFDEF CIL} + buf := BytesOf(Value); + Stream.Write(buf,length(Value)); +{$ELSE} + Stream.Write(PChar(Value)^, Length(Value)); +{$ENDIF} +end; + +{==============================================================================} +var + n: integer; +begin + for n := 1 to 12 do + begin + CustomMonthNames[n] := ShortMonthNames[n]; + MyMonthNames[0, n] := ShortMonthNames[n]; + end; end. diff --git a/synsock.pas b/synsock.pas index 55b4803..4b4fc46 100644 --- a/synsock.pas +++ b/synsock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 004.001.000 | +| Project : Ararat Synapse | 005.000.000 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| @@ -42,1428 +42,23 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -{$IFNDEF LINUX} -//{$DEFINE WINSOCK1} -{Note about define WINSOCK1: -If you activate this compiler directive, then socket interface level 1.1 is -used instead default level 2.2. Level 2.2 is not available on old W95, however -you can install update. - -On Linux is level 2.2 always used! -} -{$ENDIF} - -//{$DEFINE FORCEOLDAPI} -{Note about define FORCEOLDAPI: -If you activate this compiler directive, then is allways used old socket API -for name resolution. If you leave this directive inactive, then the new API -is used, when running system allows it. - -For IPv6 support you must have new API! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - (*$HPPEMIT '/* EDE 2003-02-19 */' *) - (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) - (*$HPPEMIT '#undef h_addr' *) - (*$HPPEMIT '#undef IOCPARM_MASK' *) - (*$HPPEMIT '#undef FD_SETSIZE' *) - (*$HPPEMIT '#undef IOC_VOID' *) - (*$HPPEMIT '#undef IOC_OUT' *) - (*$HPPEMIT '#undef IOC_IN' *) - (*$HPPEMIT '#undef IOC_INOUT' *) - (*$HPPEMIT '#undef FIONREAD' *) - (*$HPPEMIT '#undef FIONBIO' *) - (*$HPPEMIT '#undef FIOASYNC' *) - (*$HPPEMIT '#undef IPPROTO_IP' *) - (*$HPPEMIT '#undef IPPROTO_ICMP' *) - (*$HPPEMIT '#undef IPPROTO_IGMP' *) - (*$HPPEMIT '#undef IPPROTO_TCP' *) - (*$HPPEMIT '#undef IPPROTO_UDP' *) - (*$HPPEMIT '#undef IPPROTO_RAW' *) - (*$HPPEMIT '#undef IPPROTO_MAX' *) - (*$HPPEMIT '#undef INADDR_ANY' *) - (*$HPPEMIT '#undef INADDR_LOOPBACK' *) - (*$HPPEMIT '#undef INADDR_BROADCAST' *) - (*$HPPEMIT '#undef INADDR_NONE' *) - (*$HPPEMIT '#undef INVALID_SOCKET' *) - (*$HPPEMIT '#undef SOCKET_ERROR' *) - (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) - (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) - (*$HPPEMIT '#undef IP_OPTIONS' *) - (*$HPPEMIT '#undef IP_TOS' *) - (*$HPPEMIT '#undef IP_TTL' *) - (*$HPPEMIT '#undef IP_MULTICAST_IF' *) - (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) - (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) - (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) - (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) - (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) - (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) - (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) - (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) - (*$HPPEMIT '#undef SOL_SOCKET' *) - (*$HPPEMIT '#undef SO_DEBUG' *) - (*$HPPEMIT '#undef SO_ACCEPTCONN' *) - (*$HPPEMIT '#undef SO_REUSEADDR' *) - (*$HPPEMIT '#undef SO_KEEPALIVE' *) - (*$HPPEMIT '#undef SO_DONTROUTE' *) - (*$HPPEMIT '#undef SO_BROADCAST' *) - (*$HPPEMIT '#undef SO_USELOOPBACK' *) - (*$HPPEMIT '#undef SO_LINGER' *) - (*$HPPEMIT '#undef SO_OOBINLINE' *) - (*$HPPEMIT '#undef SO_DONTLINGER' *) - (*$HPPEMIT '#undef SO_SNDBUF' *) - (*$HPPEMIT '#undef SO_RCVBUF' *) - (*$HPPEMIT '#undef SO_SNDLOWAT' *) - (*$HPPEMIT '#undef SO_RCVLOWAT' *) - (*$HPPEMIT '#undef SO_SNDTIMEO' *) - (*$HPPEMIT '#undef SO_RCVTIMEO' *) - (*$HPPEMIT '#undef SO_ERROR' *) - (*$HPPEMIT '#undef SO_OPENTYPE' *) - (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) - (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) - (*$HPPEMIT '#undef SO_MAXDG' *) - (*$HPPEMIT '#undef SO_MAXPATHDG' *) - (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) - (*$HPPEMIT '#undef SO_CONNECT_TIME' *) - (*$HPPEMIT '#undef SO_TYPE' *) - (*$HPPEMIT '#undef SOCK_STREAM' *) - (*$HPPEMIT '#undef SOCK_DGRAM' *) - (*$HPPEMIT '#undef SOCK_RAW' *) - (*$HPPEMIT '#undef SOCK_RDM' *) - (*$HPPEMIT '#undef SOCK_SEQPACKET' *) - (*$HPPEMIT '#undef TCP_NODELAY' *) - (*$HPPEMIT '#undef AF_UNSPEC' *) - (*$HPPEMIT '#undef SOMAXCONN' *) - (*$HPPEMIT '#undef AF_INET' *) - (*$HPPEMIT '#undef AF_MAX' *) - (*$HPPEMIT '#undef PF_UNSPEC' *) - (*$HPPEMIT '#undef PF_INET' *) - (*$HPPEMIT '#undef PF_MAX' *) - (*$HPPEMIT '#undef MSG_OOB' *) - (*$HPPEMIT '#undef MSG_PEEK' *) - (*$HPPEMIT '#undef WSABASEERR' *) - (*$HPPEMIT '#undef WSAEINTR' *) - (*$HPPEMIT '#undef WSAEBADF' *) - (*$HPPEMIT '#undef WSAEACCES' *) - (*$HPPEMIT '#undef WSAEFAULT' *) - (*$HPPEMIT '#undef WSAEINVAL' *) - (*$HPPEMIT '#undef WSAEMFILE' *) - (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) - (*$HPPEMIT '#undef WSAEINPROGRESS' *) - (*$HPPEMIT '#undef WSAEALREADY' *) - (*$HPPEMIT '#undef WSAENOTSOCK' *) - (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) - (*$HPPEMIT '#undef WSAEMSGSIZE' *) - (*$HPPEMIT '#undef WSAEPROTOTYPE' *) - (*$HPPEMIT '#undef WSAENOPROTOOPT' *) - (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) - (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) - (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) - (*$HPPEMIT '#undef WSAEADDRINUSE' *) - (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) - (*$HPPEMIT '#undef WSAENETDOWN' *) - (*$HPPEMIT '#undef WSAENETUNREACH' *) - (*$HPPEMIT '#undef WSAENETRESET' *) - (*$HPPEMIT '#undef WSAECONNABORTED' *) - (*$HPPEMIT '#undef WSAECONNRESET' *) - (*$HPPEMIT '#undef WSAENOBUFS' *) - (*$HPPEMIT '#undef WSAEISCONN' *) - (*$HPPEMIT '#undef WSAENOTCONN' *) - (*$HPPEMIT '#undef WSAESHUTDOWN' *) - (*$HPPEMIT '#undef WSAETOOMANYREFS' *) - (*$HPPEMIT '#undef WSAETIMEDOUT' *) - (*$HPPEMIT '#undef WSAECONNREFUSED' *) - (*$HPPEMIT '#undef WSAELOOP' *) - (*$HPPEMIT '#undef WSAENAMETOOLONG' *) - (*$HPPEMIT '#undef WSAEHOSTDOWN' *) - (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) - (*$HPPEMIT '#undef WSAENOTEMPTY' *) - (*$HPPEMIT '#undef WSAEPROCLIM' *) - (*$HPPEMIT '#undef WSAEUSERS' *) - (*$HPPEMIT '#undef WSAEDQUOT' *) - (*$HPPEMIT '#undef WSAESTALE' *) - (*$HPPEMIT '#undef WSAEREMOTE' *) - (*$HPPEMIT '#undef WSASYSNOTREADY' *) - (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) - (*$HPPEMIT '#undef WSANOTINITIALISED' *) - (*$HPPEMIT '#undef WSAEDISCON' *) - (*$HPPEMIT '#undef WSAENOMORE' *) - (*$HPPEMIT '#undef WSAECANCELLED' *) - (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) - (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) - (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) - (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) - (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) - (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) - (*$HPPEMIT '#undef WSA_E_NO_MORE' *) - (*$HPPEMIT '#undef WSA_E_CANCELLED' *) - (*$HPPEMIT '#undef WSAEREFUSED' *) - (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) - (*$HPPEMIT '#undef HOST_NOT_FOUND' *) - (*$HPPEMIT '#undef WSATRY_AGAIN' *) - (*$HPPEMIT '#undef TRY_AGAIN' *) - (*$HPPEMIT '#undef WSANO_RECOVERY' *) - (*$HPPEMIT '#undef NO_RECOVERY' *) - (*$HPPEMIT '#undef WSANO_DATA' *) - (*$HPPEMIT '#undef NO_DATA' *) - (*$HPPEMIT '#undef WSANO_ADDRESS' *) - (*$HPPEMIT '#undef ENAMETOOLONG' *) - (*$HPPEMIT '#undef ENOTEMPTY' *) - (*$HPPEMIT '#undef FD_CLR' *) - (*$HPPEMIT '#undef FD_ISSET' *) - (*$HPPEMIT '#undef FD_SET' *) - (*$HPPEMIT '#undef FD_ZERO' *) - (*$HPPEMIT '#undef NO_ADDRESS' *) -{$ENDIF} - +{:@exclude} unit synsock; {$MINENUMSIZE 4} -interface - -uses - SyncObjs, SysUtils, -{$IFDEF LINUX} - {$IFDEF FPC} - synafpc, - {$ENDIF} - Libc; -{$ELSE} - Windows; -{$ENDIF} - -function InitSocketInterface(stack: string): Boolean; -function DestroySocketInterface: Boolean; - -const -{$IFDEF WINSOCK1} - WinsockLevel = $0101; -{$ELSE} - WinsockLevel = $0202; -{$ENDIF} - -type - u_char = Char; - u_short = Word; - u_int = Integer; - u_long = Longint; - pu_long = ^u_long; - pu_short = ^u_short; - TSocket = u_int; - -{$IFDEF LINUX} -type - DWORD = Integer; - __fd_mask = LongWord; -const - __FD_SETSIZE = 1024; - __NFDBITS = 8 * sizeof(__fd_mask); -type - __fd_set = {packed} record - fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask; - end; - TFDSet = __fd_set; - PFDSet = ^TFDSet; - -const - FIONREAD = $541B; - FIONBIO = $5421; - FIOASYNC = $5452; - -{$ELSE} -const - FD_SETSIZE = 64; -type - PFDSet = ^TFDSet; - TFDSet = packed record - fd_count: u_int; - fd_array: array[0..FD_SETSIZE-1] of TSocket; - end; - -const - IOCPARM_MASK = $7f; - IOC_VOID = $20000000; - IOC_OUT = $40000000; - IOC_IN = $80000000; - IOC_INOUT = (IOC_IN or IOC_OUT); - FIONREAD = IOC_OUT or { get # bytes to read } - ((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or - (Longint(Byte('f')) shl 8) or 127; - FIONBIO = IOC_IN or { set/clear non-blocking i/o } - ((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or - (Longint(Byte('f')) shl 8) or 126; - FIOASYNC = IOC_IN or { set/clear async i/o } - ((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or - (Longint(Byte('f')) shl 8) or 125; - -{$ENDIF} - -type - PTimeVal = ^TTimeVal; - TTimeVal = packed record - tv_sec: Longint; - tv_usec: Longint; - end; - -const - IPPROTO_IP = 0; { Dummy } - IPPROTO_ICMP = 1; { Internet Control Message Protocol } - IPPROTO_IGMP = 2; { Internet Group Management Protocol} - IPPROTO_TCP = 6; { TCP } - IPPROTO_UDP = 17; { User Datagram Protocol } - IPPROTO_IPV6 = 41; - IPPROTO_ICMPV6 = 58; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - SunB = packed record - s_b1, s_b2, s_b3, s_b4: u_char; - end; - - SunW = packed record - s_w1, s_w2: u_short; - end; - - PInAddr = ^TInAddr; - TInAddr = packed record - case integer of - 0: (S_un_b: SunB); - 1: (S_un_w: SunW); - 2: (S_addr: u_long); - end; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = packed record - case Integer of - 0: (sin_family: u_short; - sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - 1: (sa_family: u_short; - sa_data: array[0..13] of Char) - end; - - TIP_mreq = record - imr_multiaddr: TInAddr; { IP multicast address of group } - imr_interface: TInAddr; { local IP address of interface } - end; - - SunB6 = packed record - s_b1, s_b2, s_b3, s_b4, - s_b5, s_b6, s_b7, s_b8, - s_b9, s_b10, s_b11, s_b12, - s_b13, s_b14, s_b15, s_b16: u_char; - end; - - SunW6 = packed record - s_w1, s_w2, s_w3, s_w4, - s_w5, s_w6, s_w7, s_w8: u_short; - end; - - SunDW6 = packed record - s_dw1, s_dw2, s_dw3, s_dw4: longint; - end; - - S6_Bytes = SunB6; - S6_Words = SunW6; - S6_DWords = SunDW6; - S6_Addr = SunB6; - - PInAddr6 = ^TInAddr6; - TInAddr6 = packed record - case integer of - 0: (S_un_b: SunB6); - 1: (S_un_w: SunW6); - 2: (S_un_dw: SunDW6); - end; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = packed record - sin6_family: u_short; // AF_INET6 - sin6_port: u_short; // Transport level port number - sin6_flowinfo: u_long; // IPv6 flow information - sin6_addr: TInAddr6; // IPv6 address - sin6_scope_id: u_long; // Scope Id: IF number for link-local - // SITE id for site-local - end; - - TIPv6_mreq = record - ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: u_long; // Interface index. - padding: u_long; - end; - - -{$IFDEF LINUX} - hostent = record - h_name: PChar; - h_aliases: PPChar; - h_addrtype: Integer; - h_length: Cardinal; - case Byte of - 0: (h_addr_list: PPChar); - 1: (h_addr: PPChar); - end; - - PNetEnt = ^TNetEnt; - TNetEnt = record - n_name: PChar; - n_aliases: PPChar; - n_addrtype: Integer; - n_net: uint32_t; - end; - - PServEnt = ^TServEnt; - TServEnt = record - s_name: PChar; - s_aliases: PPChar; - s_port: Integer; - s_proto: PChar; - end; - - PProtoEnt = ^TProtoEnt; - TProtoEnt = record - p_name: PChar; - p_aliases: ^PChar; - p_proto: u_short; - end; - -{$ELSE} - PHostEnt = ^THostEnt; - THostEnt = packed record - h_name: PChar; - h_aliases: ^PChar; - h_addrtype: Smallint; - h_length: Smallint; - case integer of - 0: (h_addr_list: ^PChar); - 1: (h_addr: ^PInAddr); - end; - - PNetEnt = ^TNetEnt; - TNetEnt = packed record - n_name: PChar; - n_aliases: ^PChar; - n_addrtype: Smallint; - n_net: u_long; - end; - - PServEnt = ^TServEnt; - TServEnt = packed record - s_name: PChar; - s_aliases: ^PChar; - s_port: Smallint; - s_proto: PChar; - end; - - PProtoEnt = ^TProtoEnt; - TProtoEnt = packed record - p_name: PChar; - p_aliases: ^Pchar; - p_proto: Smallint; - end; -{$ENDIF} - -const - INADDR_ANY = $00000000; - INADDR_LOOPBACK = $7F000001; - INADDR_BROADCAST = $FFFFFFFF; - INADDR_NONE = $FFFFFFFF; - ADDR_ANY = INADDR_ANY; - INVALID_SOCKET = TSocket(NOT(0)); - SOCKET_ERROR = -1; - - function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; - function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; - function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; - function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; - procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); - procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -var - in6addr_any, in6addr_loopback : TInAddr6; - -const - WSADESCRIPTION_LEN = 256; - WSASYS_STATUS_LEN = 128; -type - PWSAData = ^TWSAData; - TWSAData = packed record - wVersion: Word; - wHighVersion: Word; - szDescription: array[0..WSADESCRIPTION_LEN] of Char; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; - iMaxSockets: Word; - iMaxUdpDg: Word; - lpVendorInfo: PChar; - end; - -{=============================================================================} -{$IFDEF LINUX} -Const - IP_TOS = 1; { int; IP type of service and precedence. } - IP_TTL = 2; { int; IP time to live. } - IP_HDRINCL = 3; { int; Header is included with data. } - IP_OPTIONS = 4; { ip_opts; IP per-packet options. } - IP_ROUTER_ALERT = 5; { bool } - IP_RECVOPTS = 6; { bool } - IP_RETOPTS = 7; { bool } - IP_PKTINFO = 8; { bool } - IP_PKTOPTIONS = 9; - IP_PMTUDISC = 10; { obsolete name? } - IP_MTU_DISCOVER = 10; { int; see below } - IP_RECVERR = 11; { bool } - IP_RECVTTL = 12; { bool } - IP_RECVTOS = 13; { bool } - IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f } - IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl } - IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership } - IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership } - - SOL_SOCKET = 1; - - SO_DEBUG = 1; - SO_REUSEADDR = 2; - SO_TYPE = 3; - SO_ERROR = 4; - SO_DONTROUTE = 5; - SO_BROADCAST = 6; - SO_SNDBUF = 7; - SO_RCVBUF = 8; - SO_KEEPALIVE = 9; - SO_OOBINLINE = 10; - SO_NO_CHECK = 11; - SO_PRIORITY = 12; - SO_LINGER = 13; - SO_BSDCOMPAT = 14; - SO_REUSEPORT = 15; - SO_PASSCRED = 16; - SO_PEERCRED = 17; - SO_RCVLOWAT = 18; - SO_SNDLOWAT = 19; - SO_RCVTIMEO = 20; - SO_SNDTIMEO = 21; -{ Security levels - as per NRL IPv6 - don't actually do anything } - SO_SECURITY_AUTHENTICATION = 22; - SO_SECURITY_ENCRYPTION_TRANSPORT = 23; - SO_SECURITY_ENCRYPTION_NETWORK = 24; - SO_BINDTODEVICE = 25; -{ Socket filtering } - SO_ATTACH_FILTER = 26; - SO_DETACH_FILTER = 27; - - SOMAXCONN = 128; - - IPV6_UNICAST_HOPS = 16; - IPV6_MULTICAST_IF = 17; - IPV6_MULTICAST_HOPS = 18; - IPV6_MULTICAST_LOOP = 19; - IPV6_JOIN_GROUP = 20; - IPV6_LEAVE_GROUP = 21; - - MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. - - // getnameinfo constants - NI_MAXHOST = 1025; - NI_MAXSERV = 32; - NI_NOFQDN = $4; - NI_NUMERICHOST = $1; - NI_NAMEREQD = $8; - NI_NUMERICSERV = $2; - NI_DGRAM = $10; - -{=============================================================================} -{$ELSE} -Const - {$IFDEF WINSOCK1} - IP_OPTIONS = 1; - IP_MULTICAST_IF = 2; { set/get IP multicast interface } - IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } - IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 5; { add an IP group membership } - IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } - IP_TTL = 7; { set/get IP Time To Live } - IP_TOS = 8; { set/get IP Type Of Service } - IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } - {$ELSE} - IP_OPTIONS = 1; - IP_HDRINCL = 2; - IP_TOS = 3; { set/get IP Type Of Service } - IP_TTL = 4; { set/get IP Time To Live } - IP_MULTICAST_IF = 9; { set/get IP multicast interface } - IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } - IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = 12; { add an IP group membership } - IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } - IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } - {$ENDIF} - - IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } - IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } - IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } - - SOL_SOCKET = $ffff; {options for socket level } -{ Option flags per-socket. } - SO_DEBUG = $0001; { turn on debugging info recording } - SO_ACCEPTCONN = $0002; { socket has had listen() } - SO_REUSEADDR = $0004; { allow local address reuse } - SO_KEEPALIVE = $0008; { keep connections alive } - SO_DONTROUTE = $0010; { just use interface addresses } - SO_BROADCAST = $0020; { permit sending of broadcast msgs } - SO_USELOOPBACK = $0040; { bypass hardware when possible } - SO_LINGER = $0080; { linger on close if data present } - SO_OOBINLINE = $0100; { leave received OOB data in line } - SO_DONTLINGER = $ff7f; -{ Additional options. } - SO_SNDBUF = $1001; { send buffer size } - SO_RCVBUF = $1002; { receive buffer size } - SO_SNDLOWAT = $1003; { send low-water mark } - SO_RCVLOWAT = $1004; { receive low-water mark } - SO_SNDTIMEO = $1005; { send timeout } - SO_RCVTIMEO = $1006; { receive timeout } - SO_ERROR = $1007; { get error status and clear } - SO_TYPE = $1008; { get socket type } -{ WinSock 2 extension -- new options } - SO_GROUP_ID = $2001; { ID of a socket group} - SO_GROUP_PRIORITY = $2002; { the relative priority within a group} - SO_MAX_MSG_SIZE = $2003; { maximum message size } - SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } - SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } - SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; - PVD_CONFIG = $3001; {configuration info for service provider } -{ Option for opening sockets for synchronous access. } - SO_OPENTYPE = $7008; - SO_SYNCHRONOUS_ALERT = $10; - SO_SYNCHRONOUS_NONALERT = $20; -{ Other NT-specific options. } - SO_MAXDG = $7009; - SO_MAXPATHDG = $700A; - SO_UPDATE_ACCEPT_CONTEXT = $700B; - SO_CONNECT_TIME = $700C; - - SOMAXCONN = $7fffffff; - - IPV6_UNICAST_HOPS = 8; // ??? - IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f - IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl - IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback - IPV6_JOIN_GROUP = 12; // add an IP group membership - IPV6_LEAVE_GROUP = 13; // drop an IP group membership - - MSG_NOSIGNAL = 0; - - // getnameinfo constants - NI_MAXHOST = 1025; - NI_MAXSERV = 32; - NI_NOFQDN = $1; - NI_NUMERICHOST = $2; - NI_NAMEREQD = $4; - NI_NUMERICSERV = $8; - NI_DGRAM = $10; - -{$ENDIF} -{=============================================================================} - -const - SOCK_STREAM = 1; { stream socket } - SOCK_DGRAM = 2; { datagram socket } - SOCK_RAW = 3; { raw-protocol interface } - SOCK_RDM = 4; { reliably-delivered message } - SOCK_SEQPACKET = 5; { sequenced packet stream } - -{ TCP options. } - TCP_NODELAY = $0001; - -{ Address families. } - - AF_UNSPEC = 0; { unspecified } - AF_INET = 2; { internetwork: UDP, TCP, etc. } -{$IFDEF LINUX} - AF_INET6 = 10; { Internetwork Version 6 } -{$ELSE} - AF_INET6 = 23; { Internetwork Version 6 } -{$ENDIF} - AF_MAX = 24; - -{ Protocol families, same as address families for now. } - PF_UNSPEC = AF_UNSPEC; - PF_INET = AF_INET; - PF_INET6 = AF_INET6; - PF_MAX = AF_MAX; - -type - { Structure used by kernel to store most addresses. } - - PSockAddr = ^TSockAddr; - TSockAddr = TSockAddrIn; - - { Structure used by kernel to pass protocol information in raw sockets. } - PSockProto = ^TSockProto; - TSockProto = packed record - sp_family: u_short; - sp_protocol: u_short; - end; - -type - PAddrInfo = ^TAddrInfo; - TAddrInfo = record - ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. - ai_family: integer; // PF_xxx. - ai_socktype: integer; // SOCK_xxx. - ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. - ai_addrlen: u_int; // Length of ai_addr. - {$IFDEF LINUX} // broken definition in LIBC??? :-O - ai_addr: PSockAddr; // Binary address. - ai_canonname: PChar; // Canonical name for nodename. - {$ELSE} - ai_canonname: PChar; // Canonical name for nodename. - ai_addr: PSockAddr; // Binary address. - {$ENDIF} - ai_next: PAddrInfo; // Next structure in linked list. - end; - -const - // Flags used in "hints" argument to getaddrinfo(). - AI_PASSIVE = $1; // Socket address will be used in bind() call. - AI_CANONNAME = $2; // Return canonical name in first ai_canonname. - AI_NUMERICHOST = $4; // Nodename must be a numeric address string. - -type -{ Structure used for manipulating linger option. } - PLinger = ^TLinger; - TLinger = packed record - l_onoff: u_short; - l_linger: u_short; - end; - -const - -{ Define constant based on rfc883, used by gethostbyxxxx() calls. } - - MSG_OOB = $01; // Process out-of-band data. - MSG_PEEK = $02; // Peek at incoming messages. - -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -procedure FD_ZERO(var FDSet: TFDSet); - -{=============================================================================} -{$IFDEF LINUX} -const - WSAEINTR = EINTR; - WSAEBADF = EBADF; - WSAEACCES = EACCES; - WSAEFAULT = EFAULT; - WSAEINVAL = EINVAL; - WSAEMFILE = EMFILE; - WSAEWOULDBLOCK = EWOULDBLOCK; - WSAEINPROGRESS = EINPROGRESS; - WSAEALREADY = EALREADY; - WSAENOTSOCK = ENOTSOCK; - WSAEDESTADDRREQ = EDESTADDRREQ; - WSAEMSGSIZE = EMSGSIZE; - WSAEPROTOTYPE = EPROTOTYPE; - WSAENOPROTOOPT = ENOPROTOOPT; - WSAEPROTONOSUPPORT = EPROTONOSUPPORT; - WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT; - WSAEOPNOTSUPP = EOPNOTSUPP; - WSAEPFNOSUPPORT = EPFNOSUPPORT; - WSAEAFNOSUPPORT = EAFNOSUPPORT; - WSAEADDRINUSE = EADDRINUSE; - WSAEADDRNOTAVAIL = EADDRNOTAVAIL; - WSAENETDOWN = ENETDOWN; - WSAENETUNREACH = ENETUNREACH; - WSAENETRESET = ENETRESET; - WSAECONNABORTED = ECONNABORTED; - WSAECONNRESET = ECONNRESET; - WSAENOBUFS = ENOBUFS; - WSAEISCONN = EISCONN; - WSAENOTCONN = ENOTCONN; - WSAESHUTDOWN = ESHUTDOWN; - WSAETOOMANYREFS = ETOOMANYREFS; - WSAETIMEDOUT = ETIMEDOUT; - WSAECONNREFUSED = ECONNREFUSED; - WSAELOOP = ELOOP; - WSAENAMETOOLONG = ENAMETOOLONG; - WSAEHOSTDOWN = EHOSTDOWN; - WSAEHOSTUNREACH = EHOSTUNREACH; - WSAENOTEMPTY = ENOTEMPTY; - WSAEPROCLIM = -1; - WSAEUSERS = EUSERS; - WSAEDQUOT = EDQUOT; - WSAESTALE = ESTALE; - WSAEREMOTE = EREMOTE; - WSASYSNOTREADY = -2; - WSAVERNOTSUPPORTED = -3; - WSANOTINITIALISED = -4; - WSAEDISCON = -5; - WSAHOST_NOT_FOUND = HOST_NOT_FOUND; - WSATRY_AGAIN = TRY_AGAIN; - WSANO_RECOVERY = NO_RECOVERY; - WSANO_DATA = -6; - - EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. } - EAI_NONAME = -2; { NAME or SERVICE is unknown. } - EAI_AGAIN = -3; { Temporary failure in name resolution. } - EAI_FAIL = -4; { Non-recoverable failure in name res. } - EAI_NODATA = -5; { No address associated with NAME. } - EAI_FAMILY = -6; { `ai_family' not supported. } - EAI_SOCKTYPE = -7; { `ai_socktype' not supported. } - EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. } - EAI_ADDRFAMILY = -9; { Address family for NAME not supported. } - EAI_MEMORY = -10; { Memory allocation failure. } - EAI_SYSTEM = -11; { System error returned in `errno'. } - -{$ELSE} - -const - -{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } - WSABASEERR = 10000; - -{ Windows Sockets definitions of regular Microsoft C error constants } - - WSAEINTR = (WSABASEERR+4); - WSAEBADF = (WSABASEERR+9); - WSAEACCES = (WSABASEERR+13); - WSAEFAULT = (WSABASEERR+14); - WSAEINVAL = (WSABASEERR+22); - WSAEMFILE = (WSABASEERR+24); - -{ Windows Sockets definitions of regular Berkeley error constants } - - WSAEWOULDBLOCK = (WSABASEERR+35); - WSAEINPROGRESS = (WSABASEERR+36); - WSAEALREADY = (WSABASEERR+37); - WSAENOTSOCK = (WSABASEERR+38); - WSAEDESTADDRREQ = (WSABASEERR+39); - WSAEMSGSIZE = (WSABASEERR+40); - WSAEPROTOTYPE = (WSABASEERR+41); - WSAENOPROTOOPT = (WSABASEERR+42); - WSAEPROTONOSUPPORT = (WSABASEERR+43); - WSAESOCKTNOSUPPORT = (WSABASEERR+44); - WSAEOPNOTSUPP = (WSABASEERR+45); - WSAEPFNOSUPPORT = (WSABASEERR+46); - WSAEAFNOSUPPORT = (WSABASEERR+47); - WSAEADDRINUSE = (WSABASEERR+48); - WSAEADDRNOTAVAIL = (WSABASEERR+49); - WSAENETDOWN = (WSABASEERR+50); - WSAENETUNREACH = (WSABASEERR+51); - WSAENETRESET = (WSABASEERR+52); - WSAECONNABORTED = (WSABASEERR+53); - WSAECONNRESET = (WSABASEERR+54); - WSAENOBUFS = (WSABASEERR+55); - WSAEISCONN = (WSABASEERR+56); - WSAENOTCONN = (WSABASEERR+57); - WSAESHUTDOWN = (WSABASEERR+58); - WSAETOOMANYREFS = (WSABASEERR+59); - WSAETIMEDOUT = (WSABASEERR+60); - WSAECONNREFUSED = (WSABASEERR+61); - WSAELOOP = (WSABASEERR+62); - WSAENAMETOOLONG = (WSABASEERR+63); - WSAEHOSTDOWN = (WSABASEERR+64); - WSAEHOSTUNREACH = (WSABASEERR+65); - WSAENOTEMPTY = (WSABASEERR+66); - WSAEPROCLIM = (WSABASEERR+67); - WSAEUSERS = (WSABASEERR+68); - WSAEDQUOT = (WSABASEERR+69); - WSAESTALE = (WSABASEERR+70); - WSAEREMOTE = (WSABASEERR+71); - -{ Extended Windows Sockets error constant definitions } - - WSASYSNOTREADY = (WSABASEERR+91); - WSAVERNOTSUPPORTED = (WSABASEERR+92); - WSANOTINITIALISED = (WSABASEERR+93); - WSAEDISCON = (WSABASEERR+101); - WSAENOMORE = (WSABASEERR+102); - WSAECANCELLED = (WSABASEERR+103); - WSAEEINVALIDPROCTABLE = (WSABASEERR+104); - WSAEINVALIDPROVIDER = (WSABASEERR+105); - WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); - WSASYSCALLFAILURE = (WSABASEERR+107); - WSASERVICE_NOT_FOUND = (WSABASEERR+108); - WSATYPE_NOT_FOUND = (WSABASEERR+109); - WSA_E_NO_MORE = (WSABASEERR+110); - WSA_E_CANCELLED = (WSABASEERR+111); - WSAEREFUSED = (WSABASEERR+112); - -{ Error return codes from gethostbyname() and gethostbyaddr() - (when using the resolver). Note that these errors are - retrieved via WSAGetLastError() and must therefore follow - the rules for avoiding clashes with error numbers from - specific implementations or language run-time systems. - For this reason the codes are based at WSABASEERR+1001. - Note also that [WSA]NO_ADDRESS is defined only for - compatibility purposes. } - -{ Authoritative Answer: Host not found } - WSAHOST_NOT_FOUND = (WSABASEERR+1001); - HOST_NOT_FOUND = WSAHOST_NOT_FOUND; -{ Non-Authoritative: Host not found, or SERVERFAIL } - WSATRY_AGAIN = (WSABASEERR+1002); - TRY_AGAIN = WSATRY_AGAIN; -{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } - WSANO_RECOVERY = (WSABASEERR+1003); - NO_RECOVERY = WSANO_RECOVERY; -{ Valid name, no data record of requested type } - WSANO_DATA = (WSABASEERR+1004); - NO_DATA = WSANO_DATA; -{ no address, look for MX record } - WSANO_ADDRESS = WSANO_DATA; - NO_ADDRESS = WSANO_ADDRESS; - - EWOULDBLOCK = WSAEWOULDBLOCK; - EINPROGRESS = WSAEINPROGRESS; - EALREADY = WSAEALREADY; - ENOTSOCK = WSAENOTSOCK; - EDESTADDRREQ = WSAEDESTADDRREQ; - EMSGSIZE = WSAEMSGSIZE; - EPROTOTYPE = WSAEPROTOTYPE; - ENOPROTOOPT = WSAENOPROTOOPT; - EPROTONOSUPPORT = WSAEPROTONOSUPPORT; - ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; - EOPNOTSUPP = WSAEOPNOTSUPP; - EPFNOSUPPORT = WSAEPFNOSUPPORT; - EAFNOSUPPORT = WSAEAFNOSUPPORT; - EADDRINUSE = WSAEADDRINUSE; - EADDRNOTAVAIL = WSAEADDRNOTAVAIL; - ENETDOWN = WSAENETDOWN; - ENETUNREACH = WSAENETUNREACH; - ENETRESET = WSAENETRESET; - ECONNABORTED = WSAECONNABORTED; - ECONNRESET = WSAECONNRESET; - ENOBUFS = WSAENOBUFS; - EISCONN = WSAEISCONN; - ENOTCONN = WSAENOTCONN; - ESHUTDOWN = WSAESHUTDOWN; - ETOOMANYREFS = WSAETOOMANYREFS; - ETIMEDOUT = WSAETIMEDOUT; - ECONNREFUSED = WSAECONNREFUSED; - ELOOP = WSAELOOP; - ENAMETOOLONG = WSAENAMETOOLONG; - EHOSTDOWN = WSAEHOSTDOWN; - EHOSTUNREACH = WSAEHOSTUNREACH; - ENOTEMPTY = WSAENOTEMPTY; - EPROCLIM = WSAEPROCLIM; - EUSERS = WSAEUSERS; - EDQUOT = WSAEDQUOT; - ESTALE = WSAESTALE; - EREMOTE = WSAEREMOTE; - - EAI_ADDRFAMILY = 1; // Address family for nodename not supported. - EAI_AGAIN = 2; // Temporary failure in name resolution. - EAI_BADFLAGS = 3; // Invalid value for ai_flags. - EAI_FAIL = 4; // Non-recoverable failure in name resolution. - EAI_FAMILY = 5; // Address family ai_family not supported. - EAI_MEMORY = 6; // Memory allocation failure. - EAI_NODATA = 7; // No address associated with nodename. - EAI_NONAME = 8; // Nodename nor servname provided, or not known. - EAI_SERVICE = 9; // Servname not supported for ai_socktype. - EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. - EAI_SYSTEM = 11; // System error returned in errno. - -{$ENDIF} - -{=============================================================================} -var - WSAStartup: function(wVersionRequired: Word; var WSData: TWSAData): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - WSACleanup: function: Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - WSAGetLastError: function: Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetServByName: function(name, proto: PChar): PServEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetServByPort: function(port: Integer; proto: PChar): PServEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetProtoByName: function(name: PChar): PProtoEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetProtoByNumber: function(proto: Integer): PProtoEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetHostByName: function(name: PChar): PHostEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetHostByAddr: function(addr: Pointer; len, Struc: Integer): PHostEnt - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetHostName: function(name: PChar; len: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Shutdown: function(s: TSocket; how: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - SetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar; - optlen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar; - var optlen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - SendTo: function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; - tolen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Send: function(s: TSocket; const Buf; len, flags: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Recv: function(s: TSocket; var Buf; len, flags: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - RecvFrom: function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; - var fromlen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - ntohs: function(netshort: u_short): u_short - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - ntohl: function(netlong: u_long): u_long - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Listen: function(s: TSocket; backlog: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - IoctlSocket: function(s: TSocket; cmd: DWORD; var arg: u_long): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Inet_ntoa: function(inaddr: TInAddr): PChar - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Inet_addr: function(cp: PChar): u_long - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - htons: function(hostshort: u_short): u_short - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - htonl: function(hostlong: u_long): u_long - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetSockName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetPeerName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Connect: function(s: TSocket; name: PSockAddr; namelen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - CloseSocket: function(s: TSocket): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Bind: function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Accept: function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Socket: function(af, Struc, Protocol: Integer): TSocket - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - Select: function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - - GetAddrInfo: function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo; - var Addrinfo: PAddrInfo): integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - FreeAddrInfo: procedure(ai: PAddrInfo) - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - GetNameInfo: function( addr: PSockAddr; namelen: Integer; host: PChar; - hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer - {$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil; - {$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF} - -{$IFNDEF LINUX} - __WSAFDIsSet: function (s: TSocket; var FDSet: TFDSet): Bool - {$IFNDEF FPC}stdcall = nil; - {$ELSE}= nil; stdcall;{$ENDIF} - - WSAIoctl: function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; - cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; - lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; - lpCompletionRoutine: pointer): u_int - {$IFNDEF FPC}stdcall = nil; - {$ELSE}= nil; stdcall;{$ENDIF} +{$IFDEF CIL} + {$I ssdotnet.pas} {$ENDIF} {$IFDEF LINUX} -function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl; -function LSWSACleanup: Integer; cdecl; -function LSWSAGetLastError: Integer; cdecl; + {$I sslinux.pas} {$ENDIF} -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -type - TVarSin = packed record - case sin_family: u_short of - AF_INET: (sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - AF_INET6: (sin6_port: u_short; - sin6_flowinfo: u_long; - sin6_addr: TInAddr6; - sin6_scope_id: u_long); - end; - -function SizeOfVarSin(sin: TVarSin): integer; - -const -{$IFDEF LINUX} - DLLStackName = 'libc.so.6'; -{$ELSE} - {$IFDEF WINSOCK1} - DLLStackName = 'wsock32.dll'; - {$ELSE} - DLLStackName = 'ws2_32.dll'; - {$ENDIF} - DLLwship6 = 'wship6.dll'; +{$IFDEF WIN32} + {$I sswin32.pas} {$ENDIF} -implementation - -var - SynSockCount: Integer = 0; - LibHandle: THandle = 0; - Libwship6Handle: THandle = 0; - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and - (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and - (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.s_un_b.s_b1 = char($FF)); -end; - -function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; -begin - Result := (CompareMem( a, b, sizeof(TInAddr6))); -end; - -procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); -end; - -procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); -begin - FillChar(a^, sizeof(TInAddr6), 0); - a^.s_un_b.s_b16 := char(1); -end; - -{=============================================================================} -{$IFDEF LINUX} -var -{$IFNDEF FPC} - errno_loc: function: PInteger cdecl = nil; -{$ELSE} - errno_loc: function: PInteger = nil; cdecl; -{$ENDIF} - -function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; -begin - with WSData do - begin - wVersion := wVersionRequired; - wHighVersion := $202; - szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; - szSystemStatus := 'Running on Linux'; - iMaxSockets := 32768; - iMaxUdpDg := 8192; - end; - Result := 0; -end; - -function LSWSACleanup: Integer; -begin - Result := 0; -end; - -function LSWSAGetLastError: Integer; -var - p: PInteger; -begin - p := errno_loc; - Result := p^; -end; - -function __FDELT(Socket: TSocket): Integer; -begin - Result := Socket div __NFDBITS; -end; - -function __FDMASK(Socket: TSocket): __fd_mask; -begin - Result := 1 shl (Socket mod __NFDBITS); -end; - -function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; -begin - Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0; -end; - -procedure FD_SET(Socket: TSocket; var fdset: TFDSet); -begin - fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket); -end; - -procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); -begin - fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket)); -end; - -procedure FD_ZERO(var fdset: TFDSet); -var - I: Integer; -begin - with fdset do - for I := Low(fds_bits) to High(fds_bits) do - fds_bits[I] := 0; -end; - -{=============================================================================} -{$ELSE} -procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); -var - I: Integer; -begin - I := 0; - while I < FDSet.fd_count do - begin - if FDSet.fd_array[I] = Socket then - begin - while I < FDSet.fd_count - 1 do - begin - FDSet.fd_array[I] := FDSet.fd_array[I + 1]; - Inc(I); - end; - Dec(FDSet.fd_count); - Break; - end; - Inc(I); - end; -end; - -function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; -begin - Result := __WSAFDIsSet(Socket, FDSet); -end; - -procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); -begin - if FDSet.fd_count < FD_SETSIZE then - begin - FDSet.fd_array[FDSet.fd_count] := Socket; - Inc(FDSet.fd_count); - end; -end; - -procedure FD_ZERO(var FDSet: TFDSet); -begin - FDSet.fd_count := 0; -end; -{$ENDIF} - -{=============================================================================} - -function SizeOfVarSin(sin: TVarSin): integer; -begin - case sin.sin_family of - AF_INET: - Result := SizeOf(TSockAddrIn); - AF_INET6: - Result := SizeOf(TSockAddrIn6); - else - Result := 0; - end; -end; -{=============================================================================} - -function InitSocketInterface(stack: string): Boolean; -begin - Result := False; - SockEnhancedApi := False; - if stack = '' then - stack := DLLStackName; - SynSockCS.Enter; - try - if SynSockCount = 0 then - begin - SockEnhancedApi := False; - SockWship6Api := False; -{$IFDEF LINUX} - Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); -{$ENDIF} - LibHandle := LoadLibrary(PChar(Stack)); - if LibHandle <> 0 then - begin -{$IFDEF LINUX} - errno_loc := GetProcAddress(LibHandle, PChar('__errno_location')); - CloseSocket := GetProcAddress(LibHandle, PChar('close')); - IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl')); - WSAGetLastError := LSWSAGetLastError; - WSAStartup := LSWSAStartup; - WSACleanup := LSWSACleanup; -{$ELSE} - WSAIoctl := GetProcAddress(LibHandle, PChar('WSAIoctl')); - __WSAFDIsSet := GetProcAddress(LibHandle, PChar('__WSAFDIsSet')); - CloseSocket := GetProcAddress(LibHandle, PChar('closesocket')); - IoctlSocket := GetProcAddress(LibHandle, PChar('ioctlsocket')); - WSAGetLastError := GetProcAddress(LibHandle, PChar('WSAGetLastError')); - WSAStartup := GetProcAddress(LibHandle, PChar('WSAStartup')); - WSACleanup := GetProcAddress(LibHandle, PChar('WSACleanup')); -{$ENDIF} - Accept := GetProcAddress(LibHandle, PChar('accept')); - Bind := GetProcAddress(LibHandle, PChar('bind')); - Connect := GetProcAddress(LibHandle, PChar('connect')); - GetPeerName := GetProcAddress(LibHandle, PChar('getpeername')); - GetSockName := GetProcAddress(LibHandle, PChar('getsockname')); - GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt')); - Htonl := GetProcAddress(LibHandle, PChar('htonl')); - Htons := GetProcAddress(LibHandle, PChar('htons')); - Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr')); - Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa')); - Listen := GetProcAddress(LibHandle, PChar('listen')); - Ntohl := GetProcAddress(LibHandle, PChar('ntohl')); - Ntohs := GetProcAddress(LibHandle, PChar('ntohs')); - Recv := GetProcAddress(LibHandle, PChar('recv')); - RecvFrom := GetProcAddress(LibHandle, PChar('recvfrom')); - Select := GetProcAddress(LibHandle, PChar('select')); - Send := GetProcAddress(LibHandle, PChar('send')); - SendTo := GetProcAddress(LibHandle, PChar('sendto')); - SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt')); - ShutDown := GetProcAddress(LibHandle, PChar('shutdown')); - Socket := GetProcAddress(LibHandle, PChar('socket')); - GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr')); - GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname')); - GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname')); - GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber')); - GetServByName := GetProcAddress(LibHandle, PChar('getservbyname')); - GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport')); - GetHostName := GetProcAddress(LibHandle, PChar('gethostname')); - -{$IFNDEF FORCEOLDAPI} - GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo')); - FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo')); - GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo')); - SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) - and Assigned(GetNameInfo); - {$IFNDEF LINUX} - if not SockEnhancedApi then - begin - LibWship6Handle := LoadLibrary(PChar(DLLWship6)); - if LibWship6Handle <> 0 then - begin - GetAddrInfo := GetProcAddress(LibWship6Handle, PChar('getaddrinfo')); - FreeAddrInfo := GetProcAddress(LibWship6Handle, PChar('freeaddrinfo')); - GetNameInfo := GetProcAddress(LibWship6Handle, PChar('getnameinfo')); - SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) - and Assigned(GetNameInfo); - end; - end; - {$ENDIF} -{$ENDIF} - Result := True; - end; - end - else Result := True; - if Result then - Inc(SynSockCount); - finally - SynSockCS.Leave; - end; -end; - -function DestroySocketInterface: Boolean; -begin - SynSockCS.Enter; - try - Dec(SynSockCount); - if SynSockCount < 0 then - SynSockCount := 0; - if SynSockCount = 0 then - begin - if LibHandle <> 0 then - begin - FreeLibrary(libHandle); - LibHandle := 0; - end; - if LibWship6Handle <> 0 then - begin - FreeLibrary(LibWship6Handle); - LibWship6Handle := 0; - end; - end; - finally - SynSockCS.Leave; - end; - Result := True; -end; - -initialization -begin - SynSockCS := SyncObjs.TCriticalSection.Create; - SET_IN6_IF_ADDR_ANY (@in6addr_any); - SET_LOOPBACK_ADDR6 (@in6addr_loopback); -end; - -finalization -begin - SynSockCS.Free; -end; - end. + diff --git a/tlntsend.pas b/tlntsend.pas index 196c583..31a5057 100644 --- a/tlntsend.pas +++ b/tlntsend.pas @@ -42,7 +42,10 @@ | (Found at URL: http://www.ararat.cz/synapse/) | |==============================================================================} -//RFC-854 +{:@abstract(Telnet script client) + +Used RFC: RFC-854 +} {$IFDEF FPC} {$MODE DELPHI} @@ -79,9 +82,14 @@ const TLNT_IAC = #255; type + {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); + {:@abstract(Class with implementation of Telnet script client.) + + Note: Are you missing properties for specify server address and port? Look to + parent @link(TSynaClient) too!} TTelnetSend = class(TSynaClient) private FSock: TTCPBlockSocket; @@ -97,15 +105,34 @@ type public constructor Create; destructor Destroy; override; + + {:Connects to Telnet server.} function Login: Boolean; + + {:Logout from telnet server.} procedure Logout; + + {:Send this data to telnet server.} procedure Send(const Value: string); + + {:Reading data from telnet server until Value is readed. If it is not readed + until timeout, result is @false. Otherwise result is @true.} function WaitFor(const Value: string): Boolean; + + {:Read data terminated by terminator from telnet server.} function RecvTerminated(const Terminator: string): string; + + {:Read string from telnet server.} function RecvString: string; published + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} property Sock: TTCPBlockSocket read FSock; + + {:all readed datas in this session (from connect) is stored in this large + string.} property SessionLog: string read FSessionLog write FSessionLog; + + {:Terminal type indentification. By default is 'SYNAPSE'.} property TermType: string read FTermType write FTermType; end;