diff --git a/restemplate.lpi b/restemplate.lpi index b6945f1..29d151f 100644 --- a/restemplate.lpi +++ b/restemplate.lpi @@ -69,7 +69,7 @@ - + diff --git a/restemplate.pas b/restemplate.pas index 5989941..437fb5d 100644 --- a/restemplate.pas +++ b/restemplate.pas @@ -22,13 +22,9 @@ program restemplate; {$mode objfpc} {$modeswitch advancedrecords} -{.$define use_synapse} -{$define use_fclweb} - uses SysUtils, Classes, strutils, IniFiles, fgl, - {$ifdef use_synapse}httpsend, ssl_openssl,{$endif} - {$ifdef use_fclweb}fphttpclient,{$endif} + fphttpclient, JTemplate, fpjson, jsonparser, DOM, XMLRead, XMLWrite, @@ -66,8 +62,7 @@ var data: TextFile; line: String; parser: TJTemplateParser; - {$ifdef use_synapse}http: THTTPSend;{$endif} - {$ifdef use_fclweb}http: TFPHTTPClient;{$endif} + http: TFPHTTPClient; method, url: String; content: TStringList; commandMode: Boolean; @@ -143,11 +138,6 @@ begin parser.Replace; AHeader := parser.Content; - {$ifdef use_synapse} - http.Headers.Add(AHeader); - {$endif} - - {$ifdef use_fclweb} i := 1; while (i < Length(AHeader)) and (AHeader[i] <> ':') do Inc(i); @@ -156,7 +146,6 @@ begin value := Trim(Copy(AHeader, i + 1, Length(AHeader))); http.AddHeader(name, value); - {$endif} end; function IdentifyContentType(AString: String; out ContentType: TContentType): Boolean; @@ -243,9 +232,7 @@ end; procedure ProcessCall(AURL: String); var s: String; - {$ifdef use_fclweb} request, response: TStream; - {$endif} jsonParser: TJSONParser; jsonData: TJSONData; contentType: TContentType; @@ -256,37 +243,6 @@ begin AURL := parser.Content; writeln('Calling ', AURL); - {$ifdef use_synapse} - if content.Count > 0 then - begin - // Variable replacement - parser.Content := content.Text; - parser.Replace; - content.Text .= parser.Content; - - content.SaveToStream(http.Document); - end; - - if http.HTTPMethod(method, AURL) then - begin - writeln; - writeln('Status: ', http.ResultCode); - writeln; - writeln('Headers:'); - for s in http.Headers do - writeln(' ', s); - writeln; - content.LoadFromStream(http.Document); - writeln(content.Text); - end else - begin - ExitCode := 2; - writeln; - writeln('FAILED! Last Socket Error: ', http.Sock.SocksLastError); - end; - {$endif} - - {$ifdef use_fclweb} response := TMemoryStream.Create; request := nil; @@ -355,7 +311,6 @@ begin response.Free; request.Free; - {$endif} end; procedure CmdBasicAuth(AData: String); @@ -475,13 +430,7 @@ begin THighlightFilter.FilterExpression := TRegExpr.Create('( (FG|BG)(\d+))*$'); THighlightFilter.ParamExpression := TRegExpr.Create('(FG|BG)(\d+)'); - {$ifdef use_synapse} - http := THTTPSend.Create; - {$endif} - - {$ifdef use_fclweb} http := TFPHttpClient.Create(nil); - {$endif} commandMode := True; diff --git a/synapse/asn1util.pas b/synapse/asn1util.pas deleted file mode 100644 index e0419c7..0000000 --- a/synapse/asn1util.pas +++ /dev/null @@ -1,510 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.004.004 | -|==============================================================================| -| Content: support for ASN.1 BER coding and decoding | -|==============================================================================| -| 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) 1999-2003 | -| Portions created by Hernan Sanchez are Copyright (c) 2000. | -| 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/) | -|==============================================================================} - -{: @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) or @link(TLdapSend)class. -} - -{$Q-} -{$H+} -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit asn1util; - -interface - -uses - SysUtils, Classes, synautil; - -const - ASN1_BOOL = $01; - ASN1_INT = $02; - ASN1_OCTSTR = $04; - ASN1_NULL = $05; - ASN1_OBJID = $06; - ASN1_ENUM = $0a; - ASN1_SEQ = $30; - ASN1_SETOF = $31; - ASN1_IPADDR = $40; - ASN1_COUNTER = $41; - ASN1_GAUGE = $42; - ASN1_TIMETICKS = $43; - ASN1_OPAQUE = $44; - -{: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): AnsiString; -var - x, xm: Integer; - b: Boolean; -begin - x := Value; - b := False; - Result := ''; - repeat - xm := x mod 128; - x := x div 128; - if b then - xm := xm or $80; - if x > 0 then - b := True; - Result := AnsiChar(xm) + Result; - until x = 0; -end; - -{==============================================================================} -function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; -var - x: Integer; - b: Boolean; -begin - Result := 0; - repeat - Result := Result * 128; - x := Ord(Buffer[Start]); - Inc(Start); - b := x > $7F; - x := x and $7F; - Result := Result + x; - until not b; -end; - -{==============================================================================} -function ASNEncLen(Len: Integer): AnsiString; -var - x, y: Integer; -begin - if Len < $80 then - Result := AnsiChar(Len) - else - begin - x := Len; - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - y := Length(Result); - y := y or $80; - Result := AnsiChar(y) + Result; - end; -end; - -{==============================================================================} -function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; -var - x, n: Integer; -begin - x := Ord(Buffer[Start]); - Inc(Start); - if x < $80 then - Result := x - else - begin - Result := 0; - x := x and $7F; - for n := 1 to x do - begin - Result := Result * 256; - x := Ord(Buffer[Start]); - Inc(Start); - Result := Result + x; - end; - end; -end; - -{==============================================================================} -function ASNEncInt(Value: Integer): AnsiString; -var - x, y: Cardinal; - neg: Boolean; -begin - neg := Value < 0; - x := Abs(Value); - if neg then - x := not (x - 1); - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - if (not neg) and (Result[1] > #$7F) then - Result := #0 + Result; -end; - -{==============================================================================} -function ASNEncUInt(Value: Integer): AnsiString; -var - x, y: Integer; - neg: Boolean; -begin - neg := Value < 0; - x := Value; - if neg then - x := x and $7FFFFFFF; - Result := ''; - repeat - y := x mod 256; - x := x div 256; - Result := AnsiChar(y) + Result; - until x = 0; - if neg then - Result[1] := AnsiChar(Ord(Result[1]) or $80); -end; - -{==============================================================================} -function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; -begin - Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; -end; - -{==============================================================================} -function ASNItem(var Start: Integer; const Buffer: AnsiString; - var ValueType: Integer): AnsiString; -var - ASNType: Integer; - ASNSize: Integer; - y, n: Integer; - x: byte; - s: AnsiString; - c: AnsiChar; - neg: Boolean; - l: Integer; -begin - Result := ''; - ValueType := ASN1_NULL; - l := Length(Buffer); - if l < (Start + 1) then - Exit; - ASNType := Ord(Buffer[Start]); - ValueType := ASNType; - Inc(Start); - ASNSize := ASNDecLen(Start, Buffer); - if (Start + ASNSize - 1) > l then - Exit; - if (ASNType and $20) > 0 then -// Result := '$' + IntToHex(ASNType, 2) - Result := Copy(Buffer, Start, ASNSize) - else - case ASNType of - ASN1_INT, ASN1_ENUM, ASN1_BOOL: - begin - y := 0; - neg := False; - for n := 1 to ASNSize do - begin - x := Ord(Buffer[Start]); - if (n = 1) and (x > $7F) then - neg := True; - if neg then - x := not x; - y := y * 256 + x; - Inc(Start); - end; - if neg then - y := -(y + 1); - Result := IntToStr(y); - end; - ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: - begin - y := 0; - for n := 1 to ASNSize do - begin - y := y * 256 + Ord(Buffer[Start]); - Inc(Start); - end; - Result := IntToStr(y); - end; - ASN1_OCTSTR, ASN1_OPAQUE: - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := s; - end; - ASN1_OBJID: - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := IdToMib(s); - end; - ASN1_IPADDR: - begin - s := ''; - for n := 1 to ASNSize do - begin - if (n <> 1) then - s := s + '.'; - y := Ord(Buffer[Start]); - Inc(Start); - s := s + IntToStr(y); - end; - Result := s; - end; - ASN1_NULL: - begin - Result := ''; - Start := Start + ASNSize; - end; - else // unknown - begin - for n := 1 to ASNSize do - begin - c := AnsiChar(Buffer[Start]); - Inc(Start); - s := s + c; - end; - Result := s; - end; - end; -end; - -{==============================================================================} -function MibToId(Mib: String): AnsiString; -var - x: Integer; - - function WalkInt(var s: String): Integer; - var - x: Integer; - t: AnsiString; - begin - x := Pos('.', s); - if x < 1 then - begin - t := s; - s := ''; - end - else - begin - t := Copy(s, 1, x - 1); - s := Copy(s, x + 1, Length(s) - x); - end; - Result := StrToIntDef(t, 0); - end; - -begin - Result := ''; - x := WalkInt(Mib); - x := x * 40 + WalkInt(Mib); - Result := ASNEncOIDItem(x); - while Mib <> '' do - begin - x := WalkInt(Mib); - Result := Result + ASNEncOIDItem(x); - end; -end; - -{==============================================================================} -function IdToMib(const Id: AnsiString): String; -var - x, y, n: Integer; -begin - Result := ''; - n := 1; - while Length(Id) + 1 > n do - begin - x := ASNDecOIDItem(n, Id); - if (n - 1) = 1 then - begin - y := x div 40; - x := x mod 40; - Result := IntToStr(y); - end; - Result := Result + '.' + IntToStr(x); - end; -end; - -{==============================================================================} -function IntMibToStr(const Value: AnsiString): AnsiString; -var - n, y: Integer; -begin - y := 0; - for n := 1 to Length(Value) - 1 do - y := y * 256 + Ord(Value[n]); - Result := IntToStr(y); -end; - -{==============================================================================} -function ASNdump(const Value: AnsiString): AnsiString; -var - i, at, x, n: integer; - s, indent: AnsiString; - il: TStringList; -begin - il := TStringList.Create; - try - Result := ''; - i := 1; - indent := ''; - while i < Length(Value) do - begin - for n := il.Count - 1 downto 0 do - begin - x := StrToIntDef(il[n], 0); - if x <= i then - begin - il.Delete(n); - Delete(indent, 1, 2); - end; - end; - s := ASNItem(i, Value, at); - Result := Result + indent + '$' + IntToHex(at, 2); - if (at and $20) > 0 then - begin - x := Length(s); - Result := Result + ' constructed: length ' + IntToStr(x); - indent := indent + ' '; - il.Add(IntToStr(x + i - 1)); - end - else - begin - case at of - ASN1_BOOL: - Result := Result + ' BOOL: '; - ASN1_INT: - Result := Result + ' INT: '; - ASN1_ENUM: - Result := Result + ' ENUM: '; - ASN1_COUNTER: - Result := Result + ' COUNTER: '; - ASN1_GAUGE: - Result := Result + ' GAUGE: '; - ASN1_TIMETICKS: - Result := Result + ' TIMETICKS: '; - ASN1_OCTSTR: - Result := Result + ' OCTSTR: '; - ASN1_OPAQUE: - Result := Result + ' OPAQUE: '; - ASN1_OBJID: - Result := Result + ' OBJID: '; - ASN1_IPADDR: - Result := Result + ' IPADDR: '; - ASN1_NULL: - Result := Result + ' NULL: '; - else // other - Result := Result + ' unknown: '; - end; - if IsBinaryString(s) then - s := DumpExStr(s); - Result := Result + s; - end; - Result := Result + #$0d + #$0a; - end; - finally - il.Free; - end; -end; - -{==============================================================================} - -end. diff --git a/synapse/blcksock.pas b/synapse/blcksock.pas deleted file mode 100644 index 38d300d..0000000 --- a/synapse/blcksock.pas +++ /dev/null @@ -1,4333 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 009.008.005 | -|==============================================================================| -| Content: Library base | -|==============================================================================| -| Copyright (c)1999-2012, 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)1999-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| 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) - for good inspiration about SSL programming. -} - -{$DEFINE ONCEWINSOCK} -{Note about define ONCEWINSOCK: -If you remove this compiler directive, then socket interface is loaded and -initialized on constructor of TBlockSocket class for each socket separately. -Socket interface is used only if your need it. - -If you leave this directive here, then socket interface is loaded and -initialized only once at start of your program! It boost performace on high -count of created and destroyed sockets. It eliminate possible small resource -leak on Windows systems too. -} - -//{$DEFINE RAISEEXCEPT} -{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} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} -{$ENDIF} -{$Q-} -{$H+} -{$M+} -{$TYPEDADDRESS OFF} - - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit blcksock; - -interface - -uses - SysUtils, Classes, - synafpc, - synsock, synautil, synacode, synaip -{$IFDEF CIL} - ,System.Net - ,System.Net.Sockets - ,System.Text -{$ENDIF} - ; - -const - - SynapseRelease = '38'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - CR = #$0d; - LF = #$0a; - CRLF = CR + LF; - c64k = 65536; - -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: AnsiString) 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; - - {:This procedural type is used for monitoring of communication.} - THookMonitor = procedure(Sender: TObject; Writing: Boolean; - const Buffer: TMemory; Len: Integer) of object; - - {:This procedural type is used for hook OnAfterConnect. By this hook you can - insert your code after TCP socket has been sucessfully connected.} - THookAfterConnect = procedure(Sender: TObject) of object; - - {:This procedural type is used for hook OnVerifyCert. By this hook you can - insert your additional certificate verification code. Usefull to verify server - CN against URL. } - - THookVerifyCert = function(Sender: TObject):boolean of object; - - {:This procedural type is used for hook OnHeartbeat. By this hook you can - call your code repeately during long socket operations. - You must enable heartbeats by @Link(HeartbeatRate) property!} - THookHeartbeat = 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_all, - LT_SSLv2, - LT_SSLv3, - LT_TLSv1, - LT_TLSv1_1, - LT_SSHv2 - ); - - {:Specify type of socket delayed option.} - TSynaOptionType = ( - SOT_Linger, - SOT_RecvBuff, - SOT_SendBuff, - SOT_NonBlock, - SOT_RecvTimeout, - SOT_SendTimeout, - SOT_Reuse, - SOT_TTL, - SOT_Broadcast, - SOT_MulticastTTL, - SOT_MulticastLoop - ); - - {:@abstract(this object is used for remember delayed socket option set.)} - TSynaOption = class(TObject) - public - Option: TSynaOptionType; - Enabled: Boolean; - Value: Integer; - end; - - TCustomSSL = class; - TSSLClass = class of TCustomSSL; - - {:@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; - FOnCreateSocket: THookCreateSocket; - FOnMonitor: THookMonitor; - FOnHeartbeat: THookHeartbeat; - FLocalSin: TVarSin; - FRemoteSin: TVarSin; - FTag: integer; - FBuffer: AnsiString; - FRaiseExcept: Boolean; - FNonBlockMode: Boolean; - FMaxLineLength: Integer; - FMaxSendBandwidth: Integer; - FNextSend: LongWord; - FMaxRecvBandwidth: Integer; - FNextRecv: LongWord; - FConvertLineEnd: Boolean; - FLastCR: Boolean; - FLastLF: Boolean; - FBinded: Boolean; - FFamily: TSocketFamily; - FFamilySave: TSocketFamily; - FIP6used: Boolean; - FPreferIP4: Boolean; - FDelayedOptions: TList; - FInterPacketTimeout: Boolean; - {$IFNDEF CIL} - FFDSet: TFDSet; - {$ENDIF} - FRecvCounter: Integer; - FSendCounter: Integer; - FSendMaxChunk: Integer; - FStopFlag: Boolean; - FNonblockSendTimeout: Integer; - FHeartbeatRate: integer; - {$IFNDEF ONCEWINSOCK} - FWsaDataOnce: TWSADATA; - {$ENDIF} - function GetSizeRecvBuffer: Integer; - procedure SetSizeRecvBuffer(Size: Integer); - function GetSizeSendBuffer: Integer; - procedure SetSizeSendBuffer(Size: Integer); - procedure SetNonBlockMode(Value: Boolean); - procedure SetTTL(TTL: integer); - function GetTTL:integer; - procedure SetFamily(Value: TSocketFamily); virtual; - procedure SetSocket(Value: TSocket); virtual; - function GetWsaData: TWSAData; - function FamilyToAF(f: TSocketFamily): TAddrFamily; - protected - FSocket: TSocket; - FLastError: Integer; - FLastErrorDesc: string; - FOwner: TObject; - 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: TMemory; var Len: Integer); - procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); - procedure DoCreateSocket; - procedure DoHeartbeat; - procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); - procedure SetBandwidth(Value: Integer); - function TestStopFlag: Boolean; - procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; - function InternalCanRead(Timeout: Integer): Boolean; virtual; - 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; - - {: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; - - {: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!} - 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).} - function Accept: TSocket; 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; - - {: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; - - {: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; - - {:Similar to @link(RecvBufferEx), but readed data is stored in binary - string, not in memory buffer.} - function RecvBufferStr(Len: 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; - - {: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; - - {: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; - - {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.} - procedure ResetLastError; - - {: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; virtual; - - {: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; - - {: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; - - {: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! read functioms what have timeout as - calling parameter, calling this function internally.} - 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); - - {:Return value of socket type.} - function GetSocketType: integer; Virtual; - - {:Return value of protocol type for socket creation.} - function GetSocketProtocol: integer; Virtual; - - {:WSA structure with information about socket provider. On non-windows - platforms this structure is simulated!} - property WSAData: TWSADATA read GetWsaData; - - {:FDset structure prepared for usage with this socket.} - property FDset: TFDSet read FFDset; - - {:Structure describing local socket side.} - property LocalSin: TVarSin read FLocalSin write FLocalSin; - - {:Structure describing remote socket side.} - property RemoteSin: TVarSin read FRemoteSin write FRemoteSin; - - {: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: AnsiString read FBuffer write FBuffer; - - {: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; - - {:Set Time-to-live value. (if system supporting it!)} - property TTL: Integer read GetTTL Write SetTTL; - - {:If is @true, then class in in IPv6 mode.} - property IP6used: Boolean read FIP6used; - - {: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; - - {:Return descriptive string for @link(LastError).} - function GetErrorDescEx: string; virtual; - - {: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 default (@true) is all timeouts used as timeout between two packets in - reading operations. If you set this to @false, 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; - - {:Timeout for data sending by non-blocking socket mode.} - property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout; - - {: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 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; - - {:This event is good for monitoring content of readed or writed datas.} - property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor; - - {:This event is good for calling your code during long socket operations. - (Example, for refresing UI if class in not called within the thread.) - Rate of heartbeats can be modified by @link(HeartbeatRate) property.} - property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat; - - {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing. - Default value 0 disabling heartbeats! Value is in milliseconds. - Real rate can be higher or smaller then this value, because it depending - on real socket operations too! - Note: Each heartbeat slowing socket processing.} - property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate; - {:What class own this socket? Used by protocol implementation classes.} - property Owner: TObject read FOwner Write FOwner; - 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; - FSocksPort: string; - FSocksTimeout: integer; - FSocksUsername: string; - FSocksPassword: string; - FUsingSocks: Boolean; - FSocksResolver: Boolean; - FSocksLastError: integer; - FSocksResponseIP: string; - FSocksResponsePort: string; - FSocksLocalIP: string; - FSocksLocalPort: string; - FSocksRemoteIP: string; - FSocksRemotePort: string; - FBypassFlag: Boolean; - FSocksType: TSocksType; - function SocksCode(IP, Port: string): Ansistring; - function SocksDecode(Value: Ansistring): 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; - - {:Is @True when class is using SOCKS proxy.} - property UsingSocks: Boolean read FUsingSocks; - - {: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 or SSH (depending on used plugin), - SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy - (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.} - TTCPBlockSocket = class(TSocksBlockSocket) - protected - FOnAfterConnect: THookAfterConnect; - FSSL: TCustomSSL; - FHTTPTunnelIP: string; - FHTTPTunnelPort: string; - FHTTPTunnel: Boolean; - FHTTPTunnelRemoteIP: string; - FHTTPTunnelRemotePort: string; - FHTTPTunnelUser: string; - FHTTPTunnelPass: string; - FHTTPTunnelTimeout: integer; - procedure SocksDoConnect(IP, Port: string); - procedure HTTPTunnelDoConnect(IP, Port: string); - procedure DoAfterConnect; - public - {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation - (see @link(SSLImplementation))} - constructor Create; - - {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation} - constructor CreateWithSSL(SSLPlugin: TSSLClass); - destructor Destroy; override; - - {: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; override; - - {: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; override; - - {: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.) - - 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 (or SSH2, if plugin - allows it) 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; - - {: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 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; - - {:Class implementing SSL/TLS support. It is allways some descendant - of @link(TCustomSSL) class. When programmer not select some SSL plugin - class, then is used @link(TSSLNone)} - property SSL: TCustomSSL read FSSL; - - {:@True if is used HTTP tunnel mode.} - property HTTPTunnel: Boolean read FHTTPTunnel; - published - {:Return descriptive string for @link(LastError). On case of error - in SSL/TLS subsystem, it returns right error description.} - function GetErrorDescEx: string; override; - - {: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; - - {:This event is called after sucessful TCP socket connection.} - property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect; - 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; - - {: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; - function UdpAssociation: Boolean; - procedure SetMulticastTTL(TTL: integer); - 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); - - {: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; - - {: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(Implementation of PGM-message socket.) - Not all systems supports this protocol!} - TPGMMessageBlockSocket = class(TBlockSocket) - public - {:Return value of socket type. For PGM-message return SOCK_RDM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For PGM-message returns - IPPROTO_RM.} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Implementation of PGM-stream socket.) - Not all systems supports this protocol!} - TPGMStreamBlockSocket = class(TBlockSocket) - public - {:Return value of socket type. For PGM-stream return SOCK_STREAM.} - function GetSocketType: integer; override; - - {:Return value of protocol type for socket creation. For PGM-stream returns - IPPROTO_RM.} - function GetSocketProtocol: integer; override; - end; - - {:@abstract(Parent class for all SSL plugins.) - This is abstract class defining interface for other SSL plugins. - - Instance of this class will be created for each @link(TTCPBlockSocket). - - Warning: not all methods and propertis can work in all existing SSL plugins! - Please, read documentation of used SSL plugin.} - TCustomSSL = class(TObject) - private - protected - FOnVerifyCert: THookVerifyCert; - FSocket: TTCPBlockSocket; - FSSLEnabled: Boolean; - FLastError: integer; - FLastErrorDesc: string; - FSSLType: TSSLType; - FKeyPassword: string; - FCiphers: string; - FCertificateFile: string; - FPrivateKeyFile: string; - FCertificate: Ansistring; - FPrivateKey: Ansistring; - FPFX: Ansistring; - FPFXfile: string; - FCertCA: Ansistring; - FCertCAFile: string; - FTrustCertificate: Ansistring; - FTrustCertificateFile: string; - FVerifyCert: Boolean; - FUsername: string; - FPassword: string; - FSSHChannelType: string; - FSSHChannelArg1: string; - FSSHChannelArg2: string; - FCertComplianceLevel: integer; - FSNIHost: string; - procedure ReturnError; - procedure SetCertCAFile(const Value: string); virtual; - function DoVerifyCert:boolean; - function CreateSelfSignedCert(Host: string): Boolean; virtual; - public - {: Create plugin class. it is called internally from @link(TTCPBlockSocket)} - constructor Create(const Value: TTCPBlockSocket); virtual; - - {: Assign settings (certificates and configuration) from another SSL plugin - class.} - procedure Assign(const Value: TCustomSSL); virtual; - - {: return description of used plugin. It usually return name and version - of used SSL library.} - function LibVersion: String; virtual; - - {: return name of used plugin.} - function LibName: String; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for start SSL connection.} - function Connect: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for acept new SSL connection.} - function Accept: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for hard shutdown of SSL connection. (for example, - before socket is closed)} - function Shutdown: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for soft shutdown of SSL connection. (for example, - when you need to continue with unprotected connection.)} - function BiShutdown: boolean; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for sending some datas by SSL connection.} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for receiving some datas by SSL connection.} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual; - - {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)! - - Here is needed code for getting count of datas what waiting for read. - If SSL plugin not allows this, then it should return 0.} - function WaitingData: Integer; virtual; - - {:Return string with identificator of SSL/TLS version of existing - connection.} - function GetSSLVersion: string; virtual; - - {:Return subject of remote SSL peer.} - function GetPeerSubject: string; virtual; - - {:Return Serial number if remote X509 certificate.} - function GetPeerSerialNo: integer; virtual; - - {:Return issuer certificate of remote SSL peer.} - function GetPeerIssuer: string; virtual; - - {:Return peer name from remote side certificate. This is good for verify, - if certificate is generated for remote side IP name.} - function GetPeerName: string; virtual; - - {:Returns has of peer name from remote side certificate. This is good - for fast remote side authentication.} - function GetPeerNameHash: cardinal; virtual; - - {:Return fingerprint of remote SSL peer.} - function GetPeerFingerprint: string; virtual; - - {:Return all detailed information about certificate from remote side of - SSL/TLS connection. Result string can be multilined! Each plugin can return - this informations in different format!} - function GetCertInfo: string; virtual; - - {:Return currently used Cipher.} - function GetCipherName: string; virtual; - - {:Return currently used number of bits in current Cipher algorythm.} - function GetCipherBits: integer; virtual; - - {:Return number of bits in current Cipher algorythm.} - function GetCipherAlgBits: integer; virtual; - - {: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 GetVerifyCert: integer; virtual; - - {: Resurn @true if SSL mode is enabled on existing cvonnection.} - property SSLEnabled: Boolean read FSSLEnabled; - - {:Return error code of last SSL operation. 0 is OK.} - property LastError: integer read FLastError; - - {:Return error description of last SSL operation.} - property LastErrorDesc: string read FLastErrorDesc; - 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; - - {:Password for decrypting of encoded certificate or key.} - property KeyPassword: string read FKeyPassword write FKeyPassword; - - {:Username for possible credentials.} - property Username: string read FUsername write FUsername; - - {:password for possible credentials.} - property Password: string read FPassword write FPassword; - - {:By this property you can modify default set of SSL/TLS ciphers.} - property Ciphers: string read FCiphers write FCiphers; - - {:Used for loading certificate from disk file. See to plugin documentation - if this method is supported and how!} - property CertificateFile: string read FCertificateFile write FCertificateFile; - - {:Used for loading private key from disk file. See to plugin documentation - if this method is supported and how!} - property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile; - - {:Used for loading certificate from binary string. See to plugin documentation - if this method is supported and how!} - property Certificate: Ansistring read FCertificate write FCertificate; - - {:Used for loading private key from binary string. See to plugin documentation - if this method is supported and how!} - property PrivateKey: Ansistring read FPrivateKey write FPrivateKey; - - {:Used for loading PFX from binary string. See to plugin documentation - if this method is supported and how!} - property PFX: Ansistring read FPFX write FPFX; - - {:Used for loading PFX from disk file. See to plugin documentation - if this method is supported and how!} - property PFXfile: string read FPFXfile write FPFXfile; - - {:Used for loading trusted certificates from disk file. See to plugin documentation - if this method is supported and how!} - property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile; - - {:Used for loading trusted certificates from binary string. See to plugin documentation - if this method is supported and how!} - property TrustCertificate: Ansistring read FTrustCertificate write FTrustCertificate; - - {:Used for loading CA certificates from binary string. See to plugin documentation - if this method is supported and how!} - property CertCA: Ansistring read FCertCA write FCertCA; - - {:Used for loading CA certificates from disk file. See to plugin documentation - if this method is supported and how!} - property CertCAFile: string read FCertCAFile write SetCertCAFile; - - {: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 VerifyCert: Boolean read FVerifyCert write FVerifyCert; - - {:channel type for possible SSH connections} - property SSHChannelType: string read FSSHChannelType write FSSHChannelType; - - {:First argument of channel type for possible SSH connections} - property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1; - - {:Second argument of channel type for possible SSH connections} - property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2; - - {: Level of standards compliance level - (CryptLib: values in cryptlib.pas, -1: use default value ) } - property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel; - - {:This event is called when verifying the server certificate immediatally after - a successfull verification in the ssl library.} - property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert; - - {: Server Name Identification. Host name to send to server. If empty the host name - found in URL will be used, which should be the normal use (http Header Host = SNI Host). - The value is cleared after the connection is established. - (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet ) } - property SNIHost:string read FSNIHost write FSNIHost; - end; - - {:@abstract(Default SSL plugin with no SSL support.) - Dummy SSL plugin implementation for applications without SSL/TLS support.} - TSSLNone = class (TCustomSSL) - public - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - end; - - {:@abstract(Record with definition of IP packet header.) - For reading data from ICMP or RAW sockets.} - TIPHeader = record - VerLen: Byte; - TOS: Byte; - TotalLen: Word; - Identifer: Word; - FragOffsets: Word; - TTL: Byte; - Protocol: Byte; - CheckSum: Word; - SourceIp: LongWord; - DestIp: LongWord; - Options: LongWord; - 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; - -var - {:Selected SSL plugin. Default is @link(TSSLNone). - - Do not change this value directly!!! - - Just add your plugin unit to your project uses instead. Each plugin unit have - initialization code what modify this variable.} - SSLImplementation: TSSLClass = TSSLNone; - -implementation - -{$IFDEF ONCEWINSOCK} -var - WsaDataOnce: TWSADATA; - e: ESynapseError; -{$ENDIF} - - -constructor TBlockSocket.Create; -begin - CreateAlternate(''); -end; - -constructor TBlockSocket.CreateAlternate(Stub: string); -{$IFNDEF ONCEWINSOCK} -var - e: ESynapseError; -{$ENDIF} -begin - inherited Create; - FDelayedOptions := TList.Create; - FRaiseExcept := False; -{$IFDEF RAISEEXCEPT} - FRaiseExcept := True; -{$ENDIF} - FSocket := INVALID_SOCKET; - FBuffer := ''; - FLastCR := False; - FLastLF := False; - FBinded := False; - FNonBlockMode := False; - FMaxLineLength := 0; - FMaxSendBandwidth := 0; - FNextSend := 0; - FMaxRecvBandwidth := 0; - FNextRecv := 0; - FConvertLineEnd := False; - FFamily := SF_Any; - FFamilySave := SF_Any; - FIP6used := False; - FPreferIP4 := True; - FInterPacketTimeout := True; - FRecvCounter := 0; - FSendCounter := 0; - FSendMaxChunk := c64k; - FStopFlag := False; - FNonblockSendTimeout := 15000; - FHeartbeatRate := 0; - FOwner := nil; -{$IFNDEF ONCEWINSOCK} - if Stub = '' then - Stub := DLLStackName; - if not InitSocketInterface(Stub) then - begin - e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!'); - e.ErrorCode := 0; - e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!'; - raise e; - end; - SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce)); - ExceptCheck; -{$ENDIF} -end; - -destructor TBlockSocket.Destroy; -var - n: integer; - p: TSynaOption; -begin - CloseSocket; -{$IFNDEF ONCEWINSOCK} - synsock.WSACleanup; - DestroySocketInterface; -{$ENDIF} - for n := FDelayedOptions.Count - 1 downto 0 do - begin - p := TSynaOption(FDelayedOptions[n]); - p.Free; - end; - FDelayedOptions.Free; - inherited Destroy; -end; - -function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily; -begin - case f of - SF_ip4: - Result := AF_INET; - SF_ip6: - Result := AF_INET6; - else - Result := AF_UNSPEC; - end; -end; - -procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); -var - li: TLinger; - x: integer; - buf: TMemory; -{$IFNDEF MSWINDOWS} - timeval: TTimeval; -{$ENDIF} -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; - buf := @li; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li)); - {$ENDIF} - end; - SOT_RecvBuff: - begin - {$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 - {$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 - FNonBlockMode := Value.Enabled; - x := Ord(FNonBlockMode); - synsock.IoctlSocket(FSocket, FIONBIO, x); - end; - SOT_RecvTimeout: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - {$IFDEF MSWINDOWS} - buf := @Value.Value; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - timeval.tv_sec:=Value.Value div 1000; - timeval.tv_usec:=(Value.Value mod 1000) * 1000; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO), - @timeval, SizeOf(timeval)); - {$ENDIF} - {$ENDIF} - end; - SOT_SendTimeout: - begin - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(value.Value); - {$ELSE} - {$IFDEF MSWINDOWS} - buf := @Value.Value; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), - buf, SizeOf(Value.Value)); - {$ELSE} - timeval.tv_sec:=Value.Value div 1000; - timeval.tv_usec:=(Value.Value mod 1000) * 1000; - synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO), - @timeval, SizeOf(timeval)); - {$ENDIF} - {$ENDIF} - end; - SOT_Reuse: - begin - x := Ord(Value.Enabled); - {$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, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS), - buf, SizeOf(Value.Value)) - else - 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); - {$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, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS), - buf, SizeOf(Value.Value)) - else - synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL), - buf, SizeOf(Value.Value)); - end; - SOT_MulticastLoop: - begin - x := Ord(Value.Enabled); - {$IFDEF CIL} - buf := System.BitConverter.GetBytes(x); - {$ELSE} - buf := @x; - {$ENDIF} - if FIP6Used then - synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x)) - else - synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)); - end; - end; - Value.free; -end; - -procedure TBlockSocket.DelayedOption(const Value: TSynaOption); -begin - if FSocket = INVALID_SOCKET then - begin - FDelayedOptions.Insert(0, Value); - end - else - SetDelayedOption(Value); -end; - -procedure TBlockSocket.ProcessDelayedOptions; -var - n: integer; - d: TSynaOption; -begin - for n := FDelayedOptions.Count - 1 downto 0 do - begin - d := TSynaOption(FDelayedOptions[n]); - SetDelayedOption(d); - end; - FDelayedOptions.Clear; -end; - -procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); -var - f: TSocketFamily; -begin - DoStatus(HR_ResolvingBegin, IP + ':' + Port); - ResetLastError; - //if socket exists, then use their type, else use users selection - f := SF_Any; - if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then - begin - if IsIP(IP) then - f := SF_IP4 - else - if IsIP6(IP) then - f := SF_IP6; - end - else - f := FFamily; - FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f), - GetSocketprotocol, GetSocketType, FPreferIP4); - DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin))); -end; - -function TBlockSocket.GetSinIP(Sin: TVarSin): string; -begin - Result := synsock.GetSinIP(sin); -end; - -function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; -begin - Result := synsock.GetSinPort(sin); -end; - -procedure TBlockSocket.CreateSocket; -var - sin: TVarSin; -begin - //dummy for SF_Any Family mode - ResetLastError; - 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; - -procedure TBlockSocket.CreateSocketByName(const Value: String); -var - sin: TVarSin; -begin - ResetLastError; - if FSocket = INVALID_SOCKET then - begin - SetSin(sin, value, '0'); - if FLastError = 0 then - InternalCreateSocket(Sin); - end; -end; - -procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin); -begin - FStopFlag := False; - FRecvCounter := 0; - FSendCounter := 0; - ResetLastError; - if FSocket = INVALID_SOCKET then - begin - FBuffer := ''; - FBinded := False; - 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') - else - DoStatus(HR_SocketCreate, 'IPv4'); - ProcessDelayedOptions; - DoCreateSocket; - end; -end; - -procedure TBlockSocket.CloseSocket; -begin - AbortSocket; -end; - -procedure TBlockSocket.AbortSocket; -var - n: integer; - p: TSynaOption; -begin - if FSocket <> INVALID_SOCKET then - synsock.CloseSocket(FSocket); - FSocket := INVALID_SOCKET; - for n := FDelayedOptions.Count - 1 downto 0 do - begin - p := TSynaOption(FDelayedOptions[n]); - p.Free; - end; - FDelayedOptions.Clear; - FFamily := FFamilySave; - DoStatus(HR_SocketClose, ''); -end; - -procedure TBlockSocket.Bind(IP, Port: string); -var - Sin: TVarSin; -begin - ResetLastError; - if (FSocket <> INVALID_SOCKET) - or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then - begin - SetSin(Sin, IP, Port); - 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; -end; - -procedure TBlockSocket.Connect(IP, Port: string); -var - Sin: TVarSin; -begin - SetSin(Sin, IP, Port); - 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.Listen; -begin - SockCheck(synsock.Listen(FSocket, SOMAXCONN)); - GetSins; - ExceptCheck; - DoStatus(HR_Listen, ''); -end; - -function TBlockSocket.Accept: TSocket; -begin - Result := synsock.Accept(FSocket, FRemoteSin); -/// SockCheck(Result); - ExceptCheck; - DoStatus(HR_Accept, ''); -end; - -procedure TBlockSocket.GetSinLocal; -begin - synsock.GetSockName(FSocket, FLocalSin); -end; - -procedure TBlockSocket.GetSinRemote; -begin - synsock.GetPeerName(FSocket, FRemoteSin); -end; - -procedure TBlockSocket.GetSins; -begin - GetSinLocal; - GetSinRemote; -end; - -procedure TBlockSocket.SetBandwidth(Value: Integer); -begin - MaxSendBandwidth := Value; - MaxRecvBandwidth := Value; -end; - -procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); -var - x: LongWord; - y: LongWord; - n: integer; -begin - if FStopFlag then - exit; - if MaxB > 0 then - begin - y := GetTick; - if Next > y then - begin - x := Next - y; - if x > 0 then - begin - DoStatus(HR_Wait, IntToStr(x)); - sleep(x mod 250); - for n := 1 to x div 250 do - if FStopFlag then - Break - else - sleep(250); - end; - end; - Next := GetTick + Trunc((Length / MaxB) * 1000); - end; -end; - -function TBlockSocket.TestStopFlag: Boolean; -begin - DoHeartbeat; - Result := FStopFlag; - if Result then - begin - FStopFlag := False; - FLastError := WSAECONNABORTED; - 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; - DoMonitor(True, Buffer, Length); -{$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); - SockCheck(r); - if FLastError = WSAEWOULDBLOCK then - begin - if CanWrite(FNonblockSendTimeout) then - begin - r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL); - SockCheck(r); - end - else - FLastError := WSAETIMEDOUT; - end; - 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; -end; - -procedure TBlockSocket.SendByte(Data: Byte); -{$IFDEF CIL} -var - buf: TMemory; -{$ENDIF} -begin -{$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 - {$IFDEF CIL} - buf := BytesOf(Data); - {$ELSE} - buf := Pointer(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); -var - i: integer; -begin - i := SwapBytes(Length(data)); - SendString(Codelongint(i) + Data); -end; - -procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); -var - l: integer; - yr: integer; - s: AnsiString; - b: boolean; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin - b := true; - l := 0; - if WithSize then - begin - l := Stream.Size - Stream.Position;; - if not Indy then - l := synsock.HToNL(l); - end; - repeat - {$IFDEF CIL} - Setlength(buf, FSendMaxChunk); - yr := Stream.read(buf, FSendMaxChunk); - if yr > 0 then - begin - if WithSize and b then - begin - b := false; - SendString(CodeLongInt(l)); - end; - SendBuffer(buf, yr); - if FLastError <> 0 then - break; - end - {$ELSE} - Setlength(s, FSendMaxChunk); - yr := Stream.read(Pointer(s)^, FSendMaxChunk); - if yr > 0 then - begin - SetLength(s, yr); - if WithSize and b then - begin - b := false; - SendString(CodeLongInt(l) + s); - end - else - SendString(s); - if FLastError <> 0 then - break; - end - {$ENDIF} - until yr <= 0; -end; - -procedure TBlockSocket.SendStreamRaw(const Stream: TStream); -begin - InternalSendStream(Stream, false, false); -end; - -procedure TBlockSocket.SendStreamIndy(const Stream: TStream); -begin - InternalSendStream(Stream, true, true); -end; - -procedure TBlockSocket.SendStream(const Stream: TStream); -begin - InternalSendStream(Stream, true, false); -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); - if Result = 0 then - FLastError := WSAECONNRESET - else - SockCheck(Result); - ExceptCheck; - if Result > 0 then - begin - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); - DoReadFilter(Buffer, Result); - end; -end; - -function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; - Timeout: Integer): Integer; -var - s: AnsiString; - rl, l: integer; - ti: LongWord; -{$IFDEF CIL} - n: integer; - b: TMemory; -{$ENDIF} -begin - ResetLastError; - Result := 0; - if Len > 0 then - begin - rl := 0; - repeat - ti := GetTick; - s := RecvPacket(Timeout); - 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 >= Len then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - FLastError := WSAETIMEDOUT; - Break; - end; - end; - until False; - delete(s, 1, l); - FBuffer := s; - Result := rl; - end; -end; - -function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): AnsiString; -var - x: integer; -{$IFDEF CIL} - buf: Tmemory; -{$ENDIF} -begin - Result := ''; - if Len > 0 then - begin - {$IFDEF CIL} - Setlength(Buf, Len); - x := RecvBufferEx(buf, Len , Timeout); - if FLastError = 0 then - begin - SetLength(Buf, x); - Result := StringOf(buf); - end - else - Result := ''; - {$ELSE} - Setlength(Result, Len); - x := RecvBufferEx(Pointer(Result), Len , Timeout); - if FLastError = 0 then - SetLength(Result, x) - else - Result := ''; - {$ENDIF} - end; -end; - -function TBlockSocket.RecvPacket(Timeout: Integer): AnsiString; -var - x: integer; -{$IFDEF CIL} - buf: TMemory; -{$ENDIF} -begin - Result := ''; - ResetLastError; - if FBuffer <> '' then - begin - Result := FBuffer; - FBuffer := ''; - end - else - begin - {$IFDEF MSWINDOWS} - //not drain CPU on large downloads... - Sleep(0); - {$ENDIF} - 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 - if CanRead(Timeout) then - begin - x := WaitingData; - if x = 0 then - 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 - FLastError := WSAETIMEDOUT; - end; - end; - if FConvertLineEnd and (Result <> '') then - begin - if FLastCR and (Result[1] = LF) then - Delete(Result, 1, 1); - if FLastLF and (Result[1] = CR) then - Delete(Result, 1, 1); - FLastCR := False; - FLastLF := False; - end; - ExceptCheck; -end; - - -function TBlockSocket.RecvByte(Timeout: Integer): Byte; -begin - Result := 0; - ResetLastError; - if FBuffer = '' then - FBuffer := RecvPacket(Timeout); - if (FLastError = 0) and (FBuffer <> '') then - begin - Result := Ord(FBuffer[1]); - Delete(FBuffer, 1, 1); - end; - ExceptCheck; -end; - -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: AnsiString; - l: Integer; - CorCRLF: Boolean; - t: AnsiString; - tl: integer; - ti: LongWord; -begin - ResetLastError; - Result := ''; - l := Length(Terminator); - if l = 0 then - Exit; - tl := l; - CorCRLF := FConvertLineEnd and (Terminator = CRLF); - s := ''; - x := 0; - repeat - //get rest of FBuffer or incomming new data... - ti := GetTick; - s := s + RecvPacket(Timeout); - if FLastError <> 0 then - Break; - x := 0; - if Length(s) > 0 then - if CorCRLF then - begin - t := ''; - x := PosCRLF(s, t); - tl := Length(t); - if t = CR then - FLastCR := True; - if t = LF then - FLastLF := True; - end - else - begin - x := pos(Terminator, s); - tl := l; - end; - if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then - begin - FLastError := WSAENOBUFS; - Break; - end; - if x > 0 then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - FLastError := WSAETIMEDOUT; - Break; - end; - end; - until False; - if x > 0 then - begin - Result := Copy(s, 1, x - 1); - Delete(s, 1, x + tl - 1); - end; - FBuffer := s; - ExceptCheck; -end; - -function TBlockSocket.RecvString(Timeout: Integer): AnsiString; -var - s: AnsiString; -begin - Result := ''; - s := RecvTerminated(Timeout, CRLF); - if FLastError = 0 then - Result := s; -end; - -function TBlockSocket.RecvBlock(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - 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; - WriteStrToStream(Stream, s); - {$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; - WriteStrToStream(Stream, s); - {$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; -begin - x := RecvInteger(Timeout); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - {$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 - SetLength(s, 1); - PeekBuffer(Pointer(s), 1); - if s <> '' then - Result := Ord(s[1]); - end - else - FLastError := WSAETIMEDOUT; - ExceptCheck; - {$ENDIF} -end; - -procedure TBlockSocket.ResetLastError; -begin - FLastError := 0; - FLastErrorDesc := ''; -end; - -function TBlockSocket.SockCheck(SockResult: Integer): Integer; -begin - ResetLastError; - if SockResult = integer(SOCKET_ERROR) then - begin - FLastError := synsock.WSAGetLastError; - FLastErrorDesc := GetErrorDescEx; - end; - Result := FLastError; -end; - -procedure TBlockSocket.ExceptCheck; -var - e: ESynapseError; -begin - FLastErrorDesc := GetErrorDescEx; - if (LastError <> 0) and (LastError <> WSAEINPROGRESS) - and (LastError <> WSAEWOULDBLOCK) then - begin - DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc); - if FRaiseExcept then - begin - e := ESynapseError.Create(Format('Synapse TCP/IP Socket error %d: %s', - [FLastError, FLastErrorDesc])); - e.ErrorCode := FLastError; - e.ErrorMessage := FLastErrorDesc; - raise e; - end; - end; -end; - -function TBlockSocket.WaitingData: Integer; -var - x: Integer; -begin - Result := 0; - if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then - Result := x; - if Result > c64k then - Result := c64k; -end; - -function TBlockSocket.WaitingDataEx: Integer; -begin - if FBuffer <> '' then - Result := Length(FBuffer) - else - Result := WaitingData; -end; - -procedure TBlockSocket.Purge; -begin - Sleep(1); - try - while (Length(FBuffer) > 0) or (WaitingData > 0) do - begin - RecvPacket(0); - if FLastError <> 0 then - break; - end; - except - on exception do; - end; - ResetLastError; -end; - -procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_Linger; - d.Enabled := Enable; - d.Value := Linger; - DelayedOption(d); -end; - -function TBlockSocket.LocalName: string; -begin - Result := synsock.GetHostName; - if Result = '' then - Result := '127.0.0.1'; -end; - -procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); -begin - IPList.Clear; - synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList); - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function TBlockSocket.ResolveName(Name: string): string; -var - l: TStringList; -begin - l := TStringList.Create; - try - ResolveNameToIP(Name, l); - Result := l[0]; - finally - l.Free; - end; -end; - -function TBlockSocket.ResolvePort(Port: string): Word; -begin - Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); -end; - -function TBlockSocket.ResolveIPToName(IP: string): string; -begin - if not IsIP(IP) and not IsIp6(IP) then - IP := ResolveName(IP); - Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); -end; - -procedure TBlockSocket.SetRemoteSin(IP, Port: string); -begin - SetSin(FRemoteSin, IP, Port); -end; - -function TBlockSocket.GetLocalSinIP: string; -begin - Result := GetSinIP(FLocalSin); -end; - -function TBlockSocket.GetRemoteSinIP: string; -begin - Result := GetSinIP(FRemoteSin); -end; - -function TBlockSocket.GetLocalSinPort: Integer; -begin - Result := GetSinPort(FLocalSin); -end; - -function TBlockSocket.GetRemoteSinPort: Integer; -begin - Result := GetSinPort(FRemoteSin); -end; - -function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean; -{$IFDEF CIL} -begin - Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead); -{$ELSE} -var - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; - FDSet: TFDSet; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FDSet := FFdSet; - x := synsock.Select(FSocket + 1, @FDSet, nil, nil, TimeVal); - SockCheck(x); - if FLastError <> 0 then - x := 0; - Result := x > 0; -{$ENDIF} -end; - -function TBlockSocket.CanRead(Timeout: Integer): Boolean; -var - ti, tr: Integer; - n: integer; -begin - if (FHeartbeatRate <> 0) and (Timeout <> -1) then - begin - ti := Timeout div FHeartbeatRate; - tr := Timeout mod FHeartbeatRate; - end - else - begin - ti := 0; - tr := Timeout; - end; - Result := InternalCanRead(tr); - if not Result then - for n := 0 to ti do - begin - DoHeartbeat; - if FStopFlag then - begin - Result := False; - FStopFlag := False; - Break; - end; - Result := InternalCanRead(FHeartbeatRate); - if Result then - break; - end; - 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; - x: Integer; - FDSet: TFDSet; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FDSet := FFdSet; - x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal); - SockCheck(x); - if FLastError <> 0 then - x := 0; - Result := x > 0; -{$ENDIF} - ExceptCheck; - if Result then - DoStatus(HR_CanWrite, ''); -end; - -function TBlockSocket.CanReadEx(Timeout: Integer): Boolean; -begin - if FBuffer <> '' then - Result := True - else - Result := CanRead(Timeout); -end; - -function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; -begin - Result := 0; - if TestStopFlag then - Exit; - DoMonitor(True, Buffer, Length); - LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); - SockCheck(Result); - ExceptCheck; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); -end; - -function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; -begin - Result := 0; - if TestStopFlag then - Exit; - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); - SockCheck(Result); - ExceptCheck; - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); -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); -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); -end; - -procedure TBlockSocket.SetNonBlockMode(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_nonblock; - d.Enabled := Value; - DelayedOption(d); -end; - -procedure TBlockSocket.SetTimeout(Timeout: Integer); -begin - SetSendTimeout(Timeout); - SetRecvTimeout(Timeout); -end; - -procedure TBlockSocket.SetSendTimeout(Timeout: Integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_sendtimeout; - d.Value := Timeout; - DelayedOption(d); -end; - -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 - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x, n: Integer; - Max: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - FD_ZERO(FDSet); - Max := 0; - for n := 0 to SocketList.Count - 1 do - if TObject(SocketList.Items[n]) is TBlockSocket then - begin - if TBlockSocket(SocketList.Items[n]).Socket > Max then - Max := TBlockSocket(SocketList.Items[n]).Socket; - FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet); - end; - x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal); - SockCheck(x); - ExceptCheck; - if FLastError <> 0 then - x := 0; - Result := x > 0; - CanReadList.Clear; - if Result then - for n := 0 to SocketList.Count - 1 do - if TObject(SocketList.Items[n]) is TBlockSocket then - 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); -end; - -procedure TBlockSocket.SetTTL(TTL: integer); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_TTL; - d.Value := TTL; - DelayedOption(d); -end; - -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); -begin - FFamily := Value; - FFamilySave := Value; -end; - -procedure TBlockSocket.SetSocket(Value: TSocket); -begin - FRecvCounter := 0; - FSendCounter := 0; - FSocket := Value; -{$IFNDEF CIL} - FD_ZERO(FFDSet); - FD_SET(FSocket, FFDSet); -{$ENDIF} - GetSins; - FIP6Used := FRemoteSin.AddressFamily = AF_INET6; -end; - -function TBlockSocket.GetWsaData: TWSAData; -begin - {$IFDEF ONCEWINSOCK} - Result := WsaDataOnce; - {$ELSE} - Result := FWsaDataOnce; - {$ENDIF} -end; - -function TBlockSocket.GetSocketType: integer; -begin - Result := 0; -end; - -function TBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_IP); -end; - -procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Reason, Value); -end; - -procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer); -var - s: AnsiString; -begin - if assigned(OnReadFilter) then - if Len > 0 then - begin - {$IFDEF CIL} - s := StringOf(Buffer); - {$ELSE} - SetLength(s, Len); - Move(Buffer^, Pointer(s)^, Len); - {$ENDIF} - OnReadFilter(Self, s); - 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.DoCreateSocket; -begin - if assigned(OnCreateSocket) then - OnCreateSocket(Self); -end; - -procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); -begin - if assigned(OnMonitor) then - begin - OnMonitor(Self, Writing, Buffer, Len); - end; -end; - -procedure TBlockSocket.DoHeartbeat; -begin - if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then - begin - OnHeartbeat(Self); - end; -end; - -function TBlockSocket.GetErrorDescEx: string; -begin - Result := GetErrorDesc(FLastError); -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 := ''; - WSAEINTR: {10004} - Result := 'Interrupted system call'; - WSAEBADF: {10009} - Result := 'Bad file number'; - WSAEACCES: {10013} - Result := 'Permission denied'; - WSAEFAULT: {10014} - Result := 'Bad address'; - WSAEINVAL: {10022} - Result := 'Invalid argument'; - WSAEMFILE: {10024} - Result := 'Too many open files'; - WSAEWOULDBLOCK: {10035} - Result := 'Operation would block'; - WSAEINPROGRESS: {10036} - Result := 'Operation now in progress'; - WSAEALREADY: {10037} - Result := 'Operation already in progress'; - WSAENOTSOCK: {10038} - Result := 'Socket operation on nonsocket'; - WSAEDESTADDRREQ: {10039} - Result := 'Destination address required'; - WSAEMSGSIZE: {10040} - Result := 'Message too long'; - WSAEPROTOTYPE: {10041} - Result := 'Protocol wrong type for Socket'; - WSAENOPROTOOPT: {10042} - Result := 'Protocol not available'; - WSAEPROTONOSUPPORT: {10043} - Result := 'Protocol not supported'; - WSAESOCKTNOSUPPORT: {10044} - Result := 'Socket not supported'; - WSAEOPNOTSUPP: {10045} - Result := 'Operation not supported on Socket'; - WSAEPFNOSUPPORT: {10046} - Result := 'Protocol family not supported'; - WSAEAFNOSUPPORT: {10047} - Result := 'Address family not supported'; - WSAEADDRINUSE: {10048} - Result := 'Address already in use'; - WSAEADDRNOTAVAIL: {10049} - Result := 'Can''t assign requested address'; - WSAENETDOWN: {10050} - Result := 'Network is down'; - WSAENETUNREACH: {10051} - Result := 'Network is unreachable'; - WSAENETRESET: {10052} - Result := 'Network dropped connection on reset'; - WSAECONNABORTED: {10053} - Result := 'Software caused connection abort'; - WSAECONNRESET: {10054} - Result := 'Connection reset by peer'; - WSAENOBUFS: {10055} - Result := 'No Buffer space available'; - WSAEISCONN: {10056} - Result := 'Socket is already connected'; - WSAENOTCONN: {10057} - Result := 'Socket is not connected'; - WSAESHUTDOWN: {10058} - Result := 'Can''t send after Socket shutdown'; - WSAETOOMANYREFS: {10059} - Result := 'Too many references:can''t splice'; - WSAETIMEDOUT: {10060} - Result := 'Connection timed out'; - WSAECONNREFUSED: {10061} - Result := 'Connection refused'; - WSAELOOP: {10062} - Result := 'Too many levels of symbolic links'; - WSAENAMETOOLONG: {10063} - Result := 'File name is too long'; - WSAEHOSTDOWN: {10064} - Result := 'Host is down'; - WSAEHOSTUNREACH: {10065} - Result := 'No route to host'; - WSAENOTEMPTY: {10066} - Result := 'Directory is not empty'; - WSAEPROCLIM: {10067} - Result := 'Too many processes'; - WSAEUSERS: {10068} - Result := 'Too many users'; - WSAEDQUOT: {10069} - Result := 'Disk quota exceeded'; - WSAESTALE: {10070} - Result := 'Stale NFS file handle'; - WSAEREMOTE: {10071} - Result := 'Too many levels of remote in path'; - WSASYSNOTREADY: {10091} - Result := 'Network subsystem is unusable'; - WSAVERNOTSUPPORTED: {10092} - Result := 'Winsock DLL cannot support this application'; - WSANOTINITIALISED: {10093} - Result := 'Winsock not initialized'; - WSAEDISCON: {10101} - Result := 'Disconnect'; - WSAHOST_NOT_FOUND: {11001} - Result := 'Host not found'; - WSATRY_AGAIN: {11002} - Result := 'Non authoritative - host not found'; - WSANO_RECOVERY: {11003} - Result := 'Non recoverable error'; - WSANO_DATA: {11004} - Result := 'Valid name, no data record of requested type' - else - Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')'; - end; -{$ENDIF} -end; - -{======================================================================} - -constructor TSocksBlockSocket.Create; -begin - inherited Create; - FSocksIP:= ''; - FSocksPort:= '1080'; - FSocksTimeout:= 60000; - FSocksUsername:= ''; - FSocksPassword:= ''; - FUsingSocks := False; - FSocksResolver := True; - FSocksLastError := 0; - FSocksResponseIP := ''; - FSocksResponsePort := ''; - FSocksLocalIP := ''; - FSocksLocalPort := ''; - FSocksRemoteIP := ''; - FSocksRemotePort := ''; - FBypassFlag := False; - FSocksType := ST_Socks5; -end; - -function TSocksBlockSocket.SocksOpen: boolean; -var - Buf: AnsiString; - n: integer; -begin - Result := False; - FUsingSocks := False; - if FSocksType <> ST_Socks5 then - begin - FUsingSocks := True; - Result := True; - end - else - begin - FBypassFlag := True; - try - if FSocksUsername = '' then - Buf := #5 + #1 + #0 - else - Buf := #5 + #2 + #2 +#0; - SendString(Buf); - Buf := RecvBufferStr(2, FSocksTimeout); - if Length(Buf) < 2 then - Exit; - if Buf[1] <> #5 then - Exit; - n := Ord(Buf[2]); - case n of - 0: //not need authorisation - ; - 2: - begin - Buf := #1 + AnsiChar(Length(FSocksUsername)) + FSocksUsername - + AnsiChar(Length(FSocksPassword)) + FSocksPassword; - SendString(Buf); - Buf := RecvBufferStr(2, FSocksTimeout); - if Length(Buf) < 2 then - Exit; - if Buf[2] <> #0 then - Exit; - end; - else - //other authorisation is not supported! - Exit; - end; - FUsingSocks := True; - Result := True; - finally - FBypassFlag := False; - end; - end; -end; - -function TSocksBlockSocket.SocksRequest(Cmd: Byte; - const IP, Port: string): Boolean; -var - Buf: AnsiString; -begin - FBypassFlag := True; - try - if FSocksType <> ST_Socks5 then - Buf := #4 + AnsiChar(Cmd) + SocksCode(IP, Port) - else - Buf := #5 + AnsiChar(Cmd) + #0 + SocksCode(IP, Port); - SendString(Buf); - Result := FLastError = 0; - finally - FBypassFlag := False; - end; -end; - -function TSocksBlockSocket.SocksResponse: Boolean; -var - Buf, s: AnsiString; - x: integer; -begin - Result := False; - FBypassFlag := True; - try - FSocksResponseIP := ''; - FSocksResponsePort := ''; - FSocksLastError := -1; - if FSocksType <> ST_Socks5 then - begin - Buf := RecvBufferStr(8, FSocksTimeout); - if FLastError <> 0 then - Exit; - if Buf[1] <> #0 then - Exit; - FSocksLastError := Ord(Buf[2]); - end - else - begin - Buf := RecvBufferStr(4, FSocksTimeout); - if FLastError <> 0 then - Exit; - if Buf[1] <> #5 then - Exit; - case Ord(Buf[4]) of - 1: - s := RecvBufferStr(4, FSocksTimeout); - 3: - begin - x := RecvByte(FSocksTimeout); - if FLastError <> 0 then - Exit; - s := AnsiChar(x) + RecvBufferStr(x, FSocksTimeout); - end; - 4: - s := RecvBufferStr(16, FSocksTimeout); - else - Exit; - end; - Buf := Buf + s + RecvBufferStr(2, FSocksTimeout); - if FLastError <> 0 then - Exit; - FSocksLastError := Ord(Buf[2]); - end; - if ((FSocksLastError <> 0) and (FSocksLastError <> 90)) then - Exit; - SocksDecode(Buf); - Result := True; - finally - FBypassFlag := False; - end; -end; - -function TSocksBlockSocket.SocksCode(IP, Port: string): Ansistring; -var - ip6: TIp6Bytes; - n: integer; -begin - if FSocksType <> ST_Socks5 then - begin - Result := CodeInt(ResolvePort(Port)); - if not FSocksResolver then - IP := ResolveName(IP); - if IsIP(IP) then - begin - Result := Result + IPToID(IP); - Result := Result + FSocksUsername + #0; - end - else - begin - Result := Result + IPToID('0.0.0.1'); - Result := Result + FSocksUsername + #0; - Result := Result + IP + #0; - end; - end - else - begin - if not FSocksResolver then - IP := ResolveName(IP); - if IsIP(IP) then - Result := #1 + IPToID(IP) - else - if IsIP6(IP) then - begin - ip6 := StrToIP6(IP); - Result := #4; - for n := 0 to 15 do - Result := Result + AnsiChar(ip6[n]); - end - else - Result := #3 + AnsiChar(Length(IP)) + IP; - Result := Result + CodeInt(ResolvePort(Port)); - end; -end; - -function TSocksBlockSocket.SocksDecode(Value: Ansistring): integer; -var - Atyp: Byte; - y, n: integer; - w: Word; - ip6: TIp6Bytes; -begin - FSocksResponsePort := '0'; - Result := 0; - if FSocksType <> ST_Socks5 then - begin - if Length(Value) < 8 then - Exit; - Result := 3; - w := DecodeInt(Value, Result); - FSocksResponsePort := IntToStr(w); - FSocksResponseIP := Format('%d.%d.%d.%d', - [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); - Result := 9; - end - else - begin - if Length(Value) < 4 then - Exit; - Atyp := Ord(Value[4]); - Result := 5; - case Atyp of - 1: - begin - if Length(Value) < 10 then - Exit; - FSocksResponseIP := Format('%d.%d.%d.%d', - [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]); - Result := 9; - end; - 3: - begin - y := Ord(Value[5]); - if Length(Value) < (5 + y + 2) then - Exit; - for n := 6 to 6 + y - 1 do - FSocksResponseIP := FSocksResponseIP + Value[n]; - Result := 5 + y + 1; - end; - 4: - begin - if Length(Value) < 22 then - Exit; - for n := 0 to 15 do - ip6[n] := ord(Value[n + 5]); - FSocksResponseIP := IP6ToStr(ip6); - Result := 21; - end; - else - Exit; - end; - w := DecodeInt(Value, Result); - FSocksResponsePort := IntToStr(w); - Result := Result + 2; - end; -end; - -{======================================================================} - -procedure TDgramBlockSocket.Connect(IP, Port: string); -begin - SetRemoteSin(IP, Port); - InternalCreateSocket(FRemoteSin); - FBuffer := ''; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - Result := RecvBufferFrom(Buffer, Length); -end; - -function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; -begin - Result := SendBufferTo(Buffer, Length); -end; - -{======================================================================} - -destructor TUDPBlockSocket.Destroy; -begin - if Assigned(FSocksControlSock) then - FSocksControlSock.Free; - inherited; -end; - -procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean); -var - d: TSynaOption; -begin - d := TSynaOption.Create; - d.Option := SOT_Broadcast; - d.Enabled := Value; - DelayedOption(d); -end; - -function TUDPBlockSocket.UdpAssociation: Boolean; -var - b: Boolean; -begin - Result := True; - FUsingSocks := False; - if FSocksIP <> '' then - begin - Result := False; - if not Assigned(FSocksControlSock) then - FSocksControlSock := TTCPBlockSocket.Create; - FSocksControlSock.CloseSocket; - FSocksControlSock.CreateSocketByName(FSocksIP); - FSocksControlSock.Connect(FSocksIP, FSocksPort); - if FSocksControlSock.LastError <> 0 then - Exit; - // if not assigned local port, assign it! - if not FBinded then - Bind(cAnyHost, cAnyPort); - //open control TCP connection to SOCKS - FSocksControlSock.FSocksUsername := FSocksUsername; - FSocksControlSock.FSocksPassword := FSocksPassword; - b := FSocksControlSock.SocksOpen; - if b then - b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort)); - if b then - b := FSocksControlSock.SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FUsingSocks :=FSocksControlSock.UsingSocks; - FSocksRemoteIP := FSocksControlSock.FSocksResponseIP; - FSocksRemotePort := FSocksControlSock.FSocksResponsePort; - Result := b and (FLastError = 0); - end; -end; - -function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; -var - SIp: string; - SPort: integer; - Buf: Ansistring; -begin - Result := 0; - FUsingSocks := False; - if (FSocksIP <> '') and (not UdpAssociation) then - FLastError := WSANO_RECOVERY - else - begin - if FUsingSocks then - begin -{$IFNDEF CIL} - Sip := GetRemoteSinIp; - SPort := GetRemoteSinPort; - SetRemoteSin(FSocksRemoteIP, FSocksRemotePort); - SetLength(Buf,Length); - Move(Buffer^, Pointer(Buf)^, Length); - Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf; - Result := inherited SendBufferTo(Pointer(Buf), System.Length(buf)); - SetRemoteSin(Sip, IntToStr(SPort)); -{$ENDIF} - end - else - Result := inherited SendBufferTo(Buffer, Length); - end; -end; - -function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; -var - Buf: Ansistring; - x: integer; -begin - Result := inherited RecvBufferFrom(Buffer, Length); - if FUsingSocks then - begin -{$IFNDEF CIL} - SetLength(Buf, Result); - Move(Buffer^, Pointer(Buf)^, Result); - x := SocksDecode(Buf); - Result := Result - x + 1; - Buf := Copy(Buf, x, Result); - Move(Pointer(Buf)^, Buffer^, Result); - SetRemoteSin(FSocksResponseIP, FSocksResponsePort); -{$ENDIF} - end; -end; - -{$IFNDEF CIL} -procedure TUDPBlockSocket.AddMulticast(MCastIP: string); -var - Multicast: TIP_mreq; - Multicast6: TIPv6_mreq; - n: integer; - ip6: Tip6bytes; -begin - if FIP6Used then - begin - ip6 := StrToIp6(MCastIP); - for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; - Multicast6.ipv6mr_interface := 0; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, - PAnsiChar(@Multicast6), SizeOf(Multicast6))); - end - else - begin - Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); - Multicast.imr_interface.S_addr := INADDR_ANY; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, - PAnsiChar(@Multicast), SizeOf(Multicast))); - end; - ExceptCheck; -end; - -procedure TUDPBlockSocket.DropMulticast(MCastIP: string); -var - Multicast: TIP_mreq; - Multicast6: TIPv6_mreq; - n: integer; - ip6: Tip6bytes; -begin - if FIP6Used then - begin - ip6 := StrToIp6(MCastIP); - for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; - Multicast6.ipv6mr_interface := 0; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, - PAnsiChar(@Multicast6), SizeOf(Multicast6))); - end - else - begin - Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP)); - Multicast.imr_interface.S_addr := INADDR_ANY; - SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, - PAnsiChar(@Multicast), SizeOf(Multicast))); - 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); -end; - -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); -end; - -function TUDPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_DGRAM); -end; - -function TUDPBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_UDP); -end; - -{======================================================================} -constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass); -begin - inherited Create; - FSSL := SSLPlugin.Create(self); - FHTTPTunnelIP := ''; - FHTTPTunnelPort := ''; - FHTTPTunnel := False; - FHTTPTunnelRemoteIP := ''; - FHTTPTunnelRemotePort := ''; - FHTTPTunnelUser := ''; - FHTTPTunnelPass := ''; - FHTTPTunnelTimeout := 30000; -end; - -constructor TTCPBlockSocket.Create; -begin - CreateWithSSL(SSLImplementation); -end; - -destructor TTCPBlockSocket.Destroy; -begin - inherited Destroy; - FSSL.Free; -end; - -function TTCPBlockSocket.GetErrorDescEx: string; -begin - Result := inherited GetErrorDescEx; - if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then - begin - Result := self.SSL.LastErrorDesc; - end; -end; - -procedure TTCPBlockSocket.CloseSocket; -begin - if FSSL.SSLEnabled then - FSSL.Shutdown; - if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then - begin - Synsock.Shutdown(FSocket, 1); - Purge; - end; - inherited CloseSocket; -end; - -procedure TTCPBlockSocket.DoAfterConnect; -begin - if assigned(OnAfterConnect) then - begin - OnAfterConnect(Self); - end; -end; - -function TTCPBlockSocket.WaitingData: Integer; -begin - Result := 0; - if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then - Result := FSSL.WaitingData; - if Result = 0 then - Result := inherited WaitingData; -end; - -procedure TTCPBlockSocket.Listen; -var - b: Boolean; - Sip,SPort: string; -begin - if FSocksIP = '' then - begin - inherited Listen; - end - else - begin - Sip := GetLocalSinIP; - if Sip = cAnyHost then - Sip := LocalName; - SPort := IntToStr(GetLocalSinPort); - inherited Connect(FSocksIP, FSocksPort); - b := SocksOpen; - if b then - b := SocksRequest(2, Sip, SPort); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FSocksLocalIP := FSocksResponseIP; - if FSocksLocalIP = cAnyHost then - FSocksLocalIP := FSocksIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := ''; - FSocksRemotePort := ''; - ExceptCheck; - DoStatus(HR_Listen, ''); - end; -end; - -function TTCPBlockSocket.Accept: TSocket; -begin - if FUsingSocks then - begin - if not SocksResponse and (FLastError = 0) then - FLastError := WSANO_RECOVERY; - FSocksRemoteIP := FSocksResponseIP; - FSocksRemotePort := FSocksResponsePort; - Result := FSocket; - ExceptCheck; - DoStatus(HR_Accept, ''); - end - else - begin - result := inherited Accept; - end; -end; - -procedure TTCPBlockSocket.Connect(IP, Port: string); -begin - if FSocksIP <> '' then - SocksDoConnect(IP, Port) - else - if FHTTPTunnelIP <> '' then - HTTPTunnelDoConnect(IP, Port) - else - inherited Connect(IP, Port); - if FLasterror = 0 then - DoAfterConnect; -end; - -procedure TTCPBlockSocket.SocksDoConnect(IP, Port: string); -var - b: Boolean; -begin - inherited Connect(FSocksIP, FSocksPort); - if FLastError = 0 then - begin - b := SocksOpen; - if b then - b := SocksRequest(1, IP, Port); - if b then - b := SocksResponse; - if not b and (FLastError = 0) then - FLastError := WSASYSNOTREADY; - FSocksLocalIP := FSocksResponseIP; - FSocksLocalPort := FSocksResponsePort; - FSocksRemoteIP := IP; - FSocksRemotePort := Port; - end; - ExceptCheck; - DoStatus(HR_Connect, IP + ':' + Port); -end; - -procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string); -//bugfixed by Mike Green (mgreen@emixode.com) -var - s: string; -begin - Port := IntToStr(ResolvePort(Port)); - inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort); - if FLastError <> 0 then - Exit; - FHTTPTunnel := False; - if IsIP6(IP) then - IP := '[' + IP + ']'; - SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF); - if FHTTPTunnelUser <> '' then - Sendstring('Proxy-Authorization: Basic ' + - EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF); - SendString(CRLF); - repeat - s := RecvTerminated(FHTTPTunnelTimeout, #$0a); - if FLastError <> 0 then - Break; - if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then - FHTTPTunnel := s[10] = '2'; - until (s = '') or (s = #$0d); - if (FLasterror = 0) and not FHTTPTunnel then - FLastError := WSASYSNOTREADY; - FHTTPTunnelRemoteIP := IP; - FHTTPTunnelRemotePort := Port; - ExceptCheck; -end; - -procedure TTCPBlockSocket.SSLDoConnect; -begin - ResetLastError; - if not FSSL.Connect then - FLastError := WSASYSNOTREADY; - ExceptCheck; -end; - -procedure TTCPBlockSocket.SSLDoShutdown; -begin - ResetLastError; - FSSL.BiShutdown; -end; - -function TTCPBlockSocket.GetLocalSinIP: string; -begin - if FUsingSocks then - Result := FSocksLocalIP - else - Result := inherited GetLocalSinIP; -end; - -function TTCPBlockSocket.GetRemoteSinIP: string; -begin - if FUsingSocks then - Result := FSocksRemoteIP - else - if FHTTPTunnel then - Result := FHTTPTunnelRemoteIP - else - Result := inherited GetRemoteSinIP; -end; - -function TTCPBlockSocket.GetLocalSinPort: Integer; -begin - if FUsingSocks then - Result := StrToIntDef(FSocksLocalPort, 0) - else - Result := inherited GetLocalSinPort; -end; - -function TTCPBlockSocket.GetRemoteSinPort: Integer; -begin - if FUsingSocks then - Result := ResolvePort(FSocksRemotePort) - else - if FHTTPTunnel then - Result := StrToIntDef(FHTTPTunnelRemotePort, 0) - else - Result := inherited GetRemoteSinPort; -end; - -function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - if FSSL.SSLEnabled then - begin - Result := 0; - if TestStopFlag then - Exit; - ResetLastError; - LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv); - Result := FSSL.RecvBuffer(Buffer, Len); - if FSSL.LastError <> 0 then - FLastError := WSASYSNOTREADY; - ExceptCheck; - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); - DoReadFilter(Buffer, Result); - end - else - Result := inherited RecvBuffer(Buffer, Len); -end; - -function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; -var - x, y: integer; - l, r: integer; -{$IFNDEF CIL} - p: Pointer; -{$ENDIF} -begin - if FSSL.SSLEnabled then - begin - Result := 0; - if TestStopFlag then - Exit; - ResetLastError; - DoMonitor(True, Buffer, Length); -{$IFDEF CIL} - Result := FSSL.SendBuffer(Buffer, Length); - if FSSL.LastError <> 0 then - FLastError := WSASYSNOTREADY; - Inc(FSendCounter, Result); - DoStatus(HR_WriteCount, IntToStr(Result)); -{$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 := FSSL.SendBuffer(p, y); - if FSSL.LastError <> 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; - end - else - Result := inherited SendBuffer(Buffer, Length); -end; - -function TTCPBlockSocket.SSLAcceptConnection: Boolean; -begin - ResetLastError; - if not FSSL.Accept then - FLastError := WSASYSNOTREADY; - ExceptCheck; - Result := FLastError = 0; -end; - -function TTCPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_STREAM); -end; - -function TTCPBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_TCP); -end; - -{======================================================================} - -function TICMPBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RAW); -end; - -function TICMPBlockSocket.GetSocketProtocol: integer; -begin - if FIP6Used then - Result := integer(IPPROTO_ICMPV6) - else - Result := integer(IPPROTO_ICMP); -end; - -{======================================================================} - -function TRAWBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RAW); -end; - -function TRAWBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RAW); -end; - -{======================================================================} - -function TPGMmessageBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_RDM); -end; - -function TPGMmessageBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RM); -end; - -{======================================================================} - -function TPGMstreamBlockSocket.GetSocketType: integer; -begin - Result := integer(SOCK_STREAM); -end; - -function TPGMstreamBlockSocket.GetSocketProtocol: integer; -begin - Result := integer(IPPROTO_RM); -end; - -{======================================================================} - -constructor TSynaClient.Create; -begin - inherited Create; - FIPInterface := cAnyHost; - FTargetHost := cLocalhost; - FTargetPort := cAnyPort; - FTimeout := 5000; - FUsername := ''; - FPassword := ''; -end; - -{======================================================================} - -constructor TCustomSSL.Create(const Value: TTCPBlockSocket); -begin - inherited Create; - FSocket := Value; - FSSLEnabled := False; - FUsername := ''; - FPassword := ''; - FLastError := 0; - FLastErrorDesc := ''; - FVerifyCert := False; - FSSLType := LT_all; - FKeyPassword := ''; - FCiphers := ''; - FCertificateFile := ''; - FPrivateKeyFile := ''; - FCertCAFile := ''; - FCertCA := ''; - FTrustCertificate := ''; - FTrustCertificateFile := ''; - FCertificate := ''; - FPrivateKey := ''; - FPFX := ''; - FPFXfile := ''; - FSSHChannelType := ''; - FSSHChannelArg1 := ''; - FSSHChannelArg2 := ''; - FCertComplianceLevel := -1; //default - FSNIHost := ''; -end; - -procedure TCustomSSL.Assign(const Value: TCustomSSL); -begin - FUsername := Value.Username; - FPassword := Value.Password; - FVerifyCert := Value.VerifyCert; - FSSLType := Value.SSLType; - FKeyPassword := Value.KeyPassword; - FCiphers := Value.Ciphers; - FCertificateFile := Value.CertificateFile; - FPrivateKeyFile := Value.PrivateKeyFile; - FCertCAFile := Value.CertCAFile; - FCertCA := Value.CertCA; - FTrustCertificate := Value.TrustCertificate; - FTrustCertificateFile := Value.TrustCertificateFile; - FCertificate := Value.Certificate; - FPrivateKey := Value.PrivateKey; - FPFX := Value.PFX; - FPFXfile := Value.PFXfile; - FCertComplianceLevel := Value.CertComplianceLevel; - FSNIHost := Value.FSNIHost; -end; - -procedure TCustomSSL.ReturnError; -begin - FLastError := -1; - FLastErrorDesc := 'SSL/TLS support is not compiled!'; -end; - -function TCustomSSL.LibVersion: String; -begin - Result := ''; -end; - -function TCustomSSL.LibName: String; -begin - Result := ''; -end; - -function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean; -begin - Result := False; -end; - -function TCustomSSL.Connect: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.Accept: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.Shutdown: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.BiShutdown: boolean; -begin - ReturnError; - Result := False; -end; - -function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - ReturnError; - Result := integer(SOCKET_ERROR); -end; - -procedure TCustomSSL.SetCertCAFile(const Value: string); -begin - FCertCAFile := Value; -end; - -function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - ReturnError; - Result := integer(SOCKET_ERROR); -end; - -function TCustomSSL.WaitingData: Integer; -begin - ReturnError; - Result := 0; -end; - -function TCustomSSL.GetSSLVersion: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerSubject: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerSerialNo: integer; -begin - Result := -1; -end; - -function TCustomSSL.GetPeerName: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerNameHash: cardinal; -begin - Result := 0; -end; - -function TCustomSSL.GetPeerIssuer: string; -begin - Result := ''; -end; - -function TCustomSSL.GetPeerFingerprint: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCertInfo: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCipherName: string; -begin - Result := ''; -end; - -function TCustomSSL.GetCipherBits: integer; -begin - Result := 0; -end; - -function TCustomSSL.GetCipherAlgBits: integer; -begin - Result := 0; -end; - -function TCustomSSL.GetVerifyCert: integer; -begin - Result := 1; -end; - -function TCustomSSL.DoVerifyCert:boolean; -begin - if assigned(OnVerifyCert) then - begin - result:=OnVerifyCert(Self); - end - else - result:=true; -end; - - -{======================================================================} - -function TSSLNone.LibVersion: String; -begin - Result := 'Without SSL support'; -end; - -function TSSLNone.LibName: String; -begin - Result := 'ssl_none'; -end; - -{======================================================================} - -initialization -begin -{$IFDEF ONCEWINSOCK} - if not InitSocketInterface(DLLStackName) then - begin - e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!'); - e.ErrorCode := 0; - e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!'; - raise e; - end; - synsock.WSAStartup(WinsockLevel, WsaDataOnce); -{$ENDIF} -end; - -finalization -begin -{$IFDEF ONCEWINSOCK} - synsock.WSACleanup; - DestroySocketInterface; -{$ENDIF} -end; - -end. diff --git a/synapse/clamsend.pas b/synapse/clamsend.pas deleted file mode 100644 index 8d3c2d6..0000000 --- a/synapse/clamsend.pas +++ /dev/null @@ -1,277 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: ClamAV-daemon client | -|==============================================================================| -| Copyright (c)2005-2010, 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)2005-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract( ClamAV-daemon client) - -This unit is capable to do antivirus scan of your data by TCP channel to ClamD -daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit clamsend; - -interface - -uses - SysUtils, Classes, - synsock, blcksock, synautil; - -const - cClamProtocol = '3310'; - -type - - {:@abstract(Implementation of ClamAV-daemon client protocol) - By this class you can scan any your data by ClamAV opensource antivirus. - - This class can connect to ClamD by TCP channel, send your data to ClamD - and read result.} - TClamSend = class(TSynaClient) - private - FSock: TTCPBlockSocket; - FDSock: TTCPBlockSocket; - FSession: boolean; - function Login: boolean; virtual; - function Logout: Boolean; virtual; - function OpenStream: Boolean; virtual; - public - constructor Create; - destructor Destroy; override; - - {:Call any command to ClamD. Used internally by other methods.} - function DoCommand(const Value: AnsiString): AnsiString; virtual; - - {:Return ClamAV version and version of loaded databases.} - function GetVersion: AnsiString; virtual; - - {:Scan content of TStrings.} - function ScanStrings(const Value: TStrings): AnsiString; virtual; - - {:Scan content of TStream.} - function ScanStream(const Value: TStream): AnsiString; virtual; - - {:Scan content of TStrings by new 0.95 API.} - function ScanStrings2(const Value: TStrings): AnsiString; virtual; - - {:Scan content of TStream by new 0.95 API.} - function ScanStream2(const Value: TStream): AnsiString; virtual; - published - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} - property DSock: TTCPBlockSocket read FDSock; - - {:Can turn-on session mode of communication with ClamD. Default is @false, - because ClamAV developers design their TCP code very badly and session mode - is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs - and this mode will be possible in future.} - property Session: boolean read FSession write FSession; - end; - -implementation - -constructor TClamSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FDSock := TTCPBlockSocket.Create; - FDSock.Owner := self; - FTimeout := 60000; - FTargetPort := cClamProtocol; - FSession := false; -end; - -destructor TClamSend.Destroy; -begin - Logout; - FDSock.Free; - FSock.Free; - inherited Destroy; -end; - -function TClamSend.DoCommand(const Value: AnsiString): AnsiString; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.SendString(Value + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.SendString(Value + LF) - else - Exit; - end; - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -function TClamSend.Login: boolean; -begin - Result := False; - Sock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError <> 0 then - Exit; - if FSession then - FSock.SendString('SESSION' + LF); - Result := FSock.LastError = 0; -end; - -function TClamSend.Logout: Boolean; -begin - FSock.SendString('END' + LF); - Result := FSock.LastError = 0; - FSock.CloseSocket; -end; - -function TClamSend.GetVersion: AnsiString; -begin - Result := DoCommand('nVERSION'); -end; - -function TClamSend.OpenStream: Boolean; -var - S: AnsiString; -begin - Result := False; - s := DoCommand('nSTREAM'); - if (s <> '') and (Copy(s, 1, 4) = 'PORT') then - begin - s := SeparateRight(s, ' '); - FDSock.CloseSocket; - FDSock.Bind(FIPInterface, cAnyPort); - if FDSock.LastError <> 0 then - Exit; - FDSock.Connect(FTargetHost, s); - if FDSock.LastError <> 0 then - Exit; - Result := True; - end; -end; - -function TClamSend.ScanStrings(const Value: TStrings): AnsiString; -begin - Result := ''; - if OpenStream then - begin - DSock.SendString(Value.Text); - DSock.CloseSocket; - Result := FSock.RecvTerminated(FTimeout, LF); - end; -end; - -function TClamSend.ScanStream(const Value: TStream): AnsiString; -begin - Result := ''; - if OpenStream then - begin - DSock.SendStreamRaw(Value); - DSock.CloseSocket; - Result := FSock.RecvTerminated(FTimeout, LF); - end; -end; - -function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; -var - i: integer; - s: AnsiString; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.sendstring('nINSTREAM' + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.sendstring('nINSTREAM' + LF) - else - Exit; - end; - s := Value.text; - i := length(s); - FSock.SendString(CodeLongint(i) + s + #0#0#0#0); - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -function TClamSend.ScanStream2(const Value: TStream): AnsiString; -var - i: integer; -begin - Result := ''; - if not FSession then - FSock.CloseSocket - else - FSock.sendstring('nINSTREAM' + LF); - if not FSession or (FSock.LastError <> 0) then - begin - if Login then - FSock.sendstring('nINSTREAM' + LF) - else - Exit; - end; - i := value.Size; - FSock.SendString(CodeLongint(i)); - FSock.SendStreamRaw(Value); - FSock.SendString(#0#0#0#0); - Result := FSock.RecvTerminated(FTimeout, LF); -end; - -end. diff --git a/synapse/dnssend.pas b/synapse/dnssend.pas deleted file mode 100644 index 84c14cc..0000000 --- a/synapse/dnssend.pas +++ /dev/null @@ -1,603 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.007.006 | -|==============================================================================| -| Content: DNS client | -|==============================================================================| -| Copyright (c)1999-2010, 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)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| 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! - -Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit dnssend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synsock; - -const - cDnsProtocol = '53'; - - QTYPE_A = 1; - QTYPE_NS = 2; - QTYPE_MD = 3; - QTYPE_MF = 4; - QTYPE_CNAME = 5; - QTYPE_SOA = 6; - QTYPE_MB = 7; - QTYPE_MG = 8; - QTYPE_MR = 9; - QTYPE_NULL = 10; - QTYPE_WKS = 11; // - QTYPE_PTR = 12; - QTYPE_HINFO = 13; - QTYPE_MINFO = 14; - QTYPE_MX = 15; - QTYPE_TXT = 16; - - QTYPE_RP = 17; - QTYPE_AFSDB = 18; - QTYPE_X25 = 19; - QTYPE_ISDN = 20; - QTYPE_RT = 21; - QTYPE_NSAP = 22; - QTYPE_NSAPPTR = 23; - QTYPE_SIG = 24; // RFC-2065 - QTYPE_KEY = 25; // RFC-2065 - QTYPE_PX = 26; - QTYPE_GPOS = 27; - QTYPE_AAAA = 28; - QTYPE_LOC = 29; // RFC-1876 - QTYPE_NXT = 30; // RFC-2065 - - QTYPE_SRV = 33; - QTYPE_NAPTR = 35; // RFC-2168 - QTYPE_KX = 36; - QTYPE_SPF = 99; - - QTYPE_AXFR = 252; - QTYPE_MAILB = 253; // - QTYPE_MAILA = 254; // - 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: AnsiString; - FSock: TUDPBlockSocket; - FTCPSock: TTCPBlockSocket; - FUseTCP: Boolean; - FAnswerInfo: TStringList; - FNameserverInfo: TStringList; - FAdditionalInfo: TStringList; - FAuthoritative: Boolean; - FTruncated: Boolean; - 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): AnsiString; - function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; - function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; - QType: Integer):boolean; - public - constructor Create; - destructor Destroy; override; - - {: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 answer is authoritative.} - property Authoritative: Boolean read FAuthoritative; - - {:@True, if answer is truncated to 512 bytes.} - property Truncated: Boolean read FTRuncated; - - {: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 AnswerInfo: TStringList read FAnswerInfo; - - {: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; - -{: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 - -constructor TDNSSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTCPSock := TTCPBlockSocket.Create; - FTCPSock.Owner := self; - FUseTCP := False; - FTimeout := 10000; - FTargetPort := cDnsProtocol; - FAnswerInfo := TStringList.Create; - FNameserverInfo := TStringList.Create; - FAdditionalInfo := TStringList.Create; - Randomize; -end; - -destructor TDNSSend.Destroy; -begin - FAnswerInfo.Free; - FNameserverInfo.Free; - FAdditionalInfo.Free; - FTCPSock.Free; - FSock.Free; - inherited Destroy; -end; - -function TDNSSend.CompressName(const Value: AnsiString): AnsiString; -var - n: Integer; - s: AnsiString; -begin - Result := ''; - if Value = '' then - Result := #0 - else - begin - s := ''; - for n := 1 to Length(Value) do - if Value[n] = '.' then - begin - Result := Result + AnsiChar(Length(s)) + s; - s := ''; - end - else - s := s + Value[n]; - if s <> '' then - Result := Result + AnsiChar(Length(s)) + s; - Result := Result + #0; - end; -end; - -function TDNSSend.CodeHeader: AnsiString; -begin - FID := Random(32767); - Result := CodeInt(FID); // ID - Result := Result + CodeInt($0100); // flags - Result := Result + CodeInt(1); // QDCount - Result := Result + CodeInt(0); // ANCount - Result := Result + CodeInt(0); // NSCount - Result := Result + CodeInt(0); // ARCount -end; - -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): AnsiString; -var - Len: integer; -begin - Len := Ord(FBuffer[From]); - Inc(From); - Result := Copy(FBuffer, From, Len); - Inc(From, Len); -end; - -function TDNSSend.DecodeLabels(var From: Integer): AnsiString; -var - l, f: Integer; -begin - Result := ''; - while True do - begin - if From >= Length(FBuffer) then - Break; - l := Ord(FBuffer[From]); - Inc(From); - if l = 0 then - Break; - if Result <> '' then - Result := Result + '.'; - if (l and $C0) = $C0 then - begin - f := l and $3F; - f := f * 256 + Ord(FBuffer[From]) + 1; - Inc(From); - Result := Result + DecodeLabels(f); - Break; - end - else - begin - Result := Result + Copy(FBuffer, From, l); - Inc(From, l); - end; - end; -end; - -function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; - QType: Integer): AnsiString; -var - Rname: AnsiString; - RType, Len, j, x, y, z, n: Integer; - R: AnsiString; - t1, t2, ttl: integer; - ip6: TIp6bytes; -begin - Result := ''; - R := ''; - Rname := DecodeLabels(i); - RType := DecodeInt(FBuffer, i); - Inc(i, 4); - t1 := DecodeInt(FBuffer, i); - Inc(i, 2); - t2 := DecodeInt(FBuffer, i); - Inc(i, 2); - ttl := t1 * 65536 + t2; - Len := DecodeInt(FBuffer, i); - Inc(i, 2); // i point to begin of data - j := i; - i := i + len; // i point to next record - if Length(FBuffer) >= (i - 1) then - case RType of - QTYPE_A: - begin - R := IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - Inc(j); - R := R + '.' + IntToStr(Ord(FBuffer[j])); - end; - QTYPE_AAAA: - begin - for n := 0 to 15 do - ip6[n] := ord(FBuffer[j + n]); - R := IP6ToStr(ip6); - end; - QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, - QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, - QTYPE_NSAPPTR: - R := DecodeLabels(j); - QTYPE_SOA: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - for n := 1 to 5 do - begin - x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); - Inc(j, 4); - R := R + ',' + IntToStr(x); - end; - end; - QTYPE_NULL: - begin - end; - QTYPE_WKS: - begin - end; - QTYPE_HINFO: - begin - R := DecodeString(j); - R := R + ',' + DecodeString(j); - end; - QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_TXT, QTYPE_SPF: - begin - R := ''; - while j < i do - R := R + DecodeString(j); - end; - QTYPE_GPOS: - begin - R := DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_PX: - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); - R := R + ',' + DecodeLabels(j); - R := R + ',' + DecodeLabels(j); - end; - QTYPE_SRV: - // Author: Dan - begin - x := DecodeInt(FBuffer, j); - Inc(j, 2); - y := DecodeInt(FBuffer, j); - Inc(j, 2); - z := DecodeInt(FBuffer, j); - Inc(j, 2); - R := IntToStr(x); // Priority - R := R + ',' + IntToStr(y); // Weight - R := R + ',' + IntToStr(z); // Port - R := R + ',' + DecodeLabels(j); // Server DNS Name - end; - end; - if R <> '' then - Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); - if QType = RType then - Result := R; -end; - -function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; -var - l: integer; -begin - Result := ''; - l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); - if l > 0 then - Result := WorkSock.RecvBufferStr(l, FTimeout); -end; - -function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; - QType: Integer):boolean; -var - n, i: Integer; - flag, qdcount, ancount, nscount, arcount: Integer; - s: AnsiString; -begin - Result := False; - Reply.Clear; - FAnswerInfo.Clear; - FNameserverInfo.Clear; - FAdditionalInfo.Clear; - FAuthoritative := False; - if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then - begin - Result := True; - flag := DecodeInt(Buf, 3); - FRCode := Flag and $000F; - FAuthoritative := (Flag and $0400) > 0; - FTruncated := (Flag and $0200) > 0; - if FRCode = 0 then - begin - qdcount := DecodeInt(Buf, 5); - ancount := DecodeInt(Buf, 7); - nscount := DecodeInt(Buf, 9); - arcount := DecodeInt(Buf, 11); - i := 13; //begin of body - if (qdcount > 0) and (Length(Buf) > i) then //skip questions - for n := 1 to qdcount do - begin - while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do - Inc(i); - Inc(i, 5); - end; - if (ancount > 0) and (Length(Buf) > i) then // decode reply - for n := 1 to ancount do - begin - s := DecodeResource(i, FAnswerInfo, QType); - if s <> '' then - Reply.Add(s); - end; - if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info - for n := 1 to nscount do - DecodeResource(i, FNameserverInfo, QType); - if (arcount > 0) and (Length(Buf) > i) then // decode additional info - for n := 1 to arcount do - DecodeResource(i, FAdditionalInfo, QType); - end; - end; -end; - -function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; - const Reply: TStrings): Boolean; -var - WorkSock: TBlockSocket; - t: TStringList; - b: boolean; -begin - Result := False; - if IsIP(Name) then - Name := ReverseIP(Name) + '.in-addr.arpa'; - if IsIP6(Name) then - Name := ReverseIP6(Name) + '.ip6.arpa'; - FBuffer := CodeHeader + CodeQuery(Name, QType); - if FUseTCP then - WorkSock := FTCPSock - else - WorkSock := FSock; - WorkSock.Bind(FIPInterface, cAnyPort); - WorkSock.Connect(FTargetHost, FTargetPort); - if FUseTCP then - FBuffer := Codeint(length(FBuffer)) + FBuffer; - WorkSock.SendString(FBuffer); - if FUseTCP then - FBuffer := RecvTCPResponse(WorkSock) - else - FBuffer := WorkSock.RecvPacket(FTimeout); - if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer - begin - t := TStringList.Create; - try - repeat - b := DecodeResponse(FBuffer, Reply, QType); - if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer - b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); - if b then - begin - t.AddStrings(AnswerInfo); - FBuffer := RecvTCPResponse(WorkSock); - if FBuffer = '' then - Break; - if WorkSock.LastError <> 0 then - Break; - end; - until not b; - Reply.Assign(t); - Result := True; - finally - t.free; - end; - end - else //normal query - if WorkSock.LastError = 0 then - Result := DecodeResponse(FBuffer, Reply, QType); -end; - -{==============================================================================} - -function GetMailServers(const DNSHost, Domain: AnsiString; - const Servers: TStrings): Boolean; -var - DNS: TDNSSend; - t: TStringList; - n, m, x: Integer; -begin - Result := False; - Servers.Clear; - t := TStringList.Create; - DNS := TDNSSend.Create; - try - DNS.TargetHost := DNSHost; - if DNS.DNSQuery(Domain, QType_MX, t) then - begin - { normalize preference number to 5 digits } - for n := 0 to t.Count - 1 do - begin - x := Pos(',', t[n]); - if x > 0 then - for m := 1 to 6 - x do - t[n] := '0' + t[n]; - end; - { sort server list } - t.Sorted := True; - { result is sorted list without preference numbers } - for n := 0 to t.Count - 1 do - begin - x := Pos(',', t[n]); - Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x)); - end; - Result := True; - end; - finally - DNS.Free; - t.Free; - end; -end; - -end. diff --git a/synapse/ftpsend.pas b/synapse/ftpsend.pas deleted file mode 100644 index 0d36835..0000000 --- a/synapse/ftpsend.pas +++ /dev/null @@ -1,1964 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.000.000 | -|==============================================================================| -| Content: FTP client | -|==============================================================================| -| Copyright (c)1999-2011, 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) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Petr Esner | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(FTP client protocol) - -Used RFC: RFC-959, RFC-2228, RFC-2428 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published - // and it requires RTTI to be generated $M+ -{$M+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ftpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synsock; - -const - cFtpProtocol = '21'; - cFtpDataProtocol = '20'; - - {: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: int64; - FFileTime: TDateTime; - FOriginalLine: string; - FMask: string; - FPermission: String; - public - {: You can assign another TFTPListRec to this object.} - procedure Assign(Value: TFTPListRec); virtual; - {: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: int64 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; - {:permission string (depending on used mask!)} - property Permission: string read FPermission write FPermission; - 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) - 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: Ansistring; - Minutes: string; - Seconds: string; - Size: Ansistring; - Permissions: Ansistring; - DirFlag: string; - function GetListItem(Index: integer): TFTPListRec; virtual; - function ParseEPLF(Value: string): Boolean; virtual; - procedure ClearStore; virtual; - function ParseByMask(Value, NextValue, Mask: ansistring): 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; - - {: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) - protected - FOnStatus: TFTPStatus; - FSock: TTCPBlockSocket; - FDSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FAccount: string; - FFWHost: string; - FFWPort: string; - FFWUsername: string; - FFWPassword: string; - FFWMode: integer; - FDataStream: TMemoryStream; - FDataIP: string; - FDataPort: string; - FDirectFile: Boolean; - FDirectFileName: string; - FCanResume: Boolean; - FPassiveMode: Boolean; - FForceDefaultPort: Boolean; - FForceOldPort: Boolean; - FFtpList: TFTPList; - FBinaryMode: Boolean; - FAutoTLS: Boolean; - FIsTLS: Boolean; - FIsDataTLS: Boolean; - FTLSonData: Boolean; - FFullSSL: Boolean; - function Auth(Mode: integer): Boolean; virtual; - function Connect: Boolean; virtual; - function InternalStor(const Command: string; RestoreAt: int64): 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; - - {: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; - - {:Break current transmission of data. It is same as Abort, but it send abort - telnet commands prior ABOR FTP command. Some servers need it. (You can call - this method from Sock.OnStatus event, or from another thread.)} - procedure TelnetAbort; 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): int64; 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 ChangeToParentDir: Boolean; virtual; - - {:walk to root directory on FTP server. (May not work with all servers properly!)} - 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; - - {: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; - - {: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; - - {: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; - -implementation - -constructor TFTPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FDataStream := TMemoryStream.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := True; - FDSock := TTCPBlockSocket.Create; - FDSock.Owner := self; - FFtpList := TFTPList.Create; - FTimeout := 300000; - FTargetPort := cFtpProtocol; - FUsername := 'anonymous'; - FPassword := 'anonymous@' + FSock.LocalName; - FDirectFile := False; - FPassiveMode := True; - FForceDefaultPort := False; - FForceOldPort := false; - FAccount := ''; - FFWHost := ''; - FFWPort := cFtpProtocol; - FFWUsername := ''; - FFWPassword := ''; - FFWMode := 0; - FBinaryMode := True; - FAutoTLS := False; - FFullSSL := False; - FIsTLS := False; - FIsDataTLS := False; - FTLSonData := True; -end; - -destructor TFTPSend.Destroy; -begin - FDSock.Free; - FSock.Free; - FFTPList.Free; - FDataStream.Free; - FFullResult.Free; - inherited Destroy; -end; - -procedure TFTPSend.DoStatus(Response: Boolean; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Response, Value); -end; - -function TFTPSend.ReadResult: Integer; -var - s, c: AnsiString; -begin - FFullResult.Clear; - c := ''; - repeat - s := FSock.RecvString(FTimeout); - if c = '' then - 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 (c <> '') and (Pos(c + ' ', s) = 1); - Result := StrToIntDef(c, 0); - FResultCode := Result; -end; - -function TFTPSend.FTPCommand(const Value: string): integer; -begin - FSock.Purge; - FSock.SendString(Value + CRLF); - DoStatus(False, Value); - Result := ReadResult; -end; - -// based on idea by Petr Esner -function TFTPSend.Auth(Mode: integer): Boolean; -const - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action0: TLogonActions = - (0, FTP_OK, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER then - // if not PASS then ERROR! - //if SITE then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action1: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 5, FTP_ERR, 9, - 0, FTP_OK, 12, - 1, FTP_OK, 15, - 2, FTP_OK, FTP_ERR); - - //if not USER then - // if not PASS then ERROR! - //if USER '@' then OK! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action2: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 6, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //if not USER then - // if not PASS then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action3: TLogonActions = - (3, 6, 3, - 4, 6, FTP_ERR, - 0, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //OPEN - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action4: TLogonActions = - (7, 3, 3, - 0, FTP_OK, 6, - 1, FTP_OK, 9, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0); - - //if USER '@' then OK! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action5: TLogonActions = - (6, FTP_OK, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER @ then - // if not PASS then ERROR! - //if not USER then - // if not PASS then - // if not ACCT then ERROR! - //OK! - Action6: TLogonActions = - (8, 6, 3, - 4, 6, FTP_ERR, - 0, FTP_OK, 9, - 1, FTP_OK, 12, - 2, FTP_OK, FTP_ERR, - 0, 0, 0); - - //if USER @ then ERROR! - //if not PASS then - // if not ACCT then ERROR! - //OK! - Action7: TLogonActions = - (9, FTP_ERR, 3, - 1, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); - - //if not USER @@ then - // if not PASS @ then - // if not ACCT then ERROR! - //OK! - Action8: TLogonActions = - (10, FTP_OK, 3, - 11, FTP_OK, 6, - 2, FTP_OK, FTP_ERR, - 0, 0, 0, 0, 0, 0, 0, 0, 0); -var - FTPServer: string; - LogonActions: TLogonActions; - i: integer; - s: string; - x: integer; -begin - Result := False; - if FFWHost = '' then - Mode := 0; - if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then - FTPServer := FTargetHost - else - FTPServer := FTargetHost + ':' + FTargetPort; - case Mode of - -1: - LogonActions := CustomLogon; - 1: - LogonActions := Action1; - 2: - LogonActions := Action2; - 3: - LogonActions := Action3; - 4: - LogonActions := Action4; - 5: - LogonActions := Action5; - 6: - LogonActions := Action6; - 7: - LogonActions := Action7; - 8: - LogonActions := Action8; - else - LogonActions := Action0; - end; - i := 0; - repeat - case LogonActions[i] of - 0: s := 'USER ' + FUserName; - 1: s := 'PASS ' + FPassword; - 2: s := 'ACCT ' + FAccount; - 3: s := 'USER ' + FFWUserName; - 4: s := 'PASS ' + FFWPassword; - 5: s := 'SITE ' + FTPServer; - 6: s := 'USER ' + FUserName + '@' + FTPServer; - 7: s := 'OPEN ' + FTPServer; - 8: s := 'USER ' + FFWUserName + '@' + FTPServer; - 9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName; - 10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer; - 11: s := 'PASS ' + FPassword + '@' + FFWPassword; - end; - x := FTPCommand(s); - x := x div 100; - if (x <> 2) and (x <> 3) then - Exit; - i := LogonActions[i + x - 1]; - case i of - FTP_ERR: - Exit; - FTP_OK: - begin - Result := True; - Exit; - end; - end; - until False; -end; - - -function TFTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - if FFWHost = '' then - FSock.Connect(FTargetHost, FTargetPort) - else - FSock.Connect(FFWHost, FFWPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TFTPSend.Login: Boolean; -var - x: integer; -begin - Result := False; - FCanResume := False; - if not Connect then - Exit; - FIsTLS := FFullSSL; - FIsDataTLS := False; - 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 - begin - FSock.SSLDoConnect; - FIsTLS := FSock.LastError = 0; - 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'); - end; - FTPCommand('TYPE I'); - FTPCommand('STRU F'); - FTPCommand('MODE S'); - if FTPCommand('REST 0') = 350 then - if FTPCommand('REST 1') = 350 then - begin - FTPCommand('REST 0'); - FCanResume := True; - end; - Result := True; -end; - -function TFTPSend.Logout: Boolean; -begin - Result := (FTPCommand('QUIT') div 100) = 2; - FSock.CloseSocket; -end; - -procedure TFTPSend.ParseRemote(Value: string); -var - n: integer; - nb, ne: integer; - s: string; - x: integer; -begin - Value := trim(Value); - nb := Pos('(',Value); - ne := Pos(')',Value); - if (nb = 0) or (ne = 0) then - begin - nb:=RPos(' ',Value); - s:=Copy(Value, nb + 1, Length(Value) - nb); - end - else - begin - s:=Copy(Value,nb+1,ne-nb-1); - end; - for n := 1 to 4 do - if n = 1 then - FDataIP := Fetch(s, ',') - else - FDataIP := FDataIP + '.' + Fetch(s, ','); - x := StrToIntDef(Fetch(s, ','), 0) * 256; - x := x + StrToIntDef(Fetch(s, ','), 0); - FDataPort := IntToStr(x); -end; - -procedure TFTPSend.ParseRemoteEPSV(Value: string); -var - n: integer; - s, v: AnsiString; -begin - s := SeparateRight(Value, '('); - s := Trim(SeparateLeft(s, ')')); - Delete(s, Length(s), 1); - v := ''; - for n := Length(s) downto 1 do - if s[n] in ['0'..'9'] then - v := s[n] + v - else - Break; - FDataPort := v; - FDataIP := FTargetHost; -end; - -function TFTPSend.DataSocket: boolean; -var - s: string; -begin - Result := False; - if FIsDataTLS then - FPassiveMode := True; - if FPassiveMode then - begin - if FSock.IP6used then - s := '2' - else - s := '1'; - if FSock.IP6used and not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then - begin - ParseRemoteEPSV(FResultString); - end - else - if FSock.IP6used then - Exit - else - begin - if (FTPCommand('PASV') div 100) <> 2 then - Exit; - ParseRemote(FResultString); - end; - FDSock.CloseSocket; - FDSock.Bind(FIPInterface, cAnyPort); - FDSock.Connect(FDataIP, FDataPort); - Result := FDSock.LastError = 0; - end - else - begin - FDSock.CloseSocket; - if FForceDefaultPort then - s := cFtpDataProtocol - else - s := '0'; - //data conection from same interface as command connection - FDSock.Bind(FSock.GetLocalSinIP, s); - if FDSock.LastError <> 0 then - Exit; - FDSock.SetLinger(True, 10000); - FDSock.Listen; - FDSock.GetSins; - FDataIP := FDSock.GetLocalSinIP; - FDataIP := FDSock.ResolveName(FDataIP); - FDataPort := IntToStr(FDSock.GetLocalSinPort); - if FSock.IP6used and (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, '.', ','); - s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256) - + ',' + IntToStr(FDSock.GetLocalSinPort mod 256); - Result := (FTPCommand(s) div 100) = 2; - end; - end; -end; - -function TFTPSend.AcceptDataSocket: Boolean; -var - x: TSocket; -begin - if FPassiveMode then - Result := True - else - begin - Result := False; - if FDSock.CanRead(FTimeout) then - begin - x := FDSock.Accept; - if not FDSock.UsingSocks then - FDSock.CloseSocket; - FDSock.Socket := x; - Result := True; - end; - end; - if Result and FIsDataTLS then - begin - FDSock.SSL.Assign(FSock.SSL); - FDSock.SSLDoConnect; - Result := FDSock.LastError = 0; - end; -end; - -function TFTPSend.DataRead(const DestStream: TStream): Boolean; -var - x: integer; -begin - Result := False; - try - if not AcceptDataSocket then - Exit; - FDSock.RecvStreamRaw(DestStream, FTimeout); - FDSock.CloseSocket; - x := ReadResult; - Result := (x div 100) = 2; - finally - FDSock.CloseSocket; - end; -end; - -function TFTPSend.DataWrite(const SourceStream: TStream): Boolean; -var - x: integer; - b: Boolean; -begin - Result := False; - try - if not AcceptDataSocket then - Exit; - FDSock.SendStreamRaw(SourceStream); - b := FDSock.LastError = 0; - FDSock.CloseSocket; - x := ReadResult; - Result := b and ((x div 100) = 2); - finally - FDSock.CloseSocket; - end; -end; - -function TFTPSend.List(Directory: string; NameList: Boolean): Boolean; -var - x: integer; -begin - Result := False; - FDataStream.Clear; - FFTPList.Clear; - if Directory <> '' then - Directory := ' ' + Directory; - FTPCommand('TYPE A'); - if not DataSocket then - Exit; - if NameList then - x := FTPCommand('NLST' + Directory) - else - x := FTPCommand('LIST' + Directory); - if (x div 100) <> 1 then - Exit; - Result := DataRead(FDataStream); - if (not NameList) and Result then - begin - FDataStream.Position := 0; - FFTPList.Lines.LoadFromStream(FDataStream); - FFTPList.ParseLines; - end; - FDataStream.Position := 0; -end; - -function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean; -var - RetrStream: TStream; -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 - RetrStream := TFileStream.Create(FDirectFileName, - fmOpenReadWrite or fmShareExclusive) - else - RetrStream := TFileStream.Create(FDirectFileName, - fmCreate or fmShareDenyWrite) - else - RetrStream := FDataStream; - try - if FBinaryMode then - FTPCommand('TYPE I') - else - FTPCommand('TYPE A'); - if Restore then - begin - RetrStream.Position := RetrStream.Size; - if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then - Exit; - end - else - if RetrStream is TMemoryStream then - TMemoryStream(RetrStream).Clear; - if (FTPCommand('RETR ' + FileName) div 100) <> 1 then - Exit; - Result := DataRead(RetrStream); - if not FDirectFile then - RetrStream.Position := 0; - finally - if FDirectFile then - RetrStream.Free; - end; -end; - -function TFTPSend.InternalStor(const Command: string; RestoreAt: int64): Boolean; -var - SendStream: TStream; - StorSize: int64; -begin - Result := False; - if FDirectFile then - if not FileExists(FDirectFileName) then - Exit - else - SendStream := TFileStream.Create(FDirectFileName, - fmOpenRead or fmShareDenyWrite) - else - SendStream := FDataStream; - try - if not DataSocket then - Exit; - if FBinaryMode then - FTPCommand('TYPE I') - else - FTPCommand('TYPE A'); - StorSize := SendStream.Size; - if not FCanResume then - RestoreAt := 0; - if (StorSize > 0) and (RestoreAt = StorSize) then - begin - Result := True; - Exit; - end; - if RestoreAt > StorSize then - RestoreAt := 0; - FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt)); - if FCanResume then - if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then - Exit; - SendStream.Position := RestoreAt; - if (FTPCommand(Command) div 100) <> 1 then - Exit; - Result := DataWrite(SendStream); - finally - if FDirectFile then - SendStream.Free; - end; -end; - -function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean; -var - RestoreAt: int64; -begin - Result := False; - if FileName = '' then - Exit; - RestoreAt := 0; - Restore := Restore and FCanResume; - if Restore then - begin - RestoreAt := Self.FileSize(FileName); - if RestoreAt < 0 then - RestoreAt := 0; - end; - Result := InternalStor('STOR ' + FileName, RestoreAt); -end; - -function TFTPSend.StoreUniqueFile: Boolean; -begin - Result := InternalStor('STOU', 0); -end; - -function TFTPSend.AppendFile(const FileName: string): Boolean; -begin - Result := False; - if FileName = '' then - Exit; - Result := InternalStor('APPE ' + FileName, 0); -end; - -function TFTPSend.NoOp: Boolean; -begin - Result := (FTPCommand('NOOP') div 100) = 2; -end; - -function TFTPSend.RenameFile(const OldName, NewName: string): Boolean; -begin - Result := False; - if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then - Exit; - Result := (FTPCommand('RNTO ' + NewName) div 100) = 2; -end; - -function TFTPSend.DeleteFile(const FileName: string): Boolean; -begin - Result := (FTPCommand('DELE ' + FileName) div 100) = 2; -end; - -function TFTPSend.FileSize(const FileName: string): int64; -var - s: string; -begin - Result := -1; - if (FTPCommand('SIZE ' + FileName) div 100) = 2 then - begin - s := Trim(SeparateRight(ResultString, ' ')); - s := Trim(SeparateLeft(s, ' ')); - {$IFDEF VER100} - Result := StrToIntDef(s, -1); - {$ELSE} - Result := StrToInt64Def(s, -1); - {$ENDIF} - end; -end; - -function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('CWD ' + Directory) div 100) = 2; -end; - -function TFTPSend.ChangeToParentDir: Boolean; -begin - Result := (FTPCommand('CDUP') div 100) = 2; -end; - -function TFTPSend.ChangeToRootDir: Boolean; -begin - Result := ChangeWorkingDir('/'); -end; - -function TFTPSend.DeleteDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('RMD ' + Directory) div 100) = 2; -end; - -function TFTPSend.CreateDir(const Directory: string): Boolean; -begin - Result := (FTPCommand('MKD ' + Directory) div 100) = 2; -end; - -function TFTPSend.GetCurrentDir: String; -begin - Result := ''; - if (FTPCommand('PWD') div 100) = 2 then - begin - Result := SeparateRight(FResultString, '"'); - Result := Trim(Separateleft(Result, '"')); - end; -end; - -procedure TFTPSend.Abort; -begin - FSock.SendString('ABOR' + CRLF); - FDSock.StopFlag := True; -end; - -procedure TFTPSend.TelnetAbort; -begin - FSock.SendString(#$FF + #$F4 + #$FF + #$F2); - Abort; -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'); - FMasks.add('n*$ YYYY MM DD hh mm$S*'); - //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; - -procedure TFTPList.Clear; -var - n:integer; -begin - for n := 0 to FList.Count - 1 do - if Assigned(FList[n]) then - TFTPListRec(FList[n]).Free; - FList.Clear; - FLines.Clear; - FUnparsedLines.Clear; -end; - -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: AnsiString): Integer; -var - Ivalue, IMask: integer; - MaskC, LastMaskC: AnsiChar; - c: AnsiChar; - 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]; - if Ivalue > Length(Value) then - Exit; - 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', 't', '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; - x: integer; - 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; - {$IFDEF VER100} - Value.FileSize := x * StrToIntDef(Size, 0); - {$ELSE} - Value.FileSize := x * StrToInt64Def(Size, 0); - {$ENDIF} - - 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 - YearTime := TrimSP(YearTime); - 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.Permission := Permissions; - 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 Value <> '' then - if Value[1] = '+' then - begin - os := Value; - Delete(Value, 1, 1); - flr := TFTPListRec.create; - flr.FileName := SeparateRight(Value, #9); - s := Fetch(Value, ','); - while s <> '' do - begin - if s[1] = #9 then - Break; - case s[1] of - '/': - flr.Directory := true; - 'r': - flr.Readable := true; - 's': - {$IFDEF VER100} - flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0); - {$ELSE} - flr.FileSize := StrToInt64Def(Copy(s, 2, Length(s) - 1), 0); - {$ENDIF} - 'm': - flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400) - + 25569; - end; - s := Fetch(Value, ','); - end; - if flr.FileName <> '' then - if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..'))) - or (flr.FileName = '') then - flr.free - else - begin - flr.OriginalLine := os; - flr.Mask := 'EPLF'; - Flist.Add(flr); - Result := True; - end; - end; -end; - -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 - 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; - -{==============================================================================} - -function FtpGetFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; -begin - Result := False; - with TFTPSend.Create do - try - if User <> '' then - begin - Username := User; - Password := Pass; - end; - TargetHost := IP; - TargetPort := Port; - if not Login then - Exit; - DirectFileName := LocalFile; - DirectFile:=True; - Result := RetrieveFile(FileName, False); - Logout; - finally - Free; - end; -end; - -function FtpPutFile(const IP, Port, FileName, LocalFile, - User, Pass: string): Boolean; -begin - Result := False; - with TFTPSend.Create do - try - if User <> '' then - begin - Username := User; - Password := Pass; - end; - TargetHost := IP; - TargetPort := Port; - if not Login then - Exit; - DirectFileName := LocalFile; - DirectFile:=True; - Result := StoreFile(FileName, False); - Logout; - finally - Free; - end; -end; - -function FtpInterServerTransfer( - const FromIP, FromPort, FromFile, FromUser, FromPass: string; - const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean; -var - FromFTP, ToFTP: TFTPSend; - s: string; - x: integer; -begin - Result := False; - FromFTP := TFTPSend.Create; - toFTP := TFTPSend.Create; - try - if FromUser <> '' then - begin - FromFTP.Username := FromUser; - FromFTP.Password := FromPass; - end; - if ToUser <> '' then - begin - ToFTP.Username := ToUser; - ToFTP.Password := ToPass; - end; - FromFTP.TargetHost := FromIP; - FromFTP.TargetPort := FromPort; - ToFTP.TargetHost := ToIP; - ToFTP.TargetPort := ToPort; - if not FromFTP.Login then - Exit; - if not ToFTP.Login then - Exit; - if (FromFTP.FTPCommand('PASV') div 100) <> 2 then - Exit; - FromFTP.ParseRemote(FromFTP.ResultString); - s := ReplaceString(FromFTP.DataIP, '.', ','); - s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256) - + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256); - if (ToFTP.FTPCommand(s) div 100) <> 2 then - Exit; - x := ToFTP.FTPCommand('RETR ' + FromFile); - if (x div 100) <> 1 then - Exit; - x := FromFTP.FTPCommand('STOR ' + ToFile); - if (x div 100) <> 1 then - Exit; - FromFTP.Timeout := 21600000; - x := FromFTP.ReadResult; - if (x div 100) <> 2 then - Exit; - ToFTP.Timeout := 21600000; - x := ToFTP.ReadResult; - if (x div 100) <> 2 then - Exit; - Result := True; - finally - ToFTP.Free; - FromFTP.Free; - end; -end; - -end. diff --git a/synapse/ftptsend.pas b/synapse/ftptsend.pas deleted file mode 100644 index 6ab4173..0000000 --- a/synapse/ftptsend.pas +++ /dev/null @@ -1,403 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: Trivial FTP (TFTP) client and server | -|==============================================================================| -| Copyright (c)1999-2010, 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-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(TFTP client and server protocol) - -Used RFC: RFC-1350 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ftptsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -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; - FErrorCode: integer; - FErrorString: string; - FData: TMemoryStream; - FRequestIP: string; - FRequestPort: string; - function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; - function RecvPacket(Serial: word; var Value: string): Boolean; - 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; - -implementation - -constructor TTFTPSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTargetPort := cTFTPProtocol; - FData := TMemoryStream.Create; - FErrorCode := 0; - FErrorString := ''; -end; - -destructor TTFTPSend.Destroy; -begin - FSock.Free; - FData.Free; - inherited Destroy; -end; - -function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; -var - s, sh: string; -begin - FErrorCode := 0; - FErrorString := ''; - Result := false; - if Cmd <> 2 then - s := CodeInt(Cmd) + CodeInt(Serial) + Value - else - s := CodeInt(Cmd) + Value; - FSock.SendString(s); - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if length(s) >= 4 then - begin - sh := CodeInt(4) + CodeInt(Serial); - if Pos(sh, s) = 1 then - Result := True - else - if s[1] = #5 then - begin - FErrorCode := DecodeInt(s, 3); - Delete(s, 1, 4); - FErrorString := SeparateLeft(s, #0); - end; - end; -end; - -function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; -var - s: string; - ser: word; -begin - FErrorCode := 0; - FErrorString := ''; - Result := False; - Value := ''; - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if length(s) >= 4 then - if DecodeInt(s, 1) = 3 then - begin - ser := DecodeInt(s, 3); - if ser = Serial then - begin - Delete(s, 1, 4); - Value := s; - S := CodeInt(4) + CodeInt(ser); - FSock.SendString(s); - Result := FSock.LastError = 0; - end - else - begin - S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; - FSock.SendString(s); - end; - end; - if DecodeInt(s, 1) = 5 then - begin - FErrorCode := DecodeInt(s, 3); - Delete(s, 1, 4); - FErrorString := SeparateLeft(s, #0); - end; -end; - -function TTFTPSend.SendFile(const Filename: string): Boolean; -var - s: string; - ser: word; - n, n1, n2: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FTargetHost, FTargetPort); - try - if FSock.LastError = 0 then - begin - s := Filename + #0 + 'octet' + #0; - if not Sendpacket(2, 0, s) then - Exit; - ser := 1; - FData.Position := 0; - n1 := FData.Size div 512; - n2 := FData.Size mod 512; - for n := 1 to n1 do - begin - s := ReadStrFromStream(FData, 512); -// SetLength(s, 512); -// FData.Read(pointer(s)^, 512); - if not Sendpacket(3, ser, s) then - Exit; - inc(ser); - end; - s := ReadStrFromStream(FData, n2); -// SetLength(s, n2); -// FData.Read(pointer(s)^, n2); - if not Sendpacket(3, ser, s) then - Exit; - Result := True; - end; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.RecvFile(const Filename: string): Boolean; -var - s: string; - ser: word; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FTargetHost, FTargetPort); - try - if FSock.LastError = 0 then - begin - s := CodeInt(1) + Filename + #0 + 'octet' + #0; - FSock.SendString(s); - if FSock.LastError <> 0 then - Exit; - FData.Clear; - ser := 1; - repeat - if not RecvPacket(ser, s) then - Exit; - inc(ser); - WriteStrToStream(FData, s); -// FData.Write(pointer(s)^, length(s)); - until length(s) <> 512; - FData.Position := 0; - Result := true; - end; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; -var - s: string; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Bind('0.0.0.0', FTargetPort); - if FSock.LastError = 0 then - begin - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - if Length(s) >= 4 then - begin - FRequestIP := FSock.GetRemoteSinIP; - FRequestPort := IntToStr(FSock.GetRemoteSinPort); - Req := DecodeInt(s, 1); - delete(s, 1, 2); - filename := Trim(SeparateLeft(s, #0)); - s := SeparateRight(s, #0); - s := SeparateLeft(s, #0); - Result := lowercase(trim(s)) = 'octet'; - end; - end; -end; - -procedure TTFTPSend.ReplyError(Error: word; Description: string); -var - s: string; -begin - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - s := CodeInt(5) + CodeInt(Error) + Description + #0; - FSock.SendString(s); - FSock.CloseSocket; -end; - -function TTFTPSend.ReplyRecv: Boolean; -var - s: string; - ser: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - try - s := CodeInt(4) + CodeInt(0); - FSock.SendString(s); - FData.Clear; - ser := 1; - repeat - if not RecvPacket(ser, s) then - Exit; - inc(ser); - WriteStrToStream(FData, s); -// FData.Write(pointer(s)^, length(s)); - until length(s) <> 512; - FData.Position := 0; - Result := true; - finally - FSock.CloseSocket; - end; -end; - -function TTFTPSend.ReplySend: Boolean; -var - s: string; - ser: word; - n, n1, n2: integer; -begin - Result := False; - FErrorCode := 0; - FErrorString := ''; - FSock.CloseSocket; - FSock.Connect(FRequestIP, FRequestPort); - try - ser := 1; - FData.Position := 0; - n1 := FData.Size div 512; - n2 := FData.Size mod 512; - for n := 1 to n1 do - begin - s := ReadStrFromStream(FData, 512); -// SetLength(s, 512); -// FData.Read(pointer(s)^, 512); - if not Sendpacket(3, ser, s) then - Exit; - inc(ser); - end; - s := ReadStrFromStream(FData, n2); -// SetLength(s, n2); -// FData.Read(pointer(s)^, n2); - if not Sendpacket(3, ser, s) then - Exit; - Result := True; - finally - FSock.CloseSocket; - end; -end; - -{==============================================================================} - -end. diff --git a/synapse/httpsend.pas b/synapse/httpsend.pas deleted file mode 100644 index 7182db3..0000000 --- a/synapse/httpsend.pas +++ /dev/null @@ -1,845 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.012.006 | -|==============================================================================| -| Content: HTTP client | -|==============================================================================| -| Copyright (c)1999-2011, 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) 1999-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(HTTP protocol client) - -Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit httpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synaip, synacode, synsock; - -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) - protected - FSock: TTCPBlockSocket; - FTransferEncoding: TTransferEncoding; - FAliveHost: string; - FAlivePort: string; - FHeaders: TStringList; - FDocument: TMemoryStream; - FMimeType: string; - FProtocol: string; - FKeepAlive: Boolean; - FKeepAliveTimeout: integer; - FStatus100: Boolean; - FProxyHost: string; - FProxyPort: string; - FProxyUser: string; - FProxyPass: string; - FResultCode: Integer; - FResultString: string; - FUserAgent: string; - FCookies: TStringList; - FDownloadSize: integer; - FUploadSize: integer; - FRangeStart: integer; - FRangeEnd: integer; - FAddPortNumberToHost: Boolean; - function ReadUnknown: Boolean; - function ReadIdentity(Size: Integer): Boolean; - function ReadChunked: Boolean; - procedure ParseCookies; - function PrepareHeaders: AnsiString; - function InternalDoConnect(needssl: Boolean): Boolean; - function InternalConnect(needssl: Boolean): Boolean; - 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', '1.0' (default) - and '0.9'.} - property Protocol: string read FProtocol Write FProtocol; - - {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.} - property KeepAlive: Boolean read FKeepAlive Write FKeepAlive; - - {:Define timeout for keepalives in seconds!} - property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout; - - {: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; - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - - {:To have possibility to switch off port number in 'Host:' HTTP header, by - default @TRUE. Some buggy servers not like port informations in this header.} - property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost; - 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; - -implementation - -constructor THTTPSend.Create; -begin - inherited Create; - FHeaders := TStringList.Create; - FCookies := TStringList.Create; - FDocument := TMemoryStream.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := True; - FSock.SizeRecvBuffer := c64k; - FSock.SizeSendBuffer := c64k; - FTimeout := 90000; - FTargetPort := cHttpProtocol; - FProxyHost := ''; - FProxyPort := '8080'; - FProxyUser := ''; - FProxyPass := ''; - FAliveHost := ''; - FAlivePort := ''; - FProtocol := '1.0'; - FKeepAlive := True; - FStatus100 := False; - FUserAgent := 'Mozilla/4.0 (compatible; Synapse)'; - FDownloadSize := 0; - FUploadSize := 0; - FAddPortNumberToHost := true; - FKeepAliveTimeout := 300; - Clear; -end; - -destructor THTTPSend.Destroy; -begin - FSock.Free; - FDocument.Free; - FCookies.Free; - FHeaders.Free; - inherited Destroy; -end; - -procedure THTTPSend.Clear; -begin - FRangeStart := 0; - FRangeEnd := 0; - FDocument.Clear; - FHeaders.Clear; - FMimeType := 'text/html'; -end; - -procedure THTTPSend.DecodeStatus(const Value: string); -var - s, su: string; -begin - s := Trim(SeparateRight(Value, ' ')); - su := Trim(SeparateLeft(s, ' ')); - FResultCode := StrToIntDef(su, 0); - FResultString := Trim(SeparateRight(s, ' ')); - if FResultString = s then - FResultString := ''; -end; - -function THTTPSend.PrepareHeaders: AnsiString; -begin - if FProtocol = '0.9' then - Result := FHeaders[0] + CRLF - else -{$IFNDEF MSWINDOWS} - Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF)); -{$ELSE} - Result := FHeaders.Text; -{$ENDIF} -end; - -function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError <> 0 then - Exit; - if needssl then - begin - if (FSock.SSL.SNIHost='') then - FSock.SSL.SNIHost:=FTargetHost; - FSock.SSLDoConnect; - FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection - if FSock.LastError <> 0 then - Exit; - end; - FAliveHost := FTargetHost; - FAlivePort := FTargetPort; - Result := True; -end; - -function THTTPSend.InternalConnect(needssl: Boolean): Boolean; -begin - if FSock.Socket = INVALID_SOCKET then - Result := InternalDoConnect(needssl) - else - if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) - or FSock.CanRead(0) then - Result := InternalDoConnect(needssl) - else - Result := True; -end; - -function THTTPSend.HTTPMethod(const Method, URL: string): Boolean; -var - Sending, Receiving: Boolean; - status100: Boolean; - status100error: string; - ToClose: Boolean; - Size: Integer; - Prot, User, Pass, Host, Port, Path, Para, URI: string; - s, su: AnsiString; - HttpTunnel: Boolean; - n: integer; - pp: string; - UsingProxy: boolean; - l: TStringList; - x: integer; -begin - {initial values} - Result := False; - FResultCode := 500; - FResultString := ''; - FDownloadSize := 0; - FUploadSize := 0; - - URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); - User := DecodeURL(user); - Pass := DecodeURL(pass); - if User = '' then - begin - User := FUsername; - Pass := FPassword; - end; - if UpperCase(Prot) = 'HTTPS' then - begin - HttpTunnel := FProxyHost <> ''; - FSock.HTTPTunnelIP := FProxyHost; - FSock.HTTPTunnelPort := FProxyPort; - FSock.HTTPTunnelUser := FProxyUser; - FSock.HTTPTunnelPass := FProxyPass; - end - else - begin - HttpTunnel := False; - FSock.HTTPTunnelIP := ''; - FSock.HTTPTunnelPort := ''; - FSock.HTTPTunnelUser := ''; - FSock.HTTPTunnelPass := ''; - end; - UsingProxy := (FProxyHost <> '') and not(HttpTunnel); - Sending := FDocument.Size > 0; - {Headers for Sending data} - status100 := FStatus100 and Sending and (FProtocol = '1.1'); - if status100 then - FHeaders.Insert(0, 'Expect: 100-continue'); - if Sending then - begin - FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); - if FMimeType <> '' then - FHeaders.Insert(0, 'Content-Type: ' + FMimeType); - end; - { setting User-agent } - if FUserAgent <> '' then - FHeaders.Insert(0, 'User-Agent: ' + FUserAgent); - { setting Ranges } - if (FRangeStart > 0) or (FRangeEnd > 0) then - begin - if FRangeEnd >= FRangeStart then - FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd)) - else - FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-'); - end; - { setting Cookies } - s := ''; - for n := 0 to FCookies.Count - 1 do - begin - if s <> '' then - s := s + '; '; - s := s + FCookies[n]; - end; - if s <> '' then - FHeaders.Insert(0, 'Cookie: ' + s); - { setting KeepAlives } - pp := ''; - if UsingProxy then - pp := 'Proxy-'; - if FKeepAlive then - begin - FHeaders.Insert(0, pp + 'Connection: keep-alive'); - FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout)); - end - else - FHeaders.Insert(0, pp + 'Connection: close'); - { set target servers/proxy, authorizations, etc... } - if User <> '' then - FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass)); - if UsingProxy and (FProxyUser <> '') then - FHeaders.Insert(0, 'Proxy-Authorization: Basic ' + - EncodeBase64(FProxyUser + ':' + FProxyPass)); - if isIP6(Host) then - s := '[' + Host + ']' - else - s := Host; - if FAddPortNumberToHost and (Port <> '80') then - FHeaders.Insert(0, 'Host: ' + s + ':' + Port) - else - FHeaders.Insert(0, 'Host: ' + s); - if UsingProxy then - URI := Prot + '://' + s + ':' + Port + URI; - if URI = '/*' then - URI := '*'; - if FProtocol = '0.9' then - FHeaders.Insert(0, UpperCase(Method) + ' ' + URI) - else - FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol); - if UsingProxy then - begin - FTargetHost := FProxyHost; - FTargetPort := FProxyPort; - end - else - begin - FTargetHost := Host; - FTargetPort := Port; - end; - if FHeaders[FHeaders.Count - 1] <> '' then - FHeaders.Add(''); - - { connect } - if not InternalConnect(UpperCase(Prot) = 'HTTPS') then - begin - FAliveHost := ''; - FAlivePort := ''; - Exit; - end; - - { reading Status } - FDocument.Position := 0; - Status100Error := ''; - if status100 then - begin - { send Headers } - FSock.SendString(PrepareHeaders); - if FSock.LastError <> 0 then - Exit; - repeat - s := FSock.RecvString(FTimeout); - if s <> '' then - Break; - until FSock.LastError <> 0; - DecodeStatus(s); - Status100Error := s; - repeat - s := FSock.recvstring(FTimeout); - if s = '' then - Break; - until FSock.LastError <> 0; - if (FResultCode >= 100) and (FResultCode < 200) then - begin - { we can upload content } - Status100Error := ''; - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); - end; - end - else - { upload content } - if sending then - begin - if FDocument.Size >= c64k then - begin - FSock.SendString(PrepareHeaders); - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); - end - else - begin - s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size); - FUploadSize := Length(s); - FSock.SendString(s); - end; - end - else - begin - { we not need to upload document, send headers only } - FSock.SendString(PrepareHeaders); - end; - - if FSock.LastError <> 0 then - Exit; - - Clear; - Size := -1; - FTransferEncoding := TE_UNKNOWN; - - { read status } - if Status100Error = '' then - begin - repeat - repeat - s := FSock.RecvString(FTimeout); - if s <> '' then - Break; - until FSock.LastError <> 0; - if Pos('HTTP/', UpperCase(s)) = 1 then - begin - FHeaders.Add(s); - DecodeStatus(s); - end - else - begin - { old HTTP 0.9 and some buggy servers not send result } - s := s + CRLF; - WriteStrToStream(FDocument, s); - FResultCode := 0; - end; - until (FSock.LastError <> 0) or (FResultCode <> 100); - end - else - FHeaders.Add(Status100Error); - - { if need receive headers, receive and parse it } - ToClose := FProtocol <> '1.1'; - if FHeaders.Count > 0 then - begin - l := TStringList.Create; - try - repeat - s := FSock.RecvString(FTimeout); - l.Add(s); - if s = '' then - Break; - until FSock.LastError <> 0; - x := 0; - while l.Count > x do - begin - s := NormalizeHeader(l, x); - FHeaders.Add(s); - su := UpperCase(s); - if Pos('CONTENT-LENGTH:', su) = 1 then - begin - Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1); - if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then - FTransferEncoding := TE_IDENTITY; - end; - if Pos('CONTENT-TYPE:', su) = 1 then - FMimeType := Trim(SeparateRight(s, ' ')); - if Pos('TRANSFER-ENCODING:', su) = 1 then - begin - s := Trim(SeparateRight(su, ' ')); - if Pos('CHUNKED', s) > 0 then - FTransferEncoding := TE_CHUNKED; - end; - if UsingProxy then - begin - if Pos('PROXY-CONNECTION:', su) = 1 then - if Pos('CLOSE', su) > 0 then - ToClose := True; - end - else - begin - if Pos('CONNECTION:', su) = 1 then - if Pos('CLOSE', su) > 0 then - ToClose := True; - end; - end; - finally - l.free; - end; - end; - - Result := FSock.LastError = 0; - if not Result then - Exit; - - {if need receive response body, read it} - Receiving := Method <> 'HEAD'; - Receiving := Receiving and (FResultCode <> 204); - Receiving := Receiving and (FResultCode <> 304); - if Receiving then - case FTransferEncoding of - TE_UNKNOWN: - Result := ReadUnknown; - TE_IDENTITY: - Result := ReadIdentity(Size); - TE_CHUNKED: - Result := ReadChunked; - end; - - FDocument.Seek(0, soFromBeginning); - if ToClose then - begin - FSock.CloseSocket; - FAliveHost := ''; - FAlivePort := ''; - end; - ParseCookies; -end; - -function THTTPSend.ReadUnknown: Boolean; -var - s: ansistring; -begin - Result := false; - repeat - s := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - WriteStrToStream(FDocument, s); - until FSock.LastError <> 0; - if FSock.LastError = WSAECONNRESET then - begin - Result := true; - FSock.ResetLastError; - end; -end; - -function THTTPSend.ReadIdentity(Size: Integer): Boolean; -begin - if Size > 0 then - begin - FDownloadSize := Size; - FSock.RecvStreamSize(FDocument, FTimeout, Size); - FDocument.Position := FDocument.Size; - Result := FSock.LastError = 0; - end - else - Result := true; -end; - -function THTTPSend.ReadChunked: Boolean; -var - s: ansistring; - Size: Integer; -begin - repeat - repeat - s := FSock.RecvString(FTimeout); - until (s <> '') or (FSock.LastError <> 0); - if FSock.LastError <> 0 then - Break; - s := Trim(SeparateLeft(s, ' ')); - s := Trim(SeparateLeft(s, ';')); - Size := StrToIntDef('$' + s, 0); - if Size = 0 then - Break; - if not ReadIdentity(Size) then - break; - until False; - Result := FSock.LastError = 0; -end; - -procedure THTTPSend.ParseCookies; -var - n: integer; - s: string; - sn, sv: string; -begin - for n := 0 to FHeaders.Count - 1 do - if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then - begin - s := SeparateRight(FHeaders[n], ':'); - s := trim(SeparateLeft(s, ';')); - sn := trim(SeparateLeft(s, '=')); - sv := trim(SeparateRight(s, '=')); - FCookies.Values[sn] := sv; - end; -end; - -procedure THTTPSend.Abort; -begin - FSock.StopFlag := True; -end; - -{==============================================================================} - -function HttpGetText(const URL: string; const Response: TStrings): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - Result := HTTP.HTTPMethod('GET', URL); - if Result then - Response.LoadFromStream(HTTP.Document); - finally - HTTP.Free; - end; -end; - -function HttpGetBinary(const URL: string; const Response: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - Result := HTTP.HTTPMethod('GET', URL); - if Result then - begin - Response.Seek(0, soFromBeginning); - Response.CopyFrom(HTTP.Document, 0); - end; - finally - HTTP.Free; - end; -end; - -function HttpPostBinary(const URL: string; const Data: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - HTTP.Document.CopyFrom(Data, 0); - HTTP.MimeType := 'Application/octet-stream'; - Result := HTTP.HTTPMethod('POST', URL); - Data.Size := 0; - if Result then - begin - Data.Seek(0, soFromBeginning); - Data.CopyFrom(HTTP.Document, 0); - end; - finally - HTTP.Free; - end; -end; - -function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean; -var - HTTP: THTTPSend; -begin - HTTP := THTTPSend.Create; - try - WriteStrToStream(HTTP.Document, URLData); - HTTP.MimeType := 'application/x-www-form-urlencoded'; - Result := HTTP.HTTPMethod('POST', URL); - if Result then - Data.CopyFrom(HTTP.Document, 0); - finally - HTTP.Free; - end; -end; - -function HttpPostFile(const URL, FieldName, FileName: string; - const Data: TStream; const ResultData: TStrings): Boolean; -var - HTTP: THTTPSend; - Bound, s: string; -begin - Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary'; - HTTP := THTTPSend.Create; - try - s := '--' + Bound + CRLF; - s := s + 'content-disposition: form-data; name="' + FieldName + '";'; - s := s + ' filename="' + FileName +'"' + CRLF; - s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF; - WriteStrToStream(HTTP.Document, s); - HTTP.Document.CopyFrom(Data, 0); - s := CRLF + '--' + Bound + '--' + CRLF; - WriteStrToStream(HTTP.Document, s); - HTTP.MimeType := 'multipart/form-data; boundary=' + Bound; - Result := HTTP.HTTPMethod('POST', URL); - if Result then - ResultData.LoadFromStream(HTTP.Document); - finally - HTTP.Free; - end; -end; - -end. diff --git a/synapse/imapsend.pas b/synapse/imapsend.pas deleted file mode 100644 index 85ac3fa..0000000 --- a/synapse/imapsend.pas +++ /dev/null @@ -1,869 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.005.003 | -|==============================================================================| -| Content: IMAP4rev1 client | -|==============================================================================| -| Copyright (c)1999-2012, 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)2001-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(IMAP4 rev1 protocol client) - -Used RFC: RFC-2060, RFC-2595 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit imapsend; - -interface - -uses - SysUtils, Classes, - 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) - protected - FSock: TTCPBlockSocket; - FTagCommand: integer; - FResultString: string; - FFullResult: TStringList; - FIMAPcap: TStringList; - FAuthDone: Boolean; - FSelectedFolder: string; - FSelectedCount: integer; - FSelectedRecent: integer; - FSelectedUIDvalidity: integer; - FUID: Boolean; - FAutoTLS: Boolean; - FFullSSL: Boolean; - function ReadResult: string; - function AuthLogin: Boolean; - function Connect: Boolean; - procedure ParseMess(Value:TStrings); - procedure ParseFolderList(Value:TStrings); - procedure ParseSelect; - procedure ParseSearch(Value:TStrings); - procedure ProcessLiterals; - 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; - - {: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 current selected folder. It mark message as Deleted. - Real deleting will 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; - - {: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; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TIMAPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FIMAPcap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := True; - FSock.SizeRecvBuffer := 32768; - FSock.SizeSendBuffer := 32768; - FTimeout := 60000; - FTargetPort := cIMAPProtocol; - FTagCommand := 0; - FSelectedFolder := ''; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - FUID := False; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TIMAPSend.Destroy; -begin - FSock.Free; - FIMAPcap.Free; - FFullResult.Free; - inherited Destroy; -end; - - -function TIMAPSend.ReadResult: string; -var - s: string; - x, l: integer; -begin - Result := ''; - FFullResult.Clear; - FResultString := ''; - repeat - s := FSock.RecvString(FTimeout); - if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then - begin - FResultString := s; - break; - end - else - FFullResult.Add(s); - if (s <> '') and (s[Length(s)]='}') then - begin - s := Copy(s, 1, Length(s) - 1); - x := RPos('{', s); - s := Copy(s, x + 1, Length(s) - x); - l := StrToIntDef(s, -1); - if l <> -1 then - begin - s := FSock.RecvBufferStr(l, FTimeout); - FFullResult.Add(s); - end; - end; - until FSock.LastError <> 0; - s := Trim(separateright(FResultString, ' ')); - Result:=uppercase(Trim(separateleft(s, ' '))); -end; - -procedure TIMAPSend.ProcessLiterals; -var - l: TStringList; - n, x: integer; - b: integer; - s: string; -begin - l := TStringList.Create; - try - l.Assign(FFullResult); - FFullResult.Clear; - b := 0; - for n := 0 to l.Count - 1 do - begin - s := l[n]; - if b > 0 then - begin - FFullResult[FFullresult.Count - 1] := - FFullResult[FFullresult.Count - 1] + s; - inc(b); - if b > 2 then - b := 0; - end - else - begin - if (s <> '') and (s[Length(s)]='}') then - begin - x := RPos('{', s); - Delete(s, x, Length(s) - x + 1); - b := 1; - end - else - b := 0; - FFullResult.Add(s); - end; - end; - finally - l.Free; - end; -end; - -function TIMAPSend.IMAPcommand(Value: string): string; -begin - Inc(FTagCommand); - FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF); - Result := ReadResult; -end; - -function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string; -var - l: integer; -begin - Inc(FTagCommand); - l := Length(Data.Text); - FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF); - FSock.RecvString(FTimeout); - FSock.SendString(Data.Text + CRLF); - Result := ReadResult; -end; - -procedure TIMAPSend.ParseMess(Value:TStrings); -var - n: integer; -begin - Value.Clear; - for n := 0 to FFullResult.Count - 2 do - if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then - begin - Value.Text := FFullResult[n + 1]; - Break; - end; -end; - -procedure TIMAPSend.ParseFolderList(Value:TStrings); -var - n, x: integer; - s: string; -begin - ProcessLiterals; - Value.Clear; - for n := 0 to FFullResult.Count - 1 do - begin - s := FFullResult[n]; - if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then - begin - if s[Length(s)] = '"' then - begin - Delete(s, Length(s), 1); - x := RPos('"', s); - end - else - x := RPos(' ', s); - if (x > 0) then - Value.Add(Copy(s, x + 1, Length(s) - x)); - end; - end; -end; - -procedure TIMAPSend.ParseSelect; -var - n: integer; - s, t: string; -begin - ProcessLiterals; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos(' EXISTS', s) > 0 then - begin - t := Trim(separateleft(s, ' EXISTS')); - t := Trim(separateright(t, '* ')); - FSelectedCount := StrToIntDef(t, 0); - end; - if Pos(' RECENT', s) > 0 then - begin - t := Trim(separateleft(s, ' RECENT')); - t := Trim(separateright(t, '* ')); - FSelectedRecent := StrToIntDef(t, 0); - end; - if Pos('UIDVALIDITY', s) > 0 then - begin - t := Trim(separateright(s, 'UIDVALIDITY ')); - t := Trim(separateleft(t, ']')); - FSelectedUIDvalidity := StrToIntDef(t, 0); - end; - end; -end; - -procedure TIMAPSend.ParseSearch(Value:TStrings); -var - n: integer; - s: string; -begin - ProcessLiterals; - Value.Clear; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos('* SEARCH', s) = 1 then - begin - s := Trim(SeparateRight(s, '* SEARCH')); - while s <> '' do - Value.Add(Fetch(s, ' ')); - end; - end; -end; - -function TIMAPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FIMAPcap.Count - 1 do - if Pos(s, UpperCase(FIMAPcap[n])) = 1 then - begin - Result := FIMAPcap[n]; - Break; - end; -end; - -function TIMAPSend.AuthLogin: Boolean; -begin - Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK'; -end; - -function TIMAPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TIMAPSend.Capability: Boolean; -var - n: Integer; - s, t: string; -begin - Result := False; - FIMAPcap.Clear; - s := IMAPcommand('CAPABILITY'); - if s = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - if Pos('* CAPABILITY ', FFullResult[n]) = 1 then - begin - s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY ')); - while not (s = '') do - begin - t := Trim(separateleft(s, ' ')); - s := Trim(separateright(s, ' ')); - if s = t then - s := ''; - FIMAPcap.Add(t); - end; - end; - Result := True; - end; -end; - -function TIMAPSend.Login: Boolean; -var - s: string; -begin - FSelectedFolder := ''; - FSelectedCount := 0; - FSelectedRecent := 0; - FSelectedUIDvalidity := 0; - Result := False; - FAuthDone := False; - if not Connect then - Exit; - s := FSock.RecvString(FTimeout); - if Pos('* PREAUTH', s) = 1 then - FAuthDone := True - else - if Pos('* OK', s) = 1 then - FAuthDone := False - else - Exit; - if Capability then - begin - if Findcap('IMAP4rev1') = '' then - Exit; - if FAutoTLS and (Findcap('STARTTLS') <> '') then - if StartTLS then - Capability; - end; - Result := AuthLogin; -end; - -function TIMAPSend.Logout: Boolean; -begin - Result := IMAPcommand('LOGOUT') = 'OK'; - FSelectedFolder := ''; - FSock.CloseSocket; -end; - -function TIMAPSend.NoOp: Boolean; -begin - Result := IMAPcommand('NOOP') = 'OK'; -end; - -function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean; -begin - Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK'; - 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'; -end; - -function TIMAPSend.DeleteFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean; -begin - Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK'; -end; - -function TIMAPSend.SubscribeFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK'; -end; - -function TIMAPSend.SelectFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK'; - FSelectedFolder := FolderName; - ParseSelect; -end; - -function TIMAPSend.SelectROFolder(FolderName: string): Boolean; -begin - Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK'; - FSelectedFolder := FolderName; - ParseSelect; -end; - -function TIMAPSend.CloseFolder: Boolean; -begin - Result := IMAPcommand('CLOSE') = 'OK'; - FSelectedFolder := ''; -end; - -function TIMAPSend.StatusFolder(FolderName, Value: string): integer; -var - n: integer; - s, t: string; -begin - Result := -1; - Value := Uppercase(Value); - if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := FFullResult[n]; -// s := UpperCase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then - begin - t := SeparateRight(s, Value); - t := SeparateLeft(t, ')'); - t := trim(t); - Result := StrToIntDef(t, -1); - Break; - end; - end; - end; -end; - -function TIMAPSend.ExpungeFolder: Boolean; -begin - Result := IMAPcommand('EXPUNGE') = 'OK'; -end; - -function TIMAPSend.CheckFolder: Boolean; -begin - Result := IMAPcommand('CHECK') = 'OK'; -end; - -function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean; -begin - Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK'; -end; - -function TIMAPSend.DeleteMess(MessID: integer): boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean; -var - s: string; -begin - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseMess(Mess); -end; - -function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean; -var - s: string; -begin - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseMess(Headers); -end; - -function TIMAPSend.MessageSize(MessID: integer): integer; -var - n: integer; - s, t: string; -begin - Result := -1; - s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)'; - if FUID then - s := 'UID ' + s; - if IMAPcommand(s) = 'OK' then - begin - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := UpperCase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then - begin - t := SeparateRight(s, 'RFC822.SIZE '); - t := Trim(SeparateLeft(t, ')')); - t := Trim(SeparateLeft(t, ' ')); - Result := StrToIntDef(t, -1); - Break; - end; - end; - end; -end; - -function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean; -var - s: string; -begin - s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean; -var - s: string; -begin - s := 'SEARCH ' + Criteria; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ParseSearch(FoundMess); -end; - -function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean; -var - s: string; -begin - s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; -end; - -function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean; -var - s: string; - n: integer; -begin - Flags := ''; - s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)'; - if FUID then - s := 'UID ' + s; - Result := IMAPcommand(s) = 'OK'; - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then - begin - s := SeparateRight(s, 'FLAGS'); - s := Separateright(s, '('); - Flags := Trim(SeparateLeft(s, ')')); - end; - end; -end; - -function TIMAPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - if IMAPcommand('STARTTLS') = 'OK' then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -//Paul Buskermolen -function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean; -var - s, sUid: string; - n: integer; -begin - sUID := ''; - s := 'FETCH ' + IntToStr(MessID) + ' UID'; - Result := IMAPcommand(s) = 'OK'; - ProcessLiterals; - for n := 0 to FFullResult.Count - 1 do - begin - s := uppercase(FFullResult[n]); - if Pos('FETCH (UID', s) >= 1 then - begin - s := Separateright(s, '(UID '); - sUID := Trim(SeparateLeft(s, ')')); - end; - end; - UID := StrToIntDef(sUID, 0); -end; - -{==============================================================================} - -end. diff --git a/synapse/laz_synapse.lpk b/synapse/laz_synapse.lpk deleted file mode 100644 index e686e41..0000000 --- a/synapse/laz_synapse.lpk +++ /dev/null @@ -1,170 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/synapse/laz_synapse.pas b/synapse/laz_synapse.pas deleted file mode 100644 index 2eaa540..0000000 --- a/synapse/laz_synapse.pas +++ /dev/null @@ -1,24 +0,0 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit laz_synapse; - -interface - -uses - asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend, - imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, - pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, - synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, - synsock, tlntsend, LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('laz_synapse', @Register); -end. diff --git a/synapse/ldapsend.pas b/synapse/ldapsend.pas deleted file mode 100644 index ece52d6..0000000 --- a/synapse/ldapsend.pas +++ /dev/null @@ -1,1208 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.007.000 | -|==============================================================================| -| Content: LDAP client | -|==============================================================================| -| Copyright (c)1999-2010, 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-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(LDAP client) - -Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ldapsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, asn1util, synacode; - -const - cLDAPProtocol = '389'; - - LDAP_ASN1_BIND_REQUEST = $60; - LDAP_ASN1_BIND_RESPONSE = $61; - LDAP_ASN1_UNBIND_REQUEST = $42; - LDAP_ASN1_SEARCH_REQUEST = $63; - LDAP_ASN1_SEARCH_ENTRY = $64; - LDAP_ASN1_SEARCH_DONE = $65; - LDAP_ASN1_SEARCH_REFERENCE = $73; - LDAP_ASN1_MODIFY_REQUEST = $66; - LDAP_ASN1_MODIFY_RESPONSE = $67; - LDAP_ASN1_ADD_REQUEST = $68; - LDAP_ASN1_ADD_RESPONSE = $69; - LDAP_ASN1_DEL_REQUEST = $4A; - LDAP_ASN1_DEL_RESPONSE = $6B; - LDAP_ASN1_MODIFYDN_REQUEST = $6C; - LDAP_ASN1_MODIFYDN_RESPONSE = $6D; - LDAP_ASN1_COMPARE_REQUEST = $6E; - LDAP_ASN1_COMPARE_RESPONSE = $6F; - LDAP_ASN1_ABANDON_REQUEST = $70; - LDAP_ASN1_EXT_REQUEST = $77; - LDAP_ASN1_EXT_RESPONSE = $78; - - -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: AnsiString; - FIsBinary: Boolean; - protected - function Get(Index: integer): string; override; - procedure Put(Index: integer; const Value: string); override; - procedure SetAttributeName(Value: AnsiString); - published - {:Name of LDAP attribute.} - property AttributeName: AnsiString 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; - function GetAttribute(Index: integer): TLDAPAttribute; - 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; - {:Delete one TLDAPAttribute object from list.} - procedure Del(Index: integer); - {:Find and return attribute with requested name. Returns nil if not found.} - function Find(AttributeName: AnsiString): TLDAPAttribute; - {:Find and return attribute value with requested name. Returns empty string if not found.} - function Get(AttributeName: AnsiString): string; - {: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: AnsiString; - FAttributes: TLDAPAttributeList; - public - constructor Create; - destructor Destroy; override; - published - {:Name of this LDAP object.} - property ObjectName: AnsiString 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; - function GetResult(Index: integer): TLDAPResult; - 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, - SA_FindingBaseObj, - 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 - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: AnsiString; - FFullResult: AnsiString; - FAutoTLS: Boolean; - FFullSSL: Boolean; - FSeq: integer; - FResponseCode: integer; - FResponseDN: AnsiString; - FReferals: TStringList; - FVersion: integer; - FSearchScope: TLDAPSearchScope; - FSearchAliases: TLDAPSearchAliases; - FSearchSizeLimit: integer; - FSearchTimeLimit: integer; - FSearchResult: TLDAPResultList; - FExtName: AnsiString; - FExtValue: AnsiString; - function Connect: Boolean; - function BuildPacket(const Value: AnsiString): AnsiString; - function ReceiveResponse: AnsiString; - function DecodeResponse(const Value: AnsiString): AnsiString; - function LdapSasl(Value: AnsiString): AnsiString; - function TranslateFilter(Value: AnsiString): AnsiString; - function GetErrorString(Value: integer): AnsiString; - 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; - - {:Close connection to LDAP server.} - function Logout: Boolean; - - {:Modify content of LDAP attribute on this object.} - function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; - - {:Add list of attributes to specified object.} - function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; - - {:Delete this LDAP object from server.} - function Delete(obj: AnsiString): Boolean; - - {:Modify object name of this LDAP object.} - function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean; - - {:Try to compare Attribute value with this LDAP object.} - function Compare(obj, AttributeValue: AnsiString): Boolean; - - {:Search LDAP base for LDAP objects by Filter.} - function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; - const Attributes: TStrings): Boolean; - - {:Call any LDAPv3 extended command.} - function Extended(const Name, Value: AnsiString): 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: AnsiString 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: AnsiString read FFullResult; - - {: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: AnsiString read FExtName; - - {:When you call @link(Extended) operation, then here is result Value returned - by server.} - property ExtValue: AnsiString read FExtValue; - - {:TCP socket used by all LDAP operations.} - property Sock: TTCPBlockSocket read FSock; - end; - -{:Dump result of LDAP SEARCH into human readable form. Good for debugging.} -function LDAPResultDump(const Value: TLDAPResultList): AnsiString; - -implementation - -{==============================================================================} -function TLDAPAttribute.Get(Index: integer): string; -begin - Result := inherited Get(Index); - if FIsbinary then - Result := DecodeBase64(Result); -end; - -procedure TLDAPAttribute.Put(Index: integer; const Value: string); -var - s: AnsiString; -begin - s := Value; - if FIsbinary then - s := EncodeBase64(Value) - else - s :=UnquoteStr(s, '"'); - inherited Put(Index, s); -end; - -procedure TLDAPAttribute.SetAttributeName(Value: AnsiString); -begin - FAttributeName := Value; - FIsBinary := Pos(';binary', Lowercase(value)) > 0; -end; - -{==============================================================================} -constructor TLDAPAttributeList.Create; -begin - inherited Create; - FAttributeList := TList.Create; -end; - -destructor TLDAPAttributeList.Destroy; -begin - Clear; - FAttributeList.Free; - inherited Destroy; -end; - -procedure TLDAPAttributeList.Clear; -var - n: integer; - x: TLDAPAttribute; -begin - for n := Count - 1 downto 0 do - begin - x := GetAttribute(n); - if Assigned(x) then - x.Free; - end; - FAttributeList.Clear; -end; - -function TLDAPAttributeList.Count: integer; -begin - Result := FAttributeList.Count; -end; - -function TLDAPAttributeList.Get(AttributeName: AnsiString): string; -var - x: TLDAPAttribute; -begin - Result := ''; - x := self.Find(AttributeName); - if x <> nil then - if x.Count > 0 then - Result := x[0]; -end; - -function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute; -begin - Result := nil; - if Index < Count then - Result := TLDAPAttribute(FAttributeList[Index]); -end; - -function TLDAPAttributeList.Add: TLDAPAttribute; -begin - Result := TLDAPAttribute.Create; - FAttributeList.Add(Result); -end; - -procedure TLDAPAttributeList.Del(Index: integer); -var - x: TLDAPAttribute; -begin - x := GetAttribute(Index); - if Assigned(x) then - x.free; - FAttributeList.Delete(Index); -end; - -function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute; -var - n: integer; - x: TLDAPAttribute; -begin - Result := nil; - AttributeName := lowercase(AttributeName); - for n := 0 to Count - 1 do - begin - x := GetAttribute(n); - if Assigned(x) then - if lowercase(x.AttributeName) = Attributename then - begin - result := x; - break; - end; - end; -end; - -{==============================================================================} -constructor TLDAPResult.Create; -begin - inherited Create; - FAttributes := TLDAPAttributeList.Create; -end; - -destructor TLDAPResult.Destroy; -begin - FAttributes.Free; - inherited Destroy; -end; - -{==============================================================================} -constructor TLDAPResultList.Create; -begin - inherited Create; - FResultList := TList.Create; -end; - -destructor TLDAPResultList.Destroy; -begin - Clear; - FResultList.Free; - inherited Destroy; -end; - -procedure TLDAPResultList.Clear; -var - n: integer; - x: TLDAPResult; -begin - for n := Count - 1 downto 0 do - begin - x := GetResult(n); - if Assigned(x) then - x.Free; - end; - FResultList.Clear; -end; - -function TLDAPResultList.Count: integer; -begin - Result := FResultList.Count; -end; - -function TLDAPResultList.GetResult(Index: integer): TLDAPResult; -begin - Result := nil; - if Index < Count then - Result := TLDAPResult(FResultList[Index]); -end; - -function TLDAPResultList.Add: TLDAPResult; -begin - Result := TLDAPResult.Create; - FResultList.Add(Result); -end; - -{==============================================================================} -constructor TLDAPSend.Create; -begin - inherited Create; - FReferals := TStringList.Create; - FFullResult := ''; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 60000; - FTargetPort := cLDAPProtocol; - FAutoTLS := False; - FFullSSL := False; - FSeq := 0; - FVersion := 3; - FSearchScope := SS_WholeSubtree; - FSearchAliases := SA_Always; - FSearchSizeLimit := 0; - FSearchTimeLimit := 0; - FSearchResult := TLDAPResultList.Create; -end; - -destructor TLDAPSend.Destroy; -begin - FSock.Free; - FSearchResult.Free; - FReferals.Free; - inherited Destroy; -end; - -function TLDAPSend.GetErrorString(Value: integer): AnsiString; -begin - case Value of - 0: - Result := 'Success'; - 1: - Result := 'Operations error'; - 2: - Result := 'Protocol error'; - 3: - Result := 'Time limit Exceeded'; - 4: - Result := 'Size limit Exceeded'; - 5: - Result := 'Compare FALSE'; - 6: - Result := 'Compare TRUE'; - 7: - Result := 'Auth method not supported'; - 8: - Result := 'Strong auth required'; - 9: - Result := '-- reserved --'; - 10: - Result := 'Referal'; - 11: - Result := 'Admin limit exceeded'; - 12: - Result := 'Unavailable critical extension'; - 13: - Result := 'Confidentality required'; - 14: - Result := 'Sasl bind in progress'; - 16: - Result := 'No such attribute'; - 17: - Result := 'Undefined attribute type'; - 18: - Result := 'Inappropriate matching'; - 19: - Result := 'Constraint violation'; - 20: - Result := 'Attribute or value exists'; - 21: - Result := 'Invalid attribute syntax'; - 32: - Result := 'No such object'; - 33: - Result := 'Alias problem'; - 34: - Result := 'Invalid DN syntax'; - 36: - Result := 'Alias dereferencing problem'; - 48: - Result := 'Inappropriate authentication'; - 49: - Result := 'Invalid credentials'; - 50: - Result := 'Insufficient access rights'; - 51: - Result := 'Busy'; - 52: - Result := 'Unavailable'; - 53: - Result := 'Unwilling to perform'; - 54: - Result := 'Loop detect'; - 64: - Result := 'Naming violation'; - 65: - Result := 'Object class violation'; - 66: - Result := 'Not allowed on non leaf'; - 67: - Result := 'Not allowed on RDN'; - 68: - Result := 'Entry already exists'; - 69: - Result := 'Object class mods prohibited'; - 71: - Result := 'Affects multiple DSAs'; - 80: - Result := 'Other'; - else - Result := '--unknown--'; - end; -end; - -function TLDAPSend.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSeq := 0; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString; -begin - Inc(FSeq); - Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value, ASN1_SEQ); -end; - -function TLDAPSend.ReceiveResponse: AnsiString; -var - x: Byte; - i,j: integer; -begin - Result := ''; - FFullResult := ''; - x := FSock.RecvByte(FTimeout); - if x <> ASN1_SEQ then - Exit; - Result := AnsiChar(x); - x := FSock.RecvByte(FTimeout); - Result := Result + AnsiChar(x); - if x < $80 then - i := 0 - else - i := x and $7F; - if i > 0 then - Result := Result + FSock.RecvBufferStr(i, Ftimeout); - if FSock.LastError <> 0 then - begin - Result := ''; - Exit; - end; - //get length of LDAP packet - j := 2; - i := ASNDecLen(j, Result); - //retreive rest of LDAP packet - if i > 0 then - Result := Result + FSock.RecvBufferStr(i, Ftimeout); - if FSock.LastError <> 0 then - begin - Result := ''; - Exit; - end; - FFullResult := Result; -end; - -function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString; -var - i, x: integer; - Svt: Integer; - s, t: AnsiString; -begin - Result := ''; - FResultCode := -1; - FResultstring := ''; - FResponseCode := -1; - FResponseDN := ''; - FReferals.Clear; - i := 1; - ASNItem(i, Value, Svt); - x := StrToIntDef(ASNItem(i, Value, Svt), 0); - if (svt <> ASN1_INT) or (x <> FSeq) then - Exit; - s := ASNItem(i, Value, Svt); - FResponseCode := svt; - if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE, - LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE, - LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE, - LDAP_ASN1_EXT_RESPONSE] then - begin - FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1); - FResponseDN := ASNItem(i, Value, Svt); - FResultString := ASNItem(i, Value, Svt); - if FResultString = '' then - FResultString := GetErrorString(FResultCode); - if FResultCode = 10 then - begin - s := ASNItem(i, Value, Svt); - if svt = $A3 then - begin - x := 1; - while x < Length(s) do - begin - t := ASNItem(x, s, Svt); - FReferals.Add(t); - end; - end; - end; - end; - Result := Copy(Value, i, Length(Value) - i + 1); -end; - -function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString; -var - nonce, cnonce, nc, realm, qop, uri, response: AnsiString; - s: AnsiString; - a1, a2: AnsiString; - l: TStringList; - n: integer; -begin - l := TStringList.Create; - try - nonce := ''; - realm := ''; - l.CommaText := Value; - n := IndexByBegin('nonce=', l); - if n >= 0 then - nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"'); - n := IndexByBegin('realm=', l); - if n >= 0 then - realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"'); - cnonce := IntToHex(GetTick, 8); - nc := '00000001'; - qop := 'auth'; - uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP); - a1 := md5(FUsername + ':' + realm + ':' + FPassword) - + ':' + nonce + ':' + cnonce; - a2 := 'AUTHENTICATE:' + uri; - s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':' - + qop +':'+strtohex(md5(a2)); - response := strtohex(md5(s)); - - Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="'; - Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop='; - Result := Result + qop + ',digest-uri="' + uri + '",response=' + response; - finally - l.Free; - end; -end; - -function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString; -var - x: integer; - s, t, l: AnsiString; - r: string; - c: Ansichar; - attr, rule: AnsiString; - dn: Boolean; -begin - Result := ''; - if Value = '' then - Exit; - s := Value; - if Value[1] = '(' then - begin - x := RPos(')', Value); - s := Copy(Value, 2, x - 2); - end; - if s = '' then - Exit; - case s[1] of - '!': - // NOT rule (recursive call) - begin - Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2); - end; - '&': - // AND rule (recursive call) - begin - repeat - t := GetBetween('(', ')', s); - s := Trim(SeparateRight(s, t)); - if s <> '' then - if s[1] = ')' then - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); - Result := Result + TranslateFilter(t); - until s = ''; - Result := ASNOBject(Result, $A0); - end; - '|': - // OR rule (recursive call) - begin - repeat - t := GetBetween('(', ')', s); - s := Trim(SeparateRight(s, t)); - if s <> '' then - if s[1] = ')' then - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1); - Result := Result + TranslateFilter(t); - until s = ''; - Result := ASNOBject(Result, $A1); - end; - else - begin - l := Trim(SeparateLeft(s, '=')); - r := Trim(SeparateRight(s, '=')); - if l <> '' then - begin - c := l[Length(l)]; - case c of - ':': - // Extensible match - begin - {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1); - dn := False; - attr := ''; - rule := ''; - if Pos(':dn', l) > 0 then - begin - dn := True; - l := ReplaceString(l, ':dn', ''); - end; - attr := Trim(SeparateLeft(l, ':')); - rule := Trim(SeparateRight(l, ':')); - if rule = l then - rule := ''; - if rule <> '' then - Result := ASNObject(rule, $81); - if attr <> '' then - Result := Result + ASNObject(attr, $82); - Result := Result + ASNObject(DecodeTriplet(r, '\'), $83); - if dn then - Result := Result + ASNObject(AsnEncInt($ff), $84) - else - Result := Result + ASNObject(AsnEncInt(0), $84); - Result := ASNOBject(Result, $a9); - end; - '~': - // Approx match - begin - {$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); - end; - '>': - // Greater or equal match - begin - {$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); - end; - '<': - // Less or equal match - begin - {$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); - end; - else - // present - if r = '*' then - Result := ASNOBject(l, $87) - else - if Pos('*', r) > 0 then - // substrings - begin - s := Fetch(r, '*'); - if s <> '' then - Result := ASNOBject(DecodeTriplet(s, '\'), $80); - while r <> '' do - begin - if Pos('*', r) <= 0 then - break; - s := Fetch(r, '*'); - Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81); - end; - if r <> '' then - Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82); - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(Result, ASN1_SEQ); - Result := ASNOBject(Result, $a4); - end - else - begin - // Equality match - Result := ASNOBject(l, ASN1_OCTSTR) - + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR); - Result := ASNOBject(Result, $a3); - end; - end; - end; - end; - end; -end; - -function TLDAPSend.Login: Boolean; -begin - Result := False; - if not Connect then - Exit; - Result := True; - if FAutoTLS then - Result := StartTLS; -end; - -function TLDAPSend.Bind: Boolean; -var - s: AnsiString; -begin - s := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject(FUsername, ASN1_OCTSTR) - + ASNObject(FPassword, $80); - s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.BindSasl: Boolean; -var - s, t: AnsiString; - x, xt: integer; - digreq: AnsiString; -begin - Result := False; - if FPassword = '' then - Result := Bind - else - begin - digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject('', ASN1_OCTSTR) - + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3); - digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(digreq)); - s := ReceiveResponse; - t := DecodeResponse(s); - if FResultCode = 14 then - begin - s := t; - x := 1; - t := ASNItem(x, s, xt); - s := ASNObject(ASNEncInt(FVersion), ASN1_INT) - + ASNObject('', ASN1_OCTSTR) - + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR) - + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3); - s := ASNObject(s, LDAP_ASN1_BIND_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - if FResultCode = 14 then - begin - Fsock.SendString(BuildPacket(digreq)); - s := ReceiveResponse; - DecodeResponse(s); - end; - Result := FResultCode = 0; - end; - end; -end; - -function TLDAPSend.Logout: Boolean; -begin - Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST))); - FSock.CloseSocket; - Result := True; -end; - -function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean; -var - s: AnsiString; - n: integer; -begin - s := ''; - for n := 0 to Value.Count -1 do - s := s + ASNObject(Value[n], ASN1_OCTSTR); - s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF); - s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, ASN1_SEQ); - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean; -var - s, t: AnsiString; - n, m: integer; -begin - s := ''; - for n := 0 to Value.Count - 1 do - begin - t := ''; - for m := 0 to Value[n].Count - 1 do - t := t + ASNObject(Value[n][m], ASN1_OCTSTR); - t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR) - + ASNObject(t, ASN1_SETOF); - s := s + ASNObject(t, ASN1_SEQ); - end; - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_ADD_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Delete(obj: AnsiString): Boolean; -var - s: AnsiString; -begin - s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean; -var - s: AnsiString; -begin - s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR); - if DeleteOldRDN then - s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) - else - s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); - if newSuperior <> '' then - s := s + ASNObject(newSuperior, $80); - s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean; -var - s: AnsiString; -begin - 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)); - s := ReceiveResponse; - DecodeResponse(s); - Result := FResultCode = 0; -end; - -function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString; - const Attributes: TStrings): Boolean; -var - s, t, u: AnsiString; - n, i, x: integer; - r: TLDAPResult; - a: TLDAPAttribute; -begin - FSearchResult.Clear; - FReferals.Clear; - s := ASNObject(obj, ASN1_OCTSTR); - s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM); - s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM); - s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT); - s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT); - if TypesOnly then - s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL) - else - s := s + ASNObject(ASNEncInt(0), ASN1_BOOL); - if Filter = '' then - Filter := '(objectclass=*)'; - t := TranslateFilter(Filter); - if t = '' then - s := s + ASNObject('', ASN1_NULL) - else - s := s + t; - t := ''; - for n := 0 to Attributes.Count - 1 do - t := t + ASNObject(Attributes[n], ASN1_OCTSTR); - s := s + ASNObject(t, ASN1_SEQ); - s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST); - Fsock.SendString(BuildPacket(s)); - repeat - s := ReceiveResponse; - t := DecodeResponse(s); - if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then - begin - //dekoduj zaznam - r := FSearchResult.Add; - n := 1; - r.ObjectName := ASNItem(n, t, x); - ASNItem(n, t, x); - if x = ASN1_SEQ then - begin - while n < Length(t) do - begin - s := ASNItem(n, t, x); - if x = ASN1_SEQ then - begin - i := n + Length(s); - a := r.Attributes.Add; - u := ASNItem(n, t, x); - a.AttributeName := u; - ASNItem(n, t, x); - if x = ASN1_SETOF then - while n < i do - begin - u := ASNItem(n, t, x); - a.Add(u); - end; - end; - end; - end; - end; - if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then - begin - n := 1; - while n < Length(t) do - FReferals.Add(ASNItem(n, t, x)); - end; - until FResponseCode = LDAP_ASN1_SEARCH_DONE; - Result := FResultCode = 0; -end; - -function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean; -var - s, t: AnsiString; - x, xt: integer; -begin - s := ASNObject(Name, $80); - if Value <> '' then - s := s + ASNObject(Value, $81); - s := ASNObject(s, LDAP_ASN1_EXT_REQUEST); - Fsock.SendString(BuildPacket(s)); - s := ReceiveResponse; - t := DecodeResponse(s); - Result := FResultCode = 0; - if Result then - begin - x := 1; - FExtName := ASNItem(x, t, xt); - FExtValue := ASNItem(x, t, xt); - end; -end; - - -function TLDAPSend.StartTLS: Boolean; -begin - Result := Extended('1.3.6.1.4.1.1466.20037', ''); - if Result then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -{==============================================================================} -function LDAPResultDump(const Value: TLDAPResultList): AnsiString; -var - n, m, o: integer; - r: TLDAPResult; - a: TLDAPAttribute; -begin - Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF; - for n := 0 to Value.Count - 1 do - begin - Result := Result + 'Result: ' + IntToStr(n) + CRLF; - r := Value[n]; - Result := Result + ' Object: ' + r.ObjectName + CRLF; - for m := 0 to r.Attributes.Count - 1 do - begin - a := r.Attributes[m]; - Result := Result + ' Attribute: ' + a.AttributeName + CRLF; - for o := 0 to a.Count - 1 do - Result := Result + ' ' + a[o] + CRLF; - end; - end; -end; - -end. diff --git a/synapse/licence.txt b/synapse/licence.txt deleted file mode 100644 index f1f9255..0000000 --- a/synapse/licence.txt +++ /dev/null @@ -1,28 +0,0 @@ -Copyright (c)1999-2002, 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. diff --git a/synapse/mimeinln.pas b/synapse/mimeinln.pas deleted file mode 100644 index 924dd5f..0000000 --- a/synapse/mimeinln.pas +++ /dev/null @@ -1,263 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.011 | -|==============================================================================| -| Content: Inline MIME support procedures and functions | -|==============================================================================| -| Copyright (c)1999-2006, 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)2000-2006. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Utilities for inline MIME) -Support for Inline MIME encoding and decoding. - -Used RFC: RFC-2047, RFC-2231 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit mimeinln; - -interface - -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; - -{: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 - -{==============================================================================} - -function InlineDecode(const Value: string; CP: TMimeChar): string; -var - s, su, v: string; - x, y, z, n: Integer; - ichar: TMimeChar; - c: Char; - - function SearchEndInline(const Value: string; be: Integer): Integer; - var - n, q: Integer; - begin - q := 0; - Result := 0; - for n := be + 2 to Length(Value) - 1 do - if Value[n] = '?' then - begin - Inc(q); - if (q > 2) and (Value[n + 1] = '=') then - begin - Result := n; - Break; - end; - end; - end; - -begin - Result := ''; - v := Value; - x := Pos('=?', v); - y := SearchEndInline(v, x); - //fix for broken coding with begin, but not with end. - if (x > 0) and (y <= 0) then - y := Length(Result); - while (y > x) and (x > 0) do - begin - s := Copy(v, 1, x - 1); - if Trim(s) <> '' then - Result := Result + s; - s := Copy(v, x, y - x + 2); - Delete(v, 1, y + 1); - su := Copy(s, 3, Length(s) - 4); - 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 - begin - s := DecodeBase64(su); - s := CharsetConversion(s, ichar, CP); - end; - if c = 'Q' then - begin - s := ''; - for n := 1 to Length(su) do - if su[n] = '_' then - s := s + ' ' - else - s := s + su[n]; - s := DecodeQuotedPrintable(s); - s := CharsetConversion(s, ichar, CP); - end; - end; - Result := Result + s; - x := Pos('=?', v); - y := SearchEndInline(v, x); - end; - Result := Result + v; -end; - -{==============================================================================} - -function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; -var - s, s1, e: string; - n: Integer; -begin - s := CharsetConversion(Value, CP, MimeP); - s := EncodeSafeQuotedPrintable(s); - e := GetIdFromCP(MimeP); - s1 := ''; - Result := ''; - for n := 1 to Length(s) do - if s[n] = ' ' then - 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]; - if s1 <> '' then - begin - if Result <> '' then - Result := Result + ' '; - Result := Result + '=?' + e + '?Q?' + s1 + '?='; - end; -end; - -{==============================================================================} - -function NeedInline(const Value: AnsiString): boolean; -var - n: Integer; -begin - Result := False; - for n := 1 to Length(Value) do - if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} - -function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; -var - c: TMimeChar; -begin - if NeedInline(Value) then - begin - c := IdealCharsetCoding(Value, FromCP, IdealCharsets); - Result := InlineEncode(Value, FromCP, c); - end - else - Result := Value; -end; - -{==============================================================================} - -function InlineCode(const Value: string): string; -begin - Result := InlineCodeEx(Value, GetCurCP); -end; - -{==============================================================================} - -function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; -var - sd, se: string; -begin - sd := GetEmailDesc(Value); - se := GetEmailAddr(Value); - if sd = '' then - Result := se - else - Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; -end; - -{==============================================================================} - -function InlineEmail(const Value: string): string; -begin - Result := InlineEmailEx(Value, GetCurCP); -end; - -end. diff --git a/synapse/mimemess.pas b/synapse/mimemess.pas deleted file mode 100644 index 0ad814d..0000000 --- a/synapse/mimemess.pas +++ /dev/null @@ -1,851 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.006.000 | -|==============================================================================| -| Content: MIME message object | -|==============================================================================| -| Copyright (c)1999-2012, 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)2000-2012. | -| Portions created by Petr Fejfar are Copyright (c)2011-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM From distribution package | -| (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} -{$H+} -{$M+} - -unit mimemess; - -interface - -uses - Classes, SysUtils, - 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; - FToList: TStringList; - FCCList: TStringList; - FSubject: string; - FOrganization: string; - FCustomHeaders: TStringList; - 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; virtual; - destructor Destroy; override; - - {:Clears all data fields.} - procedure Clear; virtual; - - {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; - FLines: TStringList; - 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; virtual; - - {: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 and set all necessary - properties. Content of part is readed from value stringlist. You can select - your charset and your encoding type. If Raw is @true, then it not doing - charset conversion!} - function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; - PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): 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; - - {pf} - {: HTTP message is received by @link(THTTPSend) component in two parts: - headers are stored in @link(THTTPSend.Headers) and a body in memory stream - @link(THTTPSend.Document). - - On the top of it, HTTP connections are always 8-bit, hence data are - transferred in native format i.e. no transfer encoding is applied. - - This method operates the similiar way and produces the same - result as @link(DecodeMessage). - } - procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); - {/pf} - 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; - -implementation - -{==============================================================================} - -constructor TMessHeader.Create; -begin - inherited Create; - FToList := TStringList.Create; - FCCList := TStringList.Create; - FCustomHeaders := TStringList.Create; - FCharsetCode := GetCurCP; -end; - -destructor TMessHeader.Destroy; -begin - FCustomHeaders.Free; - FCCList.Free; - FToList.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMessHeader.Clear; -begin - FFrom := ''; - FToList.Clear; - FCCList.Clear; - FSubject := ''; - FOrganization := ''; - FCustomHeaders.Clear; - FDate := 0; - FXMailer := ''; - FReplyTo := ''; - FMessageID := ''; - FPriority := MP_unknown; -end; - -procedure TMessHeader.EncodeHeaders(const Value: TStrings); -var - n: Integer; - s: string; -begin - if FDate = 0 then - FDate := Now; - 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 - Pascal TCP/IP library by Lukas Gebauer') - else - Value.Insert(0, 'X-mailer: ' + FXMailer); - Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)'); - if FOrganization <> '' then - Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode)); - s := ''; - for n := 0 to FCCList.Count - 1 do - if s = '' then - s := InlineEmailEx(FCCList[n], FCharsetCode) - else - s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode); - if s <> '' then - Value.Insert(0, 'CC: ' + s); - Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate)); - if FSubject <> '' then - Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode)); - s := ''; - for n := 0 to FToList.Count - 1 do - if s = '' then - s := InlineEmailEx(FToList[n], FCharsetCode) - else - s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode); - if s <> '' then - Value.Insert(0, 'To: ' + s); - Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode)); -end; - -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; - 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 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; -var - n: integer; -begin - Result := ''; - for n := 0 to FCustomHeaders.Count - 1 do - if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then - begin - Result := Trim(SeparateRight(FCustomHeaders[n], ':')); - break; - end; -end; - -procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings); -var - n: integer; -begin - HeaderList.Clear; - for n := 0 to FCustomHeaders.Count - 1 do - if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then - begin - 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 := HeadClass.Create; -end; - -destructor TMimeMess.Destroy; -begin - FMessagePart.Free; - FHeader.Free; - FLines.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMimeMess.Clear; -begin - FMessagePart.Clear; - FLines.Clear; - FHeader.Clear; -end; - -{==============================================================================} - -function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart; -begin - if PartParent = nil then - Result := FMessagePart - else - Result := PartParent.AddSubPart; - Result.Clear; -end; - -{==============================================================================} - -function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart; -begin - Result := AddPart(PartParent); - with Result do - begin - Primary := 'Multipart'; - Secondary := MultipartType; - Description := 'Multipart message'; - Boundary := GenerateBoundary; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'plain'; - Description := 'Message text'; - Disposition := 'inline'; - CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets); - EncodingCode := ME_QUOTED_PRINTABLE; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart; - PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'plain'; - Description := 'Message text'; - Disposition := 'inline'; - CharsetCode := PartCharset; - EncodingCode := PartEncoding; - ConvertCharset := not Raw; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - with Result do - begin - Value.SaveToStream(DecodedLines); - Primary := 'text'; - Secondary := 'html'; - Description := 'HTML text'; - Disposition := 'inline'; - CharsetCode := UTF_8; - EncodingCode := ME_QUOTED_PRINTABLE; - EncodePart; - EncodePartHeader; - end; -end; - -function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; -var - tmp: TStrings; -begin - tmp := TStringList.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartText(tmp, PartParent); - Finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart; -var - tmp: TStrings; -begin - tmp := TStringList.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartHTML(tmp, PartParent); - Finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - Result.DecodedLines.LoadFromStream(Stream); - Result.MimeTypeFromExt(FileName); - Result.Description := 'Attached file: ' + FileName; - Result.Disposition := 'attachment'; - Result.FileName := FileName; - Result.EncodingCode := ME_BASE64; - Result.EncodePart; - Result.EncodePartHeader; -end; - -function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart; -var - tmp: TMemoryStream; -begin - tmp := TMemoryStream.Create; - try - tmp.LoadFromFile(FileName); - Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent); - finally - tmp.Free; - end; -end; - -function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart; -begin - Result := AddPart(PartParent); - Result.DecodedLines.LoadFromStream(Stream); - Result.MimeTypeFromExt(FileName); - Result.Description := 'Included file: ' + FileName; - Result.Disposition := 'inline'; - Result.ContentID := Cid; - Result.FileName := FileName; - Result.EncodingCode := ME_BASE64; - Result.EncodePart; - Result.EncodePartHeader; -end; - -function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart; -var - tmp: TMemoryStream; -begin - tmp := TMemoryStream.Create; - try - tmp.LoadFromFile(FileName); - Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent); - finally - tmp.Free; - 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; -var - l: TStringList; - x: integer; -begin - //merge headers from THeaders and header field from MessagePart - l := TStringList.Create; - try - FHeader.EncodeHeaders(l); - x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-ID', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers); - if x >= 0 then - l.add(FMessagePart.Headers[x]); - FMessagePart.Headers.Assign(l); - finally - l.Free; - end; - FMessagePart.ComposeParts; - FLines.Assign(FMessagePart.Lines); -end; - -{==============================================================================} - -procedure TMimeMess.DecodeMessage; -begin - FHeader.Clear; - FHeader.DecodeHeaders(FLines); - FMessagePart.Lines.Assign(FLines); - FMessagePart.DecomposeParts; -end; - -{pf} -procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream); -begin - FHeader.Clear; - FLines.Clear; - FLines.Assign(AHeader); - FHeader.DecodeHeaders(FLines); - FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size); -end; -{/pf} - -end. diff --git a/synapse/mimepart.pas b/synapse/mimepart.pas deleted file mode 100644 index a637e67..0000000 --- a/synapse/mimepart.pas +++ /dev/null @@ -1,1227 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.009.000 | -|==============================================================================| -| Content: MIME support procedures and functions | -|==============================================================================| -| Copyright (c)1999-200812 | -| | -| 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)2000-2012. | -| Portions created by Petr Fejfar are Copyright (c)2011-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (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-} -{$M+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit mimepart; - -interface - -uses - SysUtils, Classes, - synafpc, - synachar, synacode, synautil, mimeinln; - -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; - - {: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; - FPrimaryCode: TMimePrimary; - FSecondary: string; - FEncoding: string; - FEncodingCode: TMimeEncoding; - FDefaultCharset: string; - FCharset: string; - FCharsetCode: TMimeChar; - FTargetCharset: TMimeChar; - FDescription: string; - FDisposition: string; - FContentID: string; - FBoundary: string; - FFileName: string; - FLines: TStringList; - FPartBody: TStringList; - FHeaders: TStringList; - FPrePart: TStringList; - FPostPart: TStringList; - FDecodedLines: TMemoryStream; - FSubParts: TList; - FOnWalkPart: THookWalkPart; - FMaxLineLength: integer; - FSubLevel: integer; - FMaxSubLevel: integer; - FAttachInside: boolean; - FConvertCharset: Boolean; - FForcedHTMLConvert: Boolean; - FBinaryDecomposer: boolean; - procedure SetPrimary(Value: string); - procedure SetEncoding(Value: string); - procedure SetCharset(Value: string); - function IsUUcode(Value: string): boolean; - 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; - - {pf} - {: HTTP message is received by @link(THTTPSend) component in two parts: - headers are stored in @link(THTTPSend.Headers) and a body in memory stream - @link(THTTPSend.Document). - - On the top of it, HTTP connections are always 8-bit, hence data are - transferred in native format i.e. no transfer encoding is applied. - - This method operates the similiar way and produces the same - result as @link(DecomposeParts). - } - procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); - {/pf} - - {: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; - - {:If @true, then do internal charset translation of part content between @link(CharsetCode) - and @link(TargetCharset)} - property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset; - - {:If @true, then allways do internal charset translation of HTML parts - by MIME even it have their own charset in META tag. Default is @false.} - property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert; - - {: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; - -const - MaxMimeType = 25; - MimeType: array[0..MaxMimeType, 0..2] of string = - ( - ('AU', 'audio', 'basic'), - ('AVI', 'video', 'x-msvideo'), - ('BMP', 'image', 'BMP'), - ('DOC', 'application', 'MSWord'), - ('EPS', 'application', 'Postscript'), - ('GIF', 'image', 'GIF'), - ('JPEG', 'image', 'JPEG'), - ('JPG', 'image', 'JPEG'), - ('MID', 'audio', 'midi'), - ('MOV', 'video', 'quicktime'), - ('MPEG', 'video', 'MPEG'), - ('MPG', 'video', 'MPEG'), - ('MP2', 'audio', 'mpeg'), - ('MP3', 'audio', 'mpeg'), - ('PDF', 'application', 'PDF'), - ('PNG', 'image', 'PNG'), - ('PS', 'application', 'Postscript'), - ('QT', 'video', 'quicktime'), - ('RA', 'audio', 'x-realaudio'), - ('RTF', 'application', 'RTF'), - ('SND', 'audio', 'basic'), - ('TIF', 'image', 'TIFF'), - ('TIFF', 'image', 'TIFF'), - ('WAV', 'audio', 'x-wav'), - ('WPD', 'application', 'Wordperfect5.1'), - ('ZIP', 'application', 'ZIP') - ); - -{:Generates a unique boundary string.} -function GenerateBoundary: string; - -implementation - -{==============================================================================} - -constructor TMIMEPart.Create; -begin - inherited Create; - FOnWalkPart := nil; - FLines := TStringList.Create; - FPartBody := TStringList.Create; - FHeaders := TStringList.Create; - FPrePart := TStringList.Create; - FPostPart := TStringList.Create; - FDecodedLines := TMemoryStream.Create; - FSubParts := TList.Create; - FTargetCharset := GetCurCP; - //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default - //system charset instead. - FDefaultCharset := GetIDFromCP(GetCurCP); - FMaxLineLength := 78; - FSubLevel := 0; - FMaxSubLevel := -1; - FAttachInside := false; - FConvertCharset := true; - FForcedHTMLConvert := false; -end; - -destructor TMIMEPart.Destroy; -begin - ClearSubParts; - FSubParts.Free; - FDecodedLines.Free; - FPartBody.Free; - FLines.Free; - FHeaders.Free; - FPrePart.Free; - FPostPart.Free; - inherited Destroy; -end; - -{==============================================================================} - -procedure TMIMEPart.Clear; -begin - FPrimary := ''; - FEncoding := ''; - FCharset := ''; - FPrimaryCode := MP_TEXT; - FEncodingCode := ME_7BIT; - FCharsetCode := ISO_8859_1; - FTargetCharset := GetCurCP; - FSecondary := ''; - FDisposition := ''; - FContentID := ''; - FDescription := ''; - FBoundary := ''; - FFileName := ''; - FAttachInside := False; - FPartBody.Clear; - FHeaders.Clear; - FPrePart.Clear; - FPostPart.Clear; - FDecodedLines.Clear; - FConvertCharset := true; - FForcedHTMLConvert := false; - ClearSubParts; -end; - -{==============================================================================} - -procedure TMIMEPart.Assign(Value: TMimePart); -begin - Primary := Value.Primary; - Encoding := Value.Encoding; - Charset := Value.Charset; - DefaultCharset := Value.DefaultCharset; - PrimaryCode := Value.PrimaryCode; - EncodingCode := Value.EncodingCode; - CharsetCode := Value.CharsetCode; - TargetCharset := Value.TargetCharset; - Secondary := Value.Secondary; - Description := Value.Description; - Disposition := Value.Disposition; - ContentID := Value.ContentID; - Boundary := Value.Boundary; - FileName := Value.FileName; - Lines.Assign(Value.Lines); - PartBody.Assign(Value.PartBody); - Headers.Assign(Value.Headers); - PrePart.Assign(Value.PrePart); - PostPart.Assign(Value.PostPart); - MaxLineLength := Value.MaxLineLength; - FAttachInside := Value.AttachInside; - FConvertCharset := Value.ConvertCharset; -end; - -{==============================================================================} - -procedure TMIMEPart.AssignSubParts(Value: TMimePart); -var - n: integer; - p: TMimePart; -begin - Assign(Value); - for n := 0 to Value.GetSubPartCount - 1 do - begin - p := AddSubPart; - p.AssignSubParts(Value.GetSubPart(n)); - end; -end; - -{==============================================================================} - -function TMIMEPart.GetSubPartCount: integer; -begin - Result := FSubParts.Count; -end; - -{==============================================================================} - -function TMIMEPart.GetSubPart(index: integer): TMimePart; -begin - Result := nil; - if Index < GetSubPartCount then - Result := TMimePart(FSubParts[Index]); -end; - -{==============================================================================} - -procedure TMIMEPart.DeleteSubPart(index: integer); -begin - if Index < GetSubPartCount then - begin - GetSubPart(Index).Free; - FSubParts.Delete(Index); - end; -end; - -{==============================================================================} - -procedure TMIMEPart.ClearSubParts; -var - n: integer; -begin - for n := 0 to GetSubPartCount - 1 do - TMimePart(FSubParts[n]).Free; - FSubParts.Clear; -end; - -{==============================================================================} - -function TMIMEPart.AddSubPart: TMimePart; -begin - Result := TMimePart.Create; - Result.DefaultCharset := FDefaultCharset; - FSubParts.Add(Result); - Result.SubLevel := FSubLevel + 1; - Result.MaxSubLevel := FMaxSubLevel; -end; - -{==============================================================================} - -procedure TMIMEPart.DecomposeParts; -var - x: integer; - s: string; - Mime: TMimePart; - - procedure SkipEmpty; - begin - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - if s <> '' then - Break; - Inc(x); - end; - end; - -begin - FBinaryDecomposer := false; - x := 0; - Clear; - //extract headers - while FLines.Count > x do - begin - s := NormalizeHeader(FLines, x); - if s = '' then - Break; - FHeaders.Add(s); - end; - DecodePartHeader; - //extract prepart - if FPrimaryCode = MP_MULTIPART then - begin - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - if TrimRight(s) = '--' + FBoundary then - Break; - FPrePart.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; - //extract body part - if FPrimaryCode = MP_MULTIPART then - begin - repeat - if CanSubPart then - begin - Mime := AddSubPart; - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - if Pos('--' + FBoundary, s) = 1 then - Break; - Mime.Lines.Add(s); - end; - Mime.DecomposeParts; - end - else - begin - s := FLines[x]; - Inc(x); - FPartBody.Add(s); - end; - if x >= FLines.Count then - break; - until s = '--' + FBoundary + '--'; - end; - if (FPrimaryCode = MP_MESSAGE) and CanSubPart then - begin - Mime := AddSubPart; - SkipEmpty; - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - Inc(x); - Mime.Lines.Add(s); - end; - Mime.DecomposeParts; - end - else - begin - while FLines.Count > x do - begin - s := FLines[x]; - Inc(x); - FPartBody.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; - //extract postpart - if FPrimaryCode = MP_MULTIPART then - begin - while FLines.Count > x do - begin - s := TrimRight(FLines[x]); - Inc(x); - FPostPart.Add(s); - if not FAttachInside then - FAttachInside := IsUUcode(s); - end; - end; -end; - -procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PANSIChar); -var - x: integer; - s: ANSIString; - Mime: TMimePart; - BOP: PANSIChar; // Beginning of Part - EOP: PANSIChar; // End of Part - - function ___HasUUCode(ALines:TStrings): boolean; - var - x: integer; - begin - Result := FALSE; - for x:=0 to ALines.Count-1 do - if IsUUcode(ALInes[x]) then - begin - Result := TRUE; - exit; - end; - end; - -begin - FBinaryDecomposer := true; - Clear; - // Parse passed headers (THTTPSend returns HTTP headers and body separately) - x := 0; - while x 0 then - x := d1 - else - if d3 > 0 then - x := d3 - else - x := d2 - 1; - t := Copy(s, 1, x); - Delete(s, 1, x); - end; - Flines.Add(t); - until s = ''; - end; - - Flines.Add(''); - //add body - //if multipart - if FPrimaryCode = MP_MULTIPART then - begin - Flines.AddStrings(FPrePart); - for n := 0 to GetSubPartCount - 1 do - begin - Flines.Add('--' + FBoundary); - mime := GetSubPart(n); - mime.ComposeParts; - FLines.AddStrings(mime.Lines); - end; - Flines.Add('--' + FBoundary + '--'); - Flines.AddStrings(FPostPart); - end; - //if message - if FPrimaryCode = MP_MESSAGE then - begin - if GetSubPartCount > 0 then - begin - mime := GetSubPart(0); - mime.ComposeParts; - FLines.AddStrings(mime.Lines); - end; - end - else - //if normal part - begin - FLines.AddStrings(FPartBody); - end; -end; - -{==============================================================================} - -procedure TMIMEPart.DecodePart; -var - n: Integer; - s, t, t2: string; - b: Boolean; -begin - FDecodedLines.Clear; - {pf} - // The part decomposer passes data via TStringList which appends trailing line - // break inherently. But in a case of native 8-bit data transferred withouth - // encoding (default e.g. for HTTP protocol), the redundant line terminators - // has to be removed - if FBinaryDecomposer and (FPartBody.Count=1) then - begin - case FEncodingCode of - ME_QUOTED_PRINTABLE: - s := DecodeQuotedPrintable(FPartBody[0]); - ME_BASE64: - s := DecodeBase64(FPartBody[0]); - ME_UU, ME_XX: - begin - s := ''; - for n := 0 to FPartBody.Count - 1 do - if FEncodingCode = ME_UU then - s := s + DecodeUU(FPartBody[n]) - else - s := s + DecodeXX(FPartBody[n]); - end; - else - s := FPartBody[0]; - end; - end - else - {/pf} - case FEncodingCode of - ME_QUOTED_PRINTABLE: - s := DecodeQuotedPrintable(FPartBody.Text); - ME_BASE64: - s := DecodeBase64(FPartBody.Text); - ME_UU, ME_XX: - begin - s := ''; - for n := 0 to FPartBody.Count - 1 do - if FEncodingCode = ME_UU then - s := s + DecodeUU(FPartBody[n]) - else - s := s + DecodeXX(FPartBody[n]); - end; - else - s := FPartBody.Text; - end; - if FConvertCharset and (FPrimaryCode = MP_TEXT) then - if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then - begin - b := false; - t2 := uppercase(s); - t := SeparateLeft(t2, ''); - if length(t) <> length(s) then - begin - t := SeparateRight(t, ''); - t := ReplaceString(t, '"', ''); - t := ReplaceString(t, ' ', ''); - b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; - end; - //workaround for shitty M$ Outlook 11 which is placing this information - //outside section - if not b then - begin - t := Copy(t2, 1, 2048); - t := ReplaceString(t, '"', ''); - t := ReplaceString(t, ' ', ''); - b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; - 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; - -{==============================================================================} - -procedure TMIMEPart.DecodePartHeader; -var - n: integer; - s, su, fn: string; - st, st2: string; -begin - Primary := 'text'; - FSecondary := 'plain'; - FDescription := ''; - Charset := FDefaultCharset; - FFileName := ''; - //was 7bit before, but this is more compatible with RFC-ignorant outlook - Encoding := '8BIT'; - FDisposition := ''; - FContentID := ''; - fn := ''; - for n := 0 to FHeaders.Count - 1 do - if FHeaders[n] <> '' then - begin - s := FHeaders[n]; - su := UpperCase(s); - if Pos('CONTENT-TYPE:', su) = 1 then - begin - 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'); - end; - MP_MULTIPART: - FBoundary := GetParameter(s, 'Boundary'); - MP_MESSAGE: - begin - end; - MP_BINARY: - FFileName := GetParameter(s, 'name'); - end; - end; - if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then - Encoding := Trim(SeparateRight(su, ':')); - if Pos('CONTENT-DESCRIPTION:', su) = 1 then - FDescription := Trim(SeparateRight(s, ':')); - if Pos('CONTENT-DISPOSITION:', su) = 1 then - begin - FDisposition := SeparateRight(su, ':'); - FDisposition := Trim(SeparateLeft(FDisposition, ';')); - fn := GetParameter(s, 'FileName'); - end; - if Pos('CONTENT-ID:', su) = 1 then - FContentID := Trim(SeparateRight(s, ':')); - end; - if fn <> '' then - FFileName := fn; - FFileName := InlineDecode(FFileName, FTargetCharset); - FFileName := ExtractFileName(FFileName); -end; - -{==============================================================================} - -procedure TMIMEPart.EncodePart; -var - l: TStringList; - s, t: string; - n, x: Integer; - d1, d2: integer; -begin - if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then - Encoding := 'base64'; - l := TStringList.Create; - FPartBody.Clear; - FDecodedLines.Seek(0, soFromBeginning); - try - case FPrimaryCode of - MP_MULTIPART, MP_MESSAGE: - FPartBody.LoadFromStream(FDecodedLines); - MP_TEXT, MP_BINARY: - begin - s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size); - if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then - s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode); - if FEncodingCode = ME_BASE64 then - begin - x := 1; - while x <= length(s) do - begin - t := copy(s, x, 54); - x := x + length(t); - t := EncodeBase64(t); - FPartBody.Add(t); - end; - end - else - begin - if FPrimaryCode = MP_BINARY then - l.Add(s) - else - l.Text := s; - for n := 0 to l.Count - 1 do - begin - s := l[n]; - if FEncodingCode = ME_QUOTED_PRINTABLE then - begin - s := EncodeQuotedPrintable(s); - repeat - if Length(s) < FMaxLineLength then - begin - t := s; - s := ''; - end - else - begin - d1 := RPosEx('=', s, FMaxLineLength); - d2 := RPosEx(' ', s, FMaxLineLength); - if (d1 = 0) and (d2 = 0) then - x := FMaxLineLength - else - if d1 > d2 then - x := d1 - 1 - else - x := d2 - 1; - if x = 0 then - x := FMaxLineLength; - t := Copy(s, 1, x); - Delete(s, 1, x); - if s <> '' then - t := t + '='; - end; - FPartBody.Add(t); - until s = ''; - end - else - FPartBody.Add(s); - end; - if (FPrimaryCode = MP_BINARY) - and (FEncodingCode = ME_QUOTED_PRINTABLE) then - FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '='; - end; - end; - end; - finally - l.Free; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.EncodePartHeader; -var - s: string; -begin - FHeaders.Clear; - if FSecondary = '' then - case FPrimaryCode of - MP_TEXT: - FSecondary := 'plain'; - MP_MULTIPART: - FSecondary := 'mixed'; - MP_MESSAGE: - FSecondary := 'rfc822'; - MP_BINARY: - FSecondary := 'octet-stream'; - end; - if FDescription <> '' then - FHeaders.Insert(0, 'Content-Description: ' + FDescription); - if FDisposition <> '' then - begin - s := ''; - if FFileName <> '' then - s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); - FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s); - end; - if FContentID <> '' then - FHeaders.Insert(0, 'Content-ID: ' + FContentID); - - case FEncodingCode of - ME_7BIT: - s := '7bit'; - ME_8BIT: - s := '8bit'; - ME_QUOTED_PRINTABLE: - s := 'Quoted-printable'; - ME_BASE64: - s := 'Base64'; - end; - case FPrimaryCode of - MP_TEXT, - MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s); - end; - case FPrimaryCode of - MP_TEXT: - s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode); - MP_MULTIPART: - s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"'; - MP_MESSAGE, MP_BINARY: - s := FPrimary + '/' + FSecondary; - end; - if FFileName <> '' then - s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"'); - FHeaders.Insert(0, 'Content-type: ' + s); -end; - -{==============================================================================} - -procedure TMIMEPart.MimeTypeFromExt(Value: string); -var - s: string; - n: Integer; -begin - Primary := ''; - FSecondary := ''; - s := UpperCase(ExtractFileExt(Value)); - if s = '' then - s := UpperCase(Value); - s := SeparateRight(s, '.'); - for n := 0 to MaxMimeType do - if MimeType[n, 0] = s then - begin - Primary := MimeType[n, 1]; - FSecondary := MimeType[n, 2]; - Break; - end; - if Primary = '' then - Primary := 'application'; - if FSecondary = '' then - FSecondary := 'octet-stream'; -end; - -{==============================================================================} - -procedure TMIMEPart.WalkPart; -var - n: integer; - m: TMimepart; -begin - if assigned(OnWalkPart) then - begin - OnWalkPart(self); - for n := 0 to GetSubPartCount - 1 do - begin - m := GetSubPart(n); - m.OnWalkPart := OnWalkPart; - m.WalkPart; - end; - end; -end; - -{==============================================================================} - -procedure TMIMEPart.SetPrimary(Value: string); -var - s: string; -begin - FPrimary := Value; - s := UpperCase(Value); - FPrimaryCode := MP_BINARY; - if Pos('TEXT', s) = 1 then - FPrimaryCode := MP_TEXT; - if Pos('MULTIPART', s) = 1 then - FPrimaryCode := MP_MULTIPART; - if Pos('MESSAGE', s) = 1 then - FPrimaryCode := MP_MESSAGE; -end; - -procedure TMIMEPart.SetEncoding(Value: string); -var - s: string; -begin - FEncoding := Value; - s := UpperCase(Value); - FEncodingCode := ME_7BIT; - if Pos('8BIT', s) = 1 then - FEncodingCode := ME_8BIT; - if Pos('QUOTED-PRINTABLE', s) = 1 then - FEncodingCode := ME_QUOTED_PRINTABLE; - if Pos('BASE64', s) = 1 then - FEncodingCode := ME_BASE64; - if Pos('X-UU', s) = 1 then - FEncodingCode := ME_UU; - if Pos('X-XX', s) = 1 then - FEncodingCode := ME_XX; -end; - -procedure TMIMEPart.SetCharset(Value: string); -begin - if value <> '' then - begin - FCharset := Value; - FCharsetCode := GetCPFromID(Value); - end; -end; - -function TMIMEPart.CanSubPart: boolean; -begin - Result := True; - if FMaxSubLevel <> -1 then - Result := FMaxSubLevel > FSubLevel; -end; - -function TMIMEPart.IsUUcode(Value: string): boolean; -begin - Value := UpperCase(Value); - Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> ''); -end; - -{==============================================================================} - -function GenerateBoundary: string; -var - x, y: Integer; -begin - y := GetTick; - x := y; - while TickDelta(y, x) = 0 do - begin - Sleep(1); - x := GetTick; - end; - Randomize; - y := Random(MaxInt); - Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary'; -end; - -end. diff --git a/synapse/nntpsend.pas b/synapse/nntpsend.pas deleted file mode 100644 index ec1af16..0000000 --- a/synapse/nntpsend.pas +++ /dev/null @@ -1,483 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.005.003 | -|==============================================================================| -| Content: NNTP client | -|==============================================================================| -| Copyright (c)1999-2011, 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) 1999-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(NNTP client) -NNTP (network news transfer protocol) - -Used RFC: RFC-977, RFC-2980 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit nntpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cNNTPProtocol = '119'; - -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 - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FData: TStringList; - FDataToSend: TStringList; - FAutoTLS: Boolean; - FFullSSL: Boolean; - FNNTPcap: TStringList; - function ReadResult: Integer; - function ReadData: boolean; - function SendData: boolean; - function Connect: Boolean; - public - constructor Create; - destructor Destroy; override; - - {:Connects to NNTP server and begin session.} - function Login: Boolean; - - {: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 - {: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; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TNNTPSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FData := TStringList.Create; - FDataToSend := TStringList.Create; - FNNTPcap := TStringList.Create; - FSock.ConvertLineEnd := True; - FTimeout := 60000; - FTargetPort := cNNTPProtocol; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TNNTPSend.Destroy; -begin - FSock.Free; - FDataToSend.Free; - FData.Free; - FNNTPcap.Free; - inherited Destroy; -end; - -function TNNTPSend.ReadResult: Integer; -var - s: string; -begin - Result := 0; - FData.Clear; - s := FSock.RecvString(FTimeout); - FResultString := Copy(s, 5, Length(s) - 4); - if FSock.LastError <> 0 then - Exit; - if Length(s) >= 3 then - Result := StrToIntDef(Copy(s, 1, 3), 0); - FResultCode := Result; -end; - -function TNNTPSend.ReadData: boolean; -var - s: string; -begin - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - break; - if (s <> '') and (s[1] = '.') then - s := Copy(s, 2, Length(s) - 1); - FData.Add(s); - until FSock.LastError <> 0; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.SendData: boolean; -var - s: string; - n: integer; -begin - for n := 0 to FDataToSend.Count - 1 do - begin - s := FDataToSend[n]; - if (s <> '') and (s[1] = '.') then - s := s + '.'; - FSock.SendString(s + CRLF); - if FSock.LastError <> 0 then - break; - end; - if FDataToSend.Count = 0 then - FSock.SendString(CRLF); - if FSock.LastError = 0 then - FSock.SendString('.' + CRLF); - FDataToSend.Clear; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TNNTPSend.Login: Boolean; -begin - Result := False; - FNNTPcap.Clear; - if not Connect then - Exit; - Result := (ReadResult div 100) = 2; - if Result then - begin - ListExtensions; - FNNTPcap.Assign(Fdata); - if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then - Result := StartTLS; - end; - if (FUsername <> '') and Result then - begin - FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); - if (ReadResult div 100) = 3 then - begin - FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); - Result := (ReadResult div 100) = 2; - end; - end; -end; - -function TNNTPSend.Logout: Boolean; -begin - FSock.SendString('QUIT' + CRLF); - Result := (ReadResult div 100) = 2; - FSock.CloseSocket; -end; - -function TNNTPSend.DoCommand(const Command: string): Boolean; -begin - FSock.SendString(Command + CRLF); - Result := (ReadResult div 100) = 2; - Result := Result and (FSock.LastError = 0); -end; - -function TNNTPSend.DoCommandRead(const Command: string): Boolean; -begin - Result := DoCommand(Command); - if Result then - begin - Result := ReadData; - Result := Result and (FSock.LastError = 0); - end; -end; - -function TNNTPSend.DoCommandWrite(const Command: string): Boolean; -var - x: integer; -begin - FDataToSend.Assign(FData); - FSock.SendString(Command + CRLF); - x := (ReadResult div 100); - if x = 3 then - begin - SendData; - x := (ReadResult div 100); - end; - Result := x = 2; - Result := Result and (FSock.LastError = 0); -end; - -function TNNTPSend.GetArticle(const Value: string): Boolean; -var - s: string; -begin - s := 'ARTICLE'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetBody(const Value: string): Boolean; -var - s: string; -begin - s := 'BODY'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetHead(const Value: string): Boolean; -var - s: string; -begin - s := 'HEAD'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommandRead(s); -end; - -function TNNTPSend.GetStat(const Value: string): Boolean; -var - s: string; -begin - s := 'STAT'; - if Value <> '' then - s := s + ' ' + Value; - Result := DoCommand(s); -end; - -function TNNTPSend.SelectGroup(const Value: string): Boolean; -begin - Result := DoCommand('GROUP ' + Value); -end; - -function TNNTPSend.IHave(const MessID: string): Boolean; -begin - Result := DoCommandWrite('IHAVE ' + MessID); -end; - -function TNNTPSend.GotoLast: Boolean; -begin - Result := DoCommand('LAST'); -end; - -function TNNTPSend.GotoNext: Boolean; -begin - Result := DoCommand('NEXT'); -end; - -function TNNTPSend.ListGroups: Boolean; -begin - Result := DoCommandRead('LIST'); -end; - -function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; -begin - Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); -end; - -function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; -begin - Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); -end; - -function TNNTPSend.PostArticle: Boolean; -begin - Result := DoCommandWrite('POST'); -end; - -function TNNTPSend.SwitchToSlave: Boolean; -begin - Result := DoCommand('SLAVE'); -end; - -function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; -var - s: string; -begin - s := 'XOVER ' + xoStart; - if xoEnd <> xoStart then - s := s + '-' + xoEnd; - Result := DoCommandRead(s); -end; - -function TNNTPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - if DoCommand('STARTTLS') then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -function TNNTPSend.ListExtensions: Boolean; -begin - Result := DoCommandRead('LIST EXTENSIONS'); -end; - -function TNNTPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FNNTPcap.Count - 1 do - if Pos(s, UpperCase(FNNTPcap[n])) = 1 then - begin - Result := FNNTPcap[n]; - Break; - end; -end; - -{==============================================================================} - -end. diff --git a/synapse/pingsend.pas b/synapse/pingsend.pas deleted file mode 100644 index 1a4e331..0000000 --- a/synapse/pingsend.pas +++ /dev/null @@ -1,720 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.000.002 | -|==============================================================================| -| Content: PING sender | -|==============================================================================| -| Copyright (c)1999-2010, 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)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(ICMP PING implementation.) -Allows create PING and TRACEROUTE. Or you can diagnose your network. - -This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying - to use RAW sockets. - -Warning: For use of RAW sockets you must have some special rights on some - systems. So, it working allways when you have administator/root rights. - Otherwise you can have problems! - -Note: This unit is NOT portable to .NET! - Use native .NET classes for Ping instead. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF CIL} - Sorry, this unit is not for .NET! -{$ENDIF} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit pingsend; - -interface - -uses - SysUtils, - synsock, blcksock, synautil, synafpc, synaip -{$IFDEF MSWINDOWS} - , windows -{$ENDIF} - ; - -const - ICMP_ECHO = 8; - ICMP_ECHOREPLY = 0; - ICMP_UNREACH = 3; - ICMP_TIME_EXCEEDED = 11; -//rfc-2292 - ICMP6_ECHO = 128; - ICMP6_ECHOREPLY = 129; - ICMP6_UNREACH = 1; - ICMP6_TIME_EXCEEDED = 3; - -type - {:List of possible ICMP reply packet types.} - TICMPError = ( - IE_NoError, - IE_Other, - IE_TTLExceed, - IE_UnreachOther, - IE_UnreachRoute, - IE_UnreachAdmin, - IE_UnreachAddr, - IE_UnreachPort - ); - - {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)} - TPINGSend = class(TSynaClient) - private - FSock: TICMPBlockSocket; - FBuffer: Ansistring; - FSeq: Integer; - FId: Integer; - FPacketSize: Integer; - FPingTime: Integer; - FIcmpEcho: Byte; - FIcmpEchoReply: Byte; - FIcmpUnreach: Byte; - FReplyFrom: string; - FReplyType: byte; - FReplyCode: byte; - FReplyError: TICMPError; - FReplyErrorDesc: string; - FTTL: Byte; - Fsin: TVarSin; - function Checksum(Value: AnsiString): Word; - function Checksum6(Value: AnsiString): Word; - function ReadPacket: Boolean; - procedure TranslateError; - procedure TranslateErrorIpHlp(value: integer); - function InternalPing(const Host: string): Boolean; - function InternalPingIpHlp(const Host: string): Boolean; - function IsHostIP6(const Host: string): Boolean; - procedure GenErrorDesc; - 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; - - {:TTL value for ICMP query} - property TTL: byte read FTTL write FTTL; - 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 - -type - {:Record for ICMP ECHO packet header.} - TIcmpEchoHeader = packed record - i_type: Byte; - i_code: Byte; - i_checkSum: Word; - i_Id: Word; - i_seq: Word; - TimeStamp: integer; - end; - - {:record used internally by TPingSend for compute checksum of ICMPv6 packet - pseudoheader.} - TICMP6Packet = packed record - in_source: TInAddr6; - in_dest: TInAddr6; - Length: integer; - free0: Byte; - free1: Byte; - free2: Byte; - proto: Byte; - end; - -{$IFDEF MSWINDOWS} -const - DLLIcmpName = 'iphlpapi.dll'; -type - TIP_OPTION_INFORMATION = record - TTL: Byte; - TOS: Byte; - Flags: Byte; - OptionsSize: Byte; - OptionsData: PAnsiChar; - end; - PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION; - - TICMP_ECHO_REPLY = record - Address: TInAddr; - Status: integer; - RoundTripTime: integer; - DataSize: Word; - Reserved: Word; - Data: pointer; - Options: TIP_OPTION_INFORMATION; - end; - PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY; - - TICMPV6_ECHO_REPLY = record - Address: TSockAddrIn6; - Status: integer; - RoundTripTime: integer; - end; - PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY; - - TIcmpCreateFile = function: integer; stdcall; - TIcmpCloseHandle = function(handle: integer): boolean; stdcall; - TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; - ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer; - RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; - ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; - TIcmp6CreateFile = function: integer; stdcall; - TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer; - ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6; - RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION; - ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall; - -var - IcmpDllHandle: TLibHandle = 0; - IcmpHelper4: boolean = false; - IcmpHelper6: boolean = false; - IcmpCreateFile: TIcmpCreateFile = nil; - IcmpCloseHandle: TIcmpCloseHandle = nil; - IcmpSendEcho2: TIcmpSendEcho2 = nil; - Icmp6CreateFile: TIcmp6CreateFile = nil; - Icmp6SendEcho2: TIcmp6SendEcho2 = nil; -{$ENDIF} -{==============================================================================} - -constructor TPINGSend.Create; -begin - inherited Create; - FSock := TICMPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FPacketSize := 32; - FSeq := 0; - Randomize; - FTTL := 128; -end; - -destructor TPINGSend.Destroy; -begin - FSock.Free; - inherited Destroy; -end; - -function TPINGSend.ReadPacket: Boolean; -begin - FBuffer := FSock.RecvPacket(Ftimeout); - Result := FSock.LastError = 0; -end; - -procedure TPINGSend.GenErrorDesc; -begin - case FReplyError of - IE_NoError: - FReplyErrorDesc := ''; - IE_Other: - FReplyErrorDesc := 'Unknown error'; - IE_TTLExceed: - FReplyErrorDesc := 'TTL Exceeded'; - IE_UnreachOther: - FReplyErrorDesc := 'Unknown unreachable'; - IE_UnreachRoute: - FReplyErrorDesc := 'No route to destination'; - IE_UnreachAdmin: - FReplyErrorDesc := 'Administratively prohibited'; - IE_UnreachAddr: - FReplyErrorDesc := 'Address unreachable'; - IE_UnreachPort: - FReplyErrorDesc := 'Port unreachable'; - end; -end; - -function TPINGSend.IsHostIP6(const Host: string): Boolean; -var - f: integer; -begin - f := AF_UNSPEC; - if IsIp(Host) then - f := AF_INET - else - if IsIp6(Host) then - f := AF_INET6; - synsock.SetVarSin(Fsin, host, '0', f, - IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4); - result := Fsin.sin_family = AF_INET6; -end; - -function TPINGSend.Ping(const Host: string): Boolean; -var - b: boolean; -begin - FPingTime := -1; - FReplyFrom := ''; - FReplyType := 0; - FReplyCode := 0; - FReplyError := IE_Other; - GenErrorDesc; - FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize); -{$IFDEF MSWINDOWS} - b := IsHostIP6(host); - if not(b) and IcmpHelper4 then - result := InternalPingIpHlp(host) - else - if b and IcmpHelper6 then - result := InternalPingIpHlp(host) - else - result := InternalPing(host); -{$ELSE} - result := InternalPing(host); -{$ENDIF} -end; - -function TPINGSend.InternalPing(const Host: string): Boolean; -var - IPHeadPtr: ^TIPHeader; - IpHdrLen: Integer; - IcmpEchoHeaderPtr: ^TICMPEchoHeader; - t: Boolean; - x: cardinal; - IcmpReqHead: string; -begin - Result := False; - FSock.TTL := FTTL; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(Host, '0'); - if FSock.LastError <> 0 then - Exit; - FSock.SizeRecvBuffer := 60 * 1024; - if FSock.IP6used then - begin - FIcmpEcho := ICMP6_ECHO; - FIcmpEchoReply := ICMP6_ECHOREPLY; - FIcmpUnreach := ICMP6_UNREACH; - end - else - begin - FIcmpEcho := ICMP_ECHO; - FIcmpEchoReply := ICMP_ECHOREPLY; - FIcmpUnreach := ICMP_UNREACH; - end; - IcmpEchoHeaderPtr := Pointer(FBuffer); - with IcmpEchoHeaderPtr^ do - begin - i_type := FIcmpEcho; - i_code := 0; - i_CheckSum := 0; - FId := System.Random(32767); - i_Id := FId; - TimeStamp := GetTick; - Inc(FSeq); - i_Seq := FSeq; - if fSock.IP6used then - i_CheckSum := CheckSum6(FBuffer) - else - 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; - if not t then - break; - if fSock.IP6used then - begin -{$IFNDEF MSWINDOWS} - IcmpEchoHeaderPtr := Pointer(FBuffer); -{$ELSE} -//WinXP SP1 with networking update doing this think by another way ;-O -// FBuffer := StringOfChar(#0, 4) + FBuffer; - IcmpEchoHeaderPtr := Pointer(FBuffer); -// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply; -{$ENDIF} - end - else - begin - IPHeadPtr := Pointer(FBuffer); - IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; - IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; - end; - //check for timeout - if TickDelta(x, GetTick) > FTimeout then - begin - t := false; - Break; - 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 (Pos(IcmpReqHead, FBuffer) > 0)); - if t then - begin - FPingTime := TickDelta(x, GetTick); - FReplyFrom := FSock.GetRemoteSinIP; - FReplyType := IcmpEchoHeaderPtr^.i_type; - FReplyCode := IcmpEchoHeaderPtr^.i_code; - TranslateError; - Result := True; - end; -end; - -function TPINGSend.Checksum(Value: AnsiString): Word; -var - CkSum: integer; - Num, Remain: Integer; - n, i: Integer; -begin - Num := Length(Value) div 2; - Remain := Length(Value) mod 2; - CkSum := 0; - i := 1; - for n := 0 to Num - 1 do - begin - CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i)); - inc(i, 2); - end; - if Remain <> 0 then - CkSum := CkSum + Ord(Value[Length(Value)]); - CkSum := (CkSum shr 16) + (CkSum and $FFFF); - CkSum := CkSum + (CkSum shr 16); - Result := Word(not CkSum); -end; - -function TPINGSend.Checksum6(Value: AnsiString): Word; -const - IOC_OUT = $40000000; - IOC_IN = $80000000; - IOC_INOUT = (IOC_IN or IOC_OUT); - IOC_WS2 = $08000000; - SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT; -var - ICMP6Ptr: ^TICMP6Packet; - s: AnsiString; - b: integer; - ip6: TSockAddrIn6; - x: integer; -begin - Result := 0; -{$IFDEF MSWINDOWS} - s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value; - ICMP6Ptr := Pointer(s); - x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY, - @FSock.RemoteSin, SizeOf(FSock.RemoteSin), - @ip6, SizeOf(ip6), @b, nil, nil); - if x <> -1 then - ICMP6Ptr^.in_dest := ip6.sin6_addr - else - ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr; - ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr; - ICMP6Ptr^.Length := synsock.htonl(Length(Value)); - ICMP6Ptr^.proto := IPPROTO_ICMPV6; - Result := Checksum(s); -{$ENDIF} -end; - -procedure TPINGSend.TranslateError; -begin - if fSock.IP6used then - begin - case FReplyType of - ICMP6_ECHOREPLY: - FReplyError := IE_NoError; - ICMP6_TIME_EXCEEDED: - FReplyError := IE_TTLExceed; - ICMP6_UNREACH: - case FReplyCode of - 0: - FReplyError := IE_UnreachRoute; - 3: - FReplyError := IE_UnreachAddr; - 4: - FReplyError := IE_UnreachPort; - 1: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_UnreachOther; - end; - else - FReplyError := IE_Other; - end; - end - else - begin - case FReplyType of - ICMP_ECHOREPLY: - FReplyError := IE_NoError; - ICMP_TIME_EXCEEDED: - FReplyError := IE_TTLExceed; - ICMP_UNREACH: - case FReplyCode of - 0: - FReplyError := IE_UnreachRoute; - 1: - FReplyError := IE_UnreachAddr; - 3: - FReplyError := IE_UnreachPort; - 13: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_UnreachOther; - end; - else - FReplyError := IE_Other; - end; - end; - GenErrorDesc; -end; - -procedure TPINGSend.TranslateErrorIpHlp(value: integer); -begin - case value of - 11000, 0: - FReplyError := IE_NoError; - 11013: - FReplyError := IE_TTLExceed; - 11002: - FReplyError := IE_UnreachRoute; - 11003: - FReplyError := IE_UnreachAddr; - 11005: - FReplyError := IE_UnreachPort; - 11004: - FReplyError := IE_UnreachAdmin; - else - FReplyError := IE_Other; - end; - GenErrorDesc; -end; - -function TPINGSend.InternalPingIpHlp(const Host: string): Boolean; -{$IFDEF MSWINDOWS} -var - PingIp6: boolean; - PingHandle: integer; - r: integer; - ipo: TIP_OPTION_INFORMATION; - RBuff: Ansistring; - ip4reply: PICMP_ECHO_REPLY; - ip6reply: PICMPV6_ECHO_REPLY; - ip6: TSockAddrIn6; -begin - Result := False; - PingIp6 := Fsin.sin_family = AF_INET6; - if pingIp6 then - PingHandle := Icmp6CreateFile - else - PingHandle := IcmpCreateFile; - if PingHandle <> -1 then - begin - try - ipo.TTL := FTTL; - ipo.TOS := 0; - ipo.Flags := 0; - ipo.OptionsSize := 0; - ipo.OptionsData := nil; - setlength(RBuff, 4096); - if pingIp6 then - begin - FillChar(ip6, sizeof(ip6), 0); - r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin, - PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); - if r > 0 then - begin - RBuff := #0 + #0 + RBuff; - ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff)); - FPingTime := ip6reply^.RoundTripTime; - ip6reply^.Address.sin6_family := AF_INET6; - FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address)); - TranslateErrorIpHlp(ip6reply^.Status); - Result := True; - end; - end - else - begin - r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr, - PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout); - if r > 0 then - begin - ip4reply := PICMP_ECHO_REPLY(pointer(RBuff)); - FPingTime := ip4reply^.RoundTripTime; - FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr)); - TranslateErrorIpHlp(ip4reply^.Status); - Result := True; - end; - end - finally - IcmpCloseHandle(PingHandle); - end; - end; -end; -{$ELSE} -begin - result := false; -end; -{$ENDIF} - -{==============================================================================} - -function PingHost(const Host: string): Integer; -begin - with TPINGSend.Create do - try - Result := -1; - if Ping(Host) then - if ReplyError = IE_NoError then - Result := PingTime; - finally - Free; - end; -end; - -function TraceRouteHost(const Host: string): string; -var - Ping: TPingSend; - ttl : byte; -begin - Result := ''; - Ping := TPINGSend.Create; - try - ttl := 1; - repeat - ping.TTL := ttl; - inc(ttl); - if ttl > 30 then - Break; - if not ping.Ping(Host) then - begin - Result := Result + cAnyHost+ ' Timeout' + CRLF; - continue; - end; - if (ping.ReplyError <> IE_NoError) - and (ping.ReplyError <> IE_TTLExceed) then - begin - Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF; - break; - end; - Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF; - until ping.ReplyError = IE_NoError; - finally - Ping.Free; - end; -end; - -{$IFDEF MSWINDOWS} -initialization -begin - IcmpHelper4 := false; - IcmpHelper6 := false; - IcmpDllHandle := LoadLibrary(DLLIcmpName); - if IcmpDllHandle <> 0 then - begin - IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile'); - IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle'); - IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2'); - Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile'); - Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2'); - IcmpHelper4 := assigned(IcmpCreateFile) - and assigned(IcmpCloseHandle) - and assigned(IcmpSendEcho2); - IcmpHelper6 := assigned(Icmp6CreateFile) - and assigned(Icmp6SendEcho2); - end; -end; - -finalization -begin - FreeLibrary(IcmpDllHandle); -end; -{$ENDIF} - -end. diff --git a/synapse/pop3send.pas b/synapse/pop3send.pas deleted file mode 100644 index 05c5ac0..0000000 --- a/synapse/pop3send.pas +++ /dev/null @@ -1,483 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.006.002 | -|==============================================================================| -| Content: POP3 client | -|==============================================================================| -| Copyright (c)1999-2010, 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)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(POP3 protocol client) - -Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$M+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit pop3send; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synacode; - -const - cPop3Protocol = '110'; - -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 - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FStatCount: Integer; - FStatSize: Integer; - FListSize: Integer; - FTimeStamp: string; - FAuthType: TPOP3AuthType; - FPOP3cap: TStringList; - FAutoTLS: Boolean; - FFullSSL: Boolean; - function ReadResult(Full: Boolean): Integer; - function Connect: Boolean; - function AuthLogin: Boolean; - function AuthApop: Boolean; - public - constructor Create; - destructor Destroy; override; - - {:You can call any custom by this method. Call Command without trailing CRLF. - If MultiLine parameter is @true, multilined response are expected. - Result is @true on sucess.} - function CustomCommand(const Command: string; MultiLine: Boolean): boolean; - - {: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; - - {: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 RETR command. After successful operation dowloaded message in - @link(Stream). If all OK, result is @true.} - function RetrStream(Value: Integer; Stream: TStream): 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; - - {: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; - - {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} - property ListSize: Integer read FListSize; - - {: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; - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - end; - -implementation - -constructor TPOP3Send.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FPOP3cap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := true; - FTimeout := 60000; - FTargetPort := cPop3Protocol; - FStatCount := 0; - FStatSize := 0; - FListSize := 0; - FAuthType := POP3AuthAll; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TPOP3Send.Destroy; -begin - FSock.Free; - FPOP3cap.Free; - FullResult.Free; - inherited Destroy; -end; - -function TPOP3Send.ReadResult(Full: Boolean): Integer; -var - s: AnsiString; -begin - Result := 0; - FFullResult.Clear; - s := FSock.RecvString(FTimeout); - if Pos('+OK', s) = 1 then - Result := 1; - FResultString := s; - if Full and (Result = 1) then - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - Break; - if s <> '' then - if s[1] = '.' then - Delete(s, 1, 1); - FFullResult.Add(s); - until FSock.LastError <> 0; - if not Full and (Result = 1) then - FFullResult.Add(SeparateRight(FResultString, ' ')); - if FSock.LastError <> 0 then - Result := 0; - FResultCode := Result; -end; - -function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; -begin - FSock.SendString(Command + CRLF); - Result := ReadResult(MultiLine) <> 0; -end; - -function TPOP3Send.AuthLogin: Boolean; -begin - Result := False; - if not CustomCommand('USER ' + FUserName, False) then - exit; - Result := CustomCommand('PASS ' + FPassword, False) -end; - -function TPOP3Send.AuthAPOP: Boolean; -var - s: string; -begin - s := StrToHex(MD5(FTimeStamp + FPassWord)); - Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); -end; - -function TPOP3Send.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FStatCount := 0; - FStatSize := 0; - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TPOP3Send.Capability: Boolean; -begin - FPOP3cap.Clear; - Result := CustomCommand('CAPA', True); - if Result then - FPOP3cap.AddStrings(FFullResult); -end; - -function TPOP3Send.Login: Boolean; -var - s, s1: string; -begin - Result := False; - FTimeStamp := ''; - if not Connect then - Exit; - if ReadResult(False) <> 1 then - Exit; - s := SeparateRight(FResultString, '<'); - if s <> FResultString then - begin - s1 := Trim(SeparateLeft(s, '>')); - if s1 <> s then - FTimeStamp := '<' + s1 + '>'; - end; - Result := False; - if Capability then - if FAutoTLS and (Findcap('STLS') <> '') then - if StartTLS then - Capability - else - begin - Result := False; - Exit; - end; - if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then - begin - Result := AuthApop; - if not Result then - begin - if not Connect then - Exit; - if ReadResult(False) <> 1 then - Exit; - end; - end; - if not Result and not (FAuthType = POP3AuthAPOP) then - Result := AuthLogin; -end; - -function TPOP3Send.Logout: Boolean; -begin - Result := CustomCommand('QUIT', False); - FSock.CloseSocket; -end; - -function TPOP3Send.Reset: Boolean; -begin - Result := CustomCommand('RSET', False); -end; - -function TPOP3Send.NoOp: Boolean; -begin - Result := CustomCommand('NOOP', False); -end; - -function TPOP3Send.Stat: Boolean; -var - s: string; -begin - Result := CustomCommand('STAT', False); - if Result then - begin - s := SeparateRight(ResultString, '+OK '); - FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); - FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); - end; -end; - -function TPOP3Send.List(Value: Integer): Boolean; -var - s: string; - n: integer; -begin - if Value = 0 then - s := 'LIST' - else - s := 'LIST ' + IntToStr(Value); - Result := CustomCommand(s, Value = 0); - FListSize := 0; - if Result then - if Value <> 0 then - begin - s := SeparateRight(ResultString, '+OK '); - FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); - end - else - for n := 0 to FFullResult.Count - 1 do - FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); -end; - -function TPOP3Send.Retr(Value: Integer): Boolean; -begin - Result := CustomCommand('RETR ' + IntToStr(Value), True); -end; - -//based on code by Miha Vrhovnik -function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; -var - s: string; -begin - Result := False; - FFullResult.Clear; - Stream.Size := 0; - FSock.SendString('RETR ' + IntToStr(Value) + CRLF); - - s := FSock.RecvString(FTimeout); - if Pos('+OK', s) = 1 then - Result := True; - FResultString := s; - if Result then begin - repeat - s := FSock.RecvString(FTimeout); - if s = '.' then - Break; - if s <> '' then begin - if s[1] = '.' then - Delete(s, 1, 1); - end; - WriteStrToStream(Stream, s); - WriteStrToStream(Stream, CRLF); - until FSock.LastError <> 0; - end; - - if Result then - FResultCode := 1 - else - FResultCode := 0; -end; - -function TPOP3Send.Dele(Value: Integer): Boolean; -begin - Result := CustomCommand('DELE ' + IntToStr(Value), False); -end; - -function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; -begin - Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); -end; - -function TPOP3Send.Uidl(Value: Integer): Boolean; -var - s: string; -begin - if Value = 0 then - s := 'UIDL' - else - s := 'UIDL ' + IntToStr(Value); - Result := CustomCommand(s, Value = 0); -end; - -function TPOP3Send.StartTLS: Boolean; -begin - Result := False; - if CustomCommand('STLS', False) then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -function TPOP3Send.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FPOP3cap.Count - 1 do - if Pos(s, UpperCase(FPOP3cap[n])) = 1 then - begin - Result := FPOP3cap[n]; - Break; - end; -end; - -end. diff --git a/synapse/slogsend.pas b/synapse/slogsend.pas deleted file mode 100644 index 900f6c0..0000000 --- a/synapse/slogsend.pas +++ /dev/null @@ -1,320 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.003 | -|==============================================================================| -| Content: SysLog client | -|==============================================================================| -| Copyright (c)1999-2010, 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)2001-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Christian Brosius | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(BSD SYSLOG protocol) - -Used RFC: RFC-3164 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -unit slogsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cSysLogProtocol = '514'; - - FCL_Kernel = 0; - FCL_UserLevel = 1; - FCL_MailSystem = 2; - FCL_System = 3; - FCL_Security = 4; - FCL_Syslogd = 5; - FCL_Printer = 6; - FCL_News = 7; - FCL_UUCP = 8; - FCL_Clock = 9; - FCL_Authorization = 10; - FCL_FTP = 11; - FCL_NTP = 12; - FCL_LogAudit = 13; - FCL_LogAlert = 14; - FCL_Time = 15; - FCL_Local0 = 16; - FCL_Local1 = 17; - FCL_Local2 = 18; - FCL_Local3 = 19; - FCL_Local4 = 20; - FCL_Local5 = 21; - FCL_Local6 = 22; - 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; - FSysLogMessage: TSysLogMessage; - public - constructor Create; - destructor Destroy; override; - {:Send Syslog UDP packet defined by @link(SysLogMessage).} - function DoIt: Boolean; - published - {: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 - -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 := TrimSP(StrBuf); -end; - -procedure TSysLogMessage.Clear; -begin - 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; - FSock.Owner := self; - FSysLogMessage := TSysLogMessage.Create; - FTargetPort := cSysLogProtocol; -end; - -destructor TSyslogSend.Destroy; -begin - FSock.Free; - FSysLogMessage.Free; - inherited Destroy; -end; - -function TSyslogSend.DoIt: Boolean; -var - L: TStringList; -begin - Result := False; - L := TStringList.Create; - try - FSock.ResolveNameToIP(FSock.Localname, L); - if L.Count < 1 then - FSysLogMessage.LocalIP := '0.0.0.0' - else - FSysLogMessage.LocalIP := L[0]; - finally - L.Free; - end; - FSysLogMessage.DateTime := Now; - if Length(FSysLogMessage.PacketBuf) <= 1024 then - begin - FSock.Connect(FTargetHost, FTargetPort); - FSock.SendString(FSysLogMessage.PacketBuf); - Result := FSock.LastError = 0; - end; -end; - -{==============================================================================} - -function ToSysLog(const SyslogServer: string; Facil: Byte; - Sever: TSyslogSeverity; const Content: string): Boolean; -begin - with TSyslogSend.Create do - try - TargetHost :=SyslogServer; - SysLogMessage.Facility := Facil; - SysLogMessage.Severity := Sever; - SysLogMessage.LogMessage := Content; - Result := DoIt; - finally - Free; - end; -end; - -end. diff --git a/synapse/smtpsend.pas b/synapse/smtpsend.pas deleted file mode 100644 index e023a38..0000000 --- a/synapse/smtpsend.pas +++ /dev/null @@ -1,724 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.005.001 | -|==============================================================================| -| Content: SMTP client | -|==============================================================================| -| Copyright (c)1999-2010, 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) 1999-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@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} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit smtpsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil, synacode; - -const - cSmtpProtocol = '25'; - -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 - FSock: TTCPBlockSocket; - FResultCode: Integer; - FResultString: string; - FFullResult: TStringList; - FESMTPcap: TStringList; - FESMTP: Boolean; - FAuthDone: Boolean; - FESMTPSize: Boolean; - FMaxSize: Integer; - FEnhCode1: Integer; - FEnhCode2: Integer; - FEnhCode3: Integer; - FSystemName: string; - FAutoTLS: Boolean; - FFullSSL: Boolean; - procedure EnhancedCode(const Value: string); - function ReadResult: Integer; - function AuthLogin: Boolean; - function AuthCram: Boolean; - function AuthPlain: Boolean; - function Helo: Boolean; - function Ehlo: Boolean; - function Connect: Boolean; - 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; - - {: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; - - {:@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; - - {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} - property Sock: TTCPBlockSocket read FSock; - 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; - -implementation - -constructor TSMTPSend.Create; -begin - inherited Create; - FFullResult := TStringList.Create; - FESMTPcap := TStringList.Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.ConvertLineEnd := true; - FTimeout := 60000; - FTargetPort := cSmtpProtocol; - FSystemName := FSock.LocalName; - FAutoTLS := False; - FFullSSL := False; -end; - -destructor TSMTPSend.Destroy; -begin - FSock.Free; - FESMTPcap.Free; - FFullResult.Free; - inherited Destroy; -end; - -procedure TSMTPSend.EnhancedCode(const Value: string); -var - s, t: string; - e1, e2, e3: Integer; -begin - FEnhCode1 := 0; - FEnhCode2 := 0; - FEnhCode3 := 0; - s := Copy(Value, 5, Length(Value) - 4); - t := Trim(SeparateLeft(s, '.')); - s := Trim(SeparateRight(s, '.')); - if t = '' then - Exit; - if Length(t) > 1 then - Exit; - e1 := StrToIntDef(t, 0); - if e1 = 0 then - Exit; - t := Trim(SeparateLeft(s, '.')); - s := Trim(SeparateRight(s, '.')); - if t = '' then - Exit; - if Length(t) > 3 then - Exit; - e2 := StrToIntDef(t, 0); - t := Trim(SeparateLeft(s, ' ')); - if t = '' then - Exit; - if Length(t) > 3 then - Exit; - e3 := StrToIntDef(t, 0); - FEnhCode1 := e1; - FEnhCode2 := e2; - FEnhCode3 := e3; -end; - -function TSMTPSend.ReadResult: Integer; -var - s: String; -begin - Result := 0; - FFullResult.Clear; - repeat - s := FSock.RecvString(FTimeout); - FResultString := s; - FFullResult.Add(s); - if FSock.LastError <> 0 then - Break; - until Pos('-', s) <> 4; - s := FFullResult[0]; - if Length(s) >= 3 then - Result := StrToIntDef(Copy(s, 1, 3), 0); - FResultCode := Result; - EnhancedCode(s); -end; - -function TSMTPSend.AuthLogin: Boolean; -begin - Result := False; - FSock.SendString('AUTH LOGIN' + CRLF); - if ReadResult <> 334 then - Exit; - FSock.SendString(EncodeBase64(FUsername) + CRLF); - if ReadResult <> 334 then - Exit; - FSock.SendString(EncodeBase64(FPassword) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.AuthCram: Boolean; -var - s: ansistring; -begin - Result := False; - FSock.SendString('AUTH CRAM-MD5' + CRLF); - if ReadResult <> 334 then - Exit; - s := Copy(FResultString, 5, Length(FResultString) - 4); - s := DecodeBase64(s); - s := HMAC_MD5(s, FPassword); - s := FUsername + ' ' + StrToHex(s); - FSock.SendString(EncodeBase64(s) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.AuthPlain: Boolean; -var - s: ansistring; -begin - s := ansichar(0) + FUsername + ansichar(0) + FPassword; - FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF); - Result := ReadResult = 235; -end; - -function TSMTPSend.Connect: Boolean; -begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError = 0 then - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if FFullSSL then - FSock.SSLDoConnect; - Result := FSock.LastError = 0; -end; - -function TSMTPSend.Helo: Boolean; -var - x: Integer; -begin - FSock.SendString('HELO ' + FSystemName + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Ehlo: Boolean; -var - x: Integer; -begin - FSock.SendString('EHLO ' + FSystemName + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Login: Boolean; -var - n: Integer; - auths: string; - s: string; -begin - Result := False; - FESMTP := True; - FAuthDone := False; - FESMTPcap.clear; - FESMTPSize := False; - FMaxSize := 0; - if not Connect then - Exit; - if ReadResult <> 220 then - Exit; - if not Ehlo then - begin - FESMTP := False; - if not Helo then - Exit; - end; - Result := True; - if FESMTP then - begin - for n := 1 to FFullResult.Count - 1 do - FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4)); - if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then - if StartTLS then - begin - Ehlo; - 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 - s := FindCap('AUTH '); - if s = '' then - s := FindCap('AUTH='); - auths := UpperCase(s); - if s <> '' then - begin - if Pos('CRAM-MD5', auths) > 0 then - FAuthDone := AuthCram; - if (not FauthDone) and (Pos('PLAIN', auths) > 0) then - FAuthDone := AuthPlain; - if (not FauthDone) and (Pos('LOGIN', auths) > 0) then - FAuthDone := AuthLogin; - end; - end; - s := FindCap('SIZE'); - if s <> '' then - begin - FESMTPsize := True; - FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0); - end; - end; -end; - -function TSMTPSend.Logout: Boolean; -begin - FSock.SendString('QUIT' + CRLF); - Result := ReadResult = 221; - FSock.CloseSocket; -end; - -function TSMTPSend.Reset: Boolean; -begin - FSock.SendString('RSET' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.NoOp: Boolean; -begin - FSock.SendString('NOOP' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean; -var - s: string; -begin - s := 'MAIL FROM:<' + Value + '>'; - if FESMTPsize and (Size > 0) then - s := s + ' SIZE=' + IntToStr(Size); - FSock.SendString(s + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailTo(const Value: string): Boolean; -begin - FSock.SendString('RCPT TO:<' + Value + '>' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.MailData(const Value: TStrings): Boolean; -var - n: Integer; - s: string; - t: string; - x: integer; -begin - Result := False; - FSock.SendString('DATA' + CRLF); - if ReadResult <> 354 then - Exit; - t := ''; - x := 1500; - for n := 0 to Value.Count - 1 do - begin - s := Value[n]; - if Length(s) >= 1 then - if s[1] = '.' then - s := '.' + s; - if Length(t) + Length(s) >= x then - begin - FSock.SendString(t); - t := ''; - end; - t := t + s + CRLF; - end; - if t <> '' then - FSock.SendString(t); - FSock.SendString('.' + CRLF); - Result := ReadResult div 100 = 2; -end; - -function TSMTPSend.Etrn(const Value: string): Boolean; -var - x: Integer; -begin - FSock.SendString('ETRN ' + Value + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.Verify(const Value: string): Boolean; -var - x: Integer; -begin - FSock.SendString('VRFY ' + Value + CRLF); - x := ReadResult; - Result := (x >= 250) and (x <= 259); -end; - -function TSMTPSend.StartTLS: Boolean; -begin - Result := False; - if FindCap('STARTTLS') <> '' then - begin - FSock.SendString('STARTTLS' + CRLF); - if (ReadResult = 220) and (FSock.LastError = 0) then - begin - Fsock.SSLDoConnect; - Result := FSock.LastError = 0; - end; - end; -end; - -function TSMTPSend.EnhCodeString: string; -var - s, t: string; -begin - s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3); - t := ''; - if s = '0.0' then t := 'Other undefined Status'; - if s = '1.0' then t := 'Other address status'; - if s = '1.1' then t := 'Bad destination mailbox address'; - if s = '1.2' then t := 'Bad destination system address'; - if s = '1.3' then t := 'Bad destination mailbox address syntax'; - if s = '1.4' then t := 'Destination mailbox address ambiguous'; - if s = '1.5' then t := 'Destination mailbox address valid'; - if s = '1.6' then t := 'Mailbox has moved'; - if s = '1.7' then t := 'Bad sender''s mailbox address syntax'; - if s = '1.8' then t := 'Bad sender''s system address'; - if s = '2.0' then t := 'Other or undefined mailbox status'; - if s = '2.1' then t := 'Mailbox disabled, not accepting messages'; - if s = '2.2' then t := 'Mailbox full'; - if s = '2.3' then t := 'Message Length exceeds administrative limit'; - if s = '2.4' then t := 'Mailing list expansion problem'; - if s = '3.0' then t := 'Other or undefined mail system status'; - if s = '3.1' then t := 'Mail system full'; - if s = '3.2' then t := 'System not accepting network messages'; - if s = '3.3' then t := 'System not capable of selected features'; - if s = '3.4' then t := 'Message too big for system'; - if s = '3.5' then t := 'System incorrectly configured'; - if s = '4.0' then t := 'Other or undefined network or routing status'; - if s = '4.1' then t := 'No answer from host'; - if s = '4.2' then t := 'Bad connection'; - if s = '4.3' then t := 'Routing server failure'; - if s = '4.4' then t := 'Unable to route'; - if s = '4.5' then t := 'Network congestion'; - if s = '4.6' then t := 'Routing loop detected'; - if s = '4.7' then t := 'Delivery time expired'; - if s = '5.0' then t := 'Other or undefined protocol status'; - if s = '5.1' then t := 'Invalid command'; - if s = '5.2' then t := 'Syntax error'; - if s = '5.3' then t := 'Too many recipients'; - if s = '5.4' then t := 'Invalid command arguments'; - if s = '5.5' then t := 'Wrong protocol version'; - if s = '6.0' then t := 'Other or undefined media error'; - if s = '6.1' then t := 'Media not supported'; - if s = '6.2' then t := 'Conversion required and prohibited'; - if s = '6.3' then t := 'Conversion required but not supported'; - if s = '6.4' then t := 'Conversion with loss performed'; - if s = '6.5' then t := 'Conversion failed'; - if s = '7.0' then t := 'Other or undefined security status'; - if s = '7.1' then t := 'Delivery not authorized, message refused'; - if s = '7.2' then t := 'Mailing list expansion prohibited'; - if s = '7.3' then t := 'Security conversion required but not possible'; - if s = '7.4' then t := 'Security features not supported'; - if s = '7.5' then t := 'Cryptographic failure'; - if s = '7.6' then t := 'Cryptographic algorithm not supported'; - if s = '7.7' then t := 'Message integrity failure'; - s := '???-'; - if FEnhCode1 = 2 then s := 'Success-'; - if FEnhCode1 = 4 then s := 'Persistent Transient Failure-'; - if FEnhCode1 = 5 then s := 'Permanent Failure-'; - Result := s + t; -end; - -function TSMTPSend.FindCap(const Value: string): string; -var - n: Integer; - s: string; -begin - s := UpperCase(Value); - Result := ''; - for n := 0 to FESMTPcap.Count - 1 do - if Pos(s, UpperCase(FESMTPcap[n])) = 1 then - begin - Result := FESMTPcap[n]; - Break; - end; -end; - -{==============================================================================} - -function SendToRaw(const MailFrom, MailTo, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; -var - SMTP: TSMTPSend; - s, t: string; -begin - Result := False; - SMTP := TSMTPSend.Create; - try -// if you need SOCKS5 support, uncomment next lines: - // SMTP.Sock.SocksIP := '127.0.0.1'; - // SMTP.Sock.SocksPort := '1080'; -// if you need support for upgrade session to TSL/SSL, uncomment next lines: - // SMTP.AutoTLS := True; -// if you need support for TSL/SSL tunnel, uncomment next lines: - // SMTP.FullSSL := True; - SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':')); - s := Trim(SeparateRight(SMTPHost, ':')); - if (s <> '') and (s <> SMTPHost) then - SMTP.TargetPort := s; - SMTP.Username := Username; - SMTP.Password := Password; - if SMTP.Login then - begin - if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then - begin - s := MailTo; - repeat - t := GetEmailAddr(Trim(FetchEx(s, ',', '"'))); - if t <> '' then - Result := SMTP.MailTo(t); - if not Result then - Break; - until s = ''; - if Result then - Result := SMTP.MailData(MailData); - end; - SMTP.Logout; - end; - finally - SMTP.Free; - end; -end; - -function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings; const Username, Password: string): Boolean; -var - t: TStrings; -begin - t := TStringList.Create; - try - t.Assign(MailData); - t.Insert(0, ''); - t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer'); - t.Insert(0, 'Subject: ' + Subject); - t.Insert(0, 'Date: ' + Rfc822DateTime(now)); - t.Insert(0, 'To: ' + MailTo); - t.Insert(0, 'From: ' + MailFrom); - Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password); - finally - t.Free; - end; -end; - -function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string; - const MailData: TStrings): Boolean; -begin - Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', ''); -end; - -end. diff --git a/synapse/snmpsend.pas b/synapse/snmpsend.pas deleted file mode 100644 index 6e44c04..0000000 --- a/synapse/snmpsend.pas +++ /dev/null @@ -1,1266 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.000.000 | -|==============================================================================| -| Content: SNMP client | -|==============================================================================| -| Copyright (c)1999-2011, 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)2000-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Jean-Fabien Connault (cycocrew@worldnet.fr) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SNMP client) -Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization -and privacy encryption. - -Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416, RFC-3826 - -Supported Authorization hashes: MD5, SHA1 -Supported Privacy encryptions: DES, 3DES, AES -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit snmpsend; - -interface - -uses - Classes, SysUtils, - blcksock, synautil, asn1util, synaip, synacode, synacrypt; - -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; //Obsolete - //for SNMPv2 - PDUGetBulkRequest = $A5; - PDUInformRequest = $A6; - PDUTrapV2 = $A7; - PDUReport = $A8; - - //errors - ENoError = 0; - ETooBig = 1; - ENoSuchName = 2; - 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(Type of SNMPv3 privacy)} - TV3Priv = ( - PrivDES, - Priv3DES, - PrivAES); - - {:@abstract(Data object with one record of MIB OID and corresponding values.)} - TSNMPMib = class(TObject) - protected - FOID: AnsiString; - FValue: AnsiString; - FValueType: Integer; - published - {: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) - protected - FVersion: Integer; - 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; - FPrivMode: TV3Priv; - FPrivPassword: AnsiString; - FPrivKey: AnsiString; - FPrivSalt: AnsiString; - FPrivSaltCounter: integer; - FOldTrapEnterprise: AnsiString; - FOldTrapHost: AnsiString; - FOldTrapGen: Integer; - FOldTrapSpec: Integer; - FOldTrapTimeTicks: Integer; - function Pass2Key(const Value: AnsiString): AnsiString; - function EncryptPDU(const value: AnsiString): AnsiString; - function DecryptPDU(const value: AnsiString): AnsiString; - public - constructor Create; - destructor Destroy; override; - - {:Decode SNMP packet in buffer to object properties.} - function DecodeBuf(Buffer: AnsiString): Boolean; - - {:Encode obeject properties to SNMP packet.} - function EncodeBuf: AnsiString; - - {:Clears all object properties to default values.} - procedure Clear; - - {: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); - - {: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; - - {: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.} - 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; - - {:For SNMPv3. Specify Privacy mode.} - property PrivMode: TV3Priv read FPrivMode write FPrivMode; - - {: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; - - {:SNMPv3 privacy password} - property PrivPassword: AnsiString read FPrivPassword write FPrivPassword; - - {:For SNMPv3. Computed Privacy key from @link(PrivPassword).} - 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) - protected - FSock: TUDPBlockSocket; - 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 - {: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; - -{: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 - -{==============================================================================} - -constructor TSNMPRec.Create; -begin - inherited Create; - FSNMPMibList := TList.Create; - Clear; - FAuthMode := AuthMD5; - FPassword := ''; - FPrivMode := PrivDES; - FPrivPassword := ''; - FID := 1; - FMaxSize := 1472; -end; - -destructor TSNMPRec.Destroy; -var - i: Integer; -begin - for i := 0 to FSNMPMibList.Count - 1 do - TSNMPMib(FSNMPMibList[i]).Free; - FSNMPMibList.Clear; - FSNMPMibList.Free; - inherited Destroy; -end; - -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.DecryptPDU(const value: AnsiString): AnsiString; -var - des: TSynaDes; - des3: TSyna3Des; - aes: TSynaAes; - s: string; -begin - FPrivKey := ''; - if FFlags <> AuthPriv then - Result := value - else - begin - case FPrivMode of - Priv3DES: - begin - FPrivKey := Pass2Key(FPrivPassword); - FPrivKey := FPrivKey + Pass2Key(FPrivKey); - des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); - try - s := PadString(FPrivKey, 32, #0); - delete(s, 1, 24); - des3.SetIV(xorstring(s, FPrivSalt)); - s := des3.DecryptCBC(value); - Result := s; - finally - des3.free; - end; - end; - PrivAES: - begin - FPrivKey := Pass2Key(FPrivPassword); - aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); - try - s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; - aes.SetIV(s); - s := aes.DecryptCFBblock(value); - Result := s; - finally - aes.free; - end; - end; - else //PrivDES as default - begin - FPrivKey := Pass2Key(FPrivPassword); - des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); - try - s := PadString(FPrivKey, 16, #0); - delete(s, 1, 8); - des.SetIV(xorstring(s, FPrivSalt)); - s := des.DecryptCBC(value); - Result := s; - finally - des.free; - end; - end; - end; - end; -end; - -function TSNMPRec.DecodeBuf(Buffer: AnsiString): Boolean; -var - Pos: Integer; - EndPos: Integer; - sm, sv: AnsiString; - Svt: Integer; - s: AnsiString; - Spos: integer; - x: Byte; -begin - Clear; - Result := False; - if Length(Buffer) < 2 then - Exit; - if (Ord(Buffer[1]) and $20) = 0 then - Exit; - Pos := 2; - EndPos := ASNDecLen(Pos, Buffer); - if Length(Buffer) < (EndPos + 2) then - Exit; - Self.FVersion := 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); - FPrivSalt := ASNItem(SPos, s, Svt); - end; - //scopedPDU - if FFlags = AuthPriv then - begin - x := Pos; - s := ASNItem(Pos, Buffer, Svt); - if Svt <> ASN1_OCTSTR then - exit; - s := DecryptPDU(s); - //replace encoded content by decoded version and continue - Buffer := copy(Buffer, 1, x - 1); - Buffer := Buffer + s; - Pos := x; - if length(Buffer) < EndPos then - EndPos := length(buffer); - end; - ASNItem(Pos, Buffer, Svt); //skip sequence mark - 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 - ASNItem(Pos, Buffer, Svt); - Sm := ASNItem(Pos, Buffer, Svt); - Sv := ASNItem(Pos, Buffer, Svt); - if sm <> '' then - Self.MIBAdd(sm, sv, Svt); - end; - Result := True; -end; - -function TSNMPRec.EncryptPDU(const value: AnsiString): AnsiString; -var - des: TSynaDes; - des3: TSyna3Des; - aes: TSynaAes; - s: string; - x: integer; -begin - FPrivKey := ''; - if FFlags <> AuthPriv then - Result := Value - else - begin - case FPrivMode of - Priv3DES: - begin - FPrivKey := Pass2Key(FPrivPassword); - FPrivKey := FPrivKey + Pass2Key(FPrivKey); - des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0)); - try - s := PadString(FPrivKey, 32, #0); - delete(s, 1, 24); - FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); - inc(FPrivSaltCounter); - s := xorstring(s, FPrivSalt); - des3.SetIV(s); - x := length(value) mod 8; - x := 8 - x; - if x = 8 then - x := 0; - s := des3.EncryptCBC(value + Stringofchar(#0, x)); - Result := ASNObject(s, ASN1_OCTSTR); - finally - des3.free; - end; - end; - PrivAES: - begin - FPrivKey := Pass2Key(FPrivPassword); - aes := TSynaAes.Create(PadString(FPrivKey, 16, #0)); - try - FPrivSalt := CodeLongInt(0) + CodeLongInt(FPrivSaltCounter); - inc(FPrivSaltCounter); - s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt; - aes.SetIV(s); - s := aes.EncryptCFBblock(value); - Result := ASNObject(s, ASN1_OCTSTR); - finally - aes.free; - end; - end; - else //PrivDES as default - begin - FPrivKey := Pass2Key(FPrivPassword); - des := TSynaDes.Create(PadString(FPrivKey, 8, #0)); - try - s := PadString(FPrivKey, 16, #0); - delete(s, 1, 8); - FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter); - inc(FPrivSaltCounter); - s := xorstring(s, FPrivSalt); - des.SetIV(s); - x := length(value) mod 8; - x := 8 - x; - if x = 8 then - x := 0; - s := des.EncryptCBC(value + Stringofchar(#0, x)); - Result := ASNObject(s, ASN1_OCTSTR); - finally - des.free; - end; - end; - end; - end; -end; - -function TSNMPRec.EncodeBuf: AnsiString; -var - s: AnsiString; - SNMPMib: TSNMPMib; - n: Integer; - pdu, head, auth, authbeg: AnsiString; - x: Byte; -begin - pdu := ''; - for n := 0 to FSNMPMibList.Count - 1 do - begin - SNMPMib := TSNMPMib(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; - 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; - pdu := ASNObject(pdu, ASN1_SEQ); - //encrypt PDU if Priv mode is enabled - pdu := EncryptPDU(pdu); - - //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 - if FAuthEngineTimeStamp = 0 then //out of sync - x := 0 - else - 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(FPrivSalt, 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(FPrivSalt, 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; - inc(self.FID); -end; - -procedure TSNMPRec.Clear; -var - i: Integer; -begin - FVersion := SNMP_V1; - FCommunity := 'public'; - FUserName := ''; - 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 := ''; - FAuthEngineID := ''; - FAuthEngineBoots := 0; - FAuthEngineTime := 0; - FAuthEngineTimeStamp := 0; - FAuthKey := ''; - FPrivKey := ''; - FPrivSalt := ''; - FPrivSaltCounter := random(maxint); -end; - -procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer); -var - SNMPMib: TSNMPMib; -begin - SNMPMib := TSNMPMib.Create; - SNMPMib.OID := MIB; - SNMPMib.Value := Value; - SNMPMib.ValueType := ValueType; - FSNMPMibList.Add(SNMPMib); -end; - -procedure TSNMPRec.MIBDelete(Index: Integer); -begin - if (Index >= 0) and (Index < MIBCount) then - begin - TSNMPMib(FSNMPMibList[Index]).Free; - FSNMPMibList.Delete(Index); - end; -end; - -function TSNMPRec.MIBCount: integer; -begin - Result := FSNMPMibList.Count; -end; - -function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib; -begin - Result := nil; - if (Index >= 0) and (Index < MIBCount) then - Result := TSNMPMib(FSNMPMibList[Index]); -end; - -function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString; -var - i: Integer; -begin - Result := ''; - for i := 0 to MIBCount - 1 do - begin - if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then - begin - Result := (TSNMPMib(FSNMPMibList[i])).Value; - Break; - end; - end; -end; - -{==============================================================================} - -constructor TSNMPSend.Create; -begin - inherited Create; - FQuery := TSNMPRec.Create; - FReply := TSNMPRec.Create; - FQuery.Clear; - FReply.Clear; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FTargetPort := cSnmpProtocol; - FHostIP := ''; -end; - -destructor TSNMPSend.Destroy; -begin - FSock.Free; - FReply.Free; - FQuery.Free; - inherited Destroy; -end; - -function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean; -begin - 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 := Value.DecodeBuf(FBuffer); - end; -end; - -function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean; -begin - Result := False; - RValue.AuthMode := QValue.AuthMode; - RValue.Password := QValue.Password; - RValue.PrivMode := QValue.PrivMode; - RValue.PrivPassword := QValue.PrivPassword; - 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; - Result := InternalSendRequest(FQuery, 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.AuthMode := FQuery.AuthMode; - SyncQuery.PrivMode := FQuery.PrivMode; - SyncQuery.PrivPassword := FQuery.PrivPassword; - 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: AnsiString; var Value: AnsiString): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.Query.Clear; - SNMPSend.Query.Community := Community; - SNMPSend.Query.PDUType := PDUGetRequest; - SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL); - SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.SendRequest; - Value := ''; - if Result then - Value := SNMPSend.Reply.MIBGet(OID); - finally - SNMPSend.Free; - end; -end; - -function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.Query.Clear; - SNMPSend.Query.Community := Community; - SNMPSend.Query.PDUType := PDUSetRequest; - SNMPSend.Query.MIBAdd(OID, Value, ValueType); - SNMPSend.TargetHost := SNMPHost; - Result := SNMPSend.Sendrequest = True; - finally - SNMPSend.Free; - end; -end; - -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.Sendrequest; - Value := ''; - if Result then - if SNMPSend.Reply.SNMPMibList.Count > 0 then - begin - OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID; - Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value; - end; -end; - -function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; -var - SNMPSend: TSNMPSend; -begin - SNMPSend := TSNMPSend.Create; - try - SNMPSend.TargetHost := SNMPHost; - Result := InternalGetNext(SNMPSend, OID, Community, Value); - finally - SNMPSend.Free; - end; -end; - -function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean; -var - OID: AnsiString; - s: AnsiString; - col,row: String; - x: integer; - SNMPSend: TSNMPSend; - RowList: TStringList; -begin - Value.Clear; - SNMPSend := TSNMPSend.Create; - RowList := TStringList.Create; - try - SNMPSend.TargetHost := SNMPHost; - OID := BaseOID; - repeat - Result := InternalGetNext(SNMPSend, OID, Community, s); - if Pos(BaseOID, OID) <> 1 then - break; - row := separateright(oid, baseoid + '.'); - col := fetch(row, '.'); - - if IsBinaryString(s) then - s := StrToHex(s); - x := RowList.indexOf(Row); - if x < 0 then - begin - x := RowList.add(Row); - Value.Add(''); - end; - if (Value[x] <> '') then - Value[x] := Value[x] + ','; - Value[x] := Value[x] + AnsiQuotedStr(s, '"'); - until not result; - finally - SNMPSend.Free; - RowList.Free; - end; -end; - -function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean; -var - 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 - Result := 1; - 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/synapse/sntpsend.pas b/synapse/sntpsend.pas deleted file mode 100644 index 4aa0bbf..0000000 --- a/synapse/sntpsend.pas +++ /dev/null @@ -1,374 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.000.003 | -|==============================================================================| -| Content: SNTP client | -|==============================================================================| -| Copyright (c)1999-2010, 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)2000-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Patrick Chevalley | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract( NTP and SNTP client) - -Used RFC: RFC-1305, RFC-2030 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -unit sntpsend; - -interface - -uses - SysUtils, - synsock, blcksock, synautil; - -const - cNtpProtocol = '123'; - -type - - {:@abstract(Record containing the NTP packet.)} - TNtp = packed record - mode: Byte; - stratum: Byte; - poll: Byte; - Precision: Byte; - RootDelay: Longint; - RootDisperson: Longint; - RefID: Longint; - Ref1: Longint; - Ref2: Longint; - Org1: Longint; - Org2: Longint; - Rcv1: Longint; - Rcv2: Longint; - Xmit1: Longint; - 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; - FNTPTime: TDateTime; - FNTPOffset: double; - FNTPDelay: double; - FMaxSyncDiff: double; - FSyncTime: Boolean; - FSock: TUDPBlockSocket; - FBuffer: AnsiString; - 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; - -implementation - -constructor TSNTPSend.Create; -begin - inherited Create; - FSock := TUDPBlockSocket.Create; - FSock.Owner := self; - FTimeout := 5000; - FTargetPort := cNtpProtocol; - FMaxSyncDiff := 3600; - FSyncTime := False; -end; - -destructor TSNTPSend.Destroy; -begin - FSock.Free; - 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 - d := Nsec; - if d < 0 then - d := maxi + d + 1; - d1 := Nfrac; - if d1 < 0 then - d1 := maxi + d1 + 1; - d1 := d1 / maxi; - d1 := Trunc(d1 * 10000) / 10000; - Result := (d + d1) / 86400; - Result := Result + 2; -end; - -procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); -const - maxi = 4294967295.0; - maxilongint = 2147483647; -var - d, d1: Double; -begin - d := (dt - 2) * 86400; - d1 := frac(d); - if d > maxilongint then - d := d - maxi - 1; - d := trunc(d); - d1 := Trunc(d1 * 10000) / 10000; - d1 := d1 * maxi; - if d1 > maxilongint then - d1 := d1 - maxi - 1; - Nsec:=trunc(d); - Nfrac:=trunc(d1); -end; - -function TSNTPSend.GetBroadcastNTP: Boolean; -var - x: Integer; -begin - Result := False; - FSock.Bind(FIPInterface, FTargetPort); - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - x := Length(FBuffer); - if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then - if x >= SizeOf(NTPReply) then - begin - FNTPReply := StrToNTP(FBuffer); - FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end; - end; -end; - -function TSNTPSend.GetSNTP: Boolean; -var - q: TNtp; - x: Integer; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - ClearNtp(q); - q.mode := $1B; - 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 - FNTPReply := StrToNTP(FBuffer); - FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end; - end; -end; - -function TSNTPSend.GetNTP: Boolean; -var - q: TNtp; - x: Integer; - t1, t2, t3, t4 : TDateTime; -begin - Result := False; - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - ClearNtp(q); - q.mode := $1B; - t1 := GetUTTime; - EncodeTs(t1, q.org1, q.org2); - FBuffer := NTPtoStr(q); - FSock.SendString(FBuffer); - FBuffer := FSock.RecvPacket(FTimeout); - if FSock.LastError = 0 then - begin - x := Length(FBuffer); - t4 := GetUTTime; - if x >= SizeOf(NTPReply) then - begin - FNTPReply := StrToNTP(FBuffer); - FLi := (NTPReply.mode and $C0) shr 6; - FVn := (NTPReply.mode and $38) shr 3; - Fmode := NTPReply.mode and $07; - if (Fli < 3) and (Fmode = 4) and - (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and - (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) - then begin - t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); - t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); - FNTPDelay := (T4 - T1) - (T2 - T3); - FNTPTime := t3 + FNTPDelay / 2; - FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; - FNTPDelay := FNTPDelay * 86400; - if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then - SetUTTime(FNTPTime); - Result := True; - end - else result:=false; - end; - end; -end; - -end. diff --git a/synapse/ssdotnet.inc b/synapse/ssdotnet.inc deleted file mode 100644 index 8a54cd8..0000000 --- a/synapse/ssdotnet.inc +++ /dev/null @@ -1,1099 +0,0 @@ -{==============================================================================| -| 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, Classes, - 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; - TAddrFamily = AddressFamily; - -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; - -const - MSG_NOSIGNAL = 0; - INVALID_SOCKET = nil; - AF_UNSPEC = AddressFamily.Unspecified; - 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: integer): 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; - -function IsNewApi(Family: TAddrFamily): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; - -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: integer): 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.ToInt32(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 IsNewApi(Family: TAddrFamily): Boolean; -begin - Result := true; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -var - IPs: array of IPAddress; - n: integer; - ip4, ip6: string; - sip: string; -begin - sip := ''; - 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; - case Family of - AF_UNSPEC: - begin - if (ip4 <> '') and (ip6 <> '') then - begin - if PreferIP4 then - sip := ip4 - else - Sip := ip6; - end - else - begin - sip := ip4; - if (ip6 <> '') then - sip := ip6; - end; - end; - AF_INET: - sip := ip4; - AF_INET6: - sip := ip6; - end; - sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); -end; - -function GetSinIP(Sin: TVarSin): string; -begin - Result := Sin.Address.ToString; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - Result := Sin.Port; -end; - -procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; 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(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET)) - or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then - begin - IPList.Add(IPs[n].toString); - end; - end; -end; - -function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; -var - n: integer; -begin - Result := StrToIntDef(port, 0); - if Result = 0 then - begin - port := Lowercase(port); - for n := 0 to High(Services) do - if services[n, 0] = port then - begin - Result := strtointdef(services[n, 1], 0); - break; - end; - end; -end; - -function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; -begin - Result := Dns.GetHostByAddress(IP).HostName; -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/synapse/ssfpc.inc b/synapse/ssfpc.inc deleted file mode 100644 index 10a434c..0000000 --- a/synapse/ssfpc.inc +++ /dev/null @@ -1,909 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.004 | -|==============================================================================| -| Content: Socket Independent Platform Layer - FreePascal definition include | -|==============================================================================| -| Copyright (c)2006-2011, 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)2006-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF FPC} -{For FreePascal 2.x.x} - -//{$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 FreeBSD} -{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr -{$endif} -{$ifdef darwin} -{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr -{$endif} - -interface - -uses - SyncObjs, SysUtils, Classes, - synafpc, BaseUnix, Unix, termio, sockets, netdb; - -function InitSocketInterface(stack: string): Boolean; -function DestroySocketInterface: Boolean; - -const - DLLStackName = ''; - WinsockLevel = $0202; - - cLocalHost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - c6AnyHost = '::0'; - c6Localhost = '::1'; - cLocalHostStr = 'localhost'; - -type - TSocket = longint; - TAddrFamily = integer; - - TMemory = pointer; - - -type - TFDSet = Baseunix.TFDSet; - PFDSet = ^TFDSet; - Ptimeval = Baseunix.ptimeval; - Ttimeval = Baseunix.ttimeval; - -const - FIONREAD = termio.FIONREAD; - FIONBIO = termio.FIONBIO; - FIOASYNC = termio.FIOASYNC; - -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_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - PInAddr = ^TInAddr; - TInAddr = sockets.in_addr; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = sockets.TInetSockAddr; - - - TIP_mreq = record - imr_multiaddr: TInAddr; // IP multicast address of group - imr_interface: TInAddr; // local IP address of interface - end; - - - PInAddr6 = ^TInAddr6; - TInAddr6 = sockets.Tin6_addr; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = sockets.TInetSockAddr6; - - - TIPv6_mreq = record - ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: integer; // Interface index. - 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 = sockets.IP_TOS; { int; IP type of service and precedence. } - IP_TTL = sockets.IP_TTL; { int; IP time to live. } - IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } - IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } -// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } - IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } - IP_RETOPTS = sockets.IP_RETOPTS; { bool } -// IP_PKTINFO = sockets.IP_PKTINFO; { bool } -// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; -// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } -// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } -// IP_RECVERR = sockets.IP_RECVERR; { bool } -// IP_RECVTTL = sockets.IP_RECVTTL; { bool } -// IP_RECVTOS = sockets.IP_RECVTOS; { bool } - IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } - IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } - IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } - IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } - IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } - - SOL_SOCKET = sockets.SOL_SOCKET; - - SO_DEBUG = sockets.SO_DEBUG; - SO_REUSEADDR = sockets.SO_REUSEADDR; - SO_TYPE = sockets.SO_TYPE; - SO_ERROR = sockets.SO_ERROR; - SO_DONTROUTE = sockets.SO_DONTROUTE; - SO_BROADCAST = sockets.SO_BROADCAST; - SO_SNDBUF = sockets.SO_SNDBUF; - SO_RCVBUF = sockets.SO_RCVBUF; - SO_KEEPALIVE = sockets.SO_KEEPALIVE; - SO_OOBINLINE = sockets.SO_OOBINLINE; -// SO_NO_CHECK = sockets.SO_NO_CHECK; -// SO_PRIORITY = sockets.SO_PRIORITY; - SO_LINGER = sockets.SO_LINGER; -// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; -// SO_REUSEPORT = sockets.SO_REUSEPORT; -// SO_PASSCRED = sockets.SO_PASSCRED; -// SO_PEERCRED = sockets.SO_PEERCRED; - SO_RCVLOWAT = sockets.SO_RCVLOWAT; - SO_SNDLOWAT = sockets.SO_SNDLOWAT; - SO_RCVTIMEO = sockets.SO_RCVTIMEO; - SO_SNDTIMEO = sockets.SO_SNDTIMEO; -{ Security levels - as per NRL IPv6 - don't actually do anything } -// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; -// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; -// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; -// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; -{ Socket filtering } -// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; -// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; - - SOMAXCONN = 1024; - - IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; - IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; - IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; - IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; - IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; - IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; - -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 for manipulating linger option. } - PLinger = ^TLinger; - TLinger = packed record - l_onoff: integer; - l_linger: integer; - end; - -const - - MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. - MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. - {$ifdef DARWIN} - MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. - // Works under MAC OS X, but is undocumented, - // So FPC doesn't include it - {$else} - MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. - {$endif} - -const - WSAEINTR = ESysEINTR; - WSAEBADF = ESysEBADF; - WSAEACCES = ESysEACCES; - WSAEFAULT = ESysEFAULT; - WSAEINVAL = ESysEINVAL; - WSAEMFILE = ESysEMFILE; - WSAEWOULDBLOCK = ESysEWOULDBLOCK; - WSAEINPROGRESS = ESysEINPROGRESS; - WSAEALREADY = ESysEALREADY; - WSAENOTSOCK = ESysENOTSOCK; - WSAEDESTADDRREQ = ESysEDESTADDRREQ; - WSAEMSGSIZE = ESysEMSGSIZE; - WSAEPROTOTYPE = ESysEPROTOTYPE; - WSAENOPROTOOPT = ESysENOPROTOOPT; - WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; - WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; - WSAEOPNOTSUPP = ESysEOPNOTSUPP; - WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; - WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; - WSAEADDRINUSE = ESysEADDRINUSE; - WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; - WSAENETDOWN = ESysENETDOWN; - WSAENETUNREACH = ESysENETUNREACH; - WSAENETRESET = ESysENETRESET; - WSAECONNABORTED = ESysECONNABORTED; - WSAECONNRESET = ESysECONNRESET; - WSAENOBUFS = ESysENOBUFS; - WSAEISCONN = ESysEISCONN; - WSAENOTCONN = ESysENOTCONN; - WSAESHUTDOWN = ESysESHUTDOWN; - WSAETOOMANYREFS = ESysETOOMANYREFS; - WSAETIMEDOUT = ESysETIMEDOUT; - WSAECONNREFUSED = ESysECONNREFUSED; - WSAELOOP = ESysELOOP; - WSAENAMETOOLONG = ESysENAMETOOLONG; - WSAEHOSTDOWN = ESysEHOSTDOWN; - WSAEHOSTUNREACH = ESysEHOSTUNREACH; - WSAENOTEMPTY = ESysENOTEMPTY; - WSAEPROCLIM = -1; - WSAEUSERS = ESysEUSERS; - WSAEDQUOT = ESysEDQUOT; - WSAESTALE = ESysESTALE; - WSAEREMOTE = ESysEREMOTE; - WSASYSNOTREADY = -2; - WSAVERNOTSUPPORTED = -3; - WSANOTINITIALISED = -4; - WSAEDISCON = -5; - WSAHOST_NOT_FOUND = 1; - WSATRY_AGAIN = 2; - WSANO_RECOVERY = 3; - WSANO_DATA = -6; - -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); - -{=============================================================================} - -var - SynSockCS: SyncObjs.TCriticalSection; - SockEnhancedApi: Boolean; - SockWship6Api: Boolean; - -type - TVarSin = packed record - {$ifdef SOCK_HAS_SINLEN} - sin_len : cuchar; - {$endif} - case integer of - 0: (AddressFamily: sa_family_t); - 1: ( - case sin_family: sa_family_t of - AF_INET: (sin_port: word; - sin_addr: TInAddr; - sin_zero: array[0..7] of Char); - AF_INET6: (sin6_port: word; - sin6_flowinfo: longword; - sin6_addr: TInAddr6; - sin6_scope_id: longword); - ); - end; - -function SizeOfVarSin(sin: TVarSin): integer; - - function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; - function WSACleanup: Integer; - function WSAGetLastError: Integer; - function GetHostName: string; - function Shutdown(s: TSocket; how: Integer): Integer; - function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - optlen: Integer): Integer; - function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; - var optlen: Integer): 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: word): word; - function ntohl(netlong: longword): longword; - function Listen(s: TSocket; backlog: Integer): Integer; - function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; - function htons(hostshort: word): word; - function htonl(hostlong: longword): longword; - function GetSockName(s: TSocket; var name: TVarSin): Integer; - function GetPeerName(s: TSocket; var name: TVarSin): Integer; - function Connect(s: TSocket; const name: TVarSin): Integer; - function CloseSocket(s: TSocket): Integer; - function Bind(s: TSocket; const addr: TVarSin): Integer; - function Accept(s: TSocket; var addr: TVarSin): TSocket; - function Socket(af, Struc, Protocol: Integer): TSocket; - function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; - - -{==============================================================================} -implementation - - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $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^.u6_addr8[15] := 1; -end; - -{=============================================================================} - -function WSAStartup(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 Unix/Linux by FreePascal'; - iMaxSockets := 32768; - iMaxUdpDg := 8192; - end; - Result := 0; -end; - -function WSACleanup: Integer; -begin - Result := 0; -end; - -function WSAGetLastError: Integer; -begin - Result := fpGetErrno; -end; - -function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; -begin - Result := fpFD_ISSET(socket, fdset) <> 0; -end; - -procedure FD_SET(Socket: TSocket; var fdset: TFDSet); -begin - fpFD_SET(Socket, fdset); -end; - -procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); -begin - fpFD_CLR(Socket, fdset); -end; - -procedure FD_ZERO(var fdset: TFDSet); -begin - fpFD_ZERO(fdset); -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 - if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function Connect(s: TSocket; const name: TVarSin): Integer; -begin - if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function GetSockName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := fpGetSockName(s, @name, @Len); -end; - -function GetPeerName(s: TSocket; var name: TVarSin): Integer; -var - len: integer; -begin - len := SizeOf(name); - FillChar(name, len, 0); - Result := fpGetPeerName(s, @name, @Len); -end; - -function GetHostName: string; -begin - Result := unix.GetHostName; -end; - -function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := fpSend(s, pointer(Buf), len, flags); -end; - -function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; -begin - Result := fpRecv(s, pointer(Buf), len, flags); -end; - -function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; -begin - Result := fpSendTo(s, pointer(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 := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x); -end; - -function Accept(s: TSocket; var addr: TVarSin): TSocket; -var - x: integer; -begin - x := SizeOf(addr); - Result := fpAccept(s, @addr, @x); -end; - -function Shutdown(s: TSocket; how: Integer): Integer; -begin - Result := fpShutdown(s, how); -end; - -function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - optlen: Integer): Integer; -begin - Result := fpsetsockopt(s, level, optname, pointer(optval), optlen); -end; - -function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; - var optlen: Integer): Integer; -begin - Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen); -end; - -function ntohs(netshort: word): word; -begin - Result := sockets.ntohs(NetShort); -end; - -function ntohl(netlong: longword): longword; -begin - Result := sockets.ntohl(NetLong); -end; - -function Listen(s: TSocket; backlog: Integer): Integer; -begin - if fpListen(s, backlog) = 0 then - Result := 0 - else - Result := SOCKET_ERROR; -end; - -function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; -begin - Result := fpIoctl(s, cmd, @arg); -end; - -function htons(hostshort: word): word; -begin - Result := sockets.htons(Hostshort); -end; - -function htonl(hostlong: longword): longword; -begin - Result := sockets.htonl(HostLong); -end; - -function CloseSocket(s: TSocket): Integer; -begin - Result := sockets.CloseSocket(s); -end; - -function Socket(af, Struc, Protocol: Integer): TSocket; -begin - Result := fpSocket(af, struc, protocol); -end; - -function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; - timeout: PTimeVal): Longint; -begin - Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); -end; - -{=============================================================================} -function IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -var - TwoPass: boolean; - f1, f2: integer; - - function GetAddr(f:integer): integer; - var - a4: array [1..1] of in_addr; - a6: array [1..1] of Tin6_addr; - he: THostEntry; - begin - Result := WSAEPROTONOSUPPORT; - case f of - AF_INET: - begin - if IP = cAnyHost then - begin - Sin.sin_family := AF_INET; - Result := 0; - end - else - begin - if lowercase(IP) = cLocalHostStr then - a4[1].s_addr := htonl(INADDR_LOOPBACK) - else - begin - a4[1].s_addr := 0; - Result := WSAHOST_NOT_FOUND; - a4[1] := StrTonetAddr(IP); - if a4[1].s_addr = INADDR_ANY then - if GetHostByName(ip, he) then - a4[1]:=HostToNet(he.Addr) - else - Resolvename(ip, a4); - end; - if a4[1].s_addr <> INADDR_ANY then - begin - Sin.sin_family := AF_INET; - sin.sin_addr := a4[1]; - Result := 0; - end; - end; - end; - AF_INET6: - begin - if IP = c6AnyHost then - begin - Sin.sin_family := AF_INET6; - Result := 0; - end - else - begin - if lowercase(IP) = cLocalHostStr then - SET_LOOPBACK_ADDR6(@a6[1]) - else - begin - Result := WSAHOST_NOT_FOUND; - SET_IN6_IF_ADDR_ANY(@a6[1]); - a6[1] := StrTonetAddr6(IP); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - Resolvename6(ip, a6); - end; - if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - begin - Sin.sin_family := AF_INET6; - sin.sin6_addr := a6[1]; - Result := 0; - end; - end; - end; - end; - end; -begin - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 then - begin - f1 := AF_INET; - f2 := AF_INET6; - TwoPass := True; - end - else - begin - f2 := AF_INET; - f1 := AF_INET6; - TwoPass := True; - end; - end - else - f1 := Family; - Result := GetAddr(f1); - if Result <> 0 then - if TwoPass then - Result := GetAddr(f2); -end; - -function GetSinIP(Sin: TVarSin): string; -begin - Result := ''; - case sin.AddressFamily of - AF_INET: - begin - result := NetAddrToStr(sin.sin_addr); - end; - AF_INET6: - begin - result := NetAddrToStr6(sin.sin6_addr); - end; - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -var - x, n: integer; - a4: array [1..255] of in_addr; - a6: array [1..255] of Tin6_addr; - he: THostEntry; -begin - IPList.Clear; - if (family = AF_INET) or (family = AF_UNSPEC) then - begin - if lowercase(name) = cLocalHostStr then - IpList.Add(cLocalHost) - else - begin - a4[1] := StrTonetAddr(name); - if a4[1].s_addr = INADDR_ANY then - if GetHostByName(name, he) then - begin - a4[1]:=HostToNet(he.Addr); - x := 1; - end - else - x := Resolvename(name, a4) - else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr(a4[n])); - end; - end; - - if (family = AF_INET6) or (family = AF_UNSPEC) then - begin - if lowercase(name) = cLocalHostStr then - IpList.Add(c6LocalHost) - else - begin - a6[1] := StrTonetAddr6(name); - if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then - x := Resolvename6(name, a6) - else - x := 1; - for n := 1 to x do - IpList.Add(netaddrToStr6(a6[n])); - end; - end; - - if IPList.Count = 0 then - IPList.Add(cLocalHost); -end; - -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: TProtocolEntry; - ServEnt: TServiceEntry; -begin - Result := synsock.htons(StrToIntDef(Port, 0)); - if Result = 0 then - begin - ProtoEnt.Name := ''; - GetProtocolByNumber(SockProtocol, ProtoEnt); - ServEnt.port := 0; - GetServiceByName(Port, ProtoEnt.Name, ServEnt); - Result := ServEnt.port; - end; -end; - -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -var - n: integer; - a4: array [1..1] of in_addr; - a6: array [1..1] of Tin6_addr; - a: array [1..1] of string; -begin - Result := IP; - a4[1] := StrToNetAddr(IP); - if a4[1].s_addr <> INADDR_ANY then - begin -//why ResolveAddress need address in HOST order? :-O - n := ResolveAddress(nettohost(a4[1]), a); - if n > 0 then - Result := a[1]; - end - else - begin - a6[1] := StrToNetAddr6(IP); - n := ResolveAddress6(a6[1], a); - if n > 0 then - Result := a[1]; - end; -end; - -{=============================================================================} - -function InitSocketInterface(stack: string): Boolean; -begin - SockEnhancedApi := False; - SockWship6Api := False; -// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); - Result := True; -end; - -function DestroySocketInterface: Boolean; -begin - 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/synapse/ssl_cryptlib.pas b/synapse/ssl_cryptlib.pas deleted file mode 100644 index b9be4de..0000000 --- a/synapse/ssl_cryptlib.pas +++ /dev/null @@ -1,677 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.000 | -|==============================================================================| -| Content: SSL/SSH support by Peter Gutmann's CryptLib | -|==============================================================================| -| Copyright (c)1999-2012, 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)2005-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL/SSH plugin for CryptLib) - -This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32 -and Linux. This library is staticly linked - when you compile your application -with this plugin, you MUST distribute it with Cryptib library, otherwise you -cannot run your application! - -It can work with keys and certificates stored as PKCS#15 only! It must be stored -as disk file only, you cannot load them from memory! Each file can hold multiple -keys and certificates. You must identify it by 'label' stored in -@link(TSSLCryptLib.PrivateKeyLabel). - -If you need to use secure connection and authorize self by certificate -(each SSL/TLS server or client with client authorization), then use -@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and -@link(TCustomSSL.KeyPassword) properties. - -If you need to use server what verifying client certificates, then use -@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients -with non-matching certificates will be rejected by cryptLib. - -This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS -server without explicitly assigned key and certificate, then this plugin create -Ad-Hoc key and certificate for each incomming connection by self. It slowdown -accepting of new connections! - -You can use this plugin for SSHv2 connections too! You must explicitly set -@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username) -and @link(TCustomSSL.password). You can use special SSH channels too, see -@link(TCustomSSL). -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_cryptlib; - -interface - -uses - Windows, - SysUtils, - blcksock, synsock, synautil, synacode, - cryptlib; - -type - {:@abstract(class implementing CryptLib SSL/SSH plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLCryptLib = class(TCustomSSL) - protected - FCryptSession: CRYPT_SESSION; - FPrivateKeyLabel: string; - FDelCert: Boolean; - FReadBuffer: string; - FTrustedCAs: array of integer; - function SSLCheck(Value: integer): Boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; - function CreateSelfSignedCert(Host: string): Boolean; override; - function PopAll: string; - public - {:See @inherited} - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:Load trusted CA's in PEM format} - procedure SetCertCAFile(const Value: string); override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited} - procedure Assign(const Value: TCustomSSL); override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetVerifyCert: integer; override; - published - {:name of certificate/key within PKCS#15 file. It can hold more then one - certificate/key and each certificate/key must have unique label within one file.} - property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel; - end; - -implementation - -{==============================================================================} - -constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - FPrivateKeyLabel := 'synapse'; - FDelCert := false; - FTrustedCAs := nil; -end; - -destructor TSSLCryptLib.Destroy; -begin - SetCertCAFile(''); // destroy certificates - DeInit; - inherited Destroy; -end; - -procedure TSSLCryptLib.Assign(const Value: TCustomSSL); -begin - inherited Assign(Value); - if Value is TSSLCryptLib then - begin - FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel; - end; -end; - -function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; -var - l: integer; -begin - l := 0; - cryptGetAttributeString(cryptHandle, attributeType, nil, l); - setlength(Result, l); - cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l); - setlength(Result, l); -end; - -function TSSLCryptLib.LibVersion: String; -var - x: integer; -begin - Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x); - Result := Result + ' v' + IntToStr(x); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x); - Result := Result + '.' + IntToStr(x); - cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x); - Result := Result + '.' + IntToStr(x); -end; - -function TSSLCryptLib.LibName: String; -begin - Result := 'ssl_cryptlib'; -end; - -function TSSLCryptLib.SSLCheck(Value: integer): Boolean; -begin - Result := true; - FLastErrorDesc := ''; - if Value = CRYPT_ERROR_COMPLETE then - Value := 0; - FLastError := Value; - if FLastError <> 0 then - begin - Result := False; -{$IF CRYPTLIB_VERSION >= 3400} - FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE); -{$ELSE} - FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE); -{$IFEND} - end; -end; - -function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean; -var - privateKey: CRYPT_CONTEXT; - keyset: CRYPT_KEYSET; - cert: CRYPT_CERTIFICATE; - publicKey: CRYPT_CONTEXT; -begin - if FPrivatekeyFile = '' then - FPrivatekeyFile := GetTempFile('', 'key'); - cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA); - cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel), - Length(FPrivatekeyLabel)); - cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024); - cryptGenerateKey(privateKey); - cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE); - FDelCert := True; - cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword)); - cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE); - cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1); - cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel)); - cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey); - cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host)); - cryptSignCert(cert, privateKey); - cryptAddPublicKey(keyset, cert); - cryptKeysetClose(keyset); - cryptDestroyCert(cert); - cryptDestroyContext(privateKey); - cryptDestroyContext(publicKey); - Result := True; -end; - -function TSSLCryptLib.PopAll: string; -const - BufferMaxSize = 32768; -var - Outbuffer: string; - WriteLen: integer; -begin - Result := ''; - repeat - setlength(outbuffer, BufferMaxSize); - Writelen := 0; - SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); - if FLastError <> 0 then - Break; - if WriteLen > 0 then - begin - setlength(outbuffer, WriteLen); - Result := Result + outbuffer; - end; - until WriteLen = 0; -end; - -function TSSLCryptLib.Init(server:Boolean): Boolean; -var - st: CRYPT_SESSION_TYPE; - keysetobj: CRYPT_KEYSET; - cryptContext: CRYPT_CONTEXT; - x: integer; -begin - Result := False; - FLastErrorDesc := ''; - FLastError := 0; - FDelCert := false; - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - if server then - case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: - st := CRYPT_SESSION_SSL_SERVER; - LT_SSHv2: - st := CRYPT_SESSION_SSH_SERVER; - else - Exit; - end - else - case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: - st := CRYPT_SESSION_SSL; - LT_SSHv2: - st := CRYPT_SESSION_SSH; - else - Exit; - end; - if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then - Exit; - x := -1; - case FSSLType of - LT_SSLv3: - x := 0; - LT_TLSv1: - x := 1; - LT_TLSv1_1: - x := 2; - end; - if x >= 0 then - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then - Exit; - - if (FCertComplianceLevel <> -1) then - if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL, - FCertComplianceLevel)) then - Exit; - - if FUsername <> '' then - begin - cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, - Pointer(FUsername), Length(FUsername)); - cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, - Pointer(FPassword), Length(FPassword)); - end; - if FSSLType = LT_SSHv2 then - if FSSHChannelType <> '' then - begin - cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED); - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE, - Pointer(FSSHChannelType), Length(FSSHChannelType)); - if FSSHChannelArg1 <> '' then - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1, - Pointer(FSSHChannelArg1), Length(FSSHChannelArg1)); - if FSSHChannelArg2 <> '' then - cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2, - Pointer(FSSHChannelArg2), Length(FSSHChannelArg2)); - end; - - - if server and (FPrivatekeyFile = '') then - begin - if FPrivatekeyLabel = '' then - FPrivatekeyLabel := 'synapse'; - if FkeyPassword = '' then - FkeyPassword := 'synapse'; - CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); - end; - - if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then - begin - if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, - PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then - Exit; - try - if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME, - PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then - Exit; - if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY, - cryptcontext)) then - Exit; - finally - cryptKeysetClose(keySetObj); - cryptDestroyContext(cryptcontext); - end; - end; - if server and FVerifyCert then - begin - if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, - PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then - Exit; - try - if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET, - keySetObj)) then - Exit; - finally - cryptKeysetClose(keySetObj); - end; - end; - Result := true; -end; - -function TSSLCryptLib.DeInit: Boolean; -begin - Result := True; - if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then - CryptDestroySession(FcryptSession); - FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); - FSSLEnabled := False; - if FDelCert then - SysUtils.DeleteFile(FPrivatekeyFile); -end; - -function TSSLCryptLib.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLCryptLib.Connect: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(false) then - begin - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then - Exit; - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then - Exit; - if FverifyCert then - if (GetVerifyCert <> 0) or (not DoVerifyCert) then - Exit; - FSSLEnabled := True; - Result := True; - FReadBuffer := ''; - end; -end; - -function TSSLCryptLib.Accept: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(true) then - begin - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then - Exit; - if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then - Exit; - FSSLEnabled := True; - Result := True; - FReadBuffer := ''; - end; -end; - -function TSSLCryptLib.Shutdown: boolean; -begin - Result := BiShutdown; -end; - -function TSSLCryptLib.BiShutdown: boolean; -begin - if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then - cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); - DeInit; - FReadBuffer := ''; - Result := True; -end; - -function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - FLastError := 0; - FLastErrorDesc := ''; - SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L)); - cryptFlushData(FcryptSession); - Result := l; -end; - -function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -begin - FLastError := 0; - FLastErrorDesc := ''; - if Length(FReadBuffer) = 0 then - FReadBuffer := PopAll; - if Len > Length(FReadBuffer) then - Len := Length(FReadBuffer); - Move(Pointer(FReadBuffer)^, buffer^, Len); - Delete(FReadBuffer, 1, Len); - Result := Len; -end; - -function TSSLCryptLib.WaitingData: Integer; -begin - Result := Length(FReadBuffer); -end; - -function TSSLCryptLib.GetSSLVersion: string; -var - x: integer; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x); - if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then - case x of - 0: - Result := 'SSLv3'; - 1: - Result := 'TLSv1'; - 2: - Result := 'TLSv1.1'; - end; - if FSSLType in [LT_SSHv2] then - case x of - 0: - Result := 'SSHv1'; - 1: - Result := 'SSHv2'; - end; -end; - -function TSSLCryptLib.GetPeerSubject: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); - Result := GetString(cert, CRYPT_CERTINFO_DN); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerName: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); - Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerIssuer: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME); - Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); - cryptDestroyCert(cert); -end; - -function TSSLCryptLib.GetPeerFingerprint: string; -var - cert: CRYPT_CERTIFICATE; -begin - Result := ''; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT); - cryptDestroyCert(cert); -end; - - -procedure TSSLCryptLib.SetCertCAFile(const Value: string); - -var F:textfile; - bInCert:boolean; - s,sCert:string; - cert: CRYPT_CERTIFICATE; - idx:integer; - -begin -if assigned(FTrustedCAs) then - begin - for idx := 0 to High(FTrustedCAs) do - cryptDestroyCert(FTrustedCAs[idx]); - FTrustedCAs:=nil; - end; -if Value<>'' then - begin - AssignFile(F,Value); - reset(F); - bInCert:=false; - idx:=0; - while not eof(F) do - begin - readln(F,s); - if pos('-----END CERTIFICATE-----',s)>0 then - begin - bInCert:=false; - cert:=0; - if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then - begin - cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 ); - SetLength(FTrustedCAs,idx+1); - FTrustedCAs[idx]:=cert; - idx:=idx+1; - end; - end; - if bInCert then - sCert:=sCert+s+#13#10; - if pos('-----BEGIN CERTIFICATE-----',s)>0 then - begin - bInCert:=true; - sCert:=''; - end; - end; - CloseFile(F); - end; -end; - -function TSSLCryptLib.GetVerifyCert: integer; -var - cert: CRYPT_CERTIFICATE; - itype,ilocus:integer; -begin - Result := -1; - if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then - Exit; - cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); - result:=cryptCheckCert(cert,CRYPT_UNUSED); - if result<>CRYPT_OK then - begin - //get extended error info if available - cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype); - cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus); - cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME); - FLastError := Result; - FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.', - [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]); - end; - cryptDestroyCert(cert); -end; - -{==============================================================================} - -var imajor,iminor,iver:integer; -// e: ESynapseError; - -initialization - if cryptInit = CRYPT_OK then - SSLImplementation := TSSLCryptLib; - cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL); - cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor); - cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor); -// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits - if CRYPTLIB_VERSION >1000 then - iver:=CRYPTLIB_VERSION div 100 - else - iver:=CRYPTLIB_VERSION div 10; - if (iver <> imajor*10+iminor) then - begin - SSLImplementation :=TSSLNone; -// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ', -// [imajor,iminor,iver div 10, iver mod 10])); -// e.ErrorCode := 0; -// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)', -// [imajor,iminor,iver div 10, iver mod 10]); -// raise e; - end; -finalization - cryptEnd; -end. - - diff --git a/synapse/ssl_openssl.pas b/synapse/ssl_openssl.pas deleted file mode 100644 index ea4fee6..0000000 --- a/synapse/ssl_openssl.pas +++ /dev/null @@ -1,896 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.000 | -|==============================================================================| -| Content: SSL support by OpenSSL | -|==============================================================================| -| Copyright (c)1999-2008, 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)2005-2012. | -| Portions created by Petr Fejfar are Copyright (c)2011-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -//requires OpenSSL libraries! - -{:@abstract(SSL plugin for OpenSSL) - -You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but -application mysteriously crashing when you are using freePascal on Linux. -Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see -any problems with FreePascal. - -OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you -compile your application with this unit. SSL just not working when you not have -OpenSSL libraries. - -This plugin have limited support for .NET too! Because is not possible to use -callbacks with CDECL calling convention under .NET, is not supported -key/certificate passwords and multithread locking. :-( - -For handling keys and certificates you can use this properties: - -@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br -@link(TCustomSSL.Certificate) for ASN1 DER format only. @br -@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br -@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br -@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br -@link(TCustomSSL.PFXFile) for PFX format. @br -@link(TCustomSSL.PFX) for PFX format from binary string. @br - -This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS -server without explicitly assigned key and certificate, then this plugin create -Ad-Hoc key and certificate for each incomming connection by self. It slowdown -accepting of new connections! -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit ssl_openssl; - -interface - -uses - SysUtils, Classes, - blcksock, synsock, synautil, -{$IFDEF CIL} - System.Text, -{$ENDIF} - ssl_openssl_lib; - -type - {:@abstract(class implementing OpenSSL SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLOpenSSL = class(TCustomSSL) - protected - FSsl: PSSL; - Fctx: PSSL_CTX; - function SSLCheck: Boolean; - function SetSslKeys: boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - function LoadPFX(pfxdata: ansistring): Boolean; - function CreateSelfSignedCert(Host: string): Boolean; override; - public - {:See @inherited} - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_cryptlib) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerSerialNo: integer; override; {pf} - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerNameHash: cardinal; override; {pf} - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - {:See @inherited} - function GetCipherName: string; override; - {:See @inherited} - function GetCipherBits: integer; override; - {:See @inherited} - function GetCipherAlgBits: integer; override; - {:See @inherited} - function GetVerifyCert: integer; override; - end; - -implementation - -{==============================================================================} - -{$IFNDEF CIL} -function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl; -var - Password: AnsiString; -begin - Password := ''; - if TCustomSSL(userdata) is TCustomSSL then - Password := TCustomSSL(userdata).KeyPassword; - if Length(Password) > (Size - 1) then - SetLength(Password, Size - 1); - Result := Length(Password); - StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); -end; -{$ENDIF} - -{==============================================================================} - -constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FCiphers := 'DEFAULT'; - FSsl := nil; - Fctx := nil; -end; - -destructor TSSLOpenSSL.Destroy; -begin - DeInit; - inherited Destroy; -end; - -function TSSLOpenSSL.LibVersion: String; -begin - Result := SSLeayversion(0); -end; - -function TSSLOpenSSL.LibName: String; -begin - Result := 'ssl_openssl'; -end; - -function TSSLOpenSSL.SSLCheck: Boolean; -var -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} - s : AnsiString; -begin - Result := true; - FLastErrorDesc := ''; - FLastError := ErrGetError; - ErrClearError; - if FLastError <> 0 then - begin - Result := False; -{$IFDEF CIL} - sb := StringBuilder.Create(256); - ErrErrorString(FLastError, sb, 256); - FLastErrorDesc := Trim(sb.ToString); -{$ELSE} - s := StringOfChar(#0, 256); - ErrErrorString(FLastError, s, Length(s)); - FLastErrorDesc := s; -{$ENDIF} - end; -end; - -function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean; -var - pk: EVP_PKEY; - x: PX509; - rsa: PRSA; - t: PASN1_UTCTIME; - name: PX509_NAME; - b: PBIO; - xn, y: integer; - s: AnsiString; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - Result := True; - pk := EvpPkeynew; - x := X509New; - try - rsa := RsaGenerateKey(1024, $10001, nil, nil); - EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); - X509SetVersion(x, 2); - Asn1IntegerSet(X509getSerialNumber(x), 0); - t := Asn1UtctimeNew; - try - X509GmtimeAdj(t, -60 * 60 *24); - X509SetNotBefore(x, t); - X509GmtimeAdj(t, 60 * 60 * 60 *24); - X509SetNotAfter(x, t); - finally - Asn1UtctimeFree(t); - end; - X509SetPubkey(x, pk); - Name := X509GetSubjectName(x); - X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0); - X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0); - x509SetIssuerName(x, Name); - x509Sign(x, pk, EvpGetDigestByName('SHA1')); - b := BioNew(BioSMem); - try - i2dX509Bio(b, x); - xn := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(xn); - y := bioread(b, sb, xn); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; - end; -{$ELSE} - setlength(s, xn); - y := bioread(b, s, xn); - if y > 0 then - setlength(s, y); -{$ENDIF} - finally - BioFreeAll(b); - end; - FCertificate := s; - b := BioNew(BioSMem); - try - i2dPrivatekeyBio(b, pk); - xn := bioctrlpending(b); -{$IFDEF CIL} - sb := StringBuilder.Create(xn); - y := bioread(b, sb, xn); - if y > 0 then - begin - sb.Length := y; - s := sb.ToString; - end; -{$ELSE} - setlength(s, xn); - y := bioread(b, s, xn); - if y > 0 then - setlength(s, y); -{$ENDIF} - finally - BioFreeAll(b); - end; - FPrivatekey := s; - finally - X509free(x); - EvpPkeyFree(pk); - end; -end; - -function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean; -var - cert, pkey, ca: SslPtr; - b: PBIO; - p12: SslPtr; -begin - Result := False; - b := BioNew(BioSMem); - try - BioWrite(b, pfxdata, Length(PfxData)); - p12 := d2iPKCS12bio(b, nil); - if not Assigned(p12) then - Exit; - try - cert := nil; - pkey := nil; - ca := nil; - try {pf} - if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then - if SSLCTXusecertificate(Fctx, cert) > 0 then - if SSLCTXusePrivateKey(Fctx, pkey) > 0 then - Result := True; - {pf} - finally - EvpPkeyFree(pkey); - X509free(cert); - SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated... - end; - {/pf} - finally - PKCS12free(p12); - end; - finally - BioFreeAll(b); - end; -end; - -function TSSLOpenSSL.SetSslKeys: boolean; -var - st: TFileStream; - s: string; -begin - Result := False; - if not assigned(FCtx) then - Exit; - try - if FCertificateFile <> '' then - if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then - if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then - if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then - Exit; - if FCertificate <> '' then - if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then - Exit; - SSLCheck; - if FPrivateKeyFile <> '' then - if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then - if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then - Exit; - if FPrivateKey <> '' then - if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then - Exit; - SSLCheck; - if FCertCAFile <> '' then - if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then - Exit; - if FPFXfile <> '' then - begin - try - st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone); - try - s := ReadStrFromStream(st, st.Size); - finally - st.Free; - end; - if not LoadPFX(s) then - Exit; - except - on Exception do - Exit; - end; - end; - if FPFX <> '' then - if not LoadPFX(FPfx) then - Exit; - SSLCheck; - Result := True; - finally - SSLCheck; - end; -end; - -function TSSLOpenSSL.Init(server:Boolean): Boolean; -var - s: AnsiString; -begin - Result := False; - FLastErrorDesc := ''; - FLastError := 0; - Fctx := nil; - case FSSLType of - LT_SSLv2: - Fctx := SslCtxNew(SslMethodV2); - LT_SSLv3: - Fctx := SslCtxNew(SslMethodV3); - LT_TLSv1: - Fctx := SslCtxNew(SslMethodTLSV1); - LT_all: - Fctx := SslCtxNew(SslMethodV23); - else - Exit; - end; - if Fctx = nil then - begin - SSLCheck; - Exit; - end - else - begin - s := FCiphers; - SslCtxSetCipherList(Fctx, s); - if FVerifyCert then - SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) - else - SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); -{$IFNDEF CIL} - SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); - SslCtxSetDefaultPasswdCbUserdata(FCtx, self); -{$ENDIF} - - if server and (FCertificateFile = '') and (FCertificate = '') - and (FPFXfile = '') and (FPFX = '') then - begin - CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); - end; - - if not SetSSLKeys then - Exit - else - begin - Fssl := nil; - Fssl := SslNew(Fctx); - if Fssl = nil then - begin - SSLCheck; - exit; - end; - end; - end; - Result := true; -end; - -function TSSLOpenSSL.DeInit: Boolean; -begin - Result := True; - if assigned (Fssl) then - sslfree(Fssl); - Fssl := nil; - if assigned (Fctx) then - begin - SslCtxFree(Fctx); - Fctx := nil; - ErrRemoveState(0); - end; - FSSLEnabled := False; -end; - -function TSSLOpenSSL.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLOpenSSL.Connect: boolean; -var - x: integer; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(False) then - begin -{$IFDEF CIL} - if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket.Socket) < 1 then -{$ENDIF} - begin - SSLCheck; - Exit; - end; - if SNIHost<>'' then - SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(SNIHost)); - x := sslconnect(FSsl); - if x < 1 then - begin - SSLcheck; - Exit; - end; - if FverifyCert then - if (GetVerifyCert <> 0) or (not DoVerifyCert) then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLOpenSSL.Accept: boolean; -var - x: integer; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(True) then - begin -{$IFDEF CIL} - if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then -{$ELSE} - if sslsetfd(FSsl, FSocket.Socket) < 1 then -{$ENDIF} - begin - SSLCheck; - Exit; - end; - x := sslAccept(FSsl); - if x < 1 then - begin - SSLcheck; - Exit; - end; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLOpenSSL.Shutdown: boolean; -begin - if assigned(FSsl) then - sslshutdown(FSsl); - DeInit; - Result := True; -end; - -function TSSLOpenSSL.BiShutdown: boolean; -var - x: integer; -begin - if assigned(FSsl) then - begin - x := sslshutdown(FSsl); - if x = 0 then - begin - Synsock.Shutdown(FSocket.Socket, 1); - sslshutdown(FSsl); - end; - end; - DeInit; - Result := True; -end; - -function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - err: integer; -{$IFDEF CIL} - s: ansistring; -{$ENDIF} -begin - FLastError := 0; - FLastErrorDesc := ''; - repeat -{$IFDEF CIL} - s := StringOf(Buffer); - Result := SslWrite(FSsl, s, Len); -{$ELSE} - Result := SslWrite(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 - Result := 0 - else - if (err <> 0) then - FLastError := err; -end; - -function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - err: integer; -{$IFDEF CIL} - sb: stringbuilder; - s: ansistring; -{$ENDIF} -begin - FLastError := 0; - FLastErrorDesc := ''; - repeat -{$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 - Result := 0 - {pf}// Verze 1.1.0 byla s else tak jak to ted mam, - // ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN - // propagovano jako Chyba. - {pf} else {/pf} if (err <> 0) then - FLastError := err; -end; - -function TSSLOpenSSL.WaitingData: Integer; -begin - Result := sslpending(Fssl); -end; - -function TSSLOpenSSL.GetSSLVersion: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SSlGetVersion(FSsl); -end; - -function TSSLOpenSSL.GetPeerSubject: string; -var - cert: PX509; - s: ansistring; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(4096); - Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s)); -{$ENDIF} - X509Free(cert); -end; - - -function TSSLOpenSSL.GetPeerSerialNo: integer; {pf} -var - cert: PX509; - SN: PASN1_INTEGER; -begin - if not assigned(FSsl) then - begin - Result := -1; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - try - if not assigned(cert) then - begin - Result := -1; - Exit; - end; - SN := X509GetSerialNumber(cert); - Result := Asn1IntegerGet(SN); - finally - X509Free(cert); - end; -end; - -function TSSLOpenSSL.GetPeerName: string; -var - s: ansistring; -begin - s := GetPeerSubject; - s := SeparateRight(s, '/CN='); - Result := Trim(SeparateLeft(s, '/')); -end; - -function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf} -var - cert: PX509; -begin - if not assigned(FSsl) then - begin - Result := 0; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - try - if not assigned(cert) then - begin - Result := 0; - Exit; - end; - Result := X509NameHash(X509GetSubjectName(cert)); - finally - X509Free(cert); - end; -end; - -function TSSLOpenSSL.GetPeerIssuer: string; -var - cert: PX509; - s: ansistring; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(4096); - Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096); -{$ELSE} - setlength(s, 4096); - Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s)); -{$ENDIF} - X509Free(cert); -end; - -function TSSLOpenSSL.GetPeerFingerprint: string; -var - cert: PX509; - x: integer; -{$IFDEF CIL} - sb: StringBuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; -{$IFDEF CIL} - sb := StringBuilder.Create(EVP_MAX_MD_SIZE); - X509Digest(cert, EvpGetDigestByName('MD5'), sb, x); - sb.Length := x; - Result := sb.ToString; -{$ELSE} - setlength(Result, EVP_MAX_MD_SIZE); - X509Digest(cert, EvpGetDigestByName('MD5'), Result, x); - SetLength(Result, x); -{$ENDIF} - X509Free(cert); -end; - -function TSSLOpenSSL.GetCertInfo: string; -var - cert: PX509; - x, y: integer; - b: PBIO; - s: AnsiString; -{$IFDEF CIL} - sb: stringbuilder; -{$ENDIF} -begin - if not assigned(FSsl) then - begin - Result := ''; - Exit; - end; - cert := SSLGetPeerCertificate(Fssl); - if not assigned(cert) then - begin - Result := ''; - Exit; - end; - try {pf} - b := BioNew(BioSMem); - 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,s,x); - if y > 0 then - setlength(s, y); - {$ENDIF} - Result := ReplaceString(s, LF, CRLF); - finally - BioFreeAll(b); - end; - {pf} - finally - X509Free(cert); - end; - {/pf} -end; - -function TSSLOpenSSL.GetCipherName: string; -begin - if not assigned(FSsl) then - Result := '' - else - Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); -end; - -function TSSLOpenSSL.GetCipherBits: integer; -var - x: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); -end; - -function TSSLOpenSSL.GetCipherAlgBits: integer; -begin - if not assigned(FSsl) then - Result := 0 - else - SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); -end; - -function TSSLOpenSSL.GetVerifyCert: integer; -begin - if not assigned(FSsl) then - Result := 1 - else - Result := SslGetVerifyResult(FSsl); -end; - -{==============================================================================} - -initialization - if InitSSLInterface then - SSLImplementation := TSSLOpenSSL; - -end. diff --git a/synapse/ssl_openssl_lib.pas b/synapse/ssl_openssl_lib.pas deleted file mode 100644 index d009684..0000000 --- a/synapse/ssl_openssl_lib.pas +++ /dev/null @@ -1,2138 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 003.007.000 | -|==============================================================================| -| Content: SSL support by OpenSSL | -|==============================================================================| -| Copyright (c)1999-2012, 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)2002-2012. | -| Portions created by Petr Fejfar are Copyright (c)2011-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| 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) - for good inspiration about begin with SSL programming. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *) -{$ENDIF} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{:@abstract(OpenSSL support) - -This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit). -OpenSSL is loaded dynamicly on-demand. If this library is not found in system, -requested OpenSSL function just return errorcode. -} -unit ssl_openssl_lib; - -interface - -uses -{$IFDEF CIL} - System.Runtime.InteropServices, - System.Text, -{$ENDIF} - Classes, - synafpc, -{$IFNDEF MSWINDOWS} - {$IFDEF FPC} - BaseUnix, SysUtils; - {$ELSE} - Libc, SysUtils; - {$ENDIF} -{$ELSE} - Windows; -{$ENDIF} - - -{$IFDEF CIL} -const - {$IFDEF LINUX} - DLLSSLName = 'libssl.so'; - DLLUtilName = 'libcrypto.so'; - {$ELSE} - DLLSSLName = 'ssleay32.dll'; - DLLUtilName = 'libeay32.dll'; - {$ENDIF} -{$ELSE} -var - {$IFNDEF MSWINDOWS} - {$IFDEF DARWIN} - DLLSSLName: string = 'libssl.dylib'; - DLLUtilName: string = 'libcrypto.dylib'; - {$ELSE} - DLLSSLName: string = 'libssl.so'; - DLLUtilName: string = 'libcrypto.so'; - {$ENDIF} - {$ELSE} - DLLSSLName: string = 'ssleay32.dll'; - DLLSSLName2: string = 'libssl32.dll'; - DLLUtilName: string = 'libeay32.dll'; - {$ENDIF} -{$ENDIF} - -type -{$IFDEF CIL} - SslPtr = IntPtr; -{$ELSE} - SslPtr = Pointer; -{$ENDIF} - PSslPtr = ^SslPtr; - PSSL_CTX = SslPtr; - PSSL = SslPtr; - PSSL_METHOD = SslPtr; - PX509 = SslPtr; - PX509_NAME = SslPtr; - PEVP_MD = SslPtr; - PInteger = ^Integer; - PBIO_METHOD = SslPtr; - PBIO = SslPtr; - EVP_PKEY = SslPtr; - PRSA = SslPtr; - PASN1_UTCTIME = SslPtr; - PASN1_INTEGER = SslPtr; - PPasswdCb = SslPtr; - PFunction = procedure; - PSTACK = SslPtr; {pf} - TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf} - TX509Free = procedure(x: PX509); cdecl; {pf} - - 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; - - SSL_ERROR_NONE = 0; - SSL_ERROR_SSL = 1; - SSL_ERROR_WANT_READ = 2; - SSL_ERROR_WANT_WRITE = 3; - SSL_ERROR_WANT_X509_LOOKUP = 4; - SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno - SSL_ERROR_ZERO_RETURN = 6; - SSL_ERROR_WANT_CONNECT = 7; - SSL_ERROR_WANT_ACCEPT = 8; - - SSL_OP_NO_SSLv2 = $01000000; - SSL_OP_NO_SSLv3 = $02000000; - SSL_OP_NO_TLSv1 = $04000000; - SSL_OP_ALL = $000FFFFF; - 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; - X509_V_ERR_UNABLE_TO_GET_CRL = 3; - X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4; - X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5; - X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6; - X509_V_ERR_CERT_SIGNATURE_FAILURE = 7; - X509_V_ERR_CRL_SIGNATURE_FAILURE = 8; - X509_V_ERR_CERT_NOT_YET_VALID = 9; - X509_V_ERR_CERT_HAS_EXPIRED = 10; - X509_V_ERR_CRL_NOT_YET_VALID = 11; - X509_V_ERR_CRL_HAS_EXPIRED = 12; - X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13; - X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14; - X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15; - X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16; - X509_V_ERR_OUT_OF_MEM = 17; - X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18; - X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19; - X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20; - X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21; - X509_V_ERR_CERT_CHAIN_TOO_LONG = 22; - X509_V_ERR_CERT_REVOKED = 23; - X509_V_ERR_INVALID_CA = 24; - X509_V_ERR_PATH_LENGTH_EXCEEDED = 25; - X509_V_ERR_INVALID_PURPOSE = 26; - X509_V_ERR_CERT_UNTRUSTED = 27; - X509_V_ERR_CERT_REJECTED = 28; - //These are 'informational' when looking for issuer cert - X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29; - X509_V_ERR_AKID_SKID_MISMATCH = 30; - X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31; - X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32; - X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33; - X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34; - //The application is not happy - X509_V_ERR_APPLICATION_VERIFICATION = 50; - - SSL_FILETYPE_ASN1 = 2; - SSL_FILETYPE_PEM = 1; - EVP_PKEY_RSA = 6; - - SSL_CTRL_SET_TLSEXT_HOSTNAME = 55; - TLSEXT_NAMETYPE_host_name = 0; - -var - SSLLibHandle: TLibHandle = 0; - SSLUtilHandle: TLibHandle = 0; - 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')] - function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')] - function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_RSAPrivateKey_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')] - function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_ASN1')] - function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer; external; - - [DllImport(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_CTX_use_certificate_file')] - function SslCtxUseCertificateFile(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')] - 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_CTX_ctrl')] - function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): 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(DLLSSLName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'SSL_ctrl')] - function SslCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: IntPtr): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_new')] - function X509New: PX509; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_free')] - procedure X509Free(x: PX509); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_oneline')] - function X509NameOneline(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 X509GetSubjectName(a: PX509):PX509_NAME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_get_issuer_name')] - function X509GetIssuerName(a: PX509):PX509_NAME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_hash')] - function X509NameHash(x: PX509_NAME):Cardinal; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_digest')] - function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_version')] - function X509SetVersion(x: PX509; version: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_pubkey')] - function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_issuer_name')] - function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_NAME_add_entry_by_txt')] - function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer; - bytes: string; len, loc, _set: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_sign')] - function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_print')] - function X509print(b: PBIO; a: PX509): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_gmtime_adj')] - function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_notBefore')] - function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_set_notAfter')] - function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'X509_get_serialNumber')] - function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_new')] - function EvpPkeyNew: EVP_PKEY; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_free')] - procedure EvpPkeyFree(pk: EVP_PKEY); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_PKEY_assign')] - function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'EVP_get_digestbyname')] - function EvpGetDigestByName(Name: String): PEVP_MD; 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 = 'SSLeay_version')] - function SSLeayversion(t: integer): String; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ERR_error_string_n')] - procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); 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_clear_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 = 'OPENSSL_add_all_algorithms_noconf')] - procedure OPENSSLaddallalgorithms; 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 = 'd2i_PKCS12_bio')] - function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'PKCS12_parse')] - function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'PKCS12_free')] - procedure PKCS12free(p12: SslPtr); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'RSA_generate_key')] - function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_UTCTIME_new')] - function Asn1UtctimeNew: PASN1_UTCTIME; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_UTCTIME_free')] - procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'ASN1_INTEGER_set')] - function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'i2d_X509_bio')] - function i2dX509bio(b: PBIO; x: PX509): integer; external; - - [DllImport(DLLUtilName, CharSet = CharSet.Ansi, - SetLastError = False, CallingConvention= CallingConvention.cdecl, - EntryPoint = 'i2d_PrivateKey_bio')] - function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): 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; var str: AnsiString):Integer; - function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; - procedure SslCtxFree(arg0: PSSL_CTX); - function SslSetFd(s: PSSL; fd: Integer):Integer; - function SslMethodV2:PSSL_METHOD; - function SslMethodV3:PSSL_METHOD; - function SslMethodTLSV1:PSSL_METHOD; - function SslMethodV23:PSSL_METHOD; - function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; - function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; -// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; - function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; - function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; - function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; - function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; - function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; - function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):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: AnsiString; const CApath: AnsiString):Integer; - function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): 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: 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):AnsiString; - function SslGetPeerCertificate(ssl: PSSL):PX509; - procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); - function SSLGetCurrentCipher(s: PSSL):SslPtr; - function SSLCipherGetName(c: SslPtr): AnsiString; - function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer; - function SSLGetVerifyResult(ssl: PSSL):Integer; - function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; - -// libeay.dll - function X509New: PX509; - procedure X509Free(x: PX509); - function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; - function X509GetSubjectName(a: PX509):PX509_NAME; - function X509GetIssuerName(a: PX509):PX509_NAME; - function X509NameHash(x: PX509_NAME):Cardinal; -// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; - function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; - function X509print(b: PBIO; a: PX509): integer; - function X509SetVersion(x: PX509; version: integer): integer; - function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; - function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; - function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; - bytes: Ansistring; len, loc, _set: integer): integer; - function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; - function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; - function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; - function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; - function X509GetSerialNumber(x: PX509): PASN1_INTEGER; - function EvpPkeyNew: EVP_PKEY; - procedure EvpPkeyFree(pk: EVP_PKEY); - function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; - function EvpGetDigestByName(Name: AnsiString): PEVP_MD; - procedure EVPcleanup; -// function ErrErrorString(e: integer; buf: PChar): PChar; - function SSLeayversion(t: integer): Ansistring; - procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); - function ErrGetError: integer; - procedure ErrClearError; - procedure ErrFreeStrings; - procedure ErrRemoveState(pid: integer); - procedure OPENSSLaddallalgorithms; - procedure CRYPTOcleanupAllExData; - procedure RandScreen; - function BioNew(b: PBIO_METHOD): PBIO; - procedure BioFreeAll(b: PBIO); - function BioSMem: PBIO_METHOD; - function BioCtrlPending(b: PBIO): integer; - function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; - function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; - function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; - function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; - procedure PKCS12free(p12: SslPtr); - function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; - function Asn1UtctimeNew: PASN1_UTCTIME; - procedure Asn1UtctimeFree(a: PASN1_UTCTIME); - function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; - function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} - function i2dX509bio(b: PBIO; x: PX509): integer; - function d2iX509bio(b:PBIO; x:PX509): PX509; {pf} - function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} - procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf} - - - function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): 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; -function DestroySSLInterface: Boolean; - -var - _X509Free: TX509Free = nil; {pf} - -implementation - -uses SyncObjs; - -{$IFNDEF CIL} -type -// libssl.dll - TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl; - TSslLibraryInit = function:Integer; cdecl; - TSslLoadErrorStrings = procedure; cdecl; - TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PAnsiChar):Integer; cdecl; - TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl; - TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl; - TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl; - TSslMethodV2 = function:PSSL_METHOD; cdecl; - TSslMethodV3 = function:PSSL_METHOD; cdecl; - TSslMethodTLSV1 = function:PSSL_METHOD; cdecl; - TSslMethodV23 = function:PSSL_METHOD; cdecl; - TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl; - TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl; - TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; - TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl; - TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl; - TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PAnsiChar; _type: Integer):Integer; cdecl; - TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PAnsiChar):Integer; cdecl; - TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl; - TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl; - TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl; - TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PAnsiChar; const CApath: PAnsiChar):Integer; cdecl; - TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl; - TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl; - TSslFree = procedure(ssl: PSSL); cdecl; - TSslAccept = function(ssl: PSSL):Integer; cdecl; - TSslConnect = function(ssl: PSSL):Integer; cdecl; - TSslShutdown = function(ssl: PSSL):Integer; cdecl; - TSslRead = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslPeek = function(ssl: PSSL; buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslWrite = function(ssl: PSSL; const buf: PAnsiChar; num: Integer):Integer; cdecl; - TSslPending = function(ssl: PSSL):Integer; cdecl; - TSslGetVersion = function(ssl: PSSL):PAnsiChar; cdecl; - TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl; - TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl; - TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl; - TSSLCipherGetName = function(c: Sslptr):PAnsiChar; cdecl; - TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl; - TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl; - TSSLCtrl = function(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl; - - TSSLSetTlsextHostName = function(ssl: PSSL; buf: PAnsiChar):Integer; cdecl; - -// libeay.dll - TX509New = function: PX509; cdecl; - TX509NameOneline = function(a: PX509_NAME; buf: PAnsiChar; size: Integer):PAnsiChar; cdecl; - TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl; - TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl; - TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl; - TX509Digest = function(data: PX509; _type: PEVP_MD; md: PAnsiChar; len: PInteger):Integer; cdecl; - TX509print = function(b: PBIO; a: PX509): integer; cdecl; - TX509SetVersion = function(x: PX509; version: integer): integer; cdecl; - TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl; - TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl; - TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PAnsiChar; _type: integer; - bytes: PAnsiChar; len, loc, _set: integer): integer; cdecl; - TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl; - TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl; - TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; - TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl; - TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl; - TEvpPkeyNew = function: EVP_PKEY; cdecl; - TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl; - TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl; - TEvpGetDigestByName = function(Name: PAnsiChar): PEVP_MD; cdecl; - TEVPcleanup = procedure; cdecl; - TSSLeayversion = function(t: integer): PAnsiChar; cdecl; - TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl; - TErrGetError = function: integer; cdecl; - TErrClearError = procedure; cdecl; - TErrFreeStrings = procedure; cdecl; - TErrRemoveState = procedure(pid: integer); cdecl; - TOPENSSLaddallalgorithms = procedure; cdecl; - TCRYPTOcleanupAllExData = procedure; cdecl; - TRandScreen = procedure; cdecl; - TBioNew = function(b: PBIO_METHOD): PBIO; cdecl; - TBioFreeAll = procedure(b: PBIO); cdecl; - TBioSMem = function: PBIO_METHOD; cdecl; - TBioCtrlPending = function(b: PBIO): integer; cdecl; - TBioRead = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; - TBioWrite = function(b: PBIO; Buf: PAnsiChar; Len: integer): integer; cdecl; - Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl; - TPKCS12parse = function(p12: SslPtr; pass: PAnsiChar; var pkey, cert, ca: SslPtr): integer; cdecl; - TPKCS12free = procedure(p12: SslPtr); cdecl; - TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl; - TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl; - TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl; - TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl; - TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf} - Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl; - Td2iX509bio = function(b:PBIO; x:PX509): PX509; cdecl; {pf} - TPEMReadBioX509 = function(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; {pf} - TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf} - Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): 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; - //thread lock functions - TCRYPTOnumlocks = function: integer; cdecl; - TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl; - -var -// libssl.dll - _SslGetError: TSslGetError = nil; - _SslLibraryInit: TSslLibraryInit = nil; - _SslLoadErrorStrings: TSslLoadErrorStrings = nil; - _SslCtxSetCipherList: TSslCtxSetCipherList = nil; - _SslCtxNew: TSslCtxNew = nil; - _SslCtxFree: TSslCtxFree = nil; - _SslSetFd: TSslSetFd = nil; - _SslMethodV2: TSslMethodV2 = nil; - _SslMethodV3: TSslMethodV3 = nil; - _SslMethodTLSV1: TSslMethodTLSV1 = nil; - _SslMethodV23: TSslMethodV23 = nil; - _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil; - _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil; - _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil; - _SslCtxUseCertificate: TSslCtxUseCertificate = nil; - _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil; - _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil; - _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil; - _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil; - _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil; - _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil; - _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil; - _SslCtxCtrl: TSslCtxCtrl = nil; - _SslNew: TSslNew = nil; - _SslFree: TSslFree = nil; - _SslAccept: TSslAccept = nil; - _SslConnect: TSslConnect = nil; - _SslShutdown: TSslShutdown = nil; - _SslRead: TSslRead = nil; - _SslPeek: TSslPeek = nil; - _SslWrite: TSslWrite = nil; - _SslPending: TSslPending = nil; - _SslGetVersion: TSslGetVersion = nil; - _SslGetPeerCertificate: TSslGetPeerCertificate = nil; - _SslCtxSetVerify: TSslCtxSetVerify = nil; - _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil; - _SSLCipherGetName: TSSLCipherGetName = nil; - _SSLCipherGetBits: TSSLCipherGetBits = nil; - _SSLGetVerifyResult: TSSLGetVerifyResult = nil; - _SSLCtrl: TSSLCtrl = nil; - -// libeay.dll - _X509New: TX509New = nil; - _X509NameOneline: TX509NameOneline = nil; - _X509GetSubjectName: TX509GetSubjectName = nil; - _X509GetIssuerName: TX509GetIssuerName = nil; - _X509NameHash: TX509NameHash = nil; - _X509Digest: TX509Digest = nil; - _X509print: TX509print = nil; - _X509SetVersion: TX509SetVersion = nil; - _X509SetPubkey: TX509SetPubkey = nil; - _X509SetIssuerName: TX509SetIssuerName = nil; - _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil; - _X509Sign: TX509Sign = nil; - _X509GmtimeAdj: TX509GmtimeAdj = nil; - _X509SetNotBefore: TX509SetNotBefore = nil; - _X509SetNotAfter: TX509SetNotAfter = nil; - _X509GetSerialNumber: TX509GetSerialNumber = nil; - _EvpPkeyNew: TEvpPkeyNew = nil; - _EvpPkeyFree: TEvpPkeyFree = nil; - _EvpPkeyAssign: TEvpPkeyAssign = nil; - _EvpGetDigestByName: TEvpGetDigestByName = nil; - _EVPcleanup: TEVPcleanup = nil; - _SSLeayversion: TSSLeayversion = nil; - _ErrErrorString: TErrErrorString = nil; - _ErrGetError: TErrGetError = nil; - _ErrClearError: TErrClearError = nil; - _ErrFreeStrings: TErrFreeStrings = nil; - _ErrRemoveState: TErrRemoveState = nil; - _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil; - _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil; - _RandScreen: TRandScreen = nil; - _BioNew: TBioNew = nil; - _BioFreeAll: TBioFreeAll = nil; - _BioSMem: TBioSMem = nil; - _BioCtrlPending: TBioCtrlPending = nil; - _BioRead: TBioRead = nil; - _BioWrite: TBioWrite = nil; - _d2iPKCS12bio: Td2iPKCS12bio = nil; - _PKCS12parse: TPKCS12parse = nil; - _PKCS12free: TPKCS12free = nil; - _RsaGenerateKey: TRsaGenerateKey = nil; - _Asn1UtctimeNew: TAsn1UtctimeNew = nil; - _Asn1UtctimeFree: TAsn1UtctimeFree = nil; - _Asn1IntegerSet: TAsn1IntegerSet = nil; - _Asn1IntegerGet: TAsn1IntegerGet = nil; {pf} - _i2dX509bio: Ti2dX509bio = nil; - _d2iX509bio: Td2iX509bio = nil; {pf} - _PEMReadBioX509: TPEMReadBioX509 = nil; {pf} - _SkX509PopFree: TSkX509PopFree = nil; {pf} - _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil; - - // 3DES functions - _DESsetoddparity: TDESsetoddparity = nil; - _DESsetkeychecked: TDESsetkeychecked = nil; - _DESecbencrypt: TDESecbencrypt = nil; - //thread lock functions - _CRYPTOnumlocks: TCRYPTOnumlocks = nil; - _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil; -{$ENDIF} - -var - SSLCS: TCriticalSection; - SSLloaded: boolean = false; -{$IFNDEF CIL} - Locks: TList; -{$ENDIF} - -{$IFNDEF CIL} -// libssl.dll -function SslGetError(s: PSSL; ret_code: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslGetError) then - Result := _SslGetError(s, ret_code) - else - Result := SSL_ERROR_SSL; -end; - -function SslLibraryInit:Integer; -begin - if InitSSLInterface and Assigned(_SslLibraryInit) then - Result := _SslLibraryInit - else - Result := 1; -end; - -procedure SslLoadErrorStrings; -begin - if InitSSLInterface and Assigned(_SslLoadErrorStrings) then - _SslLoadErrorStrings; -end; - -//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer; -function SslCtxSetCipherList(arg0: PSSL_CTX; var str: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxSetCipherList) then - Result := _SslCtxSetCipherList(arg0, PAnsiChar(str)) - else - Result := 0; -end; - -function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX; -begin - if InitSSLInterface and Assigned(_SslCtxNew) then - Result := _SslCtxNew(meth) - else - Result := nil; -end; - -procedure SslCtxFree(arg0: PSSL_CTX); -begin - if InitSSLInterface and Assigned(_SslCtxFree) then - _SslCtxFree(arg0); -end; - -function SslSetFd(s: PSSL; fd: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslSetFd) then - Result := _SslSetFd(s, fd) - else - Result := 0; -end; - -function SslMethodV2:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV2) then - Result := _SslMethodV2 - else - Result := nil; -end; - -function SslMethodV3:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV3) then - Result := _SslMethodV3 - else - Result := nil; -end; - -function SslMethodTLSV1:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodTLSV1) then - Result := _SslMethodTLSV1 - else - Result := nil; -end; - -function SslMethodV23:PSSL_METHOD; -begin - if InitSSLInterface and Assigned(_SslMethodV23) then - Result := _SslMethodV23 - else - Result := nil; -end; - -function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then - Result := _SslCtxUsePrivateKey(ctx, pkey) - else - Result := 0; -end; - -function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: AnsiString; len: integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then - Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len) - else - Result := 0; -end; - -//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; -function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then - Result := _SslCtxUsePrivateKeyFile(ctx, PAnsiChar(_file), _type) - else - Result := 0; -end; - -function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificate) then - Result := _SslCtxUseCertificate(ctx, x) - else - Result := 0; -end; - -function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then - Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d)) - else - Result := 0; -end; - -function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: AnsiString; _type: Integer):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then - Result := _SslCtxUseCertificateFile(ctx, PAnsiChar(_file), _type) - else - Result := 0; -end; - -//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer; -function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then - Result := _SslCtxUseCertificateChainFile(ctx, PAnsiChar(_file)) - else - Result := 0; -end; - -function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then - Result := _SslCtxCheckPrivateKeyFile(ctx) - else - Result := 0; -end; - -procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); -begin - if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then - _SslCtxSetDefaultPasswdCb(ctx, cb); -end; - -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: AnsiString; const CApath: AnsiString):Integer; -begin - if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then - Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath)) - else - Result := 0; -end; - -function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; -begin - if InitSSLInterface and Assigned(_SslCtxCtrl) then - Result := _SslCtxCtrl(ctx, cmd, larg, parg) - else - Result := 0; -end; - -function SslNew(ctx: PSSL_CTX):PSSL; -begin - if InitSSLInterface and Assigned(_SslNew) then - Result := _SslNew(ctx) - else - Result := nil; -end; - -procedure SslFree(ssl: PSSL); -begin - if InitSSLInterface and Assigned(_SslFree) then - _SslFree(ssl); -end; - -function SslAccept(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslAccept) then - Result := _SslAccept(ssl) - else - Result := -1; -end; - -function SslConnect(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslConnect) then - Result := _SslConnect(ssl) - else - Result := -1; -end; - -function SslShutdown(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslShutdown) then - Result := _SslShutdown(ssl) - else - Result := -1; -end; - -//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, PAnsiChar(buf), num) - else - Result := -1; -end; - -//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, PAnsiChar(buf), num) - else - Result := -1; -end; - -//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, PAnsiChar(buf), num) - else - Result := -1; -end; - -function SslPending(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SslPending) then - Result := _SslPending(ssl) - else - Result := 0; -end; - -//function SslGetVersion(ssl: PSSL):PChar; -function SslGetVersion(ssl: PSSL):AnsiString; -begin - if InitSSLInterface and Assigned(_SslGetVersion) then - Result := _SslGetVersion(ssl) - else - Result := ''; -end; - -function SslGetPeerCertificate(ssl: PSSL):PX509; -begin - if InitSSLInterface and Assigned(_SslGetPeerCertificate) then - Result := _SslGetPeerCertificate(ssl) - else - Result := nil; -end; - -//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); -procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); -begin - if InitSSLInterface and Assigned(_SslCtxSetVerify) then - _SslCtxSetVerify(ctx, mode, @arg2); -end; - -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: SslPtr):PChar; -function SSLCipherGetName(c: SslPtr):AnsiString; -begin - if InitSSLInterface and Assigned(_SSLCipherGetName) then - Result := _SSLCipherGetName(c) - else - Result := ''; -end; - -//function SSLCipherGetBits(c: SslPtr; 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) - else - Result := 0; -end; - -function SSLGetVerifyResult(ssl: PSSL):Integer; -begin - if InitSSLInterface and Assigned(_SSLGetVerifyResult) then - Result := _SSLGetVerifyResult(ssl) - else - Result := X509_V_ERR_APPLICATION_VERIFICATION; -end; - - -function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; -begin - if InitSSLInterface and Assigned(_SSLCtrl) then - Result := _SSLCtrl(ssl, cmd, larg, parg) - else - Result := X509_V_ERR_APPLICATION_VERIFICATION; -end; - -// libeay.dll -function X509New: PX509; -begin - if InitSSLInterface and Assigned(_X509New) then - Result := _X509New - else - Result := nil; -end; - -procedure X509Free(x: PX509); -begin - if InitSSLInterface and Assigned(_X509Free) then - _X509Free(x); -end; - -//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar; -function X509NameOneline(a: PX509_NAME; var buf: AnsiString; size: Integer):AnsiString; -begin - if InitSSLInterface and Assigned(_X509NameOneline) then - Result := _X509NameOneline(a, PAnsiChar(buf),size) - else - Result := ''; -end; - -function X509GetSubjectName(a: PX509):PX509_NAME; -begin - if InitSSLInterface and Assigned(_X509GetSubjectName) then - Result := _X509GetSubjectName(a) - else - Result := nil; -end; - -function X509GetIssuerName(a: PX509):PX509_NAME; -begin - if InitSSLInterface and Assigned(_X509GetIssuerName) then - Result := _X509GetIssuerName(a) - else - Result := nil; -end; - -function X509NameHash(x: PX509_NAME):Cardinal; -begin - if InitSSLInterface and Assigned(_X509NameHash) then - Result := _X509NameHash(x) - else - Result := 0; -end; - -//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; -function X509Digest(data: PX509; _type: PEVP_MD; md: AnsiString; var len: Integer):Integer; -begin - if InitSSLInterface and Assigned(_X509Digest) then - Result := _X509Digest(data, _type, PAnsiChar(md), @len) - else - Result := 0; -end; - -function EvpPkeyNew: EVP_PKEY; -begin - if InitSSLInterface and Assigned(_EvpPkeyNew) then - Result := _EvpPkeyNew - else - Result := nil; -end; - -procedure EvpPkeyFree(pk: EVP_PKEY); -begin - if InitSSLInterface and Assigned(_EvpPkeyFree) then - _EvpPkeyFree(pk); -end; - -function SSLeayversion(t: integer): Ansistring; -begin - if InitSSLInterface and Assigned(_SSLeayversion) then - Result := PAnsiChar(_SSLeayversion(t)) - else - Result := ''; -end; - -procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); -begin - if InitSSLInterface and Assigned(_ErrErrorString) then - _ErrErrorString(e, Pointer(buf), len); - buf := PAnsiChar(Buf); -end; - -function ErrGetError: integer; -begin - if InitSSLInterface and Assigned(_ErrGetError) then - Result := _ErrGetError - else - Result := SSL_ERROR_SSL; -end; - -procedure ErrClearError; -begin - if InitSSLInterface and Assigned(_ErrClearError) then - _ErrClearError; -end; - -procedure ErrFreeStrings; -begin - if InitSSLInterface and Assigned(_ErrFreeStrings) then - _ErrFreeStrings; -end; - -procedure ErrRemoveState(pid: integer); -begin - if InitSSLInterface and Assigned(_ErrRemoveState) then - _ErrRemoveState(pid); -end; - -procedure OPENSSLaddallalgorithms; -begin - if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then - _OPENSSLaddallalgorithms; -end; - -procedure EVPcleanup; -begin - if InitSSLInterface and Assigned(_EVPcleanup) then - _EVPcleanup; -end; - -procedure CRYPTOcleanupAllExData; -begin - if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then - _CRYPTOcleanupAllExData; -end; - -procedure RandScreen; -begin - if InitSSLInterface and Assigned(_RandScreen) then - _RandScreen; -end; - -function BioNew(b: PBIO_METHOD): PBIO; -begin - if InitSSLInterface and Assigned(_BioNew) then - Result := _BioNew(b) - else - Result := nil; -end; - -procedure BioFreeAll(b: PBIO); -begin - if InitSSLInterface and Assigned(_BioFreeAll) then - _BioFreeAll(b); -end; - -function BioSMem: PBIO_METHOD; -begin - if InitSSLInterface and Assigned(_BioSMem) then - Result := _BioSMem - else - Result := nil; -end; - -function BioCtrlPending(b: PBIO): integer; -begin - if InitSSLInterface and Assigned(_BioCtrlPending) then - Result := _BioCtrlPending(b) - else - Result := 0; -end; - -//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer; -function BioRead(b: PBIO; var Buf: AnsiString; Len: integer): integer; -begin - if InitSSLInterface and Assigned(_BioRead) then - Result := _BioRead(b, PAnsiChar(Buf), Len) - else - Result := -2; -end; - -//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer; -function BioWrite(b: PBIO; Buf: AnsiString; Len: integer): integer; -begin - if InitSSLInterface and Assigned(_BioWrite) then - Result := _BioWrite(b, PAnsiChar(Buf), Len) - else - Result := -2; -end; - -function X509print(b: PBIO; a: PX509): integer; -begin - if InitSSLInterface and Assigned(_X509print) then - Result := _X509print(b, a) - else - Result := 0; -end; - -function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; -begin - if InitSSLInterface and Assigned(_d2iPKCS12bio) then - Result := _d2iPKCS12bio(b, Pkcs12) - else - Result := nil; -end; - -function PKCS12parse(p12: SslPtr; pass: Ansistring; var pkey, cert, ca: SslPtr): integer; -begin - if InitSSLInterface and Assigned(_PKCS12parse) then - Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca) - else - Result := 0; -end; - -procedure PKCS12free(p12: SslPtr); -begin - if InitSSLInterface and Assigned(_PKCS12free) then - _PKCS12free(p12); -end; - -function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; -begin - if InitSSLInterface and Assigned(_RsaGenerateKey) then - Result := _RsaGenerateKey(bits, e, callback, cb_arg) - else - Result := nil; -end; - -function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; -begin - if InitSSLInterface and Assigned(_EvpPkeyAssign) then - Result := _EvpPkeyAssign(pkey, _type, key) - else - Result := 0; -end; - -function X509SetVersion(x: PX509; version: integer): integer; -begin - if InitSSLInterface and Assigned(_X509SetVersion) then - Result := _X509SetVersion(x, version) - else - Result := 0; -end; - -function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; -begin - if InitSSLInterface and Assigned(_X509SetPubkey) then - Result := _X509SetPubkey(x, pkey) - else - Result := 0; -end; - -function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; -begin - if InitSSLInterface and Assigned(_X509SetIssuerName) then - Result := _X509SetIssuerName(x, name) - else - Result := 0; -end; - -function X509NameAddEntryByTxt(name: PX509_NAME; field: Ansistring; _type: integer; - bytes: Ansistring; len, loc, _set: integer): integer; -begin - if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then - Result := _X509NameAddEntryByTxt(name, PAnsiChar(field), _type, PAnsiChar(Bytes), len, loc, _set) - else - Result := 0; -end; - -function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; -begin - if InitSSLInterface and Assigned(_X509Sign) then - Result := _X509Sign(x, pkey, md) - else - Result := 0; -end; - -function Asn1UtctimeNew: PASN1_UTCTIME; -begin - if InitSSLInterface and Assigned(_Asn1UtctimeNew) then - Result := _Asn1UtctimeNew - else - Result := nil; -end; - -procedure Asn1UtctimeFree(a: PASN1_UTCTIME); -begin - if InitSSLInterface and Assigned(_Asn1UtctimeFree) then - _Asn1UtctimeFree(a); -end; - -function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; -begin - if InitSSLInterface and Assigned(_X509GmtimeAdj) then - Result := _X509GmtimeAdj(s, adj) - else - Result := nil; -end; - -function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; -begin - if InitSSLInterface and Assigned(_X509SetNotBefore) then - Result := _X509SetNotBefore(x, tm) - else - Result := 0; -end; - -function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; -begin - if InitSSLInterface and Assigned(_X509SetNotAfter) then - Result := _X509SetNotAfter(x, tm) - else - Result := 0; -end; - -function i2dX509bio(b: PBIO; x: PX509): integer; -begin - if InitSSLInterface and Assigned(_i2dX509bio) then - Result := _i2dX509bio(b, x) - else - Result := 0; -end; - -function d2iX509bio(b: PBIO; x: PX509): PX509; {pf} -begin - if InitSSLInterface and Assigned(_d2iX509bio) then - Result := _d2iX509bio(x,b) - else - Result := nil; -end; - -function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509; {pf} -begin - if InitSSLInterface and Assigned(_PEMReadBioX509) then - Result := _PEMReadBioX509(b,x,callback,cb_arg) - else - Result := nil; -end; - -procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf} -begin - if InitSSLInterface and Assigned(_SkX509PopFree) then - _SkX509PopFree(st,func); -end; - -function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; -begin - if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then - Result := _i2dPrivateKeyBio(b, pkey) - else - Result := 0; -end; - -function EvpGetDigestByName(Name: AnsiString): PEVP_MD; -begin - if InitSSLInterface and Assigned(_EvpGetDigestByName) then - Result := _EvpGetDigestByName(PAnsiChar(Name)) - else - Result := nil; -end; - -function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; -begin - if InitSSLInterface and Assigned(_Asn1IntegerSet) then - Result := _Asn1IntegerSet(a, v) - else - Result := 0; -end; - -function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf} -begin - if InitSSLInterface and Assigned(_Asn1IntegerGet) then - Result := _Asn1IntegerGet(a) - else - Result := 0; -end; - -function X509GetSerialNumber(x: PX509): PASN1_INTEGER; -begin - if InitSSLInterface and Assigned(_X509GetSerialNumber) then - Result := _X509GetSerialNumber(x) - else - Result := nil; -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; - -procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl; -begin - if (mode and 1) > 0 then - TCriticalSection(Locks[ltype]).Enter - else - TCriticalSection(Locks[ltype]).Leave; -end; - -procedure InitLocks; -var - n: integer; - max: integer; -begin - Locks := TList.Create; - max := _CRYPTOnumlocks; - for n := 1 to max do - Locks.Add(TCriticalSection.Create); - _CRYPTOsetlockingcallback(@locking_callback); -end; - -procedure FreeLocks; -var - n: integer; -begin - _CRYPTOsetlockingcallback(nil); - for n := 0 to Locks.Count - 1 do - TCriticalSection(Locks[n]).Free; - Locks.Free; -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 - s: string; - x: integer; -begin - {pf} - if SSLLoaded then - begin - Result := TRUE; - exit; - end; - {/pf} - SSLCS.Enter; - try - if not IsSSLloaded then - begin -{$IFDEF CIL} - SSLLibHandle := 1; - SSLUtilHandle := 1; -{$ELSE} - SSLLibHandle := LoadLib(DLLSSLName); - SSLUtilHandle := LoadLib(DLLUtilName); - {$IFDEF MSWINDOWS} - if (SSLLibHandle = 0) then - SSLLibHandle := LoadLib(DLLSSLName2); - {$ENDIF} -{$ENDIF} - if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then - begin -{$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'); - _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey'); - _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1'); - //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file, - //because SSL_CTX_use_PrivateKey_file not support DER format. :-O - _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file'); - _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate'); - _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1'); - _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_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'); - _SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl'); - _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'); - _SslCtrl := GetProcAddr(SSLLibHandle, 'SSL_ctrl'); - - _X509New := GetProcAddr(SSLUtilHandle, 'X509_new'); - _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free'); - _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline'); - _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name'); - _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name'); - _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash'); - _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest'); - _X509print := GetProcAddr(SSLUtilHandle, 'X509_print'); - _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version'); - _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey'); - _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name'); - _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt'); - _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign'); - _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj'); - _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore'); - _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter'); - _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber'); - _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new'); - _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free'); - _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign'); - _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup'); - _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); - _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version'); - _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); - _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); - _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); - _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings'); - _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state'); - _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf'); - _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'); - _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio'); - _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse'); - _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free'); - _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key'); - _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new'); - _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free'); - _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set'); - _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf} - _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio'); - _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf} - _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf} - _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf} - _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio'); - - // 3DES functions - _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity'); - _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked'); - _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt'); - // - _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks'); - _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback'); -{$ENDIF} -{$IFDEF CIL} - SslLibraryInit; - SslLoadErrorStrings; - OPENSSLaddallalgorithms; - RandScreen; -{$ELSE} - SetLength(s, 1024); - x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s)); - SetLength(s, x); - SSLLibFile := s; - SetLength(s, 1024); - x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s)); - SetLength(s, x); - SSLUtilFile := s; - //init library - if assigned(_SslLibraryInit) then - _SslLibraryInit; - if assigned(_SslLoadErrorStrings) then - _SslLoadErrorStrings; - if assigned(_OPENSSLaddallalgorithms) then - _OPENSSLaddallalgorithms; - if assigned(_RandScreen) then - _RandScreen; - if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then - InitLocks; -{$ENDIF} - Result := True; - SSLloaded := True; - end - else - 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; - end; - end - else - //loaded before... - Result := true; - finally - SSLCS.Leave; - end; -end; - -function DestroySSLInterface: Boolean; -begin - SSLCS.Enter; - try - if IsSSLLoaded then - begin - //deinit library -{$IFNDEF CIL} - if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then - FreeLocks; -{$ENDIF} - EVPCleanup; - CRYPTOcleanupAllExData; - ErrRemoveState(0); - end; - 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; - _SslCtxSetCipherList := nil; - _SslCtxNew := nil; - _SslCtxFree := nil; - _SslSetFd := nil; - _SslMethodV2 := nil; - _SslMethodV3 := nil; - _SslMethodTLSV1 := nil; - _SslMethodV23 := nil; - _SslCtxUsePrivateKey := nil; - _SslCtxUsePrivateKeyASN1 := nil; - _SslCtxUsePrivateKeyFile := nil; - _SslCtxUseCertificate := nil; - _SslCtxUseCertificateASN1 := nil; - _SslCtxUseCertificateFile := nil; - _SslCtxUseCertificateChainFile := nil; - _SslCtxCheckPrivateKeyFile := nil; - _SslCtxSetDefaultPasswdCb := nil; - _SslCtxSetDefaultPasswdCbUserdata := nil; - _SslCtxLoadVerifyLocations := nil; - _SslCtxCtrl := nil; - _SslNew := nil; - _SslFree := nil; - _SslAccept := nil; - _SslConnect := nil; - _SslShutdown := nil; - _SslRead := nil; - _SslPeek := nil; - _SslWrite := nil; - _SslPending := nil; - _SslGetPeerCertificate := nil; - _SslGetVersion := nil; - _SslCtxSetVerify := nil; - _SslGetCurrentCipher := nil; - _SslCipherGetName := nil; - _SslCipherGetBits := nil; - _SslGetVerifyResult := nil; - _SslCtrl := nil; - - _X509New := nil; - _X509Free := nil; - _X509NameOneline := nil; - _X509GetSubjectName := nil; - _X509GetIssuerName := nil; - _X509NameHash := nil; - _X509Digest := nil; - _X509print := nil; - _X509SetVersion := nil; - _X509SetPubkey := nil; - _X509SetIssuerName := nil; - _X509NameAddEntryByTxt := nil; - _X509Sign := nil; - _X509GmtimeAdj := nil; - _X509SetNotBefore := nil; - _X509SetNotAfter := nil; - _X509GetSerialNumber := nil; - _EvpPkeyNew := nil; - _EvpPkeyFree := nil; - _EvpPkeyAssign := nil; - _EVPCleanup := nil; - _EvpGetDigestByName := nil; - _SSLeayversion := nil; - _ErrErrorString := nil; - _ErrGetError := nil; - _ErrClearError := nil; - _ErrFreeStrings := nil; - _ErrRemoveState := nil; - _OPENSSLaddallalgorithms := nil; - _CRYPTOcleanupAllExData := nil; - _RandScreen := nil; - _BioNew := nil; - _BioFreeAll := nil; - _BioSMem := nil; - _BioCtrlPending := nil; - _BioRead := nil; - _BioWrite := nil; - _d2iPKCS12bio := nil; - _PKCS12parse := nil; - _PKCS12free := nil; - _RsaGenerateKey := nil; - _Asn1UtctimeNew := nil; - _Asn1UtctimeFree := nil; - _Asn1IntegerSet := nil; - _Asn1IntegerGet := nil; {pf} - _SkX509PopFree := nil; {pf} - _i2dX509bio := nil; - _i2dPrivateKeyBio := nil; - - // 3DES functions - _DESsetoddparity := nil; - _DESsetkeychecked := nil; - _DESecbencrypt := nil; - // - _CRYPTOnumlocks := nil; - _CRYPTOsetlockingcallback := nil; -{$ENDIF} - finally - SSLCS.Leave; - end; - Result := True; -end; - -function IsSSLloaded: Boolean; -begin - Result := SSLLoaded; -end; - -initialization -begin - SSLCS:= TCriticalSection.Create; -end; - -finalization -begin -{$IFNDEF CIL} - DestroySSLInterface; -{$ENDIF} - SSLCS.Free; -end; - -end. diff --git a/synapse/ssl_sbb.pas b/synapse/ssl_sbb.pas deleted file mode 100644 index c9380a4..0000000 --- a/synapse/ssl_sbb.pas +++ /dev/null @@ -1,697 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.003 | -|==============================================================================| -| Content: SSL support for SecureBlackBox | -|==============================================================================| -| Copyright (c)1999-2005, 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)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Allen Drennan (adrennan@wiredred.com) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL plugin for Eldos SecureBlackBox) - -For handling keys and certificates you can use this properties: -@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), -@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), -@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), -@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), -@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats -of keys and certificates refer to SecureBlackBox documentation. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_sbb; - -interface - -uses - SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, - SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, - SBUtils, SBConstants, SBSessionPool; - -const - DEFAULT_RECV_BUFFER=32768; - -type - {:@abstract(class implementing SecureBlackbox SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLSBB=class(TCustomSSL) - protected - FServer: Boolean; - FElSecureClient:TElSecureClient; - FElSecureServer:TElSecureServer; - FElCertStorage:TElMemoryCertStorage; - FElX509Certificate:TElX509Certificate; - FElX509CACertificate:TElX509Certificate; - FCipherSuites:TBits; - private - FRecvBuffer:String; - FRecvBuffers:String; - FRecvBuffersLock:TRTLCriticalSection; - FRecvDecodedBuffers:String; - function GetCipherSuite:Integer; - procedure Reset; - function Prepare(Server:Boolean):Boolean; - procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); - procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - public - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_sbb) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - published - property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; - property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; - property CipherSuites:TBits read FCipherSuites write FCipherSuites; - property CipherSuite:Integer read GetCipherSuite; - end; - -implementation - -var - FAcceptThread:THandle=0; - -// on error -procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); - -begin - FLastErrorDesc:=''; - FLastError:=ErrorCode; -end; - -// on send -procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lResult:Integer; - -begin - if FSocket.Socket=INVALID_SOCKET then - Exit; - lResult:=Send(FSocket.Socket,Buffer,Size,0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end; -end; - -// on receive -procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt); - -begin - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - if Length(FRecvBuffers)<=MaxSize then - begin - Written:=Length(FRecvBuffers); - Move(FRecvBuffers[1],Buffer^,Written); - FRecvBuffers:=''; - end - else - begin - Written:=MaxSize; - Move(FRecvBuffers[1],Buffer^,Written); - Delete(FRecvBuffers,1,Written); - end; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; -end; - -// on data -procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); - -var - lString:String; - -begin - SetLength(lString,Size); - Move(Buffer^,lString[1],Size); - FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; -end; - -{ inherited } - -constructor TSSLSBB.Create(const Value: TTCPBlockSocket); - -var - loop1:Integer; - -begin - inherited Create(Value); - FServer:=FALSE; - FElSecureClient:=NIL; - FElSecureServer:=NIL; - FElCertStorage:=NIL; - FElX509Certificate:=NIL; - FElX509CACertificate:=NIL; - SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); - FRecvBuffers:=''; - InitializeCriticalSection(FRecvBuffersLock); - FRecvDecodedBuffers:=''; - FCipherSuites:=TBits.Create; - if FCipherSuites<>NIL then - begin - FCipherSuites.Size:=SB_SUITE_LAST+1; - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FCipherSuites[loop1]:=TRUE; - end; -end; - -destructor TSSLSBB.Destroy; - -begin - Reset; - inherited Destroy; - if FCipherSuites<>NIL then - FreeAndNIL(FCipherSuites); - DeleteCriticalSection(FRecvBuffersLock); -end; - -function TSSLSBB.LibVersion: String; - -begin - Result:='SecureBlackBox'; -end; - -function TSSLSBB.LibName: String; - -begin - Result:='ssl_sbb'; -end; - -function FileToString(lFile:String):String; - -var - lStream:TMemoryStream; - -begin - Result:=''; - lStream:=TMemoryStream.Create; - if lStream<>NIL then - begin - lStream.LoadFromFile(lFile); - if lStream.Size>0 then - begin - lStream.Position:=0; - SetLength(Result,lStream.Size); - Move(lStream.Memory^,Result[1],lStream.Size); - end; - lStream.Free; - end; -end; - -function TSSLSBB.GetCipherSuite:Integer; - -begin - if FServer then - Result:=FElSecureServer.CipherSuite - else - Result:=FElSecureClient.CipherSuite; -end; - -procedure TSSLSBB.Reset; - -begin - if FElSecureServer<>NIL then - FreeAndNIL(FElSecureServer); - if FElSecureClient<>NIL then - FreeAndNIL(FElSecureClient); - if FElX509Certificate<>NIL then - FreeAndNIL(FElX509Certificate); - if FElX509CACertificate<>NIL then - FreeAndNIL(FElX509CACertificate); - if FElCertStorage<>NIL then - FreeAndNIL(FElCertStorage); - FSSLEnabled:=FALSE; -end; - -function TSSLSBB.Prepare(Server:Boolean): Boolean; - -var - loop1:Integer; - lStream:TMemoryStream; - lCertificate,lPrivateKey,lCertCA:String; - -begin - Result:=FALSE; - FServer:=Server; - - // reset, if necessary - Reset; - - // init, certificate - if FCertificateFile<>'' then - lCertificate:=FileToString(FCertificateFile) - else - lCertificate:=FCertificate; - if FPrivateKeyFile<>'' then - lPrivateKey:=FileToString(FPrivateKeyFile) - else - lPrivateKey:=FPrivateKey; - if FCertCAFile<>'' then - lCertCA:=FileToString(FCertCAFile) - else - lCertCA:=FCertCA; - if (lCertificate<>'') and (lPrivateKey<>'') then - begin - FElCertStorage:=TElMemoryCertStorage.Create(NIL); - if FElCertStorage<>NIL then - FElCertStorage.Clear; - - // apply ca certificate - if lCertCA<>'' then - begin - FElX509CACertificate:=TElX509Certificate.Create(NIL); - if FElX509CACertificate<>NIL then - begin - with FElX509CACertificate do - begin - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lCertCA); - lStream.Seek(0,soFromBeginning); - LoadFromStream(lStream); - finally - lStream.Free; - end; - end; - if FElCertStorage<>NIL then - FElCertStorage.Add(FElX509CACertificate); - end; - end; - - // apply certificate - FElX509Certificate:=TElX509Certificate.Create(NIL); - if FElX509Certificate<>NIL then - begin - with FElX509Certificate do - begin - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lCertificate); - lStream.Seek(0,soFromBeginning); - LoadFromStream(lStream); - finally - lStream.Free; - end; - lStream:=TMemoryStream.Create; - try - WriteStrToStream(lStream,lPrivateKey); - lStream.Seek(0,soFromBeginning); - LoadKeyFromStream(lStream); - finally - lStream.Free; - end; - if FElCertStorage<>NIL then - FElCertStorage.Add(FElX509Certificate); - end; - end; - end; - - // init, as server - if FServer then - begin - FElSecureServer:=TElSecureServer.Create(NIL); - if FElSecureServer<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1]; - FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; - FElSecureServer.ClientAuthentication:=FALSE; - FElSecureServer.OnError:=OnError; - FElSecureServer.OnSend:=OnSend; - FElSecureServer.OnReceive:=OnReceive; - FElSecureServer.OnData:=OnData; - FElSecureServer.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end - else - // init, as client - begin - FElSecureClient:=TElSecureClient.Create(NIL); - if FElSecureClient<>NIL then - begin - // init, ciphers - for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do - FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1]; - FElSecureClient.Versions:=[sbSSL3,sbTLS1]; - FElSecureClient.OnError:=OnError; - FElSecureClient.OnSend:=OnSend; - FElSecureClient.OnReceive:=OnReceive; - FElSecureClient.OnData:=OnData; - FElSecureClient.CertStorage:=FElCertStorage; - Result:=TRUE; - end; - end; -end; - -function TSSLSBB.Connect:Boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(FALSE) then - begin - FElSecureClient.Open; - - // reset - FRecvBuffers:=''; - FRecvDecodedBuffers:=''; - - // wait for open or error - while (not FElSecureClient.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureClient.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureClient.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Accept:Boolean; - -var - lResult:Integer; - -begin - Result:=FALSE; - if FSocket.Socket=INVALID_SOCKET then - Exit; - if Prepare(TRUE) then - begin - FAcceptThread:=GetCurrentThreadId; - FElSecureServer.Open; - - // reset - FRecvBuffers:=''; - FRecvDecodedBuffers:=''; - - // wait for open or error - while (not FElSecureServer.Active) and - (FLastError=0) do - begin - // data available? - if FRecvBuffers<>'' then - FElSecureServer.DataAvailable - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if lResult>0 then - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) - else - Break; - end; - end; - end; - if FLastError<>0 then - Exit; - FSSLEnabled:=FElSecureServer.Active; - Result:=FSSLEnabled; - end; -end; - -function TSSLSBB.Shutdown:Boolean; - -begin - Result:=BiShutdown; -end; - -function TSSLSBB.BiShutdown: boolean; - -begin - Reset; - Result:=TRUE; -end; - -function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - if FServer then - FElSecureServer.SendData(Buffer,Len) - else - FElSecureClient.SendData(Buffer,Len); - Result:=Len; -end; - -function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; - -begin - Result:=0; - try - // recv waiting, if necessary - if FRecvDecodedBuffers='' then - WaitingData; - - // received - if Length(FRecvDecodedBuffers)FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - lRecvBuffers:=FRecvBuffers<>''; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - if lRecvBuffers then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end - else - begin - // socket recv - lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); - if lResult=SOCKET_ERROR then - begin - FLastErrorDesc:=''; - FLastError:=WSAGetLastError; - end - else - begin - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - - // data available? - if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock); - try - lRecvBuffers:=FRecvBuffers<>''; - finally - if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock); - end; - if lRecvBuffers then - begin - if FServer then - FElSecureServer.DataAvailable - else - FElSecureClient.DataAvailable; - end; - end; - end; - - // decoded buffers result - Result:=Length(FRecvDecodedBuffers); -end; - -function TSSLSBB.GetSSLVersion: string; - -begin - Result:='SSLv3 or TLSv1'; -end; - -function TSSLSBB.GetPeerSubject: string; - -begin - Result := ''; -// if FServer then - // must return subject of the client certificate -// else - // must return subject of the server certificate -end; - -function TSSLSBB.GetPeerName: string; - -begin - Result := ''; -// if FServer then - // must return commonname of the client certificate -// else - // must return commonname of the server certificate -end; - -function TSSLSBB.GetPeerIssuer: string; - -begin - Result := ''; -// if FServer then - // must return issuer of the client certificate -// else - // must return issuer of the server certificate -end; - -function TSSLSBB.GetPeerFingerprint: string; - -begin - Result := ''; -// if FServer then - // must return a unique hash string of the client certificate -// else - // must return a unique hash string of the server certificate -end; - -function TSSLSBB.GetCertInfo: string; - -begin - Result := ''; -// if FServer then - // must return a text representation of the ASN of the client certificate -// else - // must return a text representation of the ASN of the server certificate -end; - -{==============================================================================} - -initialization - SSLImplementation := TSSLSBB; - -finalization - -end. diff --git a/synapse/ssl_streamsec.pas b/synapse/ssl_streamsec.pas deleted file mode 100644 index 8c36ac8..0000000 --- a/synapse/ssl_streamsec.pas +++ /dev/null @@ -1,539 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.000.006 | -|==============================================================================| -| Content: SSL support by StreamSecII | -|==============================================================================| -| Copyright (c)1999-2005, 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)2005. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| Henrick Hellström | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII) - -StreamSecII is native pascal library, you not need any external libraries! - -You can tune lot of StreamSecII properties by using your GlobalServer. If you not -using your GlobalServer, then this plugin create own TSimpleTLSInternalServer -instance for each TCP connection. Formore information about GlobalServer usage -refer StreamSecII documentation. - -If you are not using key and certificate by GlobalServer, then you can use -properties of this plugin instead, but this have limited features and -@link(TCustomSSL.KeyPassword) not working properly yet! - -For handling keys and certificates you can use this properties: -@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), -@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), -@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), -@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), -@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats -of keys and certificates refer to StreamSecII documentation. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -unit ssl_streamsec; - -interface - -uses - SysUtils, Classes, - blcksock, synsock, synautil, synacode, - TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base, - SecUtils; - -type - {:@exclude} - TMyTLSSynSockSlave = class(TTLSSynSockSlave) - protected - procedure SetMyTLSServer(const Value: TCustomTLSInternalServer); - function GetMyTLSServer: TCustomTLSInternalServer; - published - property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer; - end; - - {:@abstract(class implementing StreamSecII SSL plugin.) - Instance of this class will be created for each @link(TTCPBlockSocket). - You not need to create instance of this class, all is done by Synapse itself!} - TSSLStreamSec = class(TCustomSSL) - protected - FSlave: TMyTLSSynSockSlave; - FIsServer: Boolean; - FTLSServer: TCustomTLSInternalServer; - FServerCreated: Boolean; - function SSLCheck: Boolean; - function Init(server:Boolean): Boolean; - function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; - procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); - function X500StrToStr(const Prefix: string; const Value: TX500String): string; - function X501NameToStr(const Value: TX501Name): string; - function GetCert: PASN1Struct; - public - constructor Create(const Value: TTCPBlockSocket); override; - destructor Destroy; override; - {:See @inherited} - function LibVersion: String; override; - {:See @inherited} - function LibName: String; override; - {:See @inherited and @link(ssl_streamsec) for more details.} - function Connect: boolean; override; - {:See @inherited and @link(ssl_streamsec) for more details.} - function Accept: boolean; override; - {:See @inherited} - function Shutdown: boolean; override; - {:See @inherited} - function BiShutdown: boolean; override; - {:See @inherited} - function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; - {:See @inherited} - function WaitingData: Integer; override; - {:See @inherited} - function GetSSLVersion: string; override; - {:See @inherited} - function GetPeerSubject: string; override; - {:See @inherited} - function GetPeerIssuer: string; override; - {:See @inherited} - function GetPeerName: string; override; - {:See @inherited} - function GetPeerFingerprint: string; override; - {:See @inherited} - function GetCertInfo: string; override; - published - {:TLS server for tuning of StreamSecII.} - property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer; - end; - -implementation - -{==============================================================================} -procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer); -begin - TLSServer := Value; -end; - -function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer; -begin - Result := TLSServer; -end; - -{==============================================================================} - -constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket); -begin - inherited Create(Value); - FSlave := nil; - FIsServer := False; - FTLSServer := nil; -end; - -destructor TSSLStreamSec.Destroy; -begin - DeInit; - inherited Destroy; -end; - -function TSSLStreamSec.LibVersion: String; -begin - Result := 'StreamSecII'; -end; - -function TSSLStreamSec.LibName: String; -begin - Result := 'ssl_streamsec'; -end; - -function TSSLStreamSec.SSLCheck: Boolean; -begin - Result := true; - FLastErrorDesc := ''; - if not Assigned(FSlave) then - Exit; - FLastError := FSlave.ErrorCode; - if FLastError <> 0 then - begin - FLastErrorDesc := TlsConst.AlertMsg(FLastError); - end; -end; - -procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean); -begin - ExplicitTrust := true; -end; - -function TSSLStreamSec.Init(server:Boolean): Boolean; -var - st: TMemoryStream; - pass: ISecretKey; - ws: WideString; -begin - Result := False; - ws := FKeyPassword; - pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws)); - try - FIsServer := Server; - FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket); - if Assigned(FTLSServer) then - FSlave.MyTLSServer := FTLSServer - else - if Assigned(TLSInternalServer.GlobalServer) then - FSlave.MyTLSServer := TLSInternalServer.GlobalServer - else begin - FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil); - FServerCreated := True; - end; - if server then - FSlave.MyTLSServer.ClientOrServer := cosServerSide - else - FSlave.MyTLSServer.ClientOrServer := cosClientSide; - if not FVerifyCert then - begin - FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent; - end; - FSlave.MyTLSServer.Options.VerifyServerName := []; - FSlave.MyTLSServer.Options.Export40Bit := prAllowed; - FSlave.MyTLSServer.Options.Export56Bit := prAllowed; - FSlave.MyTLSServer.Options.RequestClientCertificate := False; - FSlave.MyTLSServer.Options.RequireClientCertificate := False; - if server and FVerifyCert then - begin - FSlave.MyTLSServer.Options.RequestClientCertificate := True; - FSlave.MyTLSServer.Options.RequireClientCertificate := True; - end; - if FCertCAFile <> '' then - FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile); - if FCertCA <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FCertCA); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadRootCertsFromStream(st); - finally - st.free; - end; - end; - if FTrustCertificateFile <> '' then - FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile); - if FTrustCertificate <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FTrustCertificate); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadTrustedCertsFromStream(st); - finally - st.free; - end; - end; - if FPrivateKeyFile <> '' then - FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass); -// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass); - if FPrivateKey <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FPrivateKey); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass); - finally - st.free; - end; - end; - if FCertificateFile <> '' then - FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile); - if FCertificate <> '' then - begin - st := TMemoryStream.Create; - try - WriteStrToStream(st, FCertificate); - st.Seek(0, soFromBeginning); - FSlave.MyTLSServer.LoadMyCertsFromStream(st); - finally - st.free; - end; - end; - if FPFXfile <> '' then - FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass); - if server and FServerCreated then - begin - FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer; - FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed; - FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256; - FSlave.MyTLSServer.Options.SignatureRSA := prPrefer; - FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed; - FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed; - FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer; - FSlave.MyTLSServer.TLSSetupServer; - end; - Result := true; - finally - pass := nil; - end; -end; - -function TSSLStreamSec.DeInit: Boolean; -var - obj: TObject; -begin - Result := True; - if assigned(FSlave) then - begin - FSlave.Close; - if FServerCreated then - obj := FSlave.TLSServer - else - obj := nil; - FSlave.Free; - obj.Free; - FSlave := nil; - end; - FSSLEnabled := false; -end; - -function TSSLStreamSec.Prepare(server:Boolean): Boolean; -begin - Result := false; - DeInit; - if Init(server) then - Result := true - else - DeInit; -end; - -function TSSLStreamSec.Connect: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(false) then - begin - FSlave.Open; - SSLCheck; - if FLastError <> 0 then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLStreamSec.Accept: boolean; -begin - Result := False; - if FSocket.Socket = INVALID_SOCKET then - Exit; - if Prepare(true) then - begin - FSlave.DoConnect; - SSLCheck; - if FLastError <> 0 then - Exit; - FSSLEnabled := True; - Result := True; - end; -end; - -function TSSLStreamSec.Shutdown: boolean; -begin - Result := BiShutdown; -end; - -function TSSLStreamSec.BiShutdown: boolean; -begin - DeInit; - Result := True; -end; - -function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - l := len; - FSlave.SendBuf(Buffer^, l, true); - Result := l; - SSLCheck; -end; - -function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; -var - l: integer; -begin - l := Len; - Result := FSlave.ReceiveBuf(Buffer^, l); - SSLCheck; -end; - -function TSSLStreamSec.WaitingData: Integer; -begin - Result := 0; - while FSlave.Connected do begin - Result := FSlave.ReceiveLength; - if Result > 0 then - Break; - Sleep(1); - end; -end; - -function TSSLStreamSec.GetSSLVersion: string; -begin - Result := 'SSLv3 or TLSv1'; -end; - -function TSSLStreamSec.GetCert: PASN1Struct; -begin - if FIsServer then - Result := FSlave.GetClientCert - else - Result := FSlave.GetServerCert; -end; - -function TSSLStreamSec.GetPeerSubject: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractSubject(Cert^,XName, false); - Result := X501NameToStr(XName); - end; -end; - -function TSSLStreamSec.GetPeerName: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractSubject(Cert^,XName, false); - Result := XName.commonName.Str; - end; -end; - -function TSSLStreamSec.GetPeerIssuer: string; -var - XName: TX501Name; - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - ExtractIssuer(Cert^, XName, false); - Result := X501NameToStr(XName); - end; -end; - -function TSSLStreamSec.GetPeerFingerprint: string; -var - Cert: PASN1Struct; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - Result := MD5(Cert.ContentAsOctetString); -end; - -function TSSLStreamSec.GetCertInfo: string; -var - Cert: PASN1Struct; - l: Tstringlist; -begin - Result := ''; - Cert := GetCert; - if Assigned(cert) then - begin - l := TStringList.Create; - try - Asn1.RenderAsText(cert^, l, true, true, true, 2); - Result := l.Text; - finally - l.free; - end; - end; -end; - -function TSSLStreamSec.X500StrToStr(const Prefix: string; - const Value: TX500String): string; -begin - if Value.Str = '' then - Result := '' - else - Result := '/' + Prefix + '=' + Value.Str; -end; - -function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string; -begin - Result := X500StrToStr('CN',Value.commonName) + - X500StrToStr('C',Value.countryName) + - X500StrToStr('L',Value.localityName) + - X500StrToStr('ST',Value.stateOrProvinceName) + - X500StrToStr('O',Value.organizationName) + - X500StrToStr('OU',Value.organizationalUnitName) + - X500StrToStr('T',Value.title) + - X500StrToStr('N',Value.name) + - X500StrToStr('G',Value.givenName) + - X500StrToStr('I',Value.initials) + - X500StrToStr('SN',Value.surname) + - X500StrToStr('GQ',Value.generationQualifier) + - X500StrToStr('DNQ',Value.dnQualifier) + - X500StrToStr('E',Value.emailAddress); -end; - - -{==============================================================================} - -initialization - SSLImplementation := TSSLStreamSec; - -finalization - -end. - - diff --git a/synapse/sslinux.inc b/synapse/sslinux.inc deleted file mode 100644 index 2a23146..0000000 --- a/synapse/sslinux.inc +++ /dev/null @@ -1,1314 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.000.009 | -|==============================================================================| -| Content: Socket Independent Platform Layer - Linux definition include | -|==============================================================================| -| Copyright (c)1999-2010, 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-2010. | -| 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, Classes, - synafpc, - 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; - TAddrFamily = integer; - - TMemory = pointer; - - -const - DLLStackName = 'libc.so.6'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - -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_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - PInAddr = ^TInAddr; - TInAddr = packed record - case integer of - 0: (S_bytes: packed array [0..3] of byte); - 1: (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; - - PInAddr6 = ^TInAddr6; - TInAddr6 = packed record - case integer of - 0: (S6_addr: packed array [0..15] of byte); - 1: (u6_addr8: packed array [0..15] of byte); - 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..3] of integer); - 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: integer; // Interface index. - padding: u_long; - end; - - PHostEnt = ^THostEnt; - THostent = 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: integer; - l_linger: integer; - 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: integer): 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; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): string; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; - -{==============================================================================} -implementation - -var - SynSockCount: Integer = 0; - LibHandle: TLibHandle = 0; - Libwship6Handle: TLibHandle = 0; - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $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^.u6_addr8[15] := 1; -end; - -{=============================================================================} -var -{$IFNDEF VER1_0} //FTP version 1.0.x - 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 := LongWord(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 IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -type - pu_long = ^u_long; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - HostEnt: PHostEnt; - r: integer; - 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 - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - if not IsNewApi(family) then - begin - SynSockCS.Enter; - try - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(Port, 0)) - else - Sin.sin_port := ServEnt^.s_port; - if IP = cBroadcast then - Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) - else - begin - Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP)); - if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then - begin - HostEnt := synsock.GetHostByName(PChar(IP)); - Result := synsock.WSAGetLastError; - if HostEnt <> nil then - Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - begin - FillChar(Hints1, Sizeof(Hints1), 0); - FillChar(Hints2, Sizeof(Hints2), 0); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 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 - else - Hints1.ai_family := Family; - - Hints1.ai_socktype := SockType; - Hints1.ai_protocol := SockProtocol; - Hints2.ai_socktype := Hints1.ai_socktype; - Hints2.ai_protocol := Hints1.ai_protocol; - - r := GetAddr(IP, Port, Hints1, Sin1); - Result := r; - sin := sin1; - if r <> 0 then - if TwoPass then - begin - r := GetAddr(IP, Port, Hints2, Sin2); - Result := r; - if r = 0 then - sin := sin2; - end; - end; -end; - -function GetSinIP(Sin: TVarSin): string; -var - p: PChar; - host, serv: string; - hostlen, servlen: integer; - r: integer; -begin - Result := ''; - if not IsNewApi(Sin.AddressFamily) then - begin - p := synsock.inet_ntoa(Sin.sin_addr); - if p <> nil then - Result := p; - end - else - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); -type - TaPInAddr = array[0..250] of PInAddr; - PaPInAddr = ^TaPInAddr; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IP: u_long; - PAdrPtr: PaPInAddr; - i: Integer; - s: string; - InAddr: TInAddr; -begin - IPList.Clear; - if not IsNewApi(Family) then - begin - IP := synsock.inet_addr(PChar(Name)); - if IP = u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := synsock.GetHostByName(PChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do - begin - InAddr := PAdrPtr^[i]^; - s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], - InAddr.S_bytes[2], InAddr.S_bytes[3]]); - IPList.Add(s); - Inc(i); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - IPList.Add(Name); - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr); - if r = 0 then - begin - AddrNext := Addr; - while not(AddrNext = nil) do - begin - if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) - or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - begin - host := PChar(host); - IPList.Add(host); - end; - end; - AddrNext := AddrNext^.ai_next; - end; - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; -begin - Result := 0; - if not IsNewApi(Family) then - begin - SynSockCS.Enter; - try - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := StrToIntDef(Port, 0) - else - Result := synsock.htons(ServEnt^.s_port); - finally - SynSockCS.Leave; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := Sockprotocol; - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - if (r = 0) and Assigned(Addr) then - begin - if Addr^.ai_family = AF_INET then - Result := synsock.htons(Addr^.ai_addr^.sin_port); - if Addr^.ai_family = AF_INET6 then - Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IPn: u_long; -begin - Result := IP; - if not IsNewApi(Family) then - begin - IPn := synsock.inet_addr(PChar(IP)); - if IPn <> u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); - if RemoteHost <> nil then - Result := RemoteHost^.h_name; - finally - SynSockCS.Leave; - end; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr); - if (r = 0) and Assigned(Addr)then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - 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; - 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/synapse/sswin32.inc b/synapse/sswin32.inc deleted file mode 100644 index 0b55e00..0000000 --- a/synapse/sswin32.inc +++ /dev/null @@ -1,1615 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.003.000 | -|==============================================================================| -| Content: Socket Independent Platform Layer - Win32/64 definition include | -|==============================================================================| -| Copyright (c)1999-2011, 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-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -//{$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} - -{$IFDEF FPC} - {$IFDEF WIN32} - {$ALIGN OFF} - {$ELSE} - {$PACKRECORDS C} - {$ENDIF} -{$ENDIF} - -interface - -uses - SyncObjs, SysUtils, Classes, - Windows; - -function InitSocketInterface(stack: String): Boolean; -function DestroySocketInterface: Boolean; - -const -{$IFDEF WINSOCK1} - WinsockLevel = $0101; -{$ELSE} - WinsockLevel = $0202; -{$ENDIF} - -type - u_short = Word; - u_int = Integer; - u_long = Longint; - pu_long = ^u_long; - pu_short = ^u_short; -{$IFDEF FPC} - TSocket = ptruint; -{$ELSE} - {$IFDEF WIN64} - TSocket = UINT_PTR; - {$ELSE} - TSocket = u_int; - {$ENDIF} -{$ENDIF} - TAddrFamily = integer; - - TMemory = pointer; - -const - {$IFDEF WINCE} - DLLStackName = 'ws2.dll'; - {$ELSE} - {$IFDEF WINSOCK1} - DLLStackName = 'wsock32.dll'; - {$ELSE} - DLLStackName = 'ws2_32.dll'; - {$ENDIF} - {$ENDIF} - DLLwship6 = 'wship6.dll'; - - cLocalhost = '127.0.0.1'; - cAnyHost = '0.0.0.0'; - cBroadcast = '255.255.255.255'; - c6Localhost = '::1'; - c6AnyHost = '::0'; - c6Broadcast = 'ffff::1'; - cAnyPort = '0'; - - -const - FD_SETSIZE = 64; -type - PFDSet = ^TFDSet; - TFDSet = 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 = 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_RM = 113; - - IPPROTO_RAW = 255; - IPPROTO_MAX = 256; - -type - - PInAddr = ^TInAddr; - TInAddr = record - case integer of - 0: (S_bytes: packed array [0..3] of byte); - 1: (S_addr: u_long); - end; - - PSockAddrIn = ^TSockAddrIn; - TSockAddrIn = record - case Integer of - 0: (sin_family: u_short; - sin_port: u_short; - sin_addr: TInAddr; - sin_zero: array[0..7] of byte); - 1: (sa_family: u_short; - sa_data: array[0..13] of byte) - end; - - TIP_mreq = record - imr_multiaddr: TInAddr; { IP multicast address of group } - imr_interface: TInAddr; { local IP address of interface } - end; - - PInAddr6 = ^TInAddr6; - TInAddr6 = record - case integer of - 0: (S6_addr: packed array [0..15] of byte); - 1: (u6_addr8: packed array [0..15] of byte); - 2: (u6_addr16: packed array [0..7] of word); - 3: (u6_addr32: packed array [0..3] of integer); - end; - - PSockAddrIn6 = ^TSockAddrIn6; - TSockAddrIn6 = 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: integer; // Interface index. - padding: integer; - end; - - PHostEnt = ^THostEnt; - THostEnt = record - h_name: PAnsiChar; - h_aliases: ^PAnsiChar; - h_addrtype: Smallint; - h_length: Smallint; - case integer of - 0: (h_addr_list: ^PAnsiChar); - 1: (h_addr: ^PInAddr); - end; - - PNetEnt = ^TNetEnt; - TNetEnt = record - n_name: PAnsiChar; - n_aliases: ^PAnsiChar; - n_addrtype: Smallint; - n_net: u_long; - end; - - PServEnt = ^TServEnt; - TServEnt = record - s_name: PAnsiChar; - s_aliases: ^PAnsiChar; -{$ifdef WIN64} - s_proto: PAnsiChar; - s_port: Smallint; -{$else} - s_port: Smallint; - s_proto: PAnsiChar; -{$endif} - end; - - PProtoEnt = ^TProtoEnt; - TProtoEnt = record - p_name: PAnsiChar; - p_aliases: ^PAnsichar; - 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 = 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: PAnsiChar; // 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 = 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 = record - wVersion: Word; - wHighVersion: Word; -{$ifdef win64} - iMaxSockets : Word; - iMaxUdpDg : Word; - lpVendorInfo : PAnsiChar; - szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; - szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; -{$else} - szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; - szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; - iMaxSockets: Word; - iMaxUdpDg: Word; - lpVendorInfo: PAnsiChar; -{$endif} - 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: PAnsiChar): PServEnt; - stdcall; - TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; - stdcall; - TGetProtoByName = function(name: PAnsiChar): PProtoEnt; - stdcall; - TGetProtoByNumber = function(proto: Integer): PProtoEnt; - stdcall; - TGetHostByName = function(name: PAnsiChar): PHostEnt; - stdcall; - TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; - stdcall; - TGetHostName = function(name: PAnsiChar; len: Integer): Integer; - stdcall; - TShutdown = function(s: TSocket; how: Integer): Integer; - stdcall; - TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; - optlen: Integer): Integer; - stdcall; - TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; - 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: Integer): Integer; - stdcall; - TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; - stdcall; - TInet_addr = function(cp: PAnsiChar): 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: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; - var Addrinfo: PAddrInfo): integer; - stdcall; - TFreeAddrInfo = procedure(ai: PAddrInfo); - stdcall; - TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; - hostlen: DWORD; serv: PAnsiChar; 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 byte); - 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: AnsiString; -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; - -function IsNewApi(Family: integer): Boolean; -function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -function GetSinIP(Sin: TVarSin): AnsiString; -function GetSinPort(Sin: TVarSin): Integer; -procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); -function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; -function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; - -{==============================================================================} -implementation - -var - SynSockCount: Integer = 0; - LibHandle: THandle = 0; - Libwship6Handle: THandle = 0; - -function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); -end; - -function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and - (a^.u6_addr32[2] = 0) and - (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and - (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); -end; - -function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); -end; - -function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; -begin - Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); -end; - -function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; -begin - Result := (a^.u6_addr8[0] = $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^.u6_addr8[15] := 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: AnsiString; -var - s: AnsiString; -begin - Result := ''; - setlength(s, 255); - ssGetHostName(pAnsichar(s), Length(s) - 1); - Result := PAnsichar(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 IsNewApi(Family: integer): Boolean; -begin - Result := SockEnhancedApi; - if not Result then - Result := (Family = AF_INET6) and SockWship6Api; -end; - -function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; -type - pu_long = ^u_long; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - HostEnt: PHostEnt; - r: integer; - Hints1, Hints2: TAddrInfo; - Sin1, Sin2: TVarSin; - TwoPass: boolean; - - function GetAddr(const IP, port: AnsiString; 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(PAnsiChar(IP), nil, @Hints, Addr); - end - else - begin - if (IP = cAnyHost) or (IP = c6AnyHost) then - begin - Hints.ai_flags := AI_PASSIVE; - Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - end - else - if (IP = cLocalhost) or (IP = c6Localhost) then - begin - Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - end - else - begin - Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(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 - Result := 0; - FillChar(Sin, Sizeof(Sin), 0); - if not IsNewApi(family) then - begin - SynSockCS.Enter; - try - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then - ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) - else - Sin.sin_port := ServEnt^.s_port; - if IP = cBroadcast then - Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) - else - begin - Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); - if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then - begin - HostEnt := synsock.GetHostByName(PAnsiChar(IP)); - Result := synsock.WSAGetLastError; - if HostEnt <> nil then - Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - begin - FillChar(Hints1, Sizeof(Hints1), 0); - FillChar(Hints2, Sizeof(Hints2), 0); - TwoPass := False; - if Family = AF_UNSPEC then - begin - if PreferIP4 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 - else - Hints1.ai_family := Family; - - Hints1.ai_socktype := SockType; - Hints1.ai_protocol := SockProtocol; - Hints2.ai_socktype := Hints1.ai_socktype; - Hints2.ai_protocol := Hints1.ai_protocol; - - r := GetAddr(IP, Port, Hints1, Sin1); - Result := r; - sin := sin1; - if r <> 0 then - if TwoPass then - begin - r := GetAddr(IP, Port, Hints2, Sin2); - Result := r; - if r = 0 then - sin := sin2; - end; - end; -end; - -function GetSinIP(Sin: TVarSin): AnsiString; -var - p: PAnsiChar; - host, serv: AnsiString; - hostlen, servlen: integer; - r: integer; -begin - Result := ''; - if not IsNewApi(Sin.AddressFamily) then - begin - p := synsock.inet_ntoa(Sin.sin_addr); - if p <> nil then - Result := p; - end - else - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, - PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PAnsiChar(host); - end; -end; - -function GetSinPort(Sin: TVarSin): Integer; -begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -end; - -procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); -type - TaPInAddr = array[0..250] of PInAddr; - PaPInAddr = ^TaPInAddr; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; - r: integer; - host, serv: AnsiString; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IP: u_long; - PAdrPtr: PaPInAddr; - i: Integer; - s: String; - InAddr: TInAddr; -begin - IPList.Clear; - if not IsNewApi(Family) then - begin - IP := synsock.inet_addr(PAnsiChar(Name)); - if IP = u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do - begin - InAddr := PAdrPtr^[i]^; - s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], - InAddr.S_bytes[2], InAddr.S_bytes[3]]); - IPList.Add(s); - Inc(i); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - IPList.Add(string(Name)); - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); - if r = 0 then - begin - AddrNext := Addr; - while not(AddrNext = nil) do - begin - if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) - or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, - PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, - NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - begin - host := PAnsiChar(host); - IPList.Add(string(host)); - end; - end; - AddrNext := AddrNext^.ai_next; - end; - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; - if IPList.Count = 0 then - IPList.Add(cAnyHost); -end; - -function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; -begin - Result := 0; - if not IsNewApi(Family) then - begin - SynSockCS.Enter; - try - ProtoEnt := synsock.GetProtoByNumber(SockProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := StrToIntDef(string(Port), 0) - else - Result := synsock.htons(ServEnt^.s_port); - finally - SynSockCS.Leave; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := Sockprotocol; - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); - if (r = 0) and Assigned(Addr) then - begin - if Addr^.ai_family = AF_INET then - Result := synsock.htons(Addr^.ai_addr^.sin_port); - if Addr^.ai_family = AF_INET6 then - Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; - -function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; - host, serv: AnsiString; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IPn: u_long; -begin - Result := IP; - if not IsNewApi(Family) then - begin - IPn := synsock.inet_addr(PAnsiChar(IP)); - if IPn <> u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); - if RemoteHost <> nil then - Result := RemoteHost^.h_name; - finally - SynSockCS.Leave; - end; - end; - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := SockType; - Hints.ai_protocol := SockProtocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); - if (r = 0) and Assigned(Addr)then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, - PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, - NI_NUMERICSERV); - if r = 0 then - Result := PAnsiChar(host); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - 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; - LibHandle := LoadLibrary(PChar(Stack)); - if LibHandle <> 0 then - begin - WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); - __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); - CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); - IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); - WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); - WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); - WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); - ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); - ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); - ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); - ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); - ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); - GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); - Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); - Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); - Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); - Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); - Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); - Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); - Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); - ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); - ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); - Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); - ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); - ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); - SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); - ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); - Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); - GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); - GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); - GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); - GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); - GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); - GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); - ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); - -{$IFNDEF FORCEOLDAPI} - GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); - FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); - GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('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, PAnsiChar(AnsiString('getaddrinfo'))); - FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); - GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('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; \ No newline at end of file diff --git a/synapse/synachar.pas b/synapse/synachar.pas deleted file mode 100644 index af889f0..0000000 --- a/synapse/synachar.pas +++ /dev/null @@ -1,2035 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 005.002.002 | -|==============================================================================| -| Content: Charset conversion support | -|==============================================================================| -| Copyright (c)1999-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)2000-2004. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (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} -{$Q-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synachar; - -interface - -uses -{$IFNDEF WIN32} - {$IFNDEF FPC} - Libc, - {$ELSE} - {$IFDEF FPC_USE_LIBC} - Libc, - {$ENDIF} - {$ENDIF} -{$ELSE} - Windows, -{$ENDIF} - SysUtils, - synautil, synacode, synaicnv; - -type - {: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; - - {:Default set of charsets for @link(IdealCharsetCoding) function.} - IdealCharsets: TMimeSetChar = - [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, - KOI8_R, KOI8_U - {$IFNDEF CIL} //error URW778 ??? :-O - , GB2312, EUC_KR, ISO_2022_JP, EUC_TW - {$ENDIF} - ]; - -{==============================================================================} -{: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; - -{:Convert binary string with unicode content to WideString.} -function StringToWide(const Value: AnsiString): WideString; - -{:Convert WideString to binary string with unicode content.} -function WideToString(const Value: WideString): AnsiString; - -{==============================================================================} -implementation - -//character transcoding tables X to UCS-2 -{ -//dummy table -$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, -$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, -$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, -$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, -$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, -$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, -$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, -$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, -$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, -$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, -$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, -$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, -$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, -$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, -$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, -$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF -} - -const - -{Latin-1 - Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic, - Irish, Italian, Norwegian, Portuguese, Spanish and Swedish. -} - CharISO_8859_1: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Latin-2 - Albanian, Czech, English, German, Hungarian, Polish, Rumanian, - Serbo-Croatian, Slovak, Slovene and Swedish. -} - CharISO_8859_2: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, - $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, - $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, - $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, - $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, - $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, - $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, - $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, - $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 - ); - -{Latin-3 - Afrikaans, Catalan, English, Esperanto, French, Galician, - German, Italian, Maltese and Turkish. -} - CharISO_8859_3: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7, - $00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B, - $00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7, - $00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C, - $00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7, - $011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF, - $00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7, - $011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9 - ); - -{Latin-4 - Danish, English, Estonian, Finnish, German, Greenlandic, - Lappish, Latvian, Lithuanian, Norwegian and Swedish. -} - CharISO_8859_4: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7, - $00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF, - $00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7, - $00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B, - $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, - $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A, - $0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7, - $00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF, - $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, - $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B, - $0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7, - $00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9 - ); - -{CYRILLIC - Bulgarian, Bielorussian, English, Macedonian, Russian, - Serbo-Croatian and Ukrainian. -} - CharISO_8859_5: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407, - $0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F, - $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, - $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, - $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, - $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, - $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, - $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, - $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, - $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F, - $2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457, - $0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F - ); - -{ARABIC -} - CharISO_8859_6: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F, - $FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627, - $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, - $0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637, - $0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647, - $0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F, - $0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD - ); - -{GREEK -} - CharISO_8859_7: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7, - $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015, - $00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7, - $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, - $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, - $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, - $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, - $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, - $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, - $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, - $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, - $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD - ); - -{HEBREW -} - CharISO_8859_8: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017, - $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, - $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, - $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, - $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD - ); - -{Latin-5 - English, Finnish, French, German, Irish, Italian, Norwegian, - Portuguese, Spanish, Swedish and Turkish. -} - CharISO_8859_9: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7, - $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B, - $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7, - $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF - ); - -{Latin-6 - Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic, - Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish. -} - CharISO_8859_10: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7, - $013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A, - $00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7, - $013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B, - $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E, - $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF, - $00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168, - $00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F, - $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF, - $00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169, - $00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138 - ); - - CharISO_8859_13: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7, - $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, - $00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7, - $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, - $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, - $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, - $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, - $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, - $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, - $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, - $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, - $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019 - ); - - CharISO_8859_14: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7, - $1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178, - $1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56, - $1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF - ); - - CharISO_8859_15: array[128..255] of Word = - ( - $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087, - $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F, - $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097, - $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F, - $00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7, - $0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7, - $017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Eastern European -} - CharCP_1250: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, - $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A, - $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, - $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, - $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7, - $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C, - $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7, - $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, - $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF, - $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7, - $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F, - $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, - $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9 - ); - -{Cyrillic -} - CharCP_1251: array[128..255] of Word = - ( - $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021, - $20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F, - $0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F, - $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7, - $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407, - $00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7, - $0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457, - $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417, - $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, - $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, - $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F, - $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437, - $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F, - $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, - $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F - ); - -{Latin-1 (US, Western Europe) -} - CharCP_1252: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF - ); - -{Greek -} - CharCP_1253: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, - $00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015, - $00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7, - $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F, - $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397, - $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F, - $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7, - $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF, - $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7, - $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF, - $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7, - $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD - ); - -{Turkish -} - CharCP_1254: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF, - $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF, - $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF - ); - -{Hebrew -} - CharCP_1255: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD, - $00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7, - $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF, - $05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7, - $05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF, - $05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3, - $05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, - $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7, - $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF, - $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7, - $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD - ); - -{Arabic -} - CharCP_1256: array[128..255] of Word = - ( - $20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688, - $06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA, - $00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F, - $06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627, - $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F, - $0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7, - $0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643, - $00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7, - $00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF, - $064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7, - $0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2 - ); - -{Baltic -} - CharCP_1257: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021, - $FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD, - $00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7, - $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6, - $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112, - $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B, - $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7, - $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF, - $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113, - $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C, - $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7, - $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9 - ); - -{Vietnamese -} - CharCP_1258: array[128..255] of Word = - ( - $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021, - $02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD, - $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014, - $02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178, - $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, - $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, - $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF, - $00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7, - $00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF, - $0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7, - $00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF, - $00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7, - $00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF, - $0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF - ); - -{Cyrillic -} - CharKOI8_R: array[128..255] of Word = - ( - $2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524, - $252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590, - $2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248, - $2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7, - $2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556, - $2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E, - $255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565, - $2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9, - $044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433, - $0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E, - $043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432, - $044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A, - $042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413, - $0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E, - $041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412, - $042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A - ); - -{Czech (Kamenicky) -} - CharCP_895: array[128..255] of Word = - ( - $010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D, - $011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1, - $00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA, - $00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165, - $00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4, - $0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB, - $2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556, - $2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510, - $2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F, - $255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567, - $2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B, - $256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580, - $03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4, - $03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229, - $2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248, - $2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0 - ); - -{Eastern European -} - CharCP_852: array[128..255] of Word = - ( - $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7, - $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106, - $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A, - $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D, - $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E, - $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB, - $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A, - $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510, - $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103, - $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4, - $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE, - $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580, - $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161, - $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4, - $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8, - $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0 - ); - -{==============================================================================} -type - TIconvChar = record - Charset: TMimeChar; - CharName: string; - end; - TIconvArr = array [0..112] of TIconvChar; - -const - NotFoundChar = '_'; - -var - 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; -var - n: integer; -begin - if High(TransformTable) <> 0 then - for n := 0 to High(TransformTable) do - if not odd(n) then - if TransformTable[n] = Value then - begin - Value := TransformTable[n+1]; - break; - end; - Result := Value; -end; - -{==============================================================================} -procedure CopyArray(const SourceTable: array of Word; - var TargetTable: array of Word); -var - n: Integer; -begin - for n := 0 to 127 do - TargetTable[n] := SourceTable[n]; -end; - -{==============================================================================} -procedure GetArray(CharSet: TMimeChar; var Result: array of Word); -begin - case CharSet of - ISO_8859_2: - CopyArray(CharISO_8859_2, Result); - ISO_8859_3: - CopyArray(CharISO_8859_3, Result); - ISO_8859_4: - CopyArray(CharISO_8859_4, Result); - ISO_8859_5: - CopyArray(CharISO_8859_5, Result); - ISO_8859_6: - CopyArray(CharISO_8859_6, Result); - ISO_8859_7: - CopyArray(CharISO_8859_7, Result); - ISO_8859_8: - CopyArray(CharISO_8859_8, Result); - ISO_8859_9: - CopyArray(CharISO_8859_9, Result); - ISO_8859_10: - CopyArray(CharISO_8859_10, Result); - ISO_8859_13: - CopyArray(CharISO_8859_13, Result); - ISO_8859_14: - CopyArray(CharISO_8859_14, Result); - ISO_8859_15: - CopyArray(CharISO_8859_15, Result); - CP1250: - CopyArray(CharCP_1250, Result); - CP1251: - CopyArray(CharCP_1251, Result); - CP1252: - CopyArray(CharCP_1252, Result); - CP1253: - CopyArray(CharCP_1253, Result); - CP1254: - CopyArray(CharCP_1254, Result); - CP1255: - CopyArray(CharCP_1255, Result); - CP1256: - CopyArray(CharCP_1256, Result); - CP1257: - CopyArray(CharCP_1257, Result); - CP1258: - CopyArray(CharCP_1258, Result); - KOI8_R: - CopyArray(CharKOI8_R, Result); - CP895: - CopyArray(CharCP_895, Result); - CP852: - CopyArray(CharCP_852, Result); - else - CopyArray(CharISO_8859_1, Result); - end; -end; - -{==============================================================================} -procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; - var b1, b2, b3, b4: Byte; le: boolean); -Begin - b1 := 0; - b2 := 0; - b3 := 0; - b4 := 0; - if Index < 0 then - Index := 1; - if mb > 4 then - mb := 1; - if (Index + mb - 1) <= Length(Value) then - begin - if le then - Case mb Of - 1: - b1 := Ord(Value[Index]); - 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]); - 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; - end; - Inc(Index, mb); -end; - -{==============================================================================} -function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString; -begin - if mb > 4 then - mb := 1; - SetLength(Result, mb); - 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: AnsiString): AnsiString; -var - n, x, ul, m: Integer; - s: AnsiString; - w1, w2: Word; -begin - Result := ''; - n := 1; - while Length(Value) >= n do - begin - x := Ord(Value[n]); - Inc(n); - if x < 128 then - Result := Result + WriteMulti(x, 0, 0, 0, 4, false) - else - begin - m := 0; - if (x and $E0) = $C0 then - m := $1F; - if (x and $F0) = $E0 then - m := $0F; - if (x and $F8) = $F0 then - m := $07; - if (x and $FC) = $F8 then - m := $03; - if (x and $FE) = $FC then - m := $01; - ul := x and m; - s := IntToBin(ul, 0); - while Length(Value) >= n do - begin - x := Ord(Value[n]); - Inc(n); - if (x and $C0) = $80 then - s := s + IntToBin(x and $3F, 6) - else - begin - Dec(n); - Break; - end; - end; - ul := BinToInt(s); - w1 := ul div 65536; - w2 := ul mod 65536; - Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false); - end; - end; -end; - -{==============================================================================} -function UCS4toUTF8(const Value: AnsiString): AnsiString; -var - s, l, k: AnsiString; - b1, b2, b3, b4: Byte; - n, m, x, y: Integer; - b: Byte; -begin - Result := ''; - n := 1; - while Length(Value) >= n do - begin - ReadMulti(Value, n, 4, b1, b2, b3, b4, false); - if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then - Result := Result + AnsiChar(b1) - else - begin - x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536; - l := IntToBin(x, 0); - y := Length(l) div 6; - s := ''; - for m := 1 to y do - begin - k := Copy(l, Length(l) - 5, 6); - l := Copy(l, 1, Length(l) - 6); - b := BinToInt(k) or $80; - s := AnsiChar(b) + s; - end; - b := BinToInt(l); - case y of - 5: - b := b or $FC; - 4: - b := b or $F8; - 3: - b := b or $F0; - 2: - b := b or $E0; - 1: - b := b or $C0; - end; - s := AnsiChar(b) + s; - Result := Result + s; - end; - end; -end; - -{==============================================================================} -function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString; -var - n, i: Integer; - 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 <> shift then - Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false) - else - begin - s := ''; - while Length(Value) >= n do - begin - c := Value[n]; - Inc(n); - if c = '-' then - Break; - if (c = '=') or (Pos(c, table) < 1) then - begin - Dec(n); - Break; - end; - s := s + c; - end; - if s = '' then - s := WriteMulti(Ord(shift), 0, 0, 0, 2, false) - else - begin - 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(shift), 0, 0, 0, 2, false); - for i := 1 to length(t) do - s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false); - end; - end; - Result := Result + s; - end; - end; -end; - -{==============================================================================} -function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString; -var - 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, false); - if (b2 = 0) and (b1 < 128) then - if AnsiChar(b1) = shift then - Result := Result + shift + '-' - else - Result := Result + AnsiChar(b1) - else - begin - s := AnsiChar(b2) + AnsiChar(b1); - while Length(Value) >= n do - begin - ReadMulti(Value, n, 2, b1, b2, b3, b4, false); - if (b2 = 0) and (b1 < 128) then - begin - Dec(n, 2); - Break; - end; - s := s + AnsiChar(b2) + AnsiChar(b1); - end; - 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 + shift + s + '-'; - end; - end; -end; - -{==============================================================================} -function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar): AnsiString; -begin - Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None); -end; - -{==============================================================================} -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 InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString; -var - uni: Word; - n: Integer; - b1, b2, b3, b4: Byte; - SourceTable: array[128..255] of Word; - mbf: Byte; - lef: Boolean; - s: AnsiString; -begin - 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) - else - s := Value; - GetArray(CharFrom, SourceTable); - mbf := 1; - if CharFrom in SetTwo then - mbf := 2; - if CharFrom in SetFour then - mbf := 4; - lef := CharFrom in SetLe; - Result := ''; - 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; - Result := Result + WriteMulti(b1, b2, b3, b4, 2, False); - end; -end; - -function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString; -var - uni: Word; - n, m: Integer; - b: Byte; - b1, b2, b3, b4: Byte; - TargetTable: array[128..255] of Word; - mbt: Byte; - let: Boolean; - ucsstring, s, t: AnsiString; - cd: iconv_t; - f: Boolean; - NotNeedTransform: Boolean; - FromID, ToID: string; -begin - NotNeedTransform := (High(TransformTable) = 0); - if (CharFrom = CharTo) and NotNeedTransform then - begin - Result := Value; - Exit; - end; - FromID := GetIDFromCP(CharFrom); - ToID := GetIDFromCP(CharTo); - cd := Iconv_t(-1); - //do two-pass conversion. Transform to UCS-2 first. - if not DisableIconv then - cd := SynaIconvOpenIgnore('UCS-2BE', FromID); - try - if cd <> iconv_t(-1) then - SynaIconv(cd, Value, ucsstring) - else - ucsstring := InternalToUcs(Value, CharFrom); - finally - SynaIconvClose(cd); - 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 - 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 - 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 - 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 - 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; -end; - -{==============================================================================} -{$IFNDEF WIN32} - -function GetCurCP: TMimeChar; -begin - {$IFNDEF FPC} - Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); - {$ELSE} - {$IFDEF FPC_USE_LIBC} - Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); - {$ELSE} - //How to get system codepage without LIBC? - Result := UTF_8; - {$ENDIF} - {$ENDIF} -end; - -function GetCurOEMCP: TMimeChar; -begin - Result := GetCurCP; -end; - -{$ELSE} - -function CPToMimeChar(Value: Integer): TMimeChar; -begin - 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: - Result := CP1251; - 1253: - Result := CP1253; - 1254: - Result := CP1254; - 1255: - Result := CP1255; - 1256: - Result := CP1256; - 1257: - 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 NeedCharsetConversion(const Value: AnsiString): Boolean; -var - n: Integer; -begin - Result := False; - for n := 1 to Length(Value) do - if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} -function IdealCharsetCoding(const Value: AnsiString; CharFrom: TMimeChar; - CharTo: TMimeSetChar): TMimeChar; -var - n: Integer; - max: Integer; - s, t, u: AnsiString; - CharSet: TMimeChar; -begin - Result := ISO_8859_1; - s := Copy(Value, 1, 1024); //max first 1KB for next procedure - max := 0; - for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do - begin - CharSet := TMimeChar(n); - if CharSet in CharTo then - begin - t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False); - u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False); - if s = u then - begin - 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; - -{==============================================================================} -function StringToWide(const Value: AnsiString): WideString; -var - n: integer; - x, y: integer; -begin - SetLength(Result, Length(Value) div 2); - for n := 1 to Length(Value) div 2 do - begin - x := Ord(Value[((n-1) * 2) + 1]); - y := Ord(Value[((n-1) * 2) + 2]); - Result[n] := WideChar(x * 256 + y); - end; -end; - -{==============================================================================} -function WideToString(const Value: WideString): AnsiString; -var - n: integer; - x: integer; -begin - SetLength(Result, Length(Value) * 2); - for n := 1 to Length(Value) do - begin - x := Ord(Value[n]); - Result[((n-1) * 2) + 1] := AnsiChar(x div 256); - Result[((n-1) * 2) + 2] := AnsiChar(x mod 256); - 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 ISO-8859-8-I'; - 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/synapse/synacode.pas b/synapse/synacode.pas deleted file mode 100644 index 757a838..0000000 --- a/synapse/synacode.pas +++ /dev/null @@ -1,1461 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 002.002.001 | -|==============================================================================| -| Content: Coding and decoding support | -|==============================================================================| -| Copyright (c)1999-2012, 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)2000-2012. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Various encoding and decoding support)} -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} -{$TYPEDADDRESS OFF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synacode; - -interface - -uses - SysUtils; - -type - TSpecials = set of AnsiChar; - -const - - SpecialChar: TSpecials = - ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', - '"', '_']; - NonAsciiChar: TSpecials = - [#0..#31, #127..#255]; - URLFullSpecialChar: TSpecials = - [';', '/', '?', ':', '@', '=', '&', '#', '+']; - URLSpecialChar: TSpecials = - [#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', - '`', #$7F..#$FF]; - TableBase64 = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; - TableBase64mod = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; - TableUU = - '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; - TableXX = - '+-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 - +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 - +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F - +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 - +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D - +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - ReTableUU = - #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C - +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 - +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 - +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 - +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C - +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - ReTableXX = - #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 - +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A - +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F - +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B - +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 - +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D - +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 - +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; - -{: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; - -{: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; - -{: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; - -{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} -function MD4(const Value: AnsiString): AnsiString; - -implementation - -const - - Crc32Tab: array[0..255] of Integer = ( - Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), - Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), - Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), - Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), - Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), - Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), - Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), - Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), - Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), - Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), - Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), - Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), - Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), - Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), - Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), - Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), - Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), - Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), - Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), - Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), - Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), - Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), - Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), - Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), - Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), - Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), - Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), - Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), - Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), - Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), - Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), - Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), - Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), - Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), - Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), - Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), - Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), - Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), - Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), - Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), - Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), - Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), - Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), - Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), - Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), - Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), - Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), - Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), - Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), - Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), - Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), - Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), - Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), - Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), - Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), - Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), - Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), - Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), - Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), - Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), - Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), - Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), - Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), - Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) - ); - - Crc16Tab: array[0..255] of Word = ( - $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, - $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, - $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, - $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, - $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, - $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, - $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, - $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, - $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, - $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, - $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, - $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, - $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, - $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, - $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, - $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, - $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, - $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, - $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, - $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, - $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, - $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, - $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, - $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, - $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, - $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, - $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, - $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, - $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, - $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, - $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, - $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 - TMDCtx = record - State: array[0..3] of Integer; - Count: array[0..1] of Integer; - BufAnsiChar: array[0..63] of Byte; - 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; - end; - - TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); - -{==============================================================================} - -function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; -var - x, l, lv: Integer; - c: AnsiChar; - b: Byte; - bad: Boolean; -begin - lv := Length(Value); - SetLength(Result, lv); - x := 1; - l := 1; - while x <= lv do - begin - c := Value[x]; - Inc(x); - if c <> Delimiter then - begin - Result[l] := c; - Inc(l); - end - else - if x < lv then - begin - Case Value[x] Of - #13: - if (Value[x + 1] = #10) then - Inc(x, 2) - else - Inc(x); - #10: - if (Value[x + 1] = #13) then - Inc(x, 2) - else - Inc(x); - else - begin - bad := False; - Case Value[x] Of - '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; - 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; - else - begin - b := 0; - bad := True; - end; - end; - Case Value[x + 1] Of - '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); - 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); - else - bad := True; - end; - if bad then - begin - Result[l] := c; - Inc(l); - end - else - begin - Inc(x, 2); - Result[l] := AnsiChar(b); - Inc(l); - end; - end; - end; - end - else - break; - end; - Dec(l); - SetLength(Result, l); -end; - -{==============================================================================} - -function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; -begin - Result := DecodeTriplet(Value, '='); -end; - -{==============================================================================} - -function DecodeURL(const Value: AnsiString): AnsiString; -begin - Result := DecodeTriplet(Value, '%'); -end; - -{==============================================================================} - -function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; - Specials: TSpecials): AnsiString; -var - n, l: Integer; - s: AnsiString; - c: AnsiChar; -begin - SetLength(Result, Length(Value) * 3); - l := 1; - for n := 1 to Length(Value) do - begin - c := Value[n]; - if c in Specials then - begin - Result[l] := Delimiter; - Inc(l); - s := IntToHex(Ord(c), 2); - Result[l] := s[1]; - Inc(l); - Result[l] := s[2]; - Inc(l); - end - else - begin - Result[l] := c; - Inc(l); - end; - end; - Dec(l); - SetLength(Result, l); -end; - -{==============================================================================} - -function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); -end; - -{==============================================================================} - -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: AnsiString): AnsiString; -begin - Result := EncodeTriplet(Value, '%', URLSpecialChar); -end; - -{==============================================================================} - -function Decode4to3(const Value, Table: AnsiString): AnsiString; -var - x, y, n, l: Integer; - d: array[0..3] of Byte; -begin - SetLength(Result, Length(Value)); - x := 1; - l := 1; - while x <= Length(Value) do - begin - for n := 0 to 3 do - begin - if x > Length(Value) then - d[n] := 64 - else - begin - y := Pos(Value[x], Table); - if y < 1 then - y := 1; - d[n] := y - 1; - end; - Inc(x); - end; - 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] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); - Inc(l); - if d[3] <> 64 then - begin - Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); - Inc(l); - end; - end; - end; - Dec(l); - SetLength(Result, l); -end; - -{==============================================================================} -function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; -var - x, y, lv: Integer; - d: integer; - dl: integer; - c: byte; - p: integer; -begin - lv := Length(Value); - SetLength(Result, lv); - x := 1; - dl := 4; - d := 0; - p := 1; - while x <= lv do - begin - y := Ord(Value[x]); - if y in [33..127] then - c := Ord(Table[y - 32]) - else - c := 64; - Inc(x); - if c > 63 then - continue; - d := (d shl 6) or c; - dec(dl); - if dl <> 0 then - continue; - Result[p] := AnsiChar((d shr 16) and $ff); - inc(p); - Result[p] := AnsiChar((d shr 8) and $ff); - inc(p); - Result[p] := AnsiChar(d and $ff); - inc(p); - d := 0; - dl := 4; - end; - case dl of - 1: - begin - d := d shr 2; - Result[p] := AnsiChar((d shr 8) and $ff); - inc(p); - Result[p] := AnsiChar(d and $ff); - inc(p); - end; - 2: - begin - d := d shr 4; - Result[p] := AnsiChar(d and $ff); - inc(p); - end; - end; - SetLength(Result, p - 1); -end; - -{==============================================================================} - -function Encode3to4(const Value, Table: AnsiString): AnsiString; -var - c: Byte; - n, l: Integer; - Count: Integer; - DOut: array[0..3] of Byte; -begin - setlength(Result, ((Length(Value) + 2) div 3) * 4); - l := 1; - Count := 1; - while Count <= Length(Value) do - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[0] := (c and $FC) shr 2; - DOut[1] := (c and $03) shl 4; - if Count <= Length(Value) then - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[1] := DOut[1] + (c and $F0) shr 4; - DOut[2] := (c and $0F) shl 2; - if Count <= Length(Value) then - begin - c := Ord(Value[Count]); - Inc(Count); - DOut[2] := DOut[2] + (c and $C0) shr 6; - DOut[3] := (c and $3F); - end - else - begin - DOut[3] := $40; - end; - end - else - begin - DOut[2] := $40; - DOut[3] := $40; - end; - for n := 0 to 3 do - begin - 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: AnsiString): AnsiString; -begin - Result := Decode4to3Ex(Value, ReTableBase64); -end; - -{==============================================================================} - -function EncodeBase64(const Value: AnsiString): AnsiString; -begin - Result := Encode3to4(Value, TableBase64); -end; - -{==============================================================================} - -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: AnsiString; - uut: AnsiString; - x: Integer; -begin - Result := ''; - uut := TableUU; - s := trim(UpperCase(Value)); - if s = '' then Exit; - if Pos('BEGIN', s) = 1 then - Exit; - if Pos('END', s) = 1 then - Exit; - if Pos('TABLE', s) = 1 then - Exit; //ignore Table yet (set custom UUT) - //begin decoding - x := Pos(Value[1], uut) - 1; - case (x mod 3) of - 0: x :=(x div 3)* 4; - 1: x :=((x div 3) * 4) + 2; - 2: x :=((x div 3) * 4) + 3; - end; - //x - lenght UU line - s := Copy(Value, 2, x); - if s = '' then - Exit; - s := s + StringOfChar(' ', x - length(s)); - Result := Decode4to3(s, uut); -end; - -{==============================================================================} - -function EncodeUU(const Value: AnsiString): AnsiString; -begin - Result := ''; - if Length(Value) < Length(TableUU) then - Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); -end; - -{==============================================================================} - -function DecodeXX(const Value: AnsiString): AnsiString; -var - s: AnsiString; - x: Integer; -begin - Result := ''; - s := trim(UpperCase(Value)); - if s = '' then - Exit; - if Pos('BEGIN', s) = 1 then - Exit; - if Pos('END', s) = 1 then - Exit; - //begin decoding - x := Pos(Value[1], TableXX) - 1; - case (x mod 3) of - 0: x :=(x div 3)* 4; - 1: x :=((x div 3) * 4) + 2; - 2: x :=((x div 3) * 4) + 3; - end; - //x - lenght XX line - s := Copy(Value, 2, x); - if s = '' then - Exit; - s := s + StringOfChar(' ', x - length(s)); - Result := Decode4to3(s, TableXX); -end; - -{==============================================================================} - -function DecodeYEnc(const Value: AnsiString): AnsiString; -var - C : Byte; - i: integer; -begin - Result := ''; - i := 1; - while i <= Length(Value) do - begin - c := Ord(Value[i]); - Inc(i); - if c = Ord('=') then - begin - c := Ord(Value[i]); - Inc(i); - Dec(c, 64); - end; - Dec(C, 42); - Result := Result + AnsiChar(C); - end; -end; - -{==============================================================================} - -function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; -begin - Result := (Crc32 shr 8) - xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; -end; - -{==============================================================================} - -function Crc32(const Value: AnsiString): Integer; -var - n: Integer; -begin - Result := Integer($FFFFFFFF); - for n := 1 to Length(Value) do - Result := UpdateCrc32(Ord(Value[n]), Result); - Result := not Result; -end; - -{==============================================================================} - -function UpdateCrc16(Value: Byte; Crc16: Word): Word; -begin - Result := ((Crc16 shr 8) and $00FF) xor - crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; -end; - -{==============================================================================} - -function Crc16(const Value: AnsiString): Word; -var - n: Integer; -begin - Result := $FFFF; - for n := 1 to Length(Value) do - Result := UpdateCrc16(Ord(Value[n]), Result); -end; - -{==============================================================================} - -procedure MDInit(var MDContext: TMDCtx); -var - n: integer; -begin - MDContext.Count[0] := 0; - MDContext.Count[1] := 0; - for n := 0 to high(MDContext.BufAnsiChar) do - MDContext.BufAnsiChar[n] := 0; - for n := 0 to high(MDContext.BufLong) do - MDContext.BufLong[n] := 0; - MDContext.State[0] := Integer($67452301); - MDContext.State[1] := Integer($EFCDAB89); - MDContext.State[2] := Integer($98BADCFE); - MDContext.State[3] := Integer($10325476); -end; - -procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); -var - A, B, C, D: LongInt; - - procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Z xor (X and (Y xor Z))) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Y xor (Z and (X xor Y))) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (X xor Y xor Z) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; - - procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); - begin - Inc(W, (Y xor (X or not Z)) + Data); - W := (W shl S) or (W shr (32 - S)); - Inc(W, X); - end; -begin - A := Buf[0]; - B := Buf[1]; - C := Buf[2]; - D := Buf[3]; - - Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); - Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); - Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); - Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); - Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); - Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); - Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); - Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); - Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); - Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); - Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); - Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); - Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); - Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); - Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); - Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); - - Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); - Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); - Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); - Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); - Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); - Round2(D, A, B, C, Data[10] + Longint($02441453), 9); - Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); - Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); - Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); - Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); - Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); - Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); - Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); - Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); - Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); - Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); - - Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); - Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); - Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); - Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); - Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); - Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); - Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); - Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); - Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); - Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); - Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); - Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); - Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); - Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); - Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); - Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); - - Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); - Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); - Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); - Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); - Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); - Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); - Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); - Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); - Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); - Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); - Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); - Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); - Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); - Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); - Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); - Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); - - Inc(Buf[0], A); - Inc(Buf[1], B); - Inc(Buf[2], C); - Inc(Buf[3], D); -end; - -//fixed by James McAdams -procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); -var - Index, partLen, InputLen, I: integer; -{$IFDEF CIL} - n: integer; -{$ENDIF} -begin - InputLen := Length(Data); - with MDContext do - begin - 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], InputLen shr 29); - partLen := 64 - Index; - if InputLen >= partLen then - begin - 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); - Transform(State, Buflong); - I := partLen; - while I + 63 < InputLen do - begin - 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); - Transform(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 MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; -var - Cnt: Word; - P: Byte; - digest: array[0..15] of Byte; - i: Integer; - n: integer; -begin - for I := 0 to 15 do - Digest[I] := I + 1; - with MDContext do - begin - Cnt := (Count[0] shr 3) and $3F; - P := Cnt; - BufAnsiChar[P] := $80; - Inc(P); - Cnt := 64 - 1 - Cnt; - if Cnt < 8 then - begin - for n := 0 to cnt - 1 do - BufAnsiChar[P + n] := 0; - ArrByteToLong(BufAnsiChar, BufLong); -// FillChar(BufAnsiChar[P], Cnt, #0); - Transform(State, BufLong); - ArrLongToByte(BufLong, BufAnsiChar); - for n := 0 to 55 do - BufAnsiChar[n] := 0; - ArrByteToLong(BufAnsiChar, BufLong); -// FillChar(BufAnsiChar, 56, #0); - end - else - 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]; - Transform(State, BufLong); - ArrLongToByte(State, Digest); -// Move(State, Digest, 16); - Result := ''; - for i := 0 to 15 do - Result := Result + AnsiChar(digest[i]); - end; -// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) -end; - -{==============================================================================} - -function MD5(const Value: AnsiString): AnsiString; -var - MDContext: TMDCtx; -begin - MDInit(MDContext); - MDUpdate(MDContext, Value, @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -end; - -{==============================================================================} - -function HMAC_MD5(Text, Key: AnsiString): AnsiString; -var - ipad, opad, s: AnsiString; - n: Integer; - MDContext: TMDCtx; -begin - if Length(Key) > 64 then - Key := md5(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; - MDInit(MDContext); - MDUpdate(MDContext, ipad, @MD5Transform); - MDUpdate(MDContext, Text, @MD5Transform); - s := MDFinal(MDContext, @MD5Transform); - MDInit(MDContext); - MDUpdate(MDContext, opad, @MD5Transform); - MDUpdate(MDContext, s, @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -end; - -{==============================================================================} - -function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; -var - cnt, rest: integer; - l: integer; - n: integer; - MDContext: TMDCtx; -begin - l := length(Value); - cnt := Len div l; - rest := Len mod l; - MDInit(MDContext); - for n := 1 to cnt do - MDUpdate(MDContext, Value, @MD5Transform); - if rest > 0 then - MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); - Result := MDFinal(MDContext, @MD5Transform); -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; - -{==============================================================================} - -procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); -var - A, B, C, D: LongInt; - function LRot32(a, b: longint): longint; - begin - Result:= (a shl b) or (a shr (32 - b)); - end; -begin - A := Buf[0]; - B := Buf[1]; - C := Buf[2]; - D := Buf[3]; - - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); - A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); - D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); - C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); - B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); - - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); - A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); - D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); - C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); - B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); - - A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); - A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); - D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); - C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); - B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); - - Inc(Buf[0], A); - Inc(Buf[1], B); - Inc(Buf[2], C); - Inc(Buf[3], D); -end; - -{==============================================================================} - -function MD4(const Value: AnsiString): AnsiString; -var - MDContext: TMDCtx; -begin - MDInit(MDContext); - MDUpdate(MDContext, Value, @MD4Transform); - Result := MDFinal(MDContext, @MD4Transform); -end; - -{==============================================================================} - - -end. diff --git a/synapse/synacrypt.pas b/synapse/synacrypt.pas deleted file mode 100644 index f19d256..0000000 --- a/synapse/synacrypt.pas +++ /dev/null @@ -1,2412 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.000 | -|==============================================================================| -| Content: Encryption support | -|==============================================================================| -| Copyright (c)2007-2011, 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)2007-2011. | -| All Rights Reserved. | -| Based on work of David Barton and Eric Young | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Encryption support) - -Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit, - CFB-block, OFB and CTR methods. -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synacrypt; - -interface - -uses - SysUtils, Classes, synautil, synafpc; - -type - {:@abstract(Implementation of common routines block ciphers (dafault size is 64-bits)) - - Do not use this class directly, use descendants only!} - TSynaBlockCipher= class(TObject) - protected - procedure InitKey(Key: AnsiString); virtual; - function GetSize: byte; virtual; - private - IV, CV: AnsiString; - procedure IncCounter; - public - {:Sets the IV to Value and performs a reset} - procedure SetIV(const Value: AnsiString); virtual; - {:Returns the current chaining information, not the actual IV} - function GetIV: AnsiString; virtual; - {:Reset any stored chaining information} - procedure Reset; virtual; - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; virtual; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; virtual; - {:Encrypt data using the CBC method of encryption} - function EncryptCBC(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CBC method of decryption} - function DecryptCBC(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CFB (8 bit) method of encryption} - function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CFB (8 bit) method of decryption} - function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CFB (block) method of encryption} - function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CFB (block) method of decryption} - function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the OFB method of encryption} - function EncryptOFB(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the OFB method of decryption} - function DecryptOFB(const Indata: AnsiString): AnsiString; virtual; - {:Encrypt data using the CTR method of encryption} - function EncryptCTR(const Indata: AnsiString): AnsiString; virtual; - {:Decrypt data using the CTR method of decryption} - function DecryptCTR(const Indata: AnsiString): AnsiString; virtual; - {:Create a encryptor/decryptor instance and initialize it by the Key.} - constructor Create(Key: AnsiString); - end; - - {:@abstract(Datatype for holding one DES key data) - - This data type is used internally.} - TDesKeyData = array[0..31] of integer; - - {:@abstract(Implementation of common routines for DES encryption) - - Do not use this class directly, use descendants only!} - TSynaCustomDes = class(TSynaBlockcipher) - protected - procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); - function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; - function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; - end; - - {:@abstract(Implementation of DES encryption)} - TSynaDes= class(TSynaCustomDes) - protected - KeyData: TDesKeyData; - procedure InitKey(Key: AnsiString); override; - public - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; override; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; override; - end; - - {:@abstract(Implementation of 3DES encryption)} - TSyna3Des= class(TSynaCustomDes) - protected - KeyData: array[0..2] of TDesKeyData; - procedure InitKey(Key: AnsiString); override; - public - {:Encrypt a 64-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; override; - {:Decrypt a 64-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; override; - end; - -const - BC = 4; - MAXROUNDS = 14; -type - {:@abstract(Implementation of AES encryption)} - TSynaAes= class(TSynaBlockcipher) - protected - numrounds: longword; - rk, drk: array[0..MAXROUNDS,0..7] of longword; - procedure InitKey(Key: AnsiString); override; - function GetSize: byte; override; - public - {:Encrypt a 128-bit block of data using the ECB method of encryption} - function EncryptECB(const InData: AnsiString): AnsiString; override; - {:Decrypt a 128-bit block of data using the ECB method of decryption} - function DecryptECB(const InData: AnsiString): AnsiString; override; - end; - -{:Call internal test of all DES encryptions. Returns @true if all is OK.} -function TestDes: boolean; -{:Call internal test of all 3DES encryptions. Returns @true if all is OK.} -function Test3Des: boolean; -{:Call internal test of all AES encryptions. Returns @true if all is OK.} -function TestAes: boolean; - -{==============================================================================} -implementation - -//DES consts -const - shifts2: array[0..15]of byte= - (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0); - - des_skb: array[0..7,0..63]of integer=( - ( - (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) - integer($00000000),integer($00000010),integer($20000000),integer($20000010), - integer($00010000),integer($00010010),integer($20010000),integer($20010010), - integer($00000800),integer($00000810),integer($20000800),integer($20000810), - integer($00010800),integer($00010810),integer($20010800),integer($20010810), - integer($00000020),integer($00000030),integer($20000020),integer($20000030), - integer($00010020),integer($00010030),integer($20010020),integer($20010030), - integer($00000820),integer($00000830),integer($20000820),integer($20000830), - integer($00010820),integer($00010830),integer($20010820),integer($20010830), - integer($00080000),integer($00080010),integer($20080000),integer($20080010), - integer($00090000),integer($00090010),integer($20090000),integer($20090010), - integer($00080800),integer($00080810),integer($20080800),integer($20080810), - integer($00090800),integer($00090810),integer($20090800),integer($20090810), - integer($00080020),integer($00080030),integer($20080020),integer($20080030), - integer($00090020),integer($00090030),integer($20090020),integer($20090030), - integer($00080820),integer($00080830),integer($20080820),integer($20080830), - integer($00090820),integer($00090830),integer($20090820),integer($20090830) - ),( - (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *) - integer($00000000),integer($02000000),integer($00002000),integer($02002000), - integer($00200000),integer($02200000),integer($00202000),integer($02202000), - integer($00000004),integer($02000004),integer($00002004),integer($02002004), - integer($00200004),integer($02200004),integer($00202004),integer($02202004), - integer($00000400),integer($02000400),integer($00002400),integer($02002400), - integer($00200400),integer($02200400),integer($00202400),integer($02202400), - integer($00000404),integer($02000404),integer($00002404),integer($02002404), - integer($00200404),integer($02200404),integer($00202404),integer($02202404), - integer($10000000),integer($12000000),integer($10002000),integer($12002000), - integer($10200000),integer($12200000),integer($10202000),integer($12202000), - integer($10000004),integer($12000004),integer($10002004),integer($12002004), - integer($10200004),integer($12200004),integer($10202004),integer($12202004), - integer($10000400),integer($12000400),integer($10002400),integer($12002400), - integer($10200400),integer($12200400),integer($10202400),integer($12202400), - integer($10000404),integer($12000404),integer($10002404),integer($12002404), - integer($10200404),integer($12200404),integer($10202404),integer($12202404) - ),( - (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *) - integer($00000000),integer($00000001),integer($00040000),integer($00040001), - integer($01000000),integer($01000001),integer($01040000),integer($01040001), - integer($00000002),integer($00000003),integer($00040002),integer($00040003), - integer($01000002),integer($01000003),integer($01040002),integer($01040003), - integer($00000200),integer($00000201),integer($00040200),integer($00040201), - integer($01000200),integer($01000201),integer($01040200),integer($01040201), - integer($00000202),integer($00000203),integer($00040202),integer($00040203), - integer($01000202),integer($01000203),integer($01040202),integer($01040203), - integer($08000000),integer($08000001),integer($08040000),integer($08040001), - integer($09000000),integer($09000001),integer($09040000),integer($09040001), - integer($08000002),integer($08000003),integer($08040002),integer($08040003), - integer($09000002),integer($09000003),integer($09040002),integer($09040003), - integer($08000200),integer($08000201),integer($08040200),integer($08040201), - integer($09000200),integer($09000201),integer($09040200),integer($09040201), - integer($08000202),integer($08000203),integer($08040202),integer($08040203), - integer($09000202),integer($09000203),integer($09040202),integer($09040203) - ),( - (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *) - integer($00000000),integer($00100000),integer($00000100),integer($00100100), - integer($00000008),integer($00100008),integer($00000108),integer($00100108), - integer($00001000),integer($00101000),integer($00001100),integer($00101100), - integer($00001008),integer($00101008),integer($00001108),integer($00101108), - integer($04000000),integer($04100000),integer($04000100),integer($04100100), - integer($04000008),integer($04100008),integer($04000108),integer($04100108), - integer($04001000),integer($04101000),integer($04001100),integer($04101100), - integer($04001008),integer($04101008),integer($04001108),integer($04101108), - integer($00020000),integer($00120000),integer($00020100),integer($00120100), - integer($00020008),integer($00120008),integer($00020108),integer($00120108), - integer($00021000),integer($00121000),integer($00021100),integer($00121100), - integer($00021008),integer($00121008),integer($00021108),integer($00121108), - integer($04020000),integer($04120000),integer($04020100),integer($04120100), - integer($04020008),integer($04120008),integer($04020108),integer($04120108), - integer($04021000),integer($04121000),integer($04021100),integer($04121100), - integer($04021008),integer($04121008),integer($04021108),integer($04121108) - ),( - (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *) - integer($00000000),integer($10000000),integer($00010000),integer($10010000), - integer($00000004),integer($10000004),integer($00010004),integer($10010004), - integer($20000000),integer($30000000),integer($20010000),integer($30010000), - integer($20000004),integer($30000004),integer($20010004),integer($30010004), - integer($00100000),integer($10100000),integer($00110000),integer($10110000), - integer($00100004),integer($10100004),integer($00110004),integer($10110004), - integer($20100000),integer($30100000),integer($20110000),integer($30110000), - integer($20100004),integer($30100004),integer($20110004),integer($30110004), - integer($00001000),integer($10001000),integer($00011000),integer($10011000), - integer($00001004),integer($10001004),integer($00011004),integer($10011004), - integer($20001000),integer($30001000),integer($20011000),integer($30011000), - integer($20001004),integer($30001004),integer($20011004),integer($30011004), - integer($00101000),integer($10101000),integer($00111000),integer($10111000), - integer($00101004),integer($10101004),integer($00111004),integer($10111004), - integer($20101000),integer($30101000),integer($20111000),integer($30111000), - integer($20101004),integer($30101004),integer($20111004),integer($30111004) - ),( - (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *) - integer($00000000),integer($08000000),integer($00000008),integer($08000008), - integer($00000400),integer($08000400),integer($00000408),integer($08000408), - integer($00020000),integer($08020000),integer($00020008),integer($08020008), - integer($00020400),integer($08020400),integer($00020408),integer($08020408), - integer($00000001),integer($08000001),integer($00000009),integer($08000009), - integer($00000401),integer($08000401),integer($00000409),integer($08000409), - integer($00020001),integer($08020001),integer($00020009),integer($08020009), - integer($00020401),integer($08020401),integer($00020409),integer($08020409), - integer($02000000),integer($0A000000),integer($02000008),integer($0A000008), - integer($02000400),integer($0A000400),integer($02000408),integer($0A000408), - integer($02020000),integer($0A020000),integer($02020008),integer($0A020008), - integer($02020400),integer($0A020400),integer($02020408),integer($0A020408), - integer($02000001),integer($0A000001),integer($02000009),integer($0A000009), - integer($02000401),integer($0A000401),integer($02000409),integer($0A000409), - integer($02020001),integer($0A020001),integer($02020009),integer($0A020009), - integer($02020401),integer($0A020401),integer($02020409),integer($0A020409) - ),( - (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *) - integer($00000000),integer($00000100),integer($00080000),integer($00080100), - integer($01000000),integer($01000100),integer($01080000),integer($01080100), - integer($00000010),integer($00000110),integer($00080010),integer($00080110), - integer($01000010),integer($01000110),integer($01080010),integer($01080110), - integer($00200000),integer($00200100),integer($00280000),integer($00280100), - integer($01200000),integer($01200100),integer($01280000),integer($01280100), - integer($00200010),integer($00200110),integer($00280010),integer($00280110), - integer($01200010),integer($01200110),integer($01280010),integer($01280110), - integer($00000200),integer($00000300),integer($00080200),integer($00080300), - integer($01000200),integer($01000300),integer($01080200),integer($01080300), - integer($00000210),integer($00000310),integer($00080210),integer($00080310), - integer($01000210),integer($01000310),integer($01080210),integer($01080310), - integer($00200200),integer($00200300),integer($00280200),integer($00280300), - integer($01200200),integer($01200300),integer($01280200),integer($01280300), - integer($00200210),integer($00200310),integer($00280210),integer($00280310), - integer($01200210),integer($01200310),integer($01280210),integer($01280310) - ),( - (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *) - integer($00000000),integer($04000000),integer($00040000),integer($04040000), - integer($00000002),integer($04000002),integer($00040002),integer($04040002), - integer($00002000),integer($04002000),integer($00042000),integer($04042000), - integer($00002002),integer($04002002),integer($00042002),integer($04042002), - integer($00000020),integer($04000020),integer($00040020),integer($04040020), - integer($00000022),integer($04000022),integer($00040022),integer($04040022), - integer($00002020),integer($04002020),integer($00042020),integer($04042020), - integer($00002022),integer($04002022),integer($00042022),integer($04042022), - integer($00000800),integer($04000800),integer($00040800),integer($04040800), - integer($00000802),integer($04000802),integer($00040802),integer($04040802), - integer($00002800),integer($04002800),integer($00042800),integer($04042800), - integer($00002802),integer($04002802),integer($00042802),integer($04042802), - integer($00000820),integer($04000820),integer($00040820),integer($04040820), - integer($00000822),integer($04000822),integer($00040822),integer($04040822), - integer($00002820),integer($04002820),integer($00042820),integer($04042820), - integer($00002822),integer($04002822),integer($00042822),integer($04042822) - )); - - des_sptrans: array[0..7,0..63] of integer=( - ( - (* nibble 0 *) - integer($02080800), integer($00080000), integer($02000002), integer($02080802), - integer($02000000), integer($00080802), integer($00080002), integer($02000002), - integer($00080802), integer($02080800), integer($02080000), integer($00000802), - integer($02000802), integer($02000000), integer($00000000), integer($00080002), - integer($00080000), integer($00000002), integer($02000800), integer($00080800), - integer($02080802), integer($02080000), integer($00000802), integer($02000800), - integer($00000002), integer($00000800), integer($00080800), integer($02080002), - integer($00000800), integer($02000802), integer($02080002), integer($00000000), - integer($00000000), integer($02080802), integer($02000800), integer($00080002), - integer($02080800), integer($00080000), integer($00000802), integer($02000800), - integer($02080002), integer($00000800), integer($00080800), integer($02000002), - integer($00080802), integer($00000002), integer($02000002), integer($02080000), - integer($02080802), integer($00080800), integer($02080000), integer($02000802), - integer($02000000), integer($00000802), integer($00080002), integer($00000000), - integer($00080000), integer($02000000), integer($02000802), integer($02080800), - integer($00000002), integer($02080002), integer($00000800), integer($00080802) - ),( - (* nibble 1 *) - integer($40108010), integer($00000000), integer($00108000), integer($40100000), - integer($40000010), integer($00008010), integer($40008000), integer($00108000), - integer($00008000), integer($40100010), integer($00000010), integer($40008000), - integer($00100010), integer($40108000), integer($40100000), integer($00000010), - integer($00100000), integer($40008010), integer($40100010), integer($00008000), - integer($00108010), integer($40000000), integer($00000000), integer($00100010), - integer($40008010), integer($00108010), integer($40108000), integer($40000010), - integer($40000000), integer($00100000), integer($00008010), integer($40108010), - integer($00100010), integer($40108000), integer($40008000), integer($00108010), - integer($40108010), integer($00100010), integer($40000010), integer($00000000), - integer($40000000), integer($00008010), integer($00100000), integer($40100010), - integer($00008000), integer($40000000), integer($00108010), integer($40008010), - integer($40108000), integer($00008000), integer($00000000), integer($40000010), - integer($00000010), integer($40108010), integer($00108000), integer($40100000), - integer($40100010), integer($00100000), integer($00008010), integer($40008000), - integer($40008010), integer($00000010), integer($40100000), integer($00108000) - ),( - (* nibble 2 *) - integer($04000001), integer($04040100), integer($00000100), integer($04000101), - integer($00040001), integer($04000000), integer($04000101), integer($00040100), - integer($04000100), integer($00040000), integer($04040000), integer($00000001), - integer($04040101), integer($00000101), integer($00000001), integer($04040001), - integer($00000000), integer($00040001), integer($04040100), integer($00000100), - integer($00000101), integer($04040101), integer($00040000), integer($04000001), - integer($04040001), integer($04000100), integer($00040101), integer($04040000), - integer($00040100), integer($00000000), integer($04000000), integer($00040101), - integer($04040100), integer($00000100), integer($00000001), integer($00040000), - integer($00000101), integer($00040001), integer($04040000), integer($04000101), - integer($00000000), integer($04040100), integer($00040100), integer($04040001), - integer($00040001), integer($04000000), integer($04040101), integer($00000001), - integer($00040101), integer($04000001), integer($04000000), integer($04040101), - integer($00040000), integer($04000100), integer($04000101), integer($00040100), - integer($04000100), integer($00000000), integer($04040001), integer($00000101), - integer($04000001), integer($00040101), integer($00000100), integer($04040000) - ),( - (* nibble 3 *) - integer($00401008), integer($10001000), integer($00000008), integer($10401008), - integer($00000000), integer($10400000), integer($10001008), integer($00400008), - integer($10401000), integer($10000008), integer($10000000), integer($00001008), - integer($10000008), integer($00401008), integer($00400000), integer($10000000), - integer($10400008), integer($00401000), integer($00001000), integer($00000008), - integer($00401000), integer($10001008), integer($10400000), integer($00001000), - integer($00001008), integer($00000000), integer($00400008), integer($10401000), - integer($10001000), integer($10400008), integer($10401008), integer($00400000), - integer($10400008), integer($00001008), integer($00400000), integer($10000008), - integer($00401000), integer($10001000), integer($00000008), integer($10400000), - integer($10001008), integer($00000000), integer($00001000), integer($00400008), - integer($00000000), integer($10400008), integer($10401000), integer($00001000), - integer($10000000), integer($10401008), integer($00401008), integer($00400000), - integer($10401008), integer($00000008), integer($10001000), integer($00401008), - integer($00400008), integer($00401000), integer($10400000), integer($10001008), - integer($00001008), integer($10000000), integer($10000008), integer($10401000) - ),( - (* nibble 4 *) - integer($08000000), integer($00010000), integer($00000400), integer($08010420), - integer($08010020), integer($08000400), integer($00010420), integer($08010000), - integer($00010000), integer($00000020), integer($08000020), integer($00010400), - integer($08000420), integer($08010020), integer($08010400), integer($00000000), - integer($00010400), integer($08000000), integer($00010020), integer($00000420), - integer($08000400), integer($00010420), integer($00000000), integer($08000020), - integer($00000020), integer($08000420), integer($08010420), integer($00010020), - integer($08010000), integer($00000400), integer($00000420), integer($08010400), - integer($08010400), integer($08000420), integer($00010020), integer($08010000), - integer($00010000), integer($00000020), integer($08000020), integer($08000400), - integer($08000000), integer($00010400), integer($08010420), integer($00000000), - integer($00010420), integer($08000000), integer($00000400), integer($00010020), - integer($08000420), integer($00000400), integer($00000000), integer($08010420), - integer($08010020), integer($08010400), integer($00000420), integer($00010000), - integer($00010400), integer($08010020), integer($08000400), integer($00000420), - integer($00000020), integer($00010420), integer($08010000), integer($08000020) - ),( - (* nibble 5 *) - integer($80000040), integer($00200040), integer($00000000), integer($80202000), - integer($00200040), integer($00002000), integer($80002040), integer($00200000), - integer($00002040), integer($80202040), integer($00202000), integer($80000000), - integer($80002000), integer($80000040), integer($80200000), integer($00202040), - integer($00200000), integer($80002040), integer($80200040), integer($00000000), - integer($00002000), integer($00000040), integer($80202000), integer($80200040), - integer($80202040), integer($80200000), integer($80000000), integer($00002040), - integer($00000040), integer($00202000), integer($00202040), integer($80002000), - integer($00002040), integer($80000000), integer($80002000), integer($00202040), - integer($80202000), integer($00200040), integer($00000000), integer($80002000), - integer($80000000), integer($00002000), integer($80200040), integer($00200000), - integer($00200040), integer($80202040), integer($00202000), integer($00000040), - integer($80202040), integer($00202000), integer($00200000), integer($80002040), - integer($80000040), integer($80200000), integer($00202040), integer($00000000), - integer($00002000), integer($80000040), integer($80002040), integer($80202000), - integer($80200000), integer($00002040), integer($00000040), integer($80200040) - ),( - (* nibble 6 *) - integer($00004000), integer($00000200), integer($01000200), integer($01000004), - integer($01004204), integer($00004004), integer($00004200), integer($00000000), - integer($01000000), integer($01000204), integer($00000204), integer($01004000), - integer($00000004), integer($01004200), integer($01004000), integer($00000204), - integer($01000204), integer($00004000), integer($00004004), integer($01004204), - integer($00000000), integer($01000200), integer($01000004), integer($00004200), - integer($01004004), integer($00004204), integer($01004200), integer($00000004), - integer($00004204), integer($01004004), integer($00000200), integer($01000000), - integer($00004204), integer($01004000), integer($01004004), integer($00000204), - integer($00004000), integer($00000200), integer($01000000), integer($01004004), - integer($01000204), integer($00004204), integer($00004200), integer($00000000), - integer($00000200), integer($01000004), integer($00000004), integer($01000200), - integer($00000000), integer($01000204), integer($01000200), integer($00004200), - integer($00000204), integer($00004000), integer($01004204), integer($01000000), - integer($01004200), integer($00000004), integer($00004004), integer($01004204), - integer($01000004), integer($01004200), integer($01004000), integer($00004004) - ),( - (* nibble 7 *) - integer($20800080), integer($20820000), integer($00020080), integer($00000000), - integer($20020000), integer($00800080), integer($20800000), integer($20820080), - integer($00000080), integer($20000000), integer($00820000), integer($00020080), - integer($00820080), integer($20020080), integer($20000080), integer($20800000), - integer($00020000), integer($00820080), integer($00800080), integer($20020000), - integer($20820080), integer($20000080), integer($00000000), integer($00820000), - integer($20000000), integer($00800000), integer($20020080), integer($20800080), - integer($00800000), integer($00020000), integer($20820000), integer($00000080), - integer($00800000), integer($00020000), integer($20000080), integer($20820080), - integer($00020080), integer($20000000), integer($00000000), integer($00820000), - integer($20800080), integer($20020080), integer($20020000), integer($00800080), - integer($20820000), integer($00000080), integer($00800080), integer($20020000), - integer($20820080), integer($00800000), integer($20800000), integer($20000080), - integer($00820000), integer($00020080), integer($20020080), integer($20800000), - integer($00000080), integer($20820000), integer($00820080), integer($00000000), - integer($20000000), integer($20800080), integer($00020000), integer($00820080) - )); - -//AES consts -const - MAXBC= 8; - MAXKC= 8; - - S: array[0..255] of byte= ( - 99, 124, 119, 123, 242, 107, 111, 197, 48, 1, 103, 43, 254, 215, 171, 118, - 202, 130, 201, 125, 250, 89, 71, 240, 173, 212, 162, 175, 156, 164, 114, 192, - 183, 253, 147, 38, 54, 63, 247, 204, 52, 165, 229, 241, 113, 216, 49, 21, - 4, 199, 35, 195, 24, 150, 5, 154, 7, 18, 128, 226, 235, 39, 178, 117, - 9, 131, 44, 26, 27, 110, 90, 160, 82, 59, 214, 179, 41, 227, 47, 132, - 83, 209, 0, 237, 32, 252, 177, 91, 106, 203, 190, 57, 74, 76, 88, 207, - 208, 239, 170, 251, 67, 77, 51, 133, 69, 249, 2, 127, 80, 60, 159, 168, - 81, 163, 64, 143, 146, 157, 56, 245, 188, 182, 218, 33, 16, 255, 243, 210, - 205, 12, 19, 236, 95, 151, 68, 23, 196, 167, 126, 61, 100, 93, 25, 115, - 96, 129, 79, 220, 34, 42, 144, 136, 70, 238, 184, 20, 222, 94, 11, 219, - 224, 50, 58, 10, 73, 6, 36, 92, 194, 211, 172, 98, 145, 149, 228, 121, - 231, 200, 55, 109, 141, 213, 78, 169, 108, 86, 244, 234, 101, 122, 174, 8, - 186, 120, 37, 46, 28, 166, 180, 198, 232, 221, 116, 31, 75, 189, 139, 138, - 112, 62, 181, 102, 72, 3, 246, 14, 97, 53, 87, 185, 134, 193, 29, 158, - 225, 248, 152, 17, 105, 217, 142, 148, 155, 30, 135, 233, 206, 85, 40, 223, - 140, 161, 137, 13, 191, 230, 66, 104, 65, 153, 45, 15, 176, 84, 187, 22); - T1: array[0..255,0..3] of byte= ( - ($c6,$63,$63,$a5), ($f8,$7c,$7c,$84), ($ee,$77,$77,$99), ($f6,$7b,$7b,$8d), - ($ff,$f2,$f2,$0d), ($d6,$6b,$6b,$bd), ($de,$6f,$6f,$b1), ($91,$c5,$c5,$54), - ($60,$30,$30,$50), ($02,$01,$01,$03), ($ce,$67,$67,$a9), ($56,$2b,$2b,$7d), - ($e7,$fe,$fe,$19), ($b5,$d7,$d7,$62), ($4d,$ab,$ab,$e6), ($ec,$76,$76,$9a), - ($8f,$ca,$ca,$45), ($1f,$82,$82,$9d), ($89,$c9,$c9,$40), ($fa,$7d,$7d,$87), - ($ef,$fa,$fa,$15), ($b2,$59,$59,$eb), ($8e,$47,$47,$c9), ($fb,$f0,$f0,$0b), - ($41,$ad,$ad,$ec), ($b3,$d4,$d4,$67), ($5f,$a2,$a2,$fd), ($45,$af,$af,$ea), - ($23,$9c,$9c,$bf), ($53,$a4,$a4,$f7), ($e4,$72,$72,$96), ($9b,$c0,$c0,$5b), - ($75,$b7,$b7,$c2), ($e1,$fd,$fd,$1c), ($3d,$93,$93,$ae), ($4c,$26,$26,$6a), - ($6c,$36,$36,$5a), ($7e,$3f,$3f,$41), ($f5,$f7,$f7,$02), ($83,$cc,$cc,$4f), - ($68,$34,$34,$5c), ($51,$a5,$a5,$f4), ($d1,$e5,$e5,$34), ($f9,$f1,$f1,$08), - ($e2,$71,$71,$93), ($ab,$d8,$d8,$73), ($62,$31,$31,$53), ($2a,$15,$15,$3f), - ($08,$04,$04,$0c), ($95,$c7,$c7,$52), ($46,$23,$23,$65), ($9d,$c3,$c3,$5e), - ($30,$18,$18,$28), ($37,$96,$96,$a1), ($0a,$05,$05,$0f), ($2f,$9a,$9a,$b5), - ($0e,$07,$07,$09), ($24,$12,$12,$36), ($1b,$80,$80,$9b), ($df,$e2,$e2,$3d), - ($cd,$eb,$eb,$26), ($4e,$27,$27,$69), ($7f,$b2,$b2,$cd), ($ea,$75,$75,$9f), - ($12,$09,$09,$1b), ($1d,$83,$83,$9e), ($58,$2c,$2c,$74), ($34,$1a,$1a,$2e), - ($36,$1b,$1b,$2d), ($dc,$6e,$6e,$b2), ($b4,$5a,$5a,$ee), ($5b,$a0,$a0,$fb), - ($a4,$52,$52,$f6), ($76,$3b,$3b,$4d), ($b7,$d6,$d6,$61), ($7d,$b3,$b3,$ce), - ($52,$29,$29,$7b), ($dd,$e3,$e3,$3e), ($5e,$2f,$2f,$71), ($13,$84,$84,$97), - ($a6,$53,$53,$f5), ($b9,$d1,$d1,$68), ($00,$00,$00,$00), ($c1,$ed,$ed,$2c), - ($40,$20,$20,$60), ($e3,$fc,$fc,$1f), ($79,$b1,$b1,$c8), ($b6,$5b,$5b,$ed), - ($d4,$6a,$6a,$be), ($8d,$cb,$cb,$46), ($67,$be,$be,$d9), ($72,$39,$39,$4b), - ($94,$4a,$4a,$de), ($98,$4c,$4c,$d4), ($b0,$58,$58,$e8), ($85,$cf,$cf,$4a), - ($bb,$d0,$d0,$6b), ($c5,$ef,$ef,$2a), ($4f,$aa,$aa,$e5), ($ed,$fb,$fb,$16), - ($86,$43,$43,$c5), ($9a,$4d,$4d,$d7), ($66,$33,$33,$55), ($11,$85,$85,$94), - ($8a,$45,$45,$cf), ($e9,$f9,$f9,$10), ($04,$02,$02,$06), ($fe,$7f,$7f,$81), - ($a0,$50,$50,$f0), ($78,$3c,$3c,$44), ($25,$9f,$9f,$ba), ($4b,$a8,$a8,$e3), - ($a2,$51,$51,$f3), ($5d,$a3,$a3,$fe), ($80,$40,$40,$c0), ($05,$8f,$8f,$8a), - ($3f,$92,$92,$ad), ($21,$9d,$9d,$bc), ($70,$38,$38,$48), ($f1,$f5,$f5,$04), - ($63,$bc,$bc,$df), ($77,$b6,$b6,$c1), ($af,$da,$da,$75), ($42,$21,$21,$63), - ($20,$10,$10,$30), ($e5,$ff,$ff,$1a), ($fd,$f3,$f3,$0e), ($bf,$d2,$d2,$6d), - ($81,$cd,$cd,$4c), ($18,$0c,$0c,$14), ($26,$13,$13,$35), ($c3,$ec,$ec,$2f), - ($be,$5f,$5f,$e1), ($35,$97,$97,$a2), ($88,$44,$44,$cc), ($2e,$17,$17,$39), - ($93,$c4,$c4,$57), ($55,$a7,$a7,$f2), ($fc,$7e,$7e,$82), ($7a,$3d,$3d,$47), - ($c8,$64,$64,$ac), ($ba,$5d,$5d,$e7), ($32,$19,$19,$2b), ($e6,$73,$73,$95), - ($c0,$60,$60,$a0), ($19,$81,$81,$98), ($9e,$4f,$4f,$d1), ($a3,$dc,$dc,$7f), - ($44,$22,$22,$66), ($54,$2a,$2a,$7e), ($3b,$90,$90,$ab), ($0b,$88,$88,$83), - ($8c,$46,$46,$ca), ($c7,$ee,$ee,$29), ($6b,$b8,$b8,$d3), ($28,$14,$14,$3c), - ($a7,$de,$de,$79), ($bc,$5e,$5e,$e2), ($16,$0b,$0b,$1d), ($ad,$db,$db,$76), - ($db,$e0,$e0,$3b), ($64,$32,$32,$56), ($74,$3a,$3a,$4e), ($14,$0a,$0a,$1e), - ($92,$49,$49,$db), ($0c,$06,$06,$0a), ($48,$24,$24,$6c), ($b8,$5c,$5c,$e4), - ($9f,$c2,$c2,$5d), ($bd,$d3,$d3,$6e), ($43,$ac,$ac,$ef), ($c4,$62,$62,$a6), - ($39,$91,$91,$a8), ($31,$95,$95,$a4), ($d3,$e4,$e4,$37), ($f2,$79,$79,$8b), - ($d5,$e7,$e7,$32), ($8b,$c8,$c8,$43), ($6e,$37,$37,$59), ($da,$6d,$6d,$b7), - ($01,$8d,$8d,$8c), ($b1,$d5,$d5,$64), ($9c,$4e,$4e,$d2), ($49,$a9,$a9,$e0), - ($d8,$6c,$6c,$b4), ($ac,$56,$56,$fa), ($f3,$f4,$f4,$07), ($cf,$ea,$ea,$25), - ($ca,$65,$65,$af), ($f4,$7a,$7a,$8e), ($47,$ae,$ae,$e9), ($10,$08,$08,$18), - ($6f,$ba,$ba,$d5), ($f0,$78,$78,$88), ($4a,$25,$25,$6f), ($5c,$2e,$2e,$72), - ($38,$1c,$1c,$24), ($57,$a6,$a6,$f1), ($73,$b4,$b4,$c7), ($97,$c6,$c6,$51), - ($cb,$e8,$e8,$23), ($a1,$dd,$dd,$7c), ($e8,$74,$74,$9c), ($3e,$1f,$1f,$21), - ($96,$4b,$4b,$dd), ($61,$bd,$bd,$dc), ($0d,$8b,$8b,$86), ($0f,$8a,$8a,$85), - ($e0,$70,$70,$90), ($7c,$3e,$3e,$42), ($71,$b5,$b5,$c4), ($cc,$66,$66,$aa), - ($90,$48,$48,$d8), ($06,$03,$03,$05), ($f7,$f6,$f6,$01), ($1c,$0e,$0e,$12), - ($c2,$61,$61,$a3), ($6a,$35,$35,$5f), ($ae,$57,$57,$f9), ($69,$b9,$b9,$d0), - ($17,$86,$86,$91), ($99,$c1,$c1,$58), ($3a,$1d,$1d,$27), ($27,$9e,$9e,$b9), - ($d9,$e1,$e1,$38), ($eb,$f8,$f8,$13), ($2b,$98,$98,$b3), ($22,$11,$11,$33), - ($d2,$69,$69,$bb), ($a9,$d9,$d9,$70), ($07,$8e,$8e,$89), ($33,$94,$94,$a7), - ($2d,$9b,$9b,$b6), ($3c,$1e,$1e,$22), ($15,$87,$87,$92), ($c9,$e9,$e9,$20), - ($87,$ce,$ce,$49), ($aa,$55,$55,$ff), ($50,$28,$28,$78), ($a5,$df,$df,$7a), - ($03,$8c,$8c,$8f), ($59,$a1,$a1,$f8), ($09,$89,$89,$80), ($1a,$0d,$0d,$17), - ($65,$bf,$bf,$da), ($d7,$e6,$e6,$31), ($84,$42,$42,$c6), ($d0,$68,$68,$b8), - ($82,$41,$41,$c3), ($29,$99,$99,$b0), ($5a,$2d,$2d,$77), ($1e,$0f,$0f,$11), - ($7b,$b0,$b0,$cb), ($a8,$54,$54,$fc), ($6d,$bb,$bb,$d6), ($2c,$16,$16,$3a)); - T2: array[0..255,0..3] of byte= ( - ($a5,$c6,$63,$63), ($84,$f8,$7c,$7c), ($99,$ee,$77,$77), ($8d,$f6,$7b,$7b), - ($0d,$ff,$f2,$f2), ($bd,$d6,$6b,$6b), ($b1,$de,$6f,$6f), ($54,$91,$c5,$c5), - ($50,$60,$30,$30), ($03,$02,$01,$01), ($a9,$ce,$67,$67), ($7d,$56,$2b,$2b), - ($19,$e7,$fe,$fe), ($62,$b5,$d7,$d7), ($e6,$4d,$ab,$ab), ($9a,$ec,$76,$76), - ($45,$8f,$ca,$ca), ($9d,$1f,$82,$82), ($40,$89,$c9,$c9), ($87,$fa,$7d,$7d), - ($15,$ef,$fa,$fa), ($eb,$b2,$59,$59), ($c9,$8e,$47,$47), ($0b,$fb,$f0,$f0), - ($ec,$41,$ad,$ad), ($67,$b3,$d4,$d4), ($fd,$5f,$a2,$a2), ($ea,$45,$af,$af), - ($bf,$23,$9c,$9c), ($f7,$53,$a4,$a4), ($96,$e4,$72,$72), ($5b,$9b,$c0,$c0), - ($c2,$75,$b7,$b7), ($1c,$e1,$fd,$fd), ($ae,$3d,$93,$93), ($6a,$4c,$26,$26), - ($5a,$6c,$36,$36), ($41,$7e,$3f,$3f), ($02,$f5,$f7,$f7), ($4f,$83,$cc,$cc), - ($5c,$68,$34,$34), ($f4,$51,$a5,$a5), ($34,$d1,$e5,$e5), ($08,$f9,$f1,$f1), - ($93,$e2,$71,$71), ($73,$ab,$d8,$d8), ($53,$62,$31,$31), ($3f,$2a,$15,$15), - ($0c,$08,$04,$04), ($52,$95,$c7,$c7), ($65,$46,$23,$23), ($5e,$9d,$c3,$c3), - ($28,$30,$18,$18), ($a1,$37,$96,$96), ($0f,$0a,$05,$05), ($b5,$2f,$9a,$9a), - ($09,$0e,$07,$07), ($36,$24,$12,$12), ($9b,$1b,$80,$80), ($3d,$df,$e2,$e2), - ($26,$cd,$eb,$eb), ($69,$4e,$27,$27), ($cd,$7f,$b2,$b2), ($9f,$ea,$75,$75), - ($1b,$12,$09,$09), ($9e,$1d,$83,$83), ($74,$58,$2c,$2c), ($2e,$34,$1a,$1a), - ($2d,$36,$1b,$1b), ($b2,$dc,$6e,$6e), ($ee,$b4,$5a,$5a), ($fb,$5b,$a0,$a0), - ($f6,$a4,$52,$52), ($4d,$76,$3b,$3b), ($61,$b7,$d6,$d6), ($ce,$7d,$b3,$b3), - ($7b,$52,$29,$29), ($3e,$dd,$e3,$e3), ($71,$5e,$2f,$2f), ($97,$13,$84,$84), - ($f5,$a6,$53,$53), ($68,$b9,$d1,$d1), ($00,$00,$00,$00), ($2c,$c1,$ed,$ed), - ($60,$40,$20,$20), ($1f,$e3,$fc,$fc), ($c8,$79,$b1,$b1), ($ed,$b6,$5b,$5b), - ($be,$d4,$6a,$6a), ($46,$8d,$cb,$cb), ($d9,$67,$be,$be), ($4b,$72,$39,$39), - ($de,$94,$4a,$4a), ($d4,$98,$4c,$4c), ($e8,$b0,$58,$58), ($4a,$85,$cf,$cf), - ($6b,$bb,$d0,$d0), ($2a,$c5,$ef,$ef), ($e5,$4f,$aa,$aa), ($16,$ed,$fb,$fb), - ($c5,$86,$43,$43), ($d7,$9a,$4d,$4d), ($55,$66,$33,$33), ($94,$11,$85,$85), - ($cf,$8a,$45,$45), ($10,$e9,$f9,$f9), ($06,$04,$02,$02), ($81,$fe,$7f,$7f), - ($f0,$a0,$50,$50), ($44,$78,$3c,$3c), ($ba,$25,$9f,$9f), ($e3,$4b,$a8,$a8), - ($f3,$a2,$51,$51), ($fe,$5d,$a3,$a3), ($c0,$80,$40,$40), ($8a,$05,$8f,$8f), - ($ad,$3f,$92,$92), ($bc,$21,$9d,$9d), ($48,$70,$38,$38), ($04,$f1,$f5,$f5), - ($df,$63,$bc,$bc), ($c1,$77,$b6,$b6), ($75,$af,$da,$da), ($63,$42,$21,$21), - ($30,$20,$10,$10), ($1a,$e5,$ff,$ff), ($0e,$fd,$f3,$f3), ($6d,$bf,$d2,$d2), - ($4c,$81,$cd,$cd), ($14,$18,$0c,$0c), ($35,$26,$13,$13), ($2f,$c3,$ec,$ec), - ($e1,$be,$5f,$5f), ($a2,$35,$97,$97), ($cc,$88,$44,$44), ($39,$2e,$17,$17), - ($57,$93,$c4,$c4), ($f2,$55,$a7,$a7), ($82,$fc,$7e,$7e), ($47,$7a,$3d,$3d), - ($ac,$c8,$64,$64), ($e7,$ba,$5d,$5d), ($2b,$32,$19,$19), ($95,$e6,$73,$73), - ($a0,$c0,$60,$60), ($98,$19,$81,$81), ($d1,$9e,$4f,$4f), ($7f,$a3,$dc,$dc), - ($66,$44,$22,$22), ($7e,$54,$2a,$2a), ($ab,$3b,$90,$90), ($83,$0b,$88,$88), - ($ca,$8c,$46,$46), ($29,$c7,$ee,$ee), ($d3,$6b,$b8,$b8), ($3c,$28,$14,$14), - ($79,$a7,$de,$de), ($e2,$bc,$5e,$5e), ($1d,$16,$0b,$0b), ($76,$ad,$db,$db), - ($3b,$db,$e0,$e0), ($56,$64,$32,$32), ($4e,$74,$3a,$3a), ($1e,$14,$0a,$0a), - ($db,$92,$49,$49), ($0a,$0c,$06,$06), ($6c,$48,$24,$24), ($e4,$b8,$5c,$5c), - ($5d,$9f,$c2,$c2), ($6e,$bd,$d3,$d3), ($ef,$43,$ac,$ac), ($a6,$c4,$62,$62), - ($a8,$39,$91,$91), ($a4,$31,$95,$95), ($37,$d3,$e4,$e4), ($8b,$f2,$79,$79), - ($32,$d5,$e7,$e7), ($43,$8b,$c8,$c8), ($59,$6e,$37,$37), ($b7,$da,$6d,$6d), - ($8c,$01,$8d,$8d), ($64,$b1,$d5,$d5), ($d2,$9c,$4e,$4e), ($e0,$49,$a9,$a9), - ($b4,$d8,$6c,$6c), ($fa,$ac,$56,$56), ($07,$f3,$f4,$f4), ($25,$cf,$ea,$ea), - ($af,$ca,$65,$65), ($8e,$f4,$7a,$7a), ($e9,$47,$ae,$ae), ($18,$10,$08,$08), - ($d5,$6f,$ba,$ba), ($88,$f0,$78,$78), ($6f,$4a,$25,$25), ($72,$5c,$2e,$2e), - ($24,$38,$1c,$1c), ($f1,$57,$a6,$a6), ($c7,$73,$b4,$b4), ($51,$97,$c6,$c6), - ($23,$cb,$e8,$e8), ($7c,$a1,$dd,$dd), ($9c,$e8,$74,$74), ($21,$3e,$1f,$1f), - ($dd,$96,$4b,$4b), ($dc,$61,$bd,$bd), ($86,$0d,$8b,$8b), ($85,$0f,$8a,$8a), - ($90,$e0,$70,$70), ($42,$7c,$3e,$3e), ($c4,$71,$b5,$b5), ($aa,$cc,$66,$66), - ($d8,$90,$48,$48), ($05,$06,$03,$03), ($01,$f7,$f6,$f6), ($12,$1c,$0e,$0e), - ($a3,$c2,$61,$61), ($5f,$6a,$35,$35), ($f9,$ae,$57,$57), ($d0,$69,$b9,$b9), - ($91,$17,$86,$86), ($58,$99,$c1,$c1), ($27,$3a,$1d,$1d), ($b9,$27,$9e,$9e), - ($38,$d9,$e1,$e1), ($13,$eb,$f8,$f8), ($b3,$2b,$98,$98), ($33,$22,$11,$11), - ($bb,$d2,$69,$69), ($70,$a9,$d9,$d9), ($89,$07,$8e,$8e), ($a7,$33,$94,$94), - ($b6,$2d,$9b,$9b), ($22,$3c,$1e,$1e), ($92,$15,$87,$87), ($20,$c9,$e9,$e9), - ($49,$87,$ce,$ce), ($ff,$aa,$55,$55), ($78,$50,$28,$28), ($7a,$a5,$df,$df), - ($8f,$03,$8c,$8c), ($f8,$59,$a1,$a1), ($80,$09,$89,$89), ($17,$1a,$0d,$0d), - ($da,$65,$bf,$bf), ($31,$d7,$e6,$e6), ($c6,$84,$42,$42), ($b8,$d0,$68,$68), - ($c3,$82,$41,$41), ($b0,$29,$99,$99), ($77,$5a,$2d,$2d), ($11,$1e,$0f,$0f), - ($cb,$7b,$b0,$b0), ($fc,$a8,$54,$54), ($d6,$6d,$bb,$bb), ($3a,$2c,$16,$16)); - T3: array[0..255,0..3] of byte= ( - ($63,$a5,$c6,$63), ($7c,$84,$f8,$7c), ($77,$99,$ee,$77), ($7b,$8d,$f6,$7b), - ($f2,$0d,$ff,$f2), ($6b,$bd,$d6,$6b), ($6f,$b1,$de,$6f), ($c5,$54,$91,$c5), - ($30,$50,$60,$30), ($01,$03,$02,$01), ($67,$a9,$ce,$67), ($2b,$7d,$56,$2b), - ($fe,$19,$e7,$fe), ($d7,$62,$b5,$d7), ($ab,$e6,$4d,$ab), ($76,$9a,$ec,$76), - ($ca,$45,$8f,$ca), ($82,$9d,$1f,$82), ($c9,$40,$89,$c9), ($7d,$87,$fa,$7d), - ($fa,$15,$ef,$fa), ($59,$eb,$b2,$59), ($47,$c9,$8e,$47), ($f0,$0b,$fb,$f0), - ($ad,$ec,$41,$ad), ($d4,$67,$b3,$d4), ($a2,$fd,$5f,$a2), ($af,$ea,$45,$af), - ($9c,$bf,$23,$9c), ($a4,$f7,$53,$a4), ($72,$96,$e4,$72), ($c0,$5b,$9b,$c0), - ($b7,$c2,$75,$b7), ($fd,$1c,$e1,$fd), ($93,$ae,$3d,$93), ($26,$6a,$4c,$26), - ($36,$5a,$6c,$36), ($3f,$41,$7e,$3f), ($f7,$02,$f5,$f7), ($cc,$4f,$83,$cc), - ($34,$5c,$68,$34), ($a5,$f4,$51,$a5), ($e5,$34,$d1,$e5), ($f1,$08,$f9,$f1), - ($71,$93,$e2,$71), ($d8,$73,$ab,$d8), ($31,$53,$62,$31), ($15,$3f,$2a,$15), - ($04,$0c,$08,$04), ($c7,$52,$95,$c7), ($23,$65,$46,$23), ($c3,$5e,$9d,$c3), - ($18,$28,$30,$18), ($96,$a1,$37,$96), ($05,$0f,$0a,$05), ($9a,$b5,$2f,$9a), - ($07,$09,$0e,$07), ($12,$36,$24,$12), ($80,$9b,$1b,$80), ($e2,$3d,$df,$e2), - ($eb,$26,$cd,$eb), ($27,$69,$4e,$27), ($b2,$cd,$7f,$b2), ($75,$9f,$ea,$75), - ($09,$1b,$12,$09), ($83,$9e,$1d,$83), ($2c,$74,$58,$2c), ($1a,$2e,$34,$1a), - ($1b,$2d,$36,$1b), ($6e,$b2,$dc,$6e), ($5a,$ee,$b4,$5a), ($a0,$fb,$5b,$a0), - ($52,$f6,$a4,$52), ($3b,$4d,$76,$3b), ($d6,$61,$b7,$d6), ($b3,$ce,$7d,$b3), - ($29,$7b,$52,$29), ($e3,$3e,$dd,$e3), ($2f,$71,$5e,$2f), ($84,$97,$13,$84), - ($53,$f5,$a6,$53), ($d1,$68,$b9,$d1), ($00,$00,$00,$00), ($ed,$2c,$c1,$ed), - ($20,$60,$40,$20), ($fc,$1f,$e3,$fc), ($b1,$c8,$79,$b1), ($5b,$ed,$b6,$5b), - ($6a,$be,$d4,$6a), ($cb,$46,$8d,$cb), ($be,$d9,$67,$be), ($39,$4b,$72,$39), - ($4a,$de,$94,$4a), ($4c,$d4,$98,$4c), ($58,$e8,$b0,$58), ($cf,$4a,$85,$cf), - ($d0,$6b,$bb,$d0), ($ef,$2a,$c5,$ef), ($aa,$e5,$4f,$aa), ($fb,$16,$ed,$fb), - ($43,$c5,$86,$43), ($4d,$d7,$9a,$4d), ($33,$55,$66,$33), ($85,$94,$11,$85), - ($45,$cf,$8a,$45), ($f9,$10,$e9,$f9), ($02,$06,$04,$02), ($7f,$81,$fe,$7f), - ($50,$f0,$a0,$50), ($3c,$44,$78,$3c), ($9f,$ba,$25,$9f), ($a8,$e3,$4b,$a8), - ($51,$f3,$a2,$51), ($a3,$fe,$5d,$a3), ($40,$c0,$80,$40), ($8f,$8a,$05,$8f), - ($92,$ad,$3f,$92), ($9d,$bc,$21,$9d), ($38,$48,$70,$38), ($f5,$04,$f1,$f5), - ($bc,$df,$63,$bc), ($b6,$c1,$77,$b6), ($da,$75,$af,$da), ($21,$63,$42,$21), - ($10,$30,$20,$10), ($ff,$1a,$e5,$ff), ($f3,$0e,$fd,$f3), ($d2,$6d,$bf,$d2), - ($cd,$4c,$81,$cd), ($0c,$14,$18,$0c), ($13,$35,$26,$13), ($ec,$2f,$c3,$ec), - ($5f,$e1,$be,$5f), ($97,$a2,$35,$97), ($44,$cc,$88,$44), ($17,$39,$2e,$17), - ($c4,$57,$93,$c4), ($a7,$f2,$55,$a7), ($7e,$82,$fc,$7e), ($3d,$47,$7a,$3d), - ($64,$ac,$c8,$64), ($5d,$e7,$ba,$5d), ($19,$2b,$32,$19), ($73,$95,$e6,$73), - ($60,$a0,$c0,$60), ($81,$98,$19,$81), ($4f,$d1,$9e,$4f), ($dc,$7f,$a3,$dc), - ($22,$66,$44,$22), ($2a,$7e,$54,$2a), ($90,$ab,$3b,$90), ($88,$83,$0b,$88), - ($46,$ca,$8c,$46), ($ee,$29,$c7,$ee), ($b8,$d3,$6b,$b8), ($14,$3c,$28,$14), - ($de,$79,$a7,$de), ($5e,$e2,$bc,$5e), ($0b,$1d,$16,$0b), ($db,$76,$ad,$db), - ($e0,$3b,$db,$e0), ($32,$56,$64,$32), ($3a,$4e,$74,$3a), ($0a,$1e,$14,$0a), - ($49,$db,$92,$49), ($06,$0a,$0c,$06), ($24,$6c,$48,$24), ($5c,$e4,$b8,$5c), - ($c2,$5d,$9f,$c2), ($d3,$6e,$bd,$d3), ($ac,$ef,$43,$ac), ($62,$a6,$c4,$62), - ($91,$a8,$39,$91), ($95,$a4,$31,$95), ($e4,$37,$d3,$e4), ($79,$8b,$f2,$79), - ($e7,$32,$d5,$e7), ($c8,$43,$8b,$c8), ($37,$59,$6e,$37), ($6d,$b7,$da,$6d), - ($8d,$8c,$01,$8d), ($d5,$64,$b1,$d5), ($4e,$d2,$9c,$4e), ($a9,$e0,$49,$a9), - ($6c,$b4,$d8,$6c), ($56,$fa,$ac,$56), ($f4,$07,$f3,$f4), ($ea,$25,$cf,$ea), - ($65,$af,$ca,$65), ($7a,$8e,$f4,$7a), ($ae,$e9,$47,$ae), ($08,$18,$10,$08), - ($ba,$d5,$6f,$ba), ($78,$88,$f0,$78), ($25,$6f,$4a,$25), ($2e,$72,$5c,$2e), - ($1c,$24,$38,$1c), ($a6,$f1,$57,$a6), ($b4,$c7,$73,$b4), ($c6,$51,$97,$c6), - ($e8,$23,$cb,$e8), ($dd,$7c,$a1,$dd), ($74,$9c,$e8,$74), ($1f,$21,$3e,$1f), - ($4b,$dd,$96,$4b), ($bd,$dc,$61,$bd), ($8b,$86,$0d,$8b), ($8a,$85,$0f,$8a), - ($70,$90,$e0,$70), ($3e,$42,$7c,$3e), ($b5,$c4,$71,$b5), ($66,$aa,$cc,$66), - ($48,$d8,$90,$48), ($03,$05,$06,$03), ($f6,$01,$f7,$f6), ($0e,$12,$1c,$0e), - ($61,$a3,$c2,$61), ($35,$5f,$6a,$35), ($57,$f9,$ae,$57), ($b9,$d0,$69,$b9), - ($86,$91,$17,$86), ($c1,$58,$99,$c1), ($1d,$27,$3a,$1d), ($9e,$b9,$27,$9e), - ($e1,$38,$d9,$e1), ($f8,$13,$eb,$f8), ($98,$b3,$2b,$98), ($11,$33,$22,$11), - ($69,$bb,$d2,$69), ($d9,$70,$a9,$d9), ($8e,$89,$07,$8e), ($94,$a7,$33,$94), - ($9b,$b6,$2d,$9b), ($1e,$22,$3c,$1e), ($87,$92,$15,$87), ($e9,$20,$c9,$e9), - ($ce,$49,$87,$ce), ($55,$ff,$aa,$55), ($28,$78,$50,$28), ($df,$7a,$a5,$df), - ($8c,$8f,$03,$8c), ($a1,$f8,$59,$a1), ($89,$80,$09,$89), ($0d,$17,$1a,$0d), - ($bf,$da,$65,$bf), ($e6,$31,$d7,$e6), ($42,$c6,$84,$42), ($68,$b8,$d0,$68), - ($41,$c3,$82,$41), ($99,$b0,$29,$99), ($2d,$77,$5a,$2d), ($0f,$11,$1e,$0f), - ($b0,$cb,$7b,$b0), ($54,$fc,$a8,$54), ($bb,$d6,$6d,$bb), ($16,$3a,$2c,$16)); - T4: array[0..255,0..3] of byte= ( - ($63,$63,$a5,$c6), ($7c,$7c,$84,$f8), ($77,$77,$99,$ee), ($7b,$7b,$8d,$f6), - ($f2,$f2,$0d,$ff), ($6b,$6b,$bd,$d6), ($6f,$6f,$b1,$de), ($c5,$c5,$54,$91), - ($30,$30,$50,$60), ($01,$01,$03,$02), ($67,$67,$a9,$ce), ($2b,$2b,$7d,$56), - ($fe,$fe,$19,$e7), ($d7,$d7,$62,$b5), ($ab,$ab,$e6,$4d), ($76,$76,$9a,$ec), - ($ca,$ca,$45,$8f), ($82,$82,$9d,$1f), ($c9,$c9,$40,$89), ($7d,$7d,$87,$fa), - ($fa,$fa,$15,$ef), ($59,$59,$eb,$b2), ($47,$47,$c9,$8e), ($f0,$f0,$0b,$fb), - ($ad,$ad,$ec,$41), ($d4,$d4,$67,$b3), ($a2,$a2,$fd,$5f), ($af,$af,$ea,$45), - ($9c,$9c,$bf,$23), ($a4,$a4,$f7,$53), ($72,$72,$96,$e4), ($c0,$c0,$5b,$9b), - ($b7,$b7,$c2,$75), ($fd,$fd,$1c,$e1), ($93,$93,$ae,$3d), ($26,$26,$6a,$4c), - ($36,$36,$5a,$6c), ($3f,$3f,$41,$7e), ($f7,$f7,$02,$f5), ($cc,$cc,$4f,$83), - ($34,$34,$5c,$68), ($a5,$a5,$f4,$51), ($e5,$e5,$34,$d1), ($f1,$f1,$08,$f9), - ($71,$71,$93,$e2), ($d8,$d8,$73,$ab), ($31,$31,$53,$62), ($15,$15,$3f,$2a), - ($04,$04,$0c,$08), ($c7,$c7,$52,$95), ($23,$23,$65,$46), ($c3,$c3,$5e,$9d), - ($18,$18,$28,$30), ($96,$96,$a1,$37), ($05,$05,$0f,$0a), ($9a,$9a,$b5,$2f), - ($07,$07,$09,$0e), ($12,$12,$36,$24), ($80,$80,$9b,$1b), ($e2,$e2,$3d,$df), - ($eb,$eb,$26,$cd), ($27,$27,$69,$4e), ($b2,$b2,$cd,$7f), ($75,$75,$9f,$ea), - ($09,$09,$1b,$12), ($83,$83,$9e,$1d), ($2c,$2c,$74,$58), ($1a,$1a,$2e,$34), - ($1b,$1b,$2d,$36), ($6e,$6e,$b2,$dc), ($5a,$5a,$ee,$b4), ($a0,$a0,$fb,$5b), - ($52,$52,$f6,$a4), ($3b,$3b,$4d,$76), ($d6,$d6,$61,$b7), ($b3,$b3,$ce,$7d), - ($29,$29,$7b,$52), ($e3,$e3,$3e,$dd), ($2f,$2f,$71,$5e), ($84,$84,$97,$13), - ($53,$53,$f5,$a6), ($d1,$d1,$68,$b9), ($00,$00,$00,$00), ($ed,$ed,$2c,$c1), - ($20,$20,$60,$40), ($fc,$fc,$1f,$e3), ($b1,$b1,$c8,$79), ($5b,$5b,$ed,$b6), - ($6a,$6a,$be,$d4), ($cb,$cb,$46,$8d), ($be,$be,$d9,$67), ($39,$39,$4b,$72), - ($4a,$4a,$de,$94), ($4c,$4c,$d4,$98), ($58,$58,$e8,$b0), ($cf,$cf,$4a,$85), - ($d0,$d0,$6b,$bb), ($ef,$ef,$2a,$c5), ($aa,$aa,$e5,$4f), ($fb,$fb,$16,$ed), - ($43,$43,$c5,$86), ($4d,$4d,$d7,$9a), ($33,$33,$55,$66), ($85,$85,$94,$11), - ($45,$45,$cf,$8a), ($f9,$f9,$10,$e9), ($02,$02,$06,$04), ($7f,$7f,$81,$fe), - ($50,$50,$f0,$a0), ($3c,$3c,$44,$78), ($9f,$9f,$ba,$25), ($a8,$a8,$e3,$4b), - ($51,$51,$f3,$a2), ($a3,$a3,$fe,$5d), ($40,$40,$c0,$80), ($8f,$8f,$8a,$05), - ($92,$92,$ad,$3f), ($9d,$9d,$bc,$21), ($38,$38,$48,$70), ($f5,$f5,$04,$f1), - ($bc,$bc,$df,$63), ($b6,$b6,$c1,$77), ($da,$da,$75,$af), ($21,$21,$63,$42), - ($10,$10,$30,$20), ($ff,$ff,$1a,$e5), ($f3,$f3,$0e,$fd), ($d2,$d2,$6d,$bf), - ($cd,$cd,$4c,$81), ($0c,$0c,$14,$18), ($13,$13,$35,$26), ($ec,$ec,$2f,$c3), - ($5f,$5f,$e1,$be), ($97,$97,$a2,$35), ($44,$44,$cc,$88), ($17,$17,$39,$2e), - ($c4,$c4,$57,$93), ($a7,$a7,$f2,$55), ($7e,$7e,$82,$fc), ($3d,$3d,$47,$7a), - ($64,$64,$ac,$c8), ($5d,$5d,$e7,$ba), ($19,$19,$2b,$32), ($73,$73,$95,$e6), - ($60,$60,$a0,$c0), ($81,$81,$98,$19), ($4f,$4f,$d1,$9e), ($dc,$dc,$7f,$a3), - ($22,$22,$66,$44), ($2a,$2a,$7e,$54), ($90,$90,$ab,$3b), ($88,$88,$83,$0b), - ($46,$46,$ca,$8c), ($ee,$ee,$29,$c7), ($b8,$b8,$d3,$6b), ($14,$14,$3c,$28), - ($de,$de,$79,$a7), ($5e,$5e,$e2,$bc), ($0b,$0b,$1d,$16), ($db,$db,$76,$ad), - ($e0,$e0,$3b,$db), ($32,$32,$56,$64), ($3a,$3a,$4e,$74), ($0a,$0a,$1e,$14), - ($49,$49,$db,$92), ($06,$06,$0a,$0c), ($24,$24,$6c,$48), ($5c,$5c,$e4,$b8), - ($c2,$c2,$5d,$9f), ($d3,$d3,$6e,$bd), ($ac,$ac,$ef,$43), ($62,$62,$a6,$c4), - ($91,$91,$a8,$39), ($95,$95,$a4,$31), ($e4,$e4,$37,$d3), ($79,$79,$8b,$f2), - ($e7,$e7,$32,$d5), ($c8,$c8,$43,$8b), ($37,$37,$59,$6e), ($6d,$6d,$b7,$da), - ($8d,$8d,$8c,$01), ($d5,$d5,$64,$b1), ($4e,$4e,$d2,$9c), ($a9,$a9,$e0,$49), - ($6c,$6c,$b4,$d8), ($56,$56,$fa,$ac), ($f4,$f4,$07,$f3), ($ea,$ea,$25,$cf), - ($65,$65,$af,$ca), ($7a,$7a,$8e,$f4), ($ae,$ae,$e9,$47), ($08,$08,$18,$10), - ($ba,$ba,$d5,$6f), ($78,$78,$88,$f0), ($25,$25,$6f,$4a), ($2e,$2e,$72,$5c), - ($1c,$1c,$24,$38), ($a6,$a6,$f1,$57), ($b4,$b4,$c7,$73), ($c6,$c6,$51,$97), - ($e8,$e8,$23,$cb), ($dd,$dd,$7c,$a1), ($74,$74,$9c,$e8), ($1f,$1f,$21,$3e), - ($4b,$4b,$dd,$96), ($bd,$bd,$dc,$61), ($8b,$8b,$86,$0d), ($8a,$8a,$85,$0f), - ($70,$70,$90,$e0), ($3e,$3e,$42,$7c), ($b5,$b5,$c4,$71), ($66,$66,$aa,$cc), - ($48,$48,$d8,$90), ($03,$03,$05,$06), ($f6,$f6,$01,$f7), ($0e,$0e,$12,$1c), - ($61,$61,$a3,$c2), ($35,$35,$5f,$6a), ($57,$57,$f9,$ae), ($b9,$b9,$d0,$69), - ($86,$86,$91,$17), ($c1,$c1,$58,$99), ($1d,$1d,$27,$3a), ($9e,$9e,$b9,$27), - ($e1,$e1,$38,$d9), ($f8,$f8,$13,$eb), ($98,$98,$b3,$2b), ($11,$11,$33,$22), - ($69,$69,$bb,$d2), ($d9,$d9,$70,$a9), ($8e,$8e,$89,$07), ($94,$94,$a7,$33), - ($9b,$9b,$b6,$2d), ($1e,$1e,$22,$3c), ($87,$87,$92,$15), ($e9,$e9,$20,$c9), - ($ce,$ce,$49,$87), ($55,$55,$ff,$aa), ($28,$28,$78,$50), ($df,$df,$7a,$a5), - ($8c,$8c,$8f,$03), ($a1,$a1,$f8,$59), ($89,$89,$80,$09), ($0d,$0d,$17,$1a), - ($bf,$bf,$da,$65), ($e6,$e6,$31,$d7), ($42,$42,$c6,$84), ($68,$68,$b8,$d0), - ($41,$41,$c3,$82), ($99,$99,$b0,$29), ($2d,$2d,$77,$5a), ($0f,$0f,$11,$1e), - ($b0,$b0,$cb,$7b), ($54,$54,$fc,$a8), ($bb,$bb,$d6,$6d), ($16,$16,$3a,$2c)); - T5: array[0..255,0..3] of byte= ( - ($51,$f4,$a7,$50), ($7e,$41,$65,$53), ($1a,$17,$a4,$c3), ($3a,$27,$5e,$96), - ($3b,$ab,$6b,$cb), ($1f,$9d,$45,$f1), ($ac,$fa,$58,$ab), ($4b,$e3,$03,$93), - ($20,$30,$fa,$55), ($ad,$76,$6d,$f6), ($88,$cc,$76,$91), ($f5,$02,$4c,$25), - ($4f,$e5,$d7,$fc), ($c5,$2a,$cb,$d7), ($26,$35,$44,$80), ($b5,$62,$a3,$8f), - ($de,$b1,$5a,$49), ($25,$ba,$1b,$67), ($45,$ea,$0e,$98), ($5d,$fe,$c0,$e1), - ($c3,$2f,$75,$02), ($81,$4c,$f0,$12), ($8d,$46,$97,$a3), ($6b,$d3,$f9,$c6), - ($03,$8f,$5f,$e7), ($15,$92,$9c,$95), ($bf,$6d,$7a,$eb), ($95,$52,$59,$da), - ($d4,$be,$83,$2d), ($58,$74,$21,$d3), ($49,$e0,$69,$29), ($8e,$c9,$c8,$44), - ($75,$c2,$89,$6a), ($f4,$8e,$79,$78), ($99,$58,$3e,$6b), ($27,$b9,$71,$dd), - ($be,$e1,$4f,$b6), ($f0,$88,$ad,$17), ($c9,$20,$ac,$66), ($7d,$ce,$3a,$b4), - ($63,$df,$4a,$18), ($e5,$1a,$31,$82), ($97,$51,$33,$60), ($62,$53,$7f,$45), - ($b1,$64,$77,$e0), ($bb,$6b,$ae,$84), ($fe,$81,$a0,$1c), ($f9,$08,$2b,$94), - ($70,$48,$68,$58), ($8f,$45,$fd,$19), ($94,$de,$6c,$87), ($52,$7b,$f8,$b7), - ($ab,$73,$d3,$23), ($72,$4b,$02,$e2), ($e3,$1f,$8f,$57), ($66,$55,$ab,$2a), - ($b2,$eb,$28,$07), ($2f,$b5,$c2,$03), ($86,$c5,$7b,$9a), ($d3,$37,$08,$a5), - ($30,$28,$87,$f2), ($23,$bf,$a5,$b2), ($02,$03,$6a,$ba), ($ed,$16,$82,$5c), - ($8a,$cf,$1c,$2b), ($a7,$79,$b4,$92), ($f3,$07,$f2,$f0), ($4e,$69,$e2,$a1), - ($65,$da,$f4,$cd), ($06,$05,$be,$d5), ($d1,$34,$62,$1f), ($c4,$a6,$fe,$8a), - ($34,$2e,$53,$9d), ($a2,$f3,$55,$a0), ($05,$8a,$e1,$32), ($a4,$f6,$eb,$75), - ($0b,$83,$ec,$39), ($40,$60,$ef,$aa), ($5e,$71,$9f,$06), ($bd,$6e,$10,$51), - ($3e,$21,$8a,$f9), ($96,$dd,$06,$3d), ($dd,$3e,$05,$ae), ($4d,$e6,$bd,$46), - ($91,$54,$8d,$b5), ($71,$c4,$5d,$05), ($04,$06,$d4,$6f), ($60,$50,$15,$ff), - ($19,$98,$fb,$24), ($d6,$bd,$e9,$97), ($89,$40,$43,$cc), ($67,$d9,$9e,$77), - ($b0,$e8,$42,$bd), ($07,$89,$8b,$88), ($e7,$19,$5b,$38), ($79,$c8,$ee,$db), - ($a1,$7c,$0a,$47), ($7c,$42,$0f,$e9), ($f8,$84,$1e,$c9), ($00,$00,$00,$00), - ($09,$80,$86,$83), ($32,$2b,$ed,$48), ($1e,$11,$70,$ac), ($6c,$5a,$72,$4e), - ($fd,$0e,$ff,$fb), ($0f,$85,$38,$56), ($3d,$ae,$d5,$1e), ($36,$2d,$39,$27), - ($0a,$0f,$d9,$64), ($68,$5c,$a6,$21), ($9b,$5b,$54,$d1), ($24,$36,$2e,$3a), - ($0c,$0a,$67,$b1), ($93,$57,$e7,$0f), ($b4,$ee,$96,$d2), ($1b,$9b,$91,$9e), - ($80,$c0,$c5,$4f), ($61,$dc,$20,$a2), ($5a,$77,$4b,$69), ($1c,$12,$1a,$16), - ($e2,$93,$ba,$0a), ($c0,$a0,$2a,$e5), ($3c,$22,$e0,$43), ($12,$1b,$17,$1d), - ($0e,$09,$0d,$0b), ($f2,$8b,$c7,$ad), ($2d,$b6,$a8,$b9), ($14,$1e,$a9,$c8), - ($57,$f1,$19,$85), ($af,$75,$07,$4c), ($ee,$99,$dd,$bb), ($a3,$7f,$60,$fd), - ($f7,$01,$26,$9f), ($5c,$72,$f5,$bc), ($44,$66,$3b,$c5), ($5b,$fb,$7e,$34), - ($8b,$43,$29,$76), ($cb,$23,$c6,$dc), ($b6,$ed,$fc,$68), ($b8,$e4,$f1,$63), - ($d7,$31,$dc,$ca), ($42,$63,$85,$10), ($13,$97,$22,$40), ($84,$c6,$11,$20), - ($85,$4a,$24,$7d), ($d2,$bb,$3d,$f8), ($ae,$f9,$32,$11), ($c7,$29,$a1,$6d), - ($1d,$9e,$2f,$4b), ($dc,$b2,$30,$f3), ($0d,$86,$52,$ec), ($77,$c1,$e3,$d0), - ($2b,$b3,$16,$6c), ($a9,$70,$b9,$99), ($11,$94,$48,$fa), ($47,$e9,$64,$22), - ($a8,$fc,$8c,$c4), ($a0,$f0,$3f,$1a), ($56,$7d,$2c,$d8), ($22,$33,$90,$ef), - ($87,$49,$4e,$c7), ($d9,$38,$d1,$c1), ($8c,$ca,$a2,$fe), ($98,$d4,$0b,$36), - ($a6,$f5,$81,$cf), ($a5,$7a,$de,$28), ($da,$b7,$8e,$26), ($3f,$ad,$bf,$a4), - ($2c,$3a,$9d,$e4), ($50,$78,$92,$0d), ($6a,$5f,$cc,$9b), ($54,$7e,$46,$62), - ($f6,$8d,$13,$c2), ($90,$d8,$b8,$e8), ($2e,$39,$f7,$5e), ($82,$c3,$af,$f5), - ($9f,$5d,$80,$be), ($69,$d0,$93,$7c), ($6f,$d5,$2d,$a9), ($cf,$25,$12,$b3), - ($c8,$ac,$99,$3b), ($10,$18,$7d,$a7), ($e8,$9c,$63,$6e), ($db,$3b,$bb,$7b), - ($cd,$26,$78,$09), ($6e,$59,$18,$f4), ($ec,$9a,$b7,$01), ($83,$4f,$9a,$a8), - ($e6,$95,$6e,$65), ($aa,$ff,$e6,$7e), ($21,$bc,$cf,$08), ($ef,$15,$e8,$e6), - ($ba,$e7,$9b,$d9), ($4a,$6f,$36,$ce), ($ea,$9f,$09,$d4), ($29,$b0,$7c,$d6), - ($31,$a4,$b2,$af), ($2a,$3f,$23,$31), ($c6,$a5,$94,$30), ($35,$a2,$66,$c0), - ($74,$4e,$bc,$37), ($fc,$82,$ca,$a6), ($e0,$90,$d0,$b0), ($33,$a7,$d8,$15), - ($f1,$04,$98,$4a), ($41,$ec,$da,$f7), ($7f,$cd,$50,$0e), ($17,$91,$f6,$2f), - ($76,$4d,$d6,$8d), ($43,$ef,$b0,$4d), ($cc,$aa,$4d,$54), ($e4,$96,$04,$df), - ($9e,$d1,$b5,$e3), ($4c,$6a,$88,$1b), ($c1,$2c,$1f,$b8), ($46,$65,$51,$7f), - ($9d,$5e,$ea,$04), ($01,$8c,$35,$5d), ($fa,$87,$74,$73), ($fb,$0b,$41,$2e), - ($b3,$67,$1d,$5a), ($92,$db,$d2,$52), ($e9,$10,$56,$33), ($6d,$d6,$47,$13), - ($9a,$d7,$61,$8c), ($37,$a1,$0c,$7a), ($59,$f8,$14,$8e), ($eb,$13,$3c,$89), - ($ce,$a9,$27,$ee), ($b7,$61,$c9,$35), ($e1,$1c,$e5,$ed), ($7a,$47,$b1,$3c), - ($9c,$d2,$df,$59), ($55,$f2,$73,$3f), ($18,$14,$ce,$79), ($73,$c7,$37,$bf), - ($53,$f7,$cd,$ea), ($5f,$fd,$aa,$5b), ($df,$3d,$6f,$14), ($78,$44,$db,$86), - ($ca,$af,$f3,$81), ($b9,$68,$c4,$3e), ($38,$24,$34,$2c), ($c2,$a3,$40,$5f), - ($16,$1d,$c3,$72), ($bc,$e2,$25,$0c), ($28,$3c,$49,$8b), ($ff,$0d,$95,$41), - ($39,$a8,$01,$71), ($08,$0c,$b3,$de), ($d8,$b4,$e4,$9c), ($64,$56,$c1,$90), - ($7b,$cb,$84,$61), ($d5,$32,$b6,$70), ($48,$6c,$5c,$74), ($d0,$b8,$57,$42)); - T6: array[0..255,0..3] of byte= ( - ($50,$51,$f4,$a7), ($53,$7e,$41,$65), ($c3,$1a,$17,$a4), ($96,$3a,$27,$5e), - ($cb,$3b,$ab,$6b), ($f1,$1f,$9d,$45), ($ab,$ac,$fa,$58), ($93,$4b,$e3,$03), - ($55,$20,$30,$fa), ($f6,$ad,$76,$6d), ($91,$88,$cc,$76), ($25,$f5,$02,$4c), - ($fc,$4f,$e5,$d7), ($d7,$c5,$2a,$cb), ($80,$26,$35,$44), ($8f,$b5,$62,$a3), - ($49,$de,$b1,$5a), ($67,$25,$ba,$1b), ($98,$45,$ea,$0e), ($e1,$5d,$fe,$c0), - ($02,$c3,$2f,$75), ($12,$81,$4c,$f0), ($a3,$8d,$46,$97), ($c6,$6b,$d3,$f9), - ($e7,$03,$8f,$5f), ($95,$15,$92,$9c), ($eb,$bf,$6d,$7a), ($da,$95,$52,$59), - ($2d,$d4,$be,$83), ($d3,$58,$74,$21), ($29,$49,$e0,$69), ($44,$8e,$c9,$c8), - ($6a,$75,$c2,$89), ($78,$f4,$8e,$79), ($6b,$99,$58,$3e), ($dd,$27,$b9,$71), - ($b6,$be,$e1,$4f), ($17,$f0,$88,$ad), ($66,$c9,$20,$ac), ($b4,$7d,$ce,$3a), - ($18,$63,$df,$4a), ($82,$e5,$1a,$31), ($60,$97,$51,$33), ($45,$62,$53,$7f), - ($e0,$b1,$64,$77), ($84,$bb,$6b,$ae), ($1c,$fe,$81,$a0), ($94,$f9,$08,$2b), - ($58,$70,$48,$68), ($19,$8f,$45,$fd), ($87,$94,$de,$6c), ($b7,$52,$7b,$f8), - ($23,$ab,$73,$d3), ($e2,$72,$4b,$02), ($57,$e3,$1f,$8f), ($2a,$66,$55,$ab), - ($07,$b2,$eb,$28), ($03,$2f,$b5,$c2), ($9a,$86,$c5,$7b), ($a5,$d3,$37,$08), - ($f2,$30,$28,$87), ($b2,$23,$bf,$a5), ($ba,$02,$03,$6a), ($5c,$ed,$16,$82), - ($2b,$8a,$cf,$1c), ($92,$a7,$79,$b4), ($f0,$f3,$07,$f2), ($a1,$4e,$69,$e2), - ($cd,$65,$da,$f4), ($d5,$06,$05,$be), ($1f,$d1,$34,$62), ($8a,$c4,$a6,$fe), - ($9d,$34,$2e,$53), ($a0,$a2,$f3,$55), ($32,$05,$8a,$e1), ($75,$a4,$f6,$eb), - ($39,$0b,$83,$ec), ($aa,$40,$60,$ef), ($06,$5e,$71,$9f), ($51,$bd,$6e,$10), - ($f9,$3e,$21,$8a), ($3d,$96,$dd,$06), ($ae,$dd,$3e,$05), ($46,$4d,$e6,$bd), - ($b5,$91,$54,$8d), ($05,$71,$c4,$5d), ($6f,$04,$06,$d4), ($ff,$60,$50,$15), - ($24,$19,$98,$fb), ($97,$d6,$bd,$e9), ($cc,$89,$40,$43), ($77,$67,$d9,$9e), - ($bd,$b0,$e8,$42), ($88,$07,$89,$8b), ($38,$e7,$19,$5b), ($db,$79,$c8,$ee), - ($47,$a1,$7c,$0a), ($e9,$7c,$42,$0f), ($c9,$f8,$84,$1e), ($00,$00,$00,$00), - ($83,$09,$80,$86), ($48,$32,$2b,$ed), ($ac,$1e,$11,$70), ($4e,$6c,$5a,$72), - ($fb,$fd,$0e,$ff), ($56,$0f,$85,$38), ($1e,$3d,$ae,$d5), ($27,$36,$2d,$39), - ($64,$0a,$0f,$d9), ($21,$68,$5c,$a6), ($d1,$9b,$5b,$54), ($3a,$24,$36,$2e), - ($b1,$0c,$0a,$67), ($0f,$93,$57,$e7), ($d2,$b4,$ee,$96), ($9e,$1b,$9b,$91), - ($4f,$80,$c0,$c5), ($a2,$61,$dc,$20), ($69,$5a,$77,$4b), ($16,$1c,$12,$1a), - ($0a,$e2,$93,$ba), ($e5,$c0,$a0,$2a), ($43,$3c,$22,$e0), ($1d,$12,$1b,$17), - ($0b,$0e,$09,$0d), ($ad,$f2,$8b,$c7), ($b9,$2d,$b6,$a8), ($c8,$14,$1e,$a9), - ($85,$57,$f1,$19), ($4c,$af,$75,$07), ($bb,$ee,$99,$dd), ($fd,$a3,$7f,$60), - ($9f,$f7,$01,$26), ($bc,$5c,$72,$f5), ($c5,$44,$66,$3b), ($34,$5b,$fb,$7e), - ($76,$8b,$43,$29), ($dc,$cb,$23,$c6), ($68,$b6,$ed,$fc), ($63,$b8,$e4,$f1), - ($ca,$d7,$31,$dc), ($10,$42,$63,$85), ($40,$13,$97,$22), ($20,$84,$c6,$11), - ($7d,$85,$4a,$24), ($f8,$d2,$bb,$3d), ($11,$ae,$f9,$32), ($6d,$c7,$29,$a1), - ($4b,$1d,$9e,$2f), ($f3,$dc,$b2,$30), ($ec,$0d,$86,$52), ($d0,$77,$c1,$e3), - ($6c,$2b,$b3,$16), ($99,$a9,$70,$b9), ($fa,$11,$94,$48), ($22,$47,$e9,$64), - ($c4,$a8,$fc,$8c), ($1a,$a0,$f0,$3f), ($d8,$56,$7d,$2c), ($ef,$22,$33,$90), - ($c7,$87,$49,$4e), ($c1,$d9,$38,$d1), ($fe,$8c,$ca,$a2), ($36,$98,$d4,$0b), - ($cf,$a6,$f5,$81), ($28,$a5,$7a,$de), ($26,$da,$b7,$8e), ($a4,$3f,$ad,$bf), - ($e4,$2c,$3a,$9d), ($0d,$50,$78,$92), ($9b,$6a,$5f,$cc), ($62,$54,$7e,$46), - ($c2,$f6,$8d,$13), ($e8,$90,$d8,$b8), ($5e,$2e,$39,$f7), ($f5,$82,$c3,$af), - ($be,$9f,$5d,$80), ($7c,$69,$d0,$93), ($a9,$6f,$d5,$2d), ($b3,$cf,$25,$12), - ($3b,$c8,$ac,$99), ($a7,$10,$18,$7d), ($6e,$e8,$9c,$63), ($7b,$db,$3b,$bb), - ($09,$cd,$26,$78), ($f4,$6e,$59,$18), ($01,$ec,$9a,$b7), ($a8,$83,$4f,$9a), - ($65,$e6,$95,$6e), ($7e,$aa,$ff,$e6), ($08,$21,$bc,$cf), ($e6,$ef,$15,$e8), - ($d9,$ba,$e7,$9b), ($ce,$4a,$6f,$36), ($d4,$ea,$9f,$09), ($d6,$29,$b0,$7c), - ($af,$31,$a4,$b2), ($31,$2a,$3f,$23), ($30,$c6,$a5,$94), ($c0,$35,$a2,$66), - ($37,$74,$4e,$bc), ($a6,$fc,$82,$ca), ($b0,$e0,$90,$d0), ($15,$33,$a7,$d8), - ($4a,$f1,$04,$98), ($f7,$41,$ec,$da), ($0e,$7f,$cd,$50), ($2f,$17,$91,$f6), - ($8d,$76,$4d,$d6), ($4d,$43,$ef,$b0), ($54,$cc,$aa,$4d), ($df,$e4,$96,$04), - ($e3,$9e,$d1,$b5), ($1b,$4c,$6a,$88), ($b8,$c1,$2c,$1f), ($7f,$46,$65,$51), - ($04,$9d,$5e,$ea), ($5d,$01,$8c,$35), ($73,$fa,$87,$74), ($2e,$fb,$0b,$41), - ($5a,$b3,$67,$1d), ($52,$92,$db,$d2), ($33,$e9,$10,$56), ($13,$6d,$d6,$47), - ($8c,$9a,$d7,$61), ($7a,$37,$a1,$0c), ($8e,$59,$f8,$14), ($89,$eb,$13,$3c), - ($ee,$ce,$a9,$27), ($35,$b7,$61,$c9), ($ed,$e1,$1c,$e5), ($3c,$7a,$47,$b1), - ($59,$9c,$d2,$df), ($3f,$55,$f2,$73), ($79,$18,$14,$ce), ($bf,$73,$c7,$37), - ($ea,$53,$f7,$cd), ($5b,$5f,$fd,$aa), ($14,$df,$3d,$6f), ($86,$78,$44,$db), - ($81,$ca,$af,$f3), ($3e,$b9,$68,$c4), ($2c,$38,$24,$34), ($5f,$c2,$a3,$40), - ($72,$16,$1d,$c3), ($0c,$bc,$e2,$25), ($8b,$28,$3c,$49), ($41,$ff,$0d,$95), - ($71,$39,$a8,$01), ($de,$08,$0c,$b3), ($9c,$d8,$b4,$e4), ($90,$64,$56,$c1), - ($61,$7b,$cb,$84), ($70,$d5,$32,$b6), ($74,$48,$6c,$5c), ($42,$d0,$b8,$57)); - T7: array[0..255,0..3] of byte= ( - ($a7,$50,$51,$f4), ($65,$53,$7e,$41), ($a4,$c3,$1a,$17), ($5e,$96,$3a,$27), - ($6b,$cb,$3b,$ab), ($45,$f1,$1f,$9d), ($58,$ab,$ac,$fa), ($03,$93,$4b,$e3), - ($fa,$55,$20,$30), ($6d,$f6,$ad,$76), ($76,$91,$88,$cc), ($4c,$25,$f5,$02), - ($d7,$fc,$4f,$e5), ($cb,$d7,$c5,$2a), ($44,$80,$26,$35), ($a3,$8f,$b5,$62), - ($5a,$49,$de,$b1), ($1b,$67,$25,$ba), ($0e,$98,$45,$ea), ($c0,$e1,$5d,$fe), - ($75,$02,$c3,$2f), ($f0,$12,$81,$4c), ($97,$a3,$8d,$46), ($f9,$c6,$6b,$d3), - ($5f,$e7,$03,$8f), ($9c,$95,$15,$92), ($7a,$eb,$bf,$6d), ($59,$da,$95,$52), - ($83,$2d,$d4,$be), ($21,$d3,$58,$74), ($69,$29,$49,$e0), ($c8,$44,$8e,$c9), - ($89,$6a,$75,$c2), ($79,$78,$f4,$8e), ($3e,$6b,$99,$58), ($71,$dd,$27,$b9), - ($4f,$b6,$be,$e1), ($ad,$17,$f0,$88), ($ac,$66,$c9,$20), ($3a,$b4,$7d,$ce), - ($4a,$18,$63,$df), ($31,$82,$e5,$1a), ($33,$60,$97,$51), ($7f,$45,$62,$53), - ($77,$e0,$b1,$64), ($ae,$84,$bb,$6b), ($a0,$1c,$fe,$81), ($2b,$94,$f9,$08), - ($68,$58,$70,$48), ($fd,$19,$8f,$45), ($6c,$87,$94,$de), ($f8,$b7,$52,$7b), - ($d3,$23,$ab,$73), ($02,$e2,$72,$4b), ($8f,$57,$e3,$1f), ($ab,$2a,$66,$55), - ($28,$07,$b2,$eb), ($c2,$03,$2f,$b5), ($7b,$9a,$86,$c5), ($08,$a5,$d3,$37), - ($87,$f2,$30,$28), ($a5,$b2,$23,$bf), ($6a,$ba,$02,$03), ($82,$5c,$ed,$16), - ($1c,$2b,$8a,$cf), ($b4,$92,$a7,$79), ($f2,$f0,$f3,$07), ($e2,$a1,$4e,$69), - ($f4,$cd,$65,$da), ($be,$d5,$06,$05), ($62,$1f,$d1,$34), ($fe,$8a,$c4,$a6), - ($53,$9d,$34,$2e), ($55,$a0,$a2,$f3), ($e1,$32,$05,$8a), ($eb,$75,$a4,$f6), - ($ec,$39,$0b,$83), ($ef,$aa,$40,$60), ($9f,$06,$5e,$71), ($10,$51,$bd,$6e), - ($8a,$f9,$3e,$21), ($06,$3d,$96,$dd), ($05,$ae,$dd,$3e), ($bd,$46,$4d,$e6), - ($8d,$b5,$91,$54), ($5d,$05,$71,$c4), ($d4,$6f,$04,$06), ($15,$ff,$60,$50), - ($fb,$24,$19,$98), ($e9,$97,$d6,$bd), ($43,$cc,$89,$40), ($9e,$77,$67,$d9), - ($42,$bd,$b0,$e8), ($8b,$88,$07,$89), ($5b,$38,$e7,$19), ($ee,$db,$79,$c8), - ($0a,$47,$a1,$7c), ($0f,$e9,$7c,$42), ($1e,$c9,$f8,$84), ($00,$00,$00,$00), - ($86,$83,$09,$80), ($ed,$48,$32,$2b), ($70,$ac,$1e,$11), ($72,$4e,$6c,$5a), - ($ff,$fb,$fd,$0e), ($38,$56,$0f,$85), ($d5,$1e,$3d,$ae), ($39,$27,$36,$2d), - ($d9,$64,$0a,$0f), ($a6,$21,$68,$5c), ($54,$d1,$9b,$5b), ($2e,$3a,$24,$36), - ($67,$b1,$0c,$0a), ($e7,$0f,$93,$57), ($96,$d2,$b4,$ee), ($91,$9e,$1b,$9b), - ($c5,$4f,$80,$c0), ($20,$a2,$61,$dc), ($4b,$69,$5a,$77), ($1a,$16,$1c,$12), - ($ba,$0a,$e2,$93), ($2a,$e5,$c0,$a0), ($e0,$43,$3c,$22), ($17,$1d,$12,$1b), - ($0d,$0b,$0e,$09), ($c7,$ad,$f2,$8b), ($a8,$b9,$2d,$b6), ($a9,$c8,$14,$1e), - ($19,$85,$57,$f1), ($07,$4c,$af,$75), ($dd,$bb,$ee,$99), ($60,$fd,$a3,$7f), - ($26,$9f,$f7,$01), ($f5,$bc,$5c,$72), ($3b,$c5,$44,$66), ($7e,$34,$5b,$fb), - ($29,$76,$8b,$43), ($c6,$dc,$cb,$23), ($fc,$68,$b6,$ed), ($f1,$63,$b8,$e4), - ($dc,$ca,$d7,$31), ($85,$10,$42,$63), ($22,$40,$13,$97), ($11,$20,$84,$c6), - ($24,$7d,$85,$4a), ($3d,$f8,$d2,$bb), ($32,$11,$ae,$f9), ($a1,$6d,$c7,$29), - ($2f,$4b,$1d,$9e), ($30,$f3,$dc,$b2), ($52,$ec,$0d,$86), ($e3,$d0,$77,$c1), - ($16,$6c,$2b,$b3), ($b9,$99,$a9,$70), ($48,$fa,$11,$94), ($64,$22,$47,$e9), - ($8c,$c4,$a8,$fc), ($3f,$1a,$a0,$f0), ($2c,$d8,$56,$7d), ($90,$ef,$22,$33), - ($4e,$c7,$87,$49), ($d1,$c1,$d9,$38), ($a2,$fe,$8c,$ca), ($0b,$36,$98,$d4), - ($81,$cf,$a6,$f5), ($de,$28,$a5,$7a), ($8e,$26,$da,$b7), ($bf,$a4,$3f,$ad), - ($9d,$e4,$2c,$3a), ($92,$0d,$50,$78), ($cc,$9b,$6a,$5f), ($46,$62,$54,$7e), - ($13,$c2,$f6,$8d), ($b8,$e8,$90,$d8), ($f7,$5e,$2e,$39), ($af,$f5,$82,$c3), - ($80,$be,$9f,$5d), ($93,$7c,$69,$d0), ($2d,$a9,$6f,$d5), ($12,$b3,$cf,$25), - ($99,$3b,$c8,$ac), ($7d,$a7,$10,$18), ($63,$6e,$e8,$9c), ($bb,$7b,$db,$3b), - ($78,$09,$cd,$26), ($18,$f4,$6e,$59), ($b7,$01,$ec,$9a), ($9a,$a8,$83,$4f), - ($6e,$65,$e6,$95), ($e6,$7e,$aa,$ff), ($cf,$08,$21,$bc), ($e8,$e6,$ef,$15), - ($9b,$d9,$ba,$e7), ($36,$ce,$4a,$6f), ($09,$d4,$ea,$9f), ($7c,$d6,$29,$b0), - ($b2,$af,$31,$a4), ($23,$31,$2a,$3f), ($94,$30,$c6,$a5), ($66,$c0,$35,$a2), - ($bc,$37,$74,$4e), ($ca,$a6,$fc,$82), ($d0,$b0,$e0,$90), ($d8,$15,$33,$a7), - ($98,$4a,$f1,$04), ($da,$f7,$41,$ec), ($50,$0e,$7f,$cd), ($f6,$2f,$17,$91), - ($d6,$8d,$76,$4d), ($b0,$4d,$43,$ef), ($4d,$54,$cc,$aa), ($04,$df,$e4,$96), - ($b5,$e3,$9e,$d1), ($88,$1b,$4c,$6a), ($1f,$b8,$c1,$2c), ($51,$7f,$46,$65), - ($ea,$04,$9d,$5e), ($35,$5d,$01,$8c), ($74,$73,$fa,$87), ($41,$2e,$fb,$0b), - ($1d,$5a,$b3,$67), ($d2,$52,$92,$db), ($56,$33,$e9,$10), ($47,$13,$6d,$d6), - ($61,$8c,$9a,$d7), ($0c,$7a,$37,$a1), ($14,$8e,$59,$f8), ($3c,$89,$eb,$13), - ($27,$ee,$ce,$a9), ($c9,$35,$b7,$61), ($e5,$ed,$e1,$1c), ($b1,$3c,$7a,$47), - ($df,$59,$9c,$d2), ($73,$3f,$55,$f2), ($ce,$79,$18,$14), ($37,$bf,$73,$c7), - ($cd,$ea,$53,$f7), ($aa,$5b,$5f,$fd), ($6f,$14,$df,$3d), ($db,$86,$78,$44), - ($f3,$81,$ca,$af), ($c4,$3e,$b9,$68), ($34,$2c,$38,$24), ($40,$5f,$c2,$a3), - ($c3,$72,$16,$1d), ($25,$0c,$bc,$e2), ($49,$8b,$28,$3c), ($95,$41,$ff,$0d), - ($01,$71,$39,$a8), ($b3,$de,$08,$0c), ($e4,$9c,$d8,$b4), ($c1,$90,$64,$56), - ($84,$61,$7b,$cb), ($b6,$70,$d5,$32), ($5c,$74,$48,$6c), ($57,$42,$d0,$b8)); - T8: array[0..255,0..3] of byte= ( - ($f4,$a7,$50,$51), ($41,$65,$53,$7e), ($17,$a4,$c3,$1a), ($27,$5e,$96,$3a), - ($ab,$6b,$cb,$3b), ($9d,$45,$f1,$1f), ($fa,$58,$ab,$ac), ($e3,$03,$93,$4b), - ($30,$fa,$55,$20), ($76,$6d,$f6,$ad), ($cc,$76,$91,$88), ($02,$4c,$25,$f5), - ($e5,$d7,$fc,$4f), ($2a,$cb,$d7,$c5), ($35,$44,$80,$26), ($62,$a3,$8f,$b5), - ($b1,$5a,$49,$de), ($ba,$1b,$67,$25), ($ea,$0e,$98,$45), ($fe,$c0,$e1,$5d), - ($2f,$75,$02,$c3), ($4c,$f0,$12,$81), ($46,$97,$a3,$8d), ($d3,$f9,$c6,$6b), - ($8f,$5f,$e7,$03), ($92,$9c,$95,$15), ($6d,$7a,$eb,$bf), ($52,$59,$da,$95), - ($be,$83,$2d,$d4), ($74,$21,$d3,$58), ($e0,$69,$29,$49), ($c9,$c8,$44,$8e), - ($c2,$89,$6a,$75), ($8e,$79,$78,$f4), ($58,$3e,$6b,$99), ($b9,$71,$dd,$27), - ($e1,$4f,$b6,$be), ($88,$ad,$17,$f0), ($20,$ac,$66,$c9), ($ce,$3a,$b4,$7d), - ($df,$4a,$18,$63), ($1a,$31,$82,$e5), ($51,$33,$60,$97), ($53,$7f,$45,$62), - ($64,$77,$e0,$b1), ($6b,$ae,$84,$bb), ($81,$a0,$1c,$fe), ($08,$2b,$94,$f9), - ($48,$68,$58,$70), ($45,$fd,$19,$8f), ($de,$6c,$87,$94), ($7b,$f8,$b7,$52), - ($73,$d3,$23,$ab), ($4b,$02,$e2,$72), ($1f,$8f,$57,$e3), ($55,$ab,$2a,$66), - ($eb,$28,$07,$b2), ($b5,$c2,$03,$2f), ($c5,$7b,$9a,$86), ($37,$08,$a5,$d3), - ($28,$87,$f2,$30), ($bf,$a5,$b2,$23), ($03,$6a,$ba,$02), ($16,$82,$5c,$ed), - ($cf,$1c,$2b,$8a), ($79,$b4,$92,$a7), ($07,$f2,$f0,$f3), ($69,$e2,$a1,$4e), - ($da,$f4,$cd,$65), ($05,$be,$d5,$06), ($34,$62,$1f,$d1), ($a6,$fe,$8a,$c4), - ($2e,$53,$9d,$34), ($f3,$55,$a0,$a2), ($8a,$e1,$32,$05), ($f6,$eb,$75,$a4), - ($83,$ec,$39,$0b), ($60,$ef,$aa,$40), ($71,$9f,$06,$5e), ($6e,$10,$51,$bd), - ($21,$8a,$f9,$3e), ($dd,$06,$3d,$96), ($3e,$05,$ae,$dd), ($e6,$bd,$46,$4d), - ($54,$8d,$b5,$91), ($c4,$5d,$05,$71), ($06,$d4,$6f,$04), ($50,$15,$ff,$60), - ($98,$fb,$24,$19), ($bd,$e9,$97,$d6), ($40,$43,$cc,$89), ($d9,$9e,$77,$67), - ($e8,$42,$bd,$b0), ($89,$8b,$88,$07), ($19,$5b,$38,$e7), ($c8,$ee,$db,$79), - ($7c,$0a,$47,$a1), ($42,$0f,$e9,$7c), ($84,$1e,$c9,$f8), ($00,$00,$00,$00), - ($80,$86,$83,$09), ($2b,$ed,$48,$32), ($11,$70,$ac,$1e), ($5a,$72,$4e,$6c), - ($0e,$ff,$fb,$fd), ($85,$38,$56,$0f), ($ae,$d5,$1e,$3d), ($2d,$39,$27,$36), - ($0f,$d9,$64,$0a), ($5c,$a6,$21,$68), ($5b,$54,$d1,$9b), ($36,$2e,$3a,$24), - ($0a,$67,$b1,$0c), ($57,$e7,$0f,$93), ($ee,$96,$d2,$b4), ($9b,$91,$9e,$1b), - ($c0,$c5,$4f,$80), ($dc,$20,$a2,$61), ($77,$4b,$69,$5a), ($12,$1a,$16,$1c), - ($93,$ba,$0a,$e2), ($a0,$2a,$e5,$c0), ($22,$e0,$43,$3c), ($1b,$17,$1d,$12), - ($09,$0d,$0b,$0e), ($8b,$c7,$ad,$f2), ($b6,$a8,$b9,$2d), ($1e,$a9,$c8,$14), - ($f1,$19,$85,$57), ($75,$07,$4c,$af), ($99,$dd,$bb,$ee), ($7f,$60,$fd,$a3), - ($01,$26,$9f,$f7), ($72,$f5,$bc,$5c), ($66,$3b,$c5,$44), ($fb,$7e,$34,$5b), - ($43,$29,$76,$8b), ($23,$c6,$dc,$cb), ($ed,$fc,$68,$b6), ($e4,$f1,$63,$b8), - ($31,$dc,$ca,$d7), ($63,$85,$10,$42), ($97,$22,$40,$13), ($c6,$11,$20,$84), - ($4a,$24,$7d,$85), ($bb,$3d,$f8,$d2), ($f9,$32,$11,$ae), ($29,$a1,$6d,$c7), - ($9e,$2f,$4b,$1d), ($b2,$30,$f3,$dc), ($86,$52,$ec,$0d), ($c1,$e3,$d0,$77), - ($b3,$16,$6c,$2b), ($70,$b9,$99,$a9), ($94,$48,$fa,$11), ($e9,$64,$22,$47), - ($fc,$8c,$c4,$a8), ($f0,$3f,$1a,$a0), ($7d,$2c,$d8,$56), ($33,$90,$ef,$22), - ($49,$4e,$c7,$87), ($38,$d1,$c1,$d9), ($ca,$a2,$fe,$8c), ($d4,$0b,$36,$98), - ($f5,$81,$cf,$a6), ($7a,$de,$28,$a5), ($b7,$8e,$26,$da), ($ad,$bf,$a4,$3f), - ($3a,$9d,$e4,$2c), ($78,$92,$0d,$50), ($5f,$cc,$9b,$6a), ($7e,$46,$62,$54), - ($8d,$13,$c2,$f6), ($d8,$b8,$e8,$90), ($39,$f7,$5e,$2e), ($c3,$af,$f5,$82), - ($5d,$80,$be,$9f), ($d0,$93,$7c,$69), ($d5,$2d,$a9,$6f), ($25,$12,$b3,$cf), - ($ac,$99,$3b,$c8), ($18,$7d,$a7,$10), ($9c,$63,$6e,$e8), ($3b,$bb,$7b,$db), - ($26,$78,$09,$cd), ($59,$18,$f4,$6e), ($9a,$b7,$01,$ec), ($4f,$9a,$a8,$83), - ($95,$6e,$65,$e6), ($ff,$e6,$7e,$aa), ($bc,$cf,$08,$21), ($15,$e8,$e6,$ef), - ($e7,$9b,$d9,$ba), ($6f,$36,$ce,$4a), ($9f,$09,$d4,$ea), ($b0,$7c,$d6,$29), - ($a4,$b2,$af,$31), ($3f,$23,$31,$2a), ($a5,$94,$30,$c6), ($a2,$66,$c0,$35), - ($4e,$bc,$37,$74), ($82,$ca,$a6,$fc), ($90,$d0,$b0,$e0), ($a7,$d8,$15,$33), - ($04,$98,$4a,$f1), ($ec,$da,$f7,$41), ($cd,$50,$0e,$7f), ($91,$f6,$2f,$17), - ($4d,$d6,$8d,$76), ($ef,$b0,$4d,$43), ($aa,$4d,$54,$cc), ($96,$04,$df,$e4), - ($d1,$b5,$e3,$9e), ($6a,$88,$1b,$4c), ($2c,$1f,$b8,$c1), ($65,$51,$7f,$46), - ($5e,$ea,$04,$9d), ($8c,$35,$5d,$01), ($87,$74,$73,$fa), ($0b,$41,$2e,$fb), - ($67,$1d,$5a,$b3), ($db,$d2,$52,$92), ($10,$56,$33,$e9), ($d6,$47,$13,$6d), - ($d7,$61,$8c,$9a), ($a1,$0c,$7a,$37), ($f8,$14,$8e,$59), ($13,$3c,$89,$eb), - ($a9,$27,$ee,$ce), ($61,$c9,$35,$b7), ($1c,$e5,$ed,$e1), ($47,$b1,$3c,$7a), - ($d2,$df,$59,$9c), ($f2,$73,$3f,$55), ($14,$ce,$79,$18), ($c7,$37,$bf,$73), - ($f7,$cd,$ea,$53), ($fd,$aa,$5b,$5f), ($3d,$6f,$14,$df), ($44,$db,$86,$78), - ($af,$f3,$81,$ca), ($68,$c4,$3e,$b9), ($24,$34,$2c,$38), ($a3,$40,$5f,$c2), - ($1d,$c3,$72,$16), ($e2,$25,$0c,$bc), ($3c,$49,$8b,$28), ($0d,$95,$41,$ff), - ($a8,$01,$71,$39), ($0c,$b3,$de,$08), ($b4,$e4,$9c,$d8), ($56,$c1,$90,$64), - ($cb,$84,$61,$7b), ($32,$b6,$70,$d5), ($6c,$5c,$74,$48), ($b8,$57,$42,$d0)); - S5: array[0..255] of byte= ( - $52,$09,$6a,$d5, - $30,$36,$a5,$38, - $bf,$40,$a3,$9e, - $81,$f3,$d7,$fb, - $7c,$e3,$39,$82, - $9b,$2f,$ff,$87, - $34,$8e,$43,$44, - $c4,$de,$e9,$cb, - $54,$7b,$94,$32, - $a6,$c2,$23,$3d, - $ee,$4c,$95,$0b, - $42,$fa,$c3,$4e, - $08,$2e,$a1,$66, - $28,$d9,$24,$b2, - $76,$5b,$a2,$49, - $6d,$8b,$d1,$25, - $72,$f8,$f6,$64, - $86,$68,$98,$16, - $d4,$a4,$5c,$cc, - $5d,$65,$b6,$92, - $6c,$70,$48,$50, - $fd,$ed,$b9,$da, - $5e,$15,$46,$57, - $a7,$8d,$9d,$84, - $90,$d8,$ab,$00, - $8c,$bc,$d3,$0a, - $f7,$e4,$58,$05, - $b8,$b3,$45,$06, - $d0,$2c,$1e,$8f, - $ca,$3f,$0f,$02, - $c1,$af,$bd,$03, - $01,$13,$8a,$6b, - $3a,$91,$11,$41, - $4f,$67,$dc,$ea, - $97,$f2,$cf,$ce, - $f0,$b4,$e6,$73, - $96,$ac,$74,$22, - $e7,$ad,$35,$85, - $e2,$f9,$37,$e8, - $1c,$75,$df,$6e, - $47,$f1,$1a,$71, - $1d,$29,$c5,$89, - $6f,$b7,$62,$0e, - $aa,$18,$be,$1b, - $fc,$56,$3e,$4b, - $c6,$d2,$79,$20, - $9a,$db,$c0,$fe, - $78,$cd,$5a,$f4, - $1f,$dd,$a8,$33, - $88,$07,$c7,$31, - $b1,$12,$10,$59, - $27,$80,$ec,$5f, - $60,$51,$7f,$a9, - $19,$b5,$4a,$0d, - $2d,$e5,$7a,$9f, - $93,$c9,$9c,$ef, - $a0,$e0,$3b,$4d, - $ae,$2a,$f5,$b0, - $c8,$eb,$bb,$3c, - $83,$53,$99,$61, - $17,$2b,$04,$7e, - $ba,$77,$d6,$26, - $e1,$69,$14,$63, - $55,$21,$0c,$7d); - U1: array[0..255,0..3] of byte= ( - ($00,$00,$00,$00), ($0e,$09,$0d,$0b), ($1c,$12,$1a,$16), ($12,$1b,$17,$1d), - ($38,$24,$34,$2c), ($36,$2d,$39,$27), ($24,$36,$2e,$3a), ($2a,$3f,$23,$31), - ($70,$48,$68,$58), ($7e,$41,$65,$53), ($6c,$5a,$72,$4e), ($62,$53,$7f,$45), - ($48,$6c,$5c,$74), ($46,$65,$51,$7f), ($54,$7e,$46,$62), ($5a,$77,$4b,$69), - ($e0,$90,$d0,$b0), ($ee,$99,$dd,$bb), ($fc,$82,$ca,$a6), ($f2,$8b,$c7,$ad), - ($d8,$b4,$e4,$9c), ($d6,$bd,$e9,$97), ($c4,$a6,$fe,$8a), ($ca,$af,$f3,$81), - ($90,$d8,$b8,$e8), ($9e,$d1,$b5,$e3), ($8c,$ca,$a2,$fe), ($82,$c3,$af,$f5), - ($a8,$fc,$8c,$c4), ($a6,$f5,$81,$cf), ($b4,$ee,$96,$d2), ($ba,$e7,$9b,$d9), - ($db,$3b,$bb,$7b), ($d5,$32,$b6,$70), ($c7,$29,$a1,$6d), ($c9,$20,$ac,$66), - ($e3,$1f,$8f,$57), ($ed,$16,$82,$5c), ($ff,$0d,$95,$41), ($f1,$04,$98,$4a), - ($ab,$73,$d3,$23), ($a5,$7a,$de,$28), ($b7,$61,$c9,$35), ($b9,$68,$c4,$3e), - ($93,$57,$e7,$0f), ($9d,$5e,$ea,$04), ($8f,$45,$fd,$19), ($81,$4c,$f0,$12), - ($3b,$ab,$6b,$cb), ($35,$a2,$66,$c0), ($27,$b9,$71,$dd), ($29,$b0,$7c,$d6), - ($03,$8f,$5f,$e7), ($0d,$86,$52,$ec), ($1f,$9d,$45,$f1), ($11,$94,$48,$fa), - ($4b,$e3,$03,$93), ($45,$ea,$0e,$98), ($57,$f1,$19,$85), ($59,$f8,$14,$8e), - ($73,$c7,$37,$bf), ($7d,$ce,$3a,$b4), ($6f,$d5,$2d,$a9), ($61,$dc,$20,$a2), - ($ad,$76,$6d,$f6), ($a3,$7f,$60,$fd), ($b1,$64,$77,$e0), ($bf,$6d,$7a,$eb), - ($95,$52,$59,$da), ($9b,$5b,$54,$d1), ($89,$40,$43,$cc), ($87,$49,$4e,$c7), - ($dd,$3e,$05,$ae), ($d3,$37,$08,$a5), ($c1,$2c,$1f,$b8), ($cf,$25,$12,$b3), - ($e5,$1a,$31,$82), ($eb,$13,$3c,$89), ($f9,$08,$2b,$94), ($f7,$01,$26,$9f), - ($4d,$e6,$bd,$46), ($43,$ef,$b0,$4d), ($51,$f4,$a7,$50), ($5f,$fd,$aa,$5b), - ($75,$c2,$89,$6a), ($7b,$cb,$84,$61), ($69,$d0,$93,$7c), ($67,$d9,$9e,$77), - ($3d,$ae,$d5,$1e), ($33,$a7,$d8,$15), ($21,$bc,$cf,$08), ($2f,$b5,$c2,$03), - ($05,$8a,$e1,$32), ($0b,$83,$ec,$39), ($19,$98,$fb,$24), ($17,$91,$f6,$2f), - ($76,$4d,$d6,$8d), ($78,$44,$db,$86), ($6a,$5f,$cc,$9b), ($64,$56,$c1,$90), - ($4e,$69,$e2,$a1), ($40,$60,$ef,$aa), ($52,$7b,$f8,$b7), ($5c,$72,$f5,$bc), - ($06,$05,$be,$d5), ($08,$0c,$b3,$de), ($1a,$17,$a4,$c3), ($14,$1e,$a9,$c8), - ($3e,$21,$8a,$f9), ($30,$28,$87,$f2), ($22,$33,$90,$ef), ($2c,$3a,$9d,$e4), - ($96,$dd,$06,$3d), ($98,$d4,$0b,$36), ($8a,$cf,$1c,$2b), ($84,$c6,$11,$20), - ($ae,$f9,$32,$11), ($a0,$f0,$3f,$1a), ($b2,$eb,$28,$07), ($bc,$e2,$25,$0c), - ($e6,$95,$6e,$65), ($e8,$9c,$63,$6e), ($fa,$87,$74,$73), ($f4,$8e,$79,$78), - ($de,$b1,$5a,$49), ($d0,$b8,$57,$42), ($c2,$a3,$40,$5f), ($cc,$aa,$4d,$54), - ($41,$ec,$da,$f7), ($4f,$e5,$d7,$fc), ($5d,$fe,$c0,$e1), ($53,$f7,$cd,$ea), - ($79,$c8,$ee,$db), ($77,$c1,$e3,$d0), ($65,$da,$f4,$cd), ($6b,$d3,$f9,$c6), - ($31,$a4,$b2,$af), ($3f,$ad,$bf,$a4), ($2d,$b6,$a8,$b9), ($23,$bf,$a5,$b2), - ($09,$80,$86,$83), ($07,$89,$8b,$88), ($15,$92,$9c,$95), ($1b,$9b,$91,$9e), - ($a1,$7c,$0a,$47), ($af,$75,$07,$4c), ($bd,$6e,$10,$51), ($b3,$67,$1d,$5a), - ($99,$58,$3e,$6b), ($97,$51,$33,$60), ($85,$4a,$24,$7d), ($8b,$43,$29,$76), - ($d1,$34,$62,$1f), ($df,$3d,$6f,$14), ($cd,$26,$78,$09), ($c3,$2f,$75,$02), - ($e9,$10,$56,$33), ($e7,$19,$5b,$38), ($f5,$02,$4c,$25), ($fb,$0b,$41,$2e), - ($9a,$d7,$61,$8c), ($94,$de,$6c,$87), ($86,$c5,$7b,$9a), ($88,$cc,$76,$91), - ($a2,$f3,$55,$a0), ($ac,$fa,$58,$ab), ($be,$e1,$4f,$b6), ($b0,$e8,$42,$bd), - ($ea,$9f,$09,$d4), ($e4,$96,$04,$df), ($f6,$8d,$13,$c2), ($f8,$84,$1e,$c9), - ($d2,$bb,$3d,$f8), ($dc,$b2,$30,$f3), ($ce,$a9,$27,$ee), ($c0,$a0,$2a,$e5), - ($7a,$47,$b1,$3c), ($74,$4e,$bc,$37), ($66,$55,$ab,$2a), ($68,$5c,$a6,$21), - ($42,$63,$85,$10), ($4c,$6a,$88,$1b), ($5e,$71,$9f,$06), ($50,$78,$92,$0d), - ($0a,$0f,$d9,$64), ($04,$06,$d4,$6f), ($16,$1d,$c3,$72), ($18,$14,$ce,$79), - ($32,$2b,$ed,$48), ($3c,$22,$e0,$43), ($2e,$39,$f7,$5e), ($20,$30,$fa,$55), - ($ec,$9a,$b7,$01), ($e2,$93,$ba,$0a), ($f0,$88,$ad,$17), ($fe,$81,$a0,$1c), - ($d4,$be,$83,$2d), ($da,$b7,$8e,$26), ($c8,$ac,$99,$3b), ($c6,$a5,$94,$30), - ($9c,$d2,$df,$59), ($92,$db,$d2,$52), ($80,$c0,$c5,$4f), ($8e,$c9,$c8,$44), - ($a4,$f6,$eb,$75), ($aa,$ff,$e6,$7e), ($b8,$e4,$f1,$63), ($b6,$ed,$fc,$68), - ($0c,$0a,$67,$b1), ($02,$03,$6a,$ba), ($10,$18,$7d,$a7), ($1e,$11,$70,$ac), - ($34,$2e,$53,$9d), ($3a,$27,$5e,$96), ($28,$3c,$49,$8b), ($26,$35,$44,$80), - ($7c,$42,$0f,$e9), ($72,$4b,$02,$e2), ($60,$50,$15,$ff), ($6e,$59,$18,$f4), - ($44,$66,$3b,$c5), ($4a,$6f,$36,$ce), ($58,$74,$21,$d3), ($56,$7d,$2c,$d8), - ($37,$a1,$0c,$7a), ($39,$a8,$01,$71), ($2b,$b3,$16,$6c), ($25,$ba,$1b,$67), - ($0f,$85,$38,$56), ($01,$8c,$35,$5d), ($13,$97,$22,$40), ($1d,$9e,$2f,$4b), - ($47,$e9,$64,$22), ($49,$e0,$69,$29), ($5b,$fb,$7e,$34), ($55,$f2,$73,$3f), - ($7f,$cd,$50,$0e), ($71,$c4,$5d,$05), ($63,$df,$4a,$18), ($6d,$d6,$47,$13), - ($d7,$31,$dc,$ca), ($d9,$38,$d1,$c1), ($cb,$23,$c6,$dc), ($c5,$2a,$cb,$d7), - ($ef,$15,$e8,$e6), ($e1,$1c,$e5,$ed), ($f3,$07,$f2,$f0), ($fd,$0e,$ff,$fb), - ($a7,$79,$b4,$92), ($a9,$70,$b9,$99), ($bb,$6b,$ae,$84), ($b5,$62,$a3,$8f), - ($9f,$5d,$80,$be), ($91,$54,$8d,$b5), ($83,$4f,$9a,$a8), ($8d,$46,$97,$a3)); - U2: array[0..255,0..3] of byte= ( - ($00,$00,$00,$00), ($0b,$0e,$09,$0d), ($16,$1c,$12,$1a), ($1d,$12,$1b,$17), - ($2c,$38,$24,$34), ($27,$36,$2d,$39), ($3a,$24,$36,$2e), ($31,$2a,$3f,$23), - ($58,$70,$48,$68), ($53,$7e,$41,$65), ($4e,$6c,$5a,$72), ($45,$62,$53,$7f), - ($74,$48,$6c,$5c), ($7f,$46,$65,$51), ($62,$54,$7e,$46), ($69,$5a,$77,$4b), - ($b0,$e0,$90,$d0), ($bb,$ee,$99,$dd), ($a6,$fc,$82,$ca), ($ad,$f2,$8b,$c7), - ($9c,$d8,$b4,$e4), ($97,$d6,$bd,$e9), ($8a,$c4,$a6,$fe), ($81,$ca,$af,$f3), - ($e8,$90,$d8,$b8), ($e3,$9e,$d1,$b5), ($fe,$8c,$ca,$a2), ($f5,$82,$c3,$af), - ($c4,$a8,$fc,$8c), ($cf,$a6,$f5,$81), ($d2,$b4,$ee,$96), ($d9,$ba,$e7,$9b), - ($7b,$db,$3b,$bb), ($70,$d5,$32,$b6), ($6d,$c7,$29,$a1), ($66,$c9,$20,$ac), - ($57,$e3,$1f,$8f), ($5c,$ed,$16,$82), ($41,$ff,$0d,$95), ($4a,$f1,$04,$98), - ($23,$ab,$73,$d3), ($28,$a5,$7a,$de), ($35,$b7,$61,$c9), ($3e,$b9,$68,$c4), - ($0f,$93,$57,$e7), ($04,$9d,$5e,$ea), ($19,$8f,$45,$fd), ($12,$81,$4c,$f0), - ($cb,$3b,$ab,$6b), ($c0,$35,$a2,$66), ($dd,$27,$b9,$71), ($d6,$29,$b0,$7c), - ($e7,$03,$8f,$5f), ($ec,$0d,$86,$52), ($f1,$1f,$9d,$45), ($fa,$11,$94,$48), - ($93,$4b,$e3,$03), ($98,$45,$ea,$0e), ($85,$57,$f1,$19), ($8e,$59,$f8,$14), - ($bf,$73,$c7,$37), ($b4,$7d,$ce,$3a), ($a9,$6f,$d5,$2d), ($a2,$61,$dc,$20), - ($f6,$ad,$76,$6d), ($fd,$a3,$7f,$60), ($e0,$b1,$64,$77), ($eb,$bf,$6d,$7a), - ($da,$95,$52,$59), ($d1,$9b,$5b,$54), ($cc,$89,$40,$43), ($c7,$87,$49,$4e), - ($ae,$dd,$3e,$05), ($a5,$d3,$37,$08), ($b8,$c1,$2c,$1f), ($b3,$cf,$25,$12), - ($82,$e5,$1a,$31), ($89,$eb,$13,$3c), ($94,$f9,$08,$2b), ($9f,$f7,$01,$26), - ($46,$4d,$e6,$bd), ($4d,$43,$ef,$b0), ($50,$51,$f4,$a7), ($5b,$5f,$fd,$aa), - ($6a,$75,$c2,$89), ($61,$7b,$cb,$84), ($7c,$69,$d0,$93), ($77,$67,$d9,$9e), - ($1e,$3d,$ae,$d5), ($15,$33,$a7,$d8), ($08,$21,$bc,$cf), ($03,$2f,$b5,$c2), - ($32,$05,$8a,$e1), ($39,$0b,$83,$ec), ($24,$19,$98,$fb), ($2f,$17,$91,$f6), - ($8d,$76,$4d,$d6), ($86,$78,$44,$db), ($9b,$6a,$5f,$cc), ($90,$64,$56,$c1), - ($a1,$4e,$69,$e2), ($aa,$40,$60,$ef), ($b7,$52,$7b,$f8), ($bc,$5c,$72,$f5), - ($d5,$06,$05,$be), ($de,$08,$0c,$b3), ($c3,$1a,$17,$a4), ($c8,$14,$1e,$a9), - ($f9,$3e,$21,$8a), ($f2,$30,$28,$87), ($ef,$22,$33,$90), ($e4,$2c,$3a,$9d), - ($3d,$96,$dd,$06), ($36,$98,$d4,$0b), ($2b,$8a,$cf,$1c), ($20,$84,$c6,$11), - ($11,$ae,$f9,$32), ($1a,$a0,$f0,$3f), ($07,$b2,$eb,$28), ($0c,$bc,$e2,$25), - ($65,$e6,$95,$6e), ($6e,$e8,$9c,$63), ($73,$fa,$87,$74), ($78,$f4,$8e,$79), - ($49,$de,$b1,$5a), ($42,$d0,$b8,$57), ($5f,$c2,$a3,$40), ($54,$cc,$aa,$4d), - ($f7,$41,$ec,$da), ($fc,$4f,$e5,$d7), ($e1,$5d,$fe,$c0), ($ea,$53,$f7,$cd), - ($db,$79,$c8,$ee), ($d0,$77,$c1,$e3), ($cd,$65,$da,$f4), ($c6,$6b,$d3,$f9), - ($af,$31,$a4,$b2), ($a4,$3f,$ad,$bf), ($b9,$2d,$b6,$a8), ($b2,$23,$bf,$a5), - ($83,$09,$80,$86), ($88,$07,$89,$8b), ($95,$15,$92,$9c), ($9e,$1b,$9b,$91), - ($47,$a1,$7c,$0a), ($4c,$af,$75,$07), ($51,$bd,$6e,$10), ($5a,$b3,$67,$1d), - ($6b,$99,$58,$3e), ($60,$97,$51,$33), ($7d,$85,$4a,$24), ($76,$8b,$43,$29), - ($1f,$d1,$34,$62), ($14,$df,$3d,$6f), ($09,$cd,$26,$78), ($02,$c3,$2f,$75), - ($33,$e9,$10,$56), ($38,$e7,$19,$5b), ($25,$f5,$02,$4c), ($2e,$fb,$0b,$41), - ($8c,$9a,$d7,$61), ($87,$94,$de,$6c), ($9a,$86,$c5,$7b), ($91,$88,$cc,$76), - ($a0,$a2,$f3,$55), ($ab,$ac,$fa,$58), ($b6,$be,$e1,$4f), ($bd,$b0,$e8,$42), - ($d4,$ea,$9f,$09), ($df,$e4,$96,$04), ($c2,$f6,$8d,$13), ($c9,$f8,$84,$1e), - ($f8,$d2,$bb,$3d), ($f3,$dc,$b2,$30), ($ee,$ce,$a9,$27), ($e5,$c0,$a0,$2a), - ($3c,$7a,$47,$b1), ($37,$74,$4e,$bc), ($2a,$66,$55,$ab), ($21,$68,$5c,$a6), - ($10,$42,$63,$85), ($1b,$4c,$6a,$88), ($06,$5e,$71,$9f), ($0d,$50,$78,$92), - ($64,$0a,$0f,$d9), ($6f,$04,$06,$d4), ($72,$16,$1d,$c3), ($79,$18,$14,$ce), - ($48,$32,$2b,$ed), ($43,$3c,$22,$e0), ($5e,$2e,$39,$f7), ($55,$20,$30,$fa), - ($01,$ec,$9a,$b7), ($0a,$e2,$93,$ba), ($17,$f0,$88,$ad), ($1c,$fe,$81,$a0), - ($2d,$d4,$be,$83), ($26,$da,$b7,$8e), ($3b,$c8,$ac,$99), ($30,$c6,$a5,$94), - ($59,$9c,$d2,$df), ($52,$92,$db,$d2), ($4f,$80,$c0,$c5), ($44,$8e,$c9,$c8), - ($75,$a4,$f6,$eb), ($7e,$aa,$ff,$e6), ($63,$b8,$e4,$f1), ($68,$b6,$ed,$fc), - ($b1,$0c,$0a,$67), ($ba,$02,$03,$6a), ($a7,$10,$18,$7d), ($ac,$1e,$11,$70), - ($9d,$34,$2e,$53), ($96,$3a,$27,$5e), ($8b,$28,$3c,$49), ($80,$26,$35,$44), - ($e9,$7c,$42,$0f), ($e2,$72,$4b,$02), ($ff,$60,$50,$15), ($f4,$6e,$59,$18), - ($c5,$44,$66,$3b), ($ce,$4a,$6f,$36), ($d3,$58,$74,$21), ($d8,$56,$7d,$2c), - ($7a,$37,$a1,$0c), ($71,$39,$a8,$01), ($6c,$2b,$b3,$16), ($67,$25,$ba,$1b), - ($56,$0f,$85,$38), ($5d,$01,$8c,$35), ($40,$13,$97,$22), ($4b,$1d,$9e,$2f), - ($22,$47,$e9,$64), ($29,$49,$e0,$69), ($34,$5b,$fb,$7e), ($3f,$55,$f2,$73), - ($0e,$7f,$cd,$50), ($05,$71,$c4,$5d), ($18,$63,$df,$4a), ($13,$6d,$d6,$47), - ($ca,$d7,$31,$dc), ($c1,$d9,$38,$d1), ($dc,$cb,$23,$c6), ($d7,$c5,$2a,$cb), - ($e6,$ef,$15,$e8), ($ed,$e1,$1c,$e5), ($f0,$f3,$07,$f2), ($fb,$fd,$0e,$ff), - ($92,$a7,$79,$b4), ($99,$a9,$70,$b9), ($84,$bb,$6b,$ae), ($8f,$b5,$62,$a3), - ($be,$9f,$5d,$80), ($b5,$91,$54,$8d), ($a8,$83,$4f,$9a), ($a3,$8d,$46,$97)); - U3: array[0..255,0..3] of byte= ( - ($00,$00,$00,$00), ($0d,$0b,$0e,$09), ($1a,$16,$1c,$12), ($17,$1d,$12,$1b), - ($34,$2c,$38,$24), ($39,$27,$36,$2d), ($2e,$3a,$24,$36), ($23,$31,$2a,$3f), - ($68,$58,$70,$48), ($65,$53,$7e,$41), ($72,$4e,$6c,$5a), ($7f,$45,$62,$53), - ($5c,$74,$48,$6c), ($51,$7f,$46,$65), ($46,$62,$54,$7e), ($4b,$69,$5a,$77), - ($d0,$b0,$e0,$90), ($dd,$bb,$ee,$99), ($ca,$a6,$fc,$82), ($c7,$ad,$f2,$8b), - ($e4,$9c,$d8,$b4), ($e9,$97,$d6,$bd), ($fe,$8a,$c4,$a6), ($f3,$81,$ca,$af), - ($b8,$e8,$90,$d8), ($b5,$e3,$9e,$d1), ($a2,$fe,$8c,$ca), ($af,$f5,$82,$c3), - ($8c,$c4,$a8,$fc), ($81,$cf,$a6,$f5), ($96,$d2,$b4,$ee), ($9b,$d9,$ba,$e7), - ($bb,$7b,$db,$3b), ($b6,$70,$d5,$32), ($a1,$6d,$c7,$29), ($ac,$66,$c9,$20), - ($8f,$57,$e3,$1f), ($82,$5c,$ed,$16), ($95,$41,$ff,$0d), ($98,$4a,$f1,$04), - ($d3,$23,$ab,$73), ($de,$28,$a5,$7a), ($c9,$35,$b7,$61), ($c4,$3e,$b9,$68), - ($e7,$0f,$93,$57), ($ea,$04,$9d,$5e), ($fd,$19,$8f,$45), ($f0,$12,$81,$4c), - ($6b,$cb,$3b,$ab), ($66,$c0,$35,$a2), ($71,$dd,$27,$b9), ($7c,$d6,$29,$b0), - ($5f,$e7,$03,$8f), ($52,$ec,$0d,$86), ($45,$f1,$1f,$9d), ($48,$fa,$11,$94), - ($03,$93,$4b,$e3), ($0e,$98,$45,$ea), ($19,$85,$57,$f1), ($14,$8e,$59,$f8), - ($37,$bf,$73,$c7), ($3a,$b4,$7d,$ce), ($2d,$a9,$6f,$d5), ($20,$a2,$61,$dc), - ($6d,$f6,$ad,$76), ($60,$fd,$a3,$7f), ($77,$e0,$b1,$64), ($7a,$eb,$bf,$6d), - ($59,$da,$95,$52), ($54,$d1,$9b,$5b), ($43,$cc,$89,$40), ($4e,$c7,$87,$49), - ($05,$ae,$dd,$3e), ($08,$a5,$d3,$37), ($1f,$b8,$c1,$2c), ($12,$b3,$cf,$25), - ($31,$82,$e5,$1a), ($3c,$89,$eb,$13), ($2b,$94,$f9,$08), ($26,$9f,$f7,$01), - ($bd,$46,$4d,$e6), ($b0,$4d,$43,$ef), ($a7,$50,$51,$f4), ($aa,$5b,$5f,$fd), - ($89,$6a,$75,$c2), ($84,$61,$7b,$cb), ($93,$7c,$69,$d0), ($9e,$77,$67,$d9), - ($d5,$1e,$3d,$ae), ($d8,$15,$33,$a7), ($cf,$08,$21,$bc), ($c2,$03,$2f,$b5), - ($e1,$32,$05,$8a), ($ec,$39,$0b,$83), ($fb,$24,$19,$98), ($f6,$2f,$17,$91), - ($d6,$8d,$76,$4d), ($db,$86,$78,$44), ($cc,$9b,$6a,$5f), ($c1,$90,$64,$56), - ($e2,$a1,$4e,$69), ($ef,$aa,$40,$60), ($f8,$b7,$52,$7b), ($f5,$bc,$5c,$72), - ($be,$d5,$06,$05), ($b3,$de,$08,$0c), ($a4,$c3,$1a,$17), ($a9,$c8,$14,$1e), - ($8a,$f9,$3e,$21), ($87,$f2,$30,$28), ($90,$ef,$22,$33), ($9d,$e4,$2c,$3a), - ($06,$3d,$96,$dd), ($0b,$36,$98,$d4), ($1c,$2b,$8a,$cf), ($11,$20,$84,$c6), - ($32,$11,$ae,$f9), ($3f,$1a,$a0,$f0), ($28,$07,$b2,$eb), ($25,$0c,$bc,$e2), - ($6e,$65,$e6,$95), ($63,$6e,$e8,$9c), ($74,$73,$fa,$87), ($79,$78,$f4,$8e), - ($5a,$49,$de,$b1), ($57,$42,$d0,$b8), ($40,$5f,$c2,$a3), ($4d,$54,$cc,$aa), - ($da,$f7,$41,$ec), ($d7,$fc,$4f,$e5), ($c0,$e1,$5d,$fe), ($cd,$ea,$53,$f7), - ($ee,$db,$79,$c8), ($e3,$d0,$77,$c1), ($f4,$cd,$65,$da), ($f9,$c6,$6b,$d3), - ($b2,$af,$31,$a4), ($bf,$a4,$3f,$ad), ($a8,$b9,$2d,$b6), ($a5,$b2,$23,$bf), - ($86,$83,$09,$80), ($8b,$88,$07,$89), ($9c,$95,$15,$92), ($91,$9e,$1b,$9b), - ($0a,$47,$a1,$7c), ($07,$4c,$af,$75), ($10,$51,$bd,$6e), ($1d,$5a,$b3,$67), - ($3e,$6b,$99,$58), ($33,$60,$97,$51), ($24,$7d,$85,$4a), ($29,$76,$8b,$43), - ($62,$1f,$d1,$34), ($6f,$14,$df,$3d), ($78,$09,$cd,$26), ($75,$02,$c3,$2f), - ($56,$33,$e9,$10), ($5b,$38,$e7,$19), ($4c,$25,$f5,$02), ($41,$2e,$fb,$0b), - ($61,$8c,$9a,$d7), ($6c,$87,$94,$de), ($7b,$9a,$86,$c5), ($76,$91,$88,$cc), - ($55,$a0,$a2,$f3), ($58,$ab,$ac,$fa), ($4f,$b6,$be,$e1), ($42,$bd,$b0,$e8), - ($09,$d4,$ea,$9f), ($04,$df,$e4,$96), ($13,$c2,$f6,$8d), ($1e,$c9,$f8,$84), - ($3d,$f8,$d2,$bb), ($30,$f3,$dc,$b2), ($27,$ee,$ce,$a9), ($2a,$e5,$c0,$a0), - ($b1,$3c,$7a,$47), ($bc,$37,$74,$4e), ($ab,$2a,$66,$55), ($a6,$21,$68,$5c), - ($85,$10,$42,$63), ($88,$1b,$4c,$6a), ($9f,$06,$5e,$71), ($92,$0d,$50,$78), - ($d9,$64,$0a,$0f), ($d4,$6f,$04,$06), ($c3,$72,$16,$1d), ($ce,$79,$18,$14), - ($ed,$48,$32,$2b), ($e0,$43,$3c,$22), ($f7,$5e,$2e,$39), ($fa,$55,$20,$30), - ($b7,$01,$ec,$9a), ($ba,$0a,$e2,$93), ($ad,$17,$f0,$88), ($a0,$1c,$fe,$81), - ($83,$2d,$d4,$be), ($8e,$26,$da,$b7), ($99,$3b,$c8,$ac), ($94,$30,$c6,$a5), - ($df,$59,$9c,$d2), ($d2,$52,$92,$db), ($c5,$4f,$80,$c0), ($c8,$44,$8e,$c9), - ($eb,$75,$a4,$f6), ($e6,$7e,$aa,$ff), ($f1,$63,$b8,$e4), ($fc,$68,$b6,$ed), - ($67,$b1,$0c,$0a), ($6a,$ba,$02,$03), ($7d,$a7,$10,$18), ($70,$ac,$1e,$11), - ($53,$9d,$34,$2e), ($5e,$96,$3a,$27), ($49,$8b,$28,$3c), ($44,$80,$26,$35), - ($0f,$e9,$7c,$42), ($02,$e2,$72,$4b), ($15,$ff,$60,$50), ($18,$f4,$6e,$59), - ($3b,$c5,$44,$66), ($36,$ce,$4a,$6f), ($21,$d3,$58,$74), ($2c,$d8,$56,$7d), - ($0c,$7a,$37,$a1), ($01,$71,$39,$a8), ($16,$6c,$2b,$b3), ($1b,$67,$25,$ba), - ($38,$56,$0f,$85), ($35,$5d,$01,$8c), ($22,$40,$13,$97), ($2f,$4b,$1d,$9e), - ($64,$22,$47,$e9), ($69,$29,$49,$e0), ($7e,$34,$5b,$fb), ($73,$3f,$55,$f2), - ($50,$0e,$7f,$cd), ($5d,$05,$71,$c4), ($4a,$18,$63,$df), ($47,$13,$6d,$d6), - ($dc,$ca,$d7,$31), ($d1,$c1,$d9,$38), ($c6,$dc,$cb,$23), ($cb,$d7,$c5,$2a), - ($e8,$e6,$ef,$15), ($e5,$ed,$e1,$1c), ($f2,$f0,$f3,$07), ($ff,$fb,$fd,$0e), - ($b4,$92,$a7,$79), ($b9,$99,$a9,$70), ($ae,$84,$bb,$6b), ($a3,$8f,$b5,$62), - ($80,$be,$9f,$5d), ($8d,$b5,$91,$54), ($9a,$a8,$83,$4f), ($97,$a3,$8d,$46)); - U4: array[0..255,0..3] of byte= ( - ($00,$00,$00,$00), ($09,$0d,$0b,$0e), ($12,$1a,$16,$1c), ($1b,$17,$1d,$12), - ($24,$34,$2c,$38), ($2d,$39,$27,$36), ($36,$2e,$3a,$24), ($3f,$23,$31,$2a), - ($48,$68,$58,$70), ($41,$65,$53,$7e), ($5a,$72,$4e,$6c), ($53,$7f,$45,$62), - ($6c,$5c,$74,$48), ($65,$51,$7f,$46), ($7e,$46,$62,$54), ($77,$4b,$69,$5a), - ($90,$d0,$b0,$e0), ($99,$dd,$bb,$ee), ($82,$ca,$a6,$fc), ($8b,$c7,$ad,$f2), - ($b4,$e4,$9c,$d8), ($bd,$e9,$97,$d6), ($a6,$fe,$8a,$c4), ($af,$f3,$81,$ca), - ($d8,$b8,$e8,$90), ($d1,$b5,$e3,$9e), ($ca,$a2,$fe,$8c), ($c3,$af,$f5,$82), - ($fc,$8c,$c4,$a8), ($f5,$81,$cf,$a6), ($ee,$96,$d2,$b4), ($e7,$9b,$d9,$ba), - ($3b,$bb,$7b,$db), ($32,$b6,$70,$d5), ($29,$a1,$6d,$c7), ($20,$ac,$66,$c9), - ($1f,$8f,$57,$e3), ($16,$82,$5c,$ed), ($0d,$95,$41,$ff), ($04,$98,$4a,$f1), - ($73,$d3,$23,$ab), ($7a,$de,$28,$a5), ($61,$c9,$35,$b7), ($68,$c4,$3e,$b9), - ($57,$e7,$0f,$93), ($5e,$ea,$04,$9d), ($45,$fd,$19,$8f), ($4c,$f0,$12,$81), - ($ab,$6b,$cb,$3b), ($a2,$66,$c0,$35), ($b9,$71,$dd,$27), ($b0,$7c,$d6,$29), - ($8f,$5f,$e7,$03), ($86,$52,$ec,$0d), ($9d,$45,$f1,$1f), ($94,$48,$fa,$11), - ($e3,$03,$93,$4b), ($ea,$0e,$98,$45), ($f1,$19,$85,$57), ($f8,$14,$8e,$59), - ($c7,$37,$bf,$73), ($ce,$3a,$b4,$7d), ($d5,$2d,$a9,$6f), ($dc,$20,$a2,$61), - ($76,$6d,$f6,$ad), ($7f,$60,$fd,$a3), ($64,$77,$e0,$b1), ($6d,$7a,$eb,$bf), - ($52,$59,$da,$95), ($5b,$54,$d1,$9b), ($40,$43,$cc,$89), ($49,$4e,$c7,$87), - ($3e,$05,$ae,$dd), ($37,$08,$a5,$d3), ($2c,$1f,$b8,$c1), ($25,$12,$b3,$cf), - ($1a,$31,$82,$e5), ($13,$3c,$89,$eb), ($08,$2b,$94,$f9), ($01,$26,$9f,$f7), - ($e6,$bd,$46,$4d), ($ef,$b0,$4d,$43), ($f4,$a7,$50,$51), ($fd,$aa,$5b,$5f), - ($c2,$89,$6a,$75), ($cb,$84,$61,$7b), ($d0,$93,$7c,$69), ($d9,$9e,$77,$67), - ($ae,$d5,$1e,$3d), ($a7,$d8,$15,$33), ($bc,$cf,$08,$21), ($b5,$c2,$03,$2f), - ($8a,$e1,$32,$05), ($83,$ec,$39,$0b), ($98,$fb,$24,$19), ($91,$f6,$2f,$17), - ($4d,$d6,$8d,$76), ($44,$db,$86,$78), ($5f,$cc,$9b,$6a), ($56,$c1,$90,$64), - ($69,$e2,$a1,$4e), ($60,$ef,$aa,$40), ($7b,$f8,$b7,$52), ($72,$f5,$bc,$5c), - ($05,$be,$d5,$06), ($0c,$b3,$de,$08), ($17,$a4,$c3,$1a), ($1e,$a9,$c8,$14), - ($21,$8a,$f9,$3e), ($28,$87,$f2,$30), ($33,$90,$ef,$22), ($3a,$9d,$e4,$2c), - ($dd,$06,$3d,$96), ($d4,$0b,$36,$98), ($cf,$1c,$2b,$8a), ($c6,$11,$20,$84), - ($f9,$32,$11,$ae), ($f0,$3f,$1a,$a0), ($eb,$28,$07,$b2), ($e2,$25,$0c,$bc), - ($95,$6e,$65,$e6), ($9c,$63,$6e,$e8), ($87,$74,$73,$fa), ($8e,$79,$78,$f4), - ($b1,$5a,$49,$de), ($b8,$57,$42,$d0), ($a3,$40,$5f,$c2), ($aa,$4d,$54,$cc), - ($ec,$da,$f7,$41), ($e5,$d7,$fc,$4f), ($fe,$c0,$e1,$5d), ($f7,$cd,$ea,$53), - ($c8,$ee,$db,$79), ($c1,$e3,$d0,$77), ($da,$f4,$cd,$65), ($d3,$f9,$c6,$6b), - ($a4,$b2,$af,$31), ($ad,$bf,$a4,$3f), ($b6,$a8,$b9,$2d), ($bf,$a5,$b2,$23), - ($80,$86,$83,$09), ($89,$8b,$88,$07), ($92,$9c,$95,$15), ($9b,$91,$9e,$1b), - ($7c,$0a,$47,$a1), ($75,$07,$4c,$af), ($6e,$10,$51,$bd), ($67,$1d,$5a,$b3), - ($58,$3e,$6b,$99), ($51,$33,$60,$97), ($4a,$24,$7d,$85), ($43,$29,$76,$8b), - ($34,$62,$1f,$d1), ($3d,$6f,$14,$df), ($26,$78,$09,$cd), ($2f,$75,$02,$c3), - ($10,$56,$33,$e9), ($19,$5b,$38,$e7), ($02,$4c,$25,$f5), ($0b,$41,$2e,$fb), - ($d7,$61,$8c,$9a), ($de,$6c,$87,$94), ($c5,$7b,$9a,$86), ($cc,$76,$91,$88), - ($f3,$55,$a0,$a2), ($fa,$58,$ab,$ac), ($e1,$4f,$b6,$be), ($e8,$42,$bd,$b0), - ($9f,$09,$d4,$ea), ($96,$04,$df,$e4), ($8d,$13,$c2,$f6), ($84,$1e,$c9,$f8), - ($bb,$3d,$f8,$d2), ($b2,$30,$f3,$dc), ($a9,$27,$ee,$ce), ($a0,$2a,$e5,$c0), - ($47,$b1,$3c,$7a), ($4e,$bc,$37,$74), ($55,$ab,$2a,$66), ($5c,$a6,$21,$68), - ($63,$85,$10,$42), ($6a,$88,$1b,$4c), ($71,$9f,$06,$5e), ($78,$92,$0d,$50), - ($0f,$d9,$64,$0a), ($06,$d4,$6f,$04), ($1d,$c3,$72,$16), ($14,$ce,$79,$18), - ($2b,$ed,$48,$32), ($22,$e0,$43,$3c), ($39,$f7,$5e,$2e), ($30,$fa,$55,$20), - ($9a,$b7,$01,$ec), ($93,$ba,$0a,$e2), ($88,$ad,$17,$f0), ($81,$a0,$1c,$fe), - ($be,$83,$2d,$d4), ($b7,$8e,$26,$da), ($ac,$99,$3b,$c8), ($a5,$94,$30,$c6), - ($d2,$df,$59,$9c), ($db,$d2,$52,$92), ($c0,$c5,$4f,$80), ($c9,$c8,$44,$8e), - ($f6,$eb,$75,$a4), ($ff,$e6,$7e,$aa), ($e4,$f1,$63,$b8), ($ed,$fc,$68,$b6), - ($0a,$67,$b1,$0c), ($03,$6a,$ba,$02), ($18,$7d,$a7,$10), ($11,$70,$ac,$1e), - ($2e,$53,$9d,$34), ($27,$5e,$96,$3a), ($3c,$49,$8b,$28), ($35,$44,$80,$26), - ($42,$0f,$e9,$7c), ($4b,$02,$e2,$72), ($50,$15,$ff,$60), ($59,$18,$f4,$6e), - ($66,$3b,$c5,$44), ($6f,$36,$ce,$4a), ($74,$21,$d3,$58), ($7d,$2c,$d8,$56), - ($a1,$0c,$7a,$37), ($a8,$01,$71,$39), ($b3,$16,$6c,$2b), ($ba,$1b,$67,$25), - ($85,$38,$56,$0f), ($8c,$35,$5d,$01), ($97,$22,$40,$13), ($9e,$2f,$4b,$1d), - ($e9,$64,$22,$47), ($e0,$69,$29,$49), ($fb,$7e,$34,$5b), ($f2,$73,$3f,$55), - ($cd,$50,$0e,$7f), ($c4,$5d,$05,$71), ($df,$4a,$18,$63), ($d6,$47,$13,$6d), - ($31,$dc,$ca,$d7), ($38,$d1,$c1,$d9), ($23,$c6,$dc,$cb), ($2a,$cb,$d7,$c5), - ($15,$e8,$e6,$ef), ($1c,$e5,$ed,$e1), ($07,$f2,$f0,$f3), ($0e,$ff,$fb,$fd), - ($79,$b4,$92,$a7), ($70,$b9,$99,$a9), ($6b,$ae,$84,$bb), ($62,$a3,$8f,$b5), - ($5d,$80,$be,$9f), ($54,$8d,$b5,$91), ($4f,$9a,$a8,$83), ($46,$97,$a3,$8d)); - - rcon: array[0..29] of cardinal= ( - $01, $02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, $d8, $ab, $4d, $9a, - $2f, $5e, $bc, $63, $c6, $97, $35, $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91); - -{==============================================================================} -type - PDWord = ^LongWord; - -procedure hperm_op(var a, t: integer; n, m: integer); -begin - t:= ((a shl (16 - n)) xor a) and m; - a:= a xor t xor (t shr (16 - n)); -end; - -procedure perm_op(var a, b, t: integer; n, m: integer); -begin - t:= ((a shr n) xor b) and m; - b:= b xor t; - a:= a xor (t shl n); -end; - -{==============================================================================} -function TSynaBlockCipher.GetSize: byte; -begin - Result := 8; -end; - -procedure TSynaBlockCipher.IncCounter; -var - i: integer; -begin - Inc(CV[GetSize]); - i:= GetSize -1; - while (i> 0) and (CV[i + 1] = #0) do - begin - Inc(CV[i]); - Dec(i); - end; -end; - -procedure TSynaBlockCipher.Reset; -begin - CV := IV; -end; - -procedure TSynaBlockCipher.InitKey(Key: AnsiString); -begin -end; - -procedure TSynaBlockCipher.SetIV(const Value: AnsiString); -begin - IV := PadString(Value, GetSize, #0); - Reset; -end; - -function TSynaBlockCipher.GetIV: AnsiString; -begin - Result := CV; -end; - -function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := InData; -end; - -function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := InData; -end; - -function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString; -var - i: integer; - s: ansistring; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, CV); - s := EncryptECB(s); - CV := s; - Result := Result + s; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString; -var - i: integer; - s, temp: ansistring; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - s := copy(Indata, (i - 1) * bs + 1, bs); - temp := s; - s := DecryptECB(s); - s := XorString(s, CV); - Result := Result + s; - CV := Temp; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString; -var - i: integer; - Temp: AnsiString; - c: AnsiChar; -begin - Result := ''; - for i:= 1 to Length(Indata) do - begin - Temp := EncryptECB(CV); - c := AnsiChar(ord(InData[i]) xor ord(temp[1])); - Result := Result + c; - Delete(CV, 1, 1); - CV := CV + c; - end; -end; - -function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString; -var - i: integer; - Temp: AnsiString; - c: AnsiChar; -begin - Result := ''; - for i:= 1 to length(Indata) do - begin - c:= Indata[i]; - Temp := EncryptECB(CV); - Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1])); - Delete(CV, 1, 1); - CV := CV + c; - end; -end; - -function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - CV := EncryptECB(CV); - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, CV); - Result := Result + s; - CV := s; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString; -var - i: integer; - S, Temp: AnsiString; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - s := copy(Indata, (i - 1) * bs + 1, bs); - Temp := s; - CV := EncryptECB(CV); - s := XorString(s, CV); - Result := result + s; - CV := temp; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - CV := EncryptECB(CV); - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, CV); - Result := Result + s; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString; -var - i: integer; - s: AnsiString; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - Cv := EncryptECB(CV); - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, CV); - Result := Result + s; - end; - if (l mod bs)<> 0 then - begin - CV := EncryptECB(CV); - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, CV); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString; -var - temp: AnsiString; - i: integer; - s: AnsiString; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, temp); - Result := Result + s; - end; - if (l mod bs)<> 0 then - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, temp); - Result := Result + s; - end; -end; - -function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString; -var - temp: AnsiString; - s: AnsiString; - i: integer; - l: integer; - bs: byte; -begin - Result := ''; - l := Length(InData); - bs := GetSize; - for i:= 1 to (l div bs) do - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (i - 1) * bs + 1, bs); - s := XorString(s, temp); - Result := Result + s; - end; - if (l mod bs)<> 0 then - begin - temp := EncryptECB(CV); - IncCounter; - s := copy(Indata, (l div bs) * bs + 1, l mod bs); - s := XorString(s, temp); - Result := Result + s; - end; -end; - -constructor TSynaBlockCipher.Create(Key: AnsiString); -begin - inherited Create; - InitKey(Key); - IV := StringOfChar(#0, GetSize); - IV := EncryptECB(IV); - Reset; -end; - -{==============================================================================} - -procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData); -var - c, d, t, s, t2, i: integer; -begin - KeyB := PadString(KeyB, 8, #0); - c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24); - d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24); - perm_op(d,c,t,4,integer($0f0f0f0f)); - hperm_op(c,t,integer(-2),integer($cccc0000)); - hperm_op(d,t,integer(-2),integer($cccc0000)); - perm_op(d,c,t,1,integer($55555555)); - perm_op(c,d,t,8,integer($00ff00ff)); - perm_op(d,c,t,1,integer($55555555)); - d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or - ((c and integer($f0000000)) shr 4); - c:= c and $fffffff; - for i:= 0 to 15 do - begin - if shifts2[i]<> 0 then - begin - c:= ((c shr 2) or (c shl 26)); - d:= ((d shr 2) or (d shl 26)); - end - else - begin - c:= ((c shr 1) or (c shl 27)); - d:= ((d shr 1) or (d shl 27)); - end; - c:= c and $fffffff; - d:= d and $fffffff; - s:= des_skb[0,c and $3f] or - des_skb[1,((c shr 6) and $03) or ((c shr 7) and $3c)] or - des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or - des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)]; - t:= des_skb[4,d and $3f] or - des_skb[5,((d shr 7) and $03) or ((d shr 8) and $3c)] or - des_skb[6, (d shr 15) and $3f ] or - des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)]; - t2:= ((t shl 16) or (s and $ffff)); - KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30)); - t2:= ((s shr 16) or (t and integer($ffff0000))); - KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26)); - end; -end; - -function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; -var - l, r, t, u: integer; - i: longint; -begin - r := Swapbytes(DecodeLongint(Indata, 1)); - l := swapbytes(DecodeLongint(Indata, 5)); - t:= ((l shr 4) xor r) and $0f0f0f0f; - r:= r xor t; - l:= l xor (t shl 4); - t:= ((r shr 16) xor l) and $0000ffff; - l:= l xor t; - r:= r xor (t shl 16); - t:= ((l shr 2) xor r) and $33333333; - r:= r xor t; - l:= l xor (t shl 2); - t:= ((r shr 8) xor l) and $00ff00ff; - l:= l xor t; - r:= r xor (t shl 8); - t:= ((l shr 1) xor r) and $55555555; - r:= r xor t; - l:= l xor (t shl 1); - r:= (r shr 29) or (r shl 3); - l:= (l shr 29) or (l shl 3); - i:= 0; - while i< 32 do - begin - u:= r xor KeyData[i ]; - t:= r xor KeyData[i+1]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i+2]; - t:= l xor KeyData[i+3]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= r xor KeyData[i+4]; - t:= r xor KeyData[i+5]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i+6]; - t:= l xor KeyData[i+7]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - Inc(i,8); - end; - r:= (r shr 3) or (r shl 29); - l:= (l shr 3) or (l shl 29); - t:= ((r shr 1) xor l) and $55555555; - l:= l xor t; - r:= r xor (t shl 1); - t:= ((l shr 8) xor r) and $00ff00ff; - r:= r xor t; - l:= l xor (t shl 8); - t:= ((r shr 2) xor l) and $33333333; - l:= l xor t; - r:= r xor (t shl 2); - t:= ((l shr 16) xor r) and $0000ffff; - r:= r xor t; - l:= l xor (t shl 16); - t:= ((r shr 4) xor l) and $0f0f0f0f; - l:= l xor t; - r:= r xor (t shl 4); - Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); -end; - -function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString; -var - l, r, t, u: integer; - i: longint; -begin - r := Swapbytes(DecodeLongint(Indata, 1)); - l := Swapbytes(DecodeLongint(Indata, 5)); - t:= ((l shr 4) xor r) and $0f0f0f0f; - r:= r xor t; - l:= l xor (t shl 4); - t:= ((r shr 16) xor l) and $0000ffff; - l:= l xor t; - r:= r xor (t shl 16); - t:= ((l shr 2) xor r) and $33333333; - r:= r xor t; - l:= l xor (t shl 2); - t:= ((r shr 8) xor l) and $00ff00ff; - l:= l xor t; - r:= r xor (t shl 8); - t:= ((l shr 1) xor r) and $55555555; - r:= r xor t; - l:= l xor (t shl 1); - r:= (r shr 29) or (r shl 3); - l:= (l shr 29) or (l shl 3); - i:= 30; - while i> 0 do - begin - u:= r xor KeyData[i ]; - t:= r xor KeyData[i+1]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i-2]; - t:= l xor KeyData[i-1]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= r xor KeyData[i-4]; - t:= r xor KeyData[i-3]; - t:= (t shr 4) or (t shl 28); - l:= l xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - u:= l xor KeyData[i-6]; - t:= l xor KeyData[i-5]; - t:= (t shr 4) or (t shl 28); - r:= r xor des_SPtrans[0,(u shr 2) and $3f] xor - des_SPtrans[2,(u shr 10) and $3f] xor - des_SPtrans[4,(u shr 18) and $3f] xor - des_SPtrans[6,(u shr 26) and $3f] xor - des_SPtrans[1,(t shr 2) and $3f] xor - des_SPtrans[3,(t shr 10) and $3f] xor - des_SPtrans[5,(t shr 18) and $3f] xor - des_SPtrans[7,(t shr 26) and $3f]; - Dec(i,8); - end; - r:= (r shr 3) or (r shl 29); - l:= (l shr 3) or (l shl 29); - t:= ((r shr 1) xor l) and $55555555; - l:= l xor t; - r:= r xor (t shl 1); - t:= ((l shr 8) xor r) and $00ff00ff; - r:= r xor t; - l:= l xor (t shl 8); - t:= ((r shr 2) xor l) and $33333333; - l:= l xor t; - r:= r xor (t shl 2); - t:= ((l shr 16) xor r) and $0000ffff; - r:= r xor t; - l:= l xor (t shl 16); - t:= ((r shr 4) xor l) and $0f0f0f0f; - l:= l xor t; - r:= r xor (t shl 4); - Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r)); -end; - -{==============================================================================} - -procedure TSynaDes.InitKey(Key: AnsiString); -begin - Key := PadString(Key, 8, #0); - DoInit(Key,KeyData); -end; - -function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := EncryptBlock(InData,KeyData); -end; - -function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := DecryptBlock(Indata,KeyData); -end; - -{==============================================================================} - -procedure TSyna3Des.InitKey(Key: AnsiString); -var - Size: integer; - n: integer; -begin - Size := length(Key); - key := PadString(key, 3 * 8, #0); - DoInit(Copy(key, 1, 8),KeyData[0]); - DoInit(Copy(key, 9, 8),KeyData[1]); - if Size > 16 then - DoInit(Copy(key, 17, 8),KeyData[2]) - else - for n := 0 to high(KeyData[0]) do - KeyData[2][n] := Keydata[0][n]; -end; - -function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString; -begin - Result := EncryptBlock(Indata,KeyData[0]); - Result := DecryptBlock(Result,KeyData[1]); - Result := EncryptBlock(Result,KeyData[2]); -end; - -function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString; -begin - Result := DecryptBlock(InData,KeyData[2]); - Result := EncryptBlock(Result,KeyData[1]); - Result := DecryptBlock(Result,KeyData[0]); -end; - -{==============================================================================} - -procedure InvMixColumn(a: PByteArray; BC: byte); -var - j: longword; -begin - for j:= 0 to (BC-1) do - PDWord(@(a^[j*4]))^:= PDWord(@U1[a^[j*4+0]])^ - xor PDWord(@U2[a^[j*4+1]])^ - xor PDWord(@U3[a^[j*4+2]])^ - xor PDWord(@U4[a^[j*4+3]])^; -end; - -{==============================================================================} - -function TSynaAes.GetSize: byte; -begin - Result := 16; -end; - -procedure TSynaAes.InitKey(Key: AnsiString); -var - Size: integer; - KC, ROUNDS, j, r, t, rconpointer: longword; - tk: array[0..MAXKC-1,0..3] of byte; - n: integer; -begin - FillChar(tk,Sizeof(tk),0); - //key must have at least 128 bits and max 256 bits - if length(key) < 16 then - key := PadString(key, 16, #0); - if length(key) > 32 then - delete(key, 33, maxint); - Size := length(Key); - Move(PAnsiChar(Key)^, tk, Size); - if Size<= 16 then - begin - KC:= 4; - Rounds:= 10; - end - else if Size<= 24 then - begin - KC:= 6; - Rounds:= 12; - end - else - begin - KC:= 8; - Rounds:= 14; - end; - numrounds:= rounds; - r:= 0; - t:= 0; - j:= 0; - while (j< KC) and (r< (rounds+1)) do - begin - while (j< KC) and (t< BC) do - begin - rk[r,t]:= PDWord(@tk[j])^; - Inc(j); - Inc(t); - end; - if t= BC then - begin - t:= 0; - Inc(r); - end; - end; - rconpointer:= 0; - while (r< (rounds+1)) do - begin - tk[0,0]:= tk[0,0] xor S[tk[KC-1,1]]; - tk[0,1]:= tk[0,1] xor S[tk[KC-1,2]]; - tk[0,2]:= tk[0,2] xor S[tk[KC-1,3]]; - tk[0,3]:= tk[0,3] xor S[tk[KC-1,0]]; - tk[0,0]:= tk[0,0] xor rcon[rconpointer]; - Inc(rconpointer); - if KC<> 8 then - begin - for j:= 1 to (KC-1) do - PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; - end - else - begin - for j:= 1 to ((KC div 2)-1) do - PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; - tk[KC div 2,0]:= tk[KC div 2,0] xor S[tk[KC div 2 - 1,0]]; - tk[KC div 2,1]:= tk[KC div 2,1] xor S[tk[KC div 2 - 1,1]]; - tk[KC div 2,2]:= tk[KC div 2,2] xor S[tk[KC div 2 - 1,2]]; - tk[KC div 2,3]:= tk[KC div 2,3] xor S[tk[KC div 2 - 1,3]]; - for j:= ((KC div 2) + 1) to (KC-1) do - PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^; - end; - j:= 0; - while (j< KC) and (r< (rounds+1)) do - begin - while (j< KC) and (t< BC) do - begin - rk[r,t]:= PDWord(@tk[j])^; - Inc(j); - Inc(t); - end; - if t= BC then - begin - Inc(r); - t:= 0; - end; - end; - end; - Move(rk,drk,Sizeof(rk)); - for r:= 1 to (numrounds-1) do - InvMixColumn(@drk[r],BC); -end; - -function TSynaAes.EncryptECB(const InData: AnsiString): AnsiString; -var - r: longword; - tempb: array[0..MAXBC-1,0..3] of byte; - a: array[0..MAXBC,0..3] of byte; - p: pointer; -begin - p := @a[0,0]; - move(pointer(InData)^, p^, 16); - for r:= 0 to (numrounds-2) do - begin - PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[r,0]; - PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[r,1]; - PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[r,2]; - PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[r,3]; - PDWord(@a[0])^:= PDWord(@T1[tempb[0,0]])^ xor - PDWord(@T2[tempb[1,1]])^ xor - PDWord(@T3[tempb[2,2]])^ xor - PDWord(@T4[tempb[3,3]])^; - PDWord(@a[1])^:= PDWord(@T1[tempb[1,0]])^ xor - PDWord(@T2[tempb[2,1]])^ xor - PDWord(@T3[tempb[3,2]])^ xor - PDWord(@T4[tempb[0,3]])^; - PDWord(@a[2])^:= PDWord(@T1[tempb[2,0]])^ xor - PDWord(@T2[tempb[3,1]])^ xor - PDWord(@T3[tempb[0,2]])^ xor - PDWord(@T4[tempb[1,3]])^; - PDWord(@a[3])^:= PDWord(@T1[tempb[3,0]])^ xor - PDWord(@T2[tempb[0,1]])^ xor - PDWord(@T3[tempb[1,2]])^ xor - PDWord(@T4[tempb[2,3]])^; - end; - PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[numrounds-1,0]; - PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[numrounds-1,1]; - PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[numrounds-1,2]; - PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[numrounds-1,3]; - a[0,0]:= T1[tempb[0,0],1]; - a[0,1]:= T1[tempb[1,1],1]; - a[0,2]:= T1[tempb[2,2],1]; - a[0,3]:= T1[tempb[3,3],1]; - a[1,0]:= T1[tempb[1,0],1]; - a[1,1]:= T1[tempb[2,1],1]; - a[1,2]:= T1[tempb[3,2],1]; - a[1,3]:= T1[tempb[0,3],1]; - a[2,0]:= T1[tempb[2,0],1]; - a[2,1]:= T1[tempb[3,1],1]; - a[2,2]:= T1[tempb[0,2],1]; - a[2,3]:= T1[tempb[1,3],1]; - a[3,0]:= T1[tempb[3,0],1]; - a[3,1]:= T1[tempb[0,1],1]; - a[3,2]:= T1[tempb[1,2],1]; - a[3,3]:= T1[tempb[2,3],1]; - PDWord(@a[0])^:= PDWord(@a[0])^ xor rk[numrounds,0]; - PDWord(@a[1])^:= PDWord(@a[1])^ xor rk[numrounds,1]; - PDWord(@a[2])^:= PDWord(@a[2])^ xor rk[numrounds,2]; - PDWord(@a[3])^:= PDWord(@a[3])^ xor rk[numrounds,3]; - - Result := StringOfChar(#0, 16); - move(p^, pointer(Result)^, 16); -end; - -function TSynaAes.DecryptECB(const InData: AnsiString): AnsiString; -var - r: longword; - tempb: array[0..MAXBC-1,0..3] of byte; - a: array[0..MAXBC,0..3] of byte; - p: pointer; -begin - p := @a[0,0]; - move(pointer(InData)^, p^, 16); - for r:= NumRounds downto 2 do - begin - PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[r,0]; - PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[r,1]; - PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[r,2]; - PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[r,3]; - PDWord(@a[0])^:= PDWord(@T5[tempb[0,0]])^ xor - PDWord(@T6[tempb[3,1]])^ xor - PDWord(@T7[tempb[2,2]])^ xor - PDWord(@T8[tempb[1,3]])^; - PDWord(@a[1])^:= PDWord(@T5[tempb[1,0]])^ xor - PDWord(@T6[tempb[0,1]])^ xor - PDWord(@T7[tempb[3,2]])^ xor - PDWord(@T8[tempb[2,3]])^; - PDWord(@a[2])^:= PDWord(@T5[tempb[2,0]])^ xor - PDWord(@T6[tempb[1,1]])^ xor - PDWord(@T7[tempb[0,2]])^ xor - PDWord(@T8[tempb[3,3]])^; - PDWord(@a[3])^:= PDWord(@T5[tempb[3,0]])^ xor - PDWord(@T6[tempb[2,1]])^ xor - PDWord(@T7[tempb[1,2]])^ xor - PDWord(@T8[tempb[0,3]])^; - end; - PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[1,0]; - PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[1,1]; - PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[1,2]; - PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[1,3]; - a[0,0]:= S5[tempb[0,0]]; - a[0,1]:= S5[tempb[3,1]]; - a[0,2]:= S5[tempb[2,2]]; - a[0,3]:= S5[tempb[1,3]]; - a[1,0]:= S5[tempb[1,0]]; - a[1,1]:= S5[tempb[0,1]]; - a[1,2]:= S5[tempb[3,2]]; - a[1,3]:= S5[tempb[2,3]]; - a[2,0]:= S5[tempb[2,0]]; - a[2,1]:= S5[tempb[1,1]]; - a[2,2]:= S5[tempb[0,2]]; - a[2,3]:= S5[tempb[3,3]]; - a[3,0]:= S5[tempb[3,0]]; - a[3,1]:= S5[tempb[2,1]]; - a[3,2]:= S5[tempb[1,2]]; - a[3,3]:= S5[tempb[0,3]]; - PDWord(@a[0])^:= PDWord(@a[0])^ xor drk[0,0]; - PDWord(@a[1])^:= PDWord(@a[1])^ xor drk[0,1]; - PDWord(@a[2])^:= PDWord(@a[2])^ xor drk[0,2]; - PDWord(@a[3])^:= PDWord(@a[3])^ xor drk[0,3]; - Result := StringOfChar(#0, 16); - move(p^, pointer(Result)^, 16); -end; - -{==============================================================================} - -function TestDes: boolean; -var - des: TSynaDes; - s, t: string; -const - key = '01234567'; - data1= '01234567'; - data2= '0123456789abcdefghij'; -begin - //ECB - des := TSynaDes.Create(key); - try - s := des.EncryptECB(data1); - t := strtohex(s); - result := t = 'c50ad028c6da9800'; - s := des.DecryptECB(s); - result := result and (data1 = s); - finally - des.free; - end; - //CBC - des := TSynaDes.Create(key); - try - s := des.EncryptCBC(data2); - t := strtohex(s); - result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35'); - des.Reset; - s := des.DecryptCBC(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-8bit - des := TSynaDes.Create(key); - try - s := des.EncryptCFB8bit(data2); - t := strtohex(s); - result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452'); - des.Reset; - s := des.DecryptCFB8bit(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-block - des := TSynaDes.Create(key); - try - s := des.EncryptCFBblock(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257'); - des.Reset; - s := des.DecryptCFBblock(s); - result := result and (data2 = s); - finally - des.free; - end; - //OFB - des := TSynaDes.Create(key); - try - s := des.EncryptOFB(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc'); - des.Reset; - s := des.DecryptOFB(s); - result := result and (data2 = s); - finally - des.free; - end; - //CTR - des := TSynaDes.Create(key); - try - s := des.EncryptCTR(data2); - t := strtohex(s); - result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e'); - des.Reset; - s := des.DecryptCTR(s); - result := result and (data2 = s); - finally - des.free; - end; -end; - -function Test3Des: boolean; -var - des: TSyna3Des; - s, t: string; -const - key = '0123456789abcdefghijklmn'; - data1= '01234567'; - data2= '0123456789abcdefghij'; -begin - //ECB - des := TSyna3Des.Create(key); - try - s := des.EncryptECB(data1); - t := strtohex(s); - result := t = 'e0dee91008dc460c'; - s := des.DecryptECB(s); - result := result and (data1 = s); - finally - des.free; - end; - //CBC - des := TSyna3Des.Create(key); - try - s := des.EncryptCBC(data2); - t := strtohex(s); - result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a'); - des.Reset; - s := des.DecryptCBC(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-8bit - des := TSyna3Des.Create(key); - try - s := des.EncryptCFB8bit(data2); - t := strtohex(s); - result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8'); - des.Reset; - s := des.DecryptCFB8bit(s); - result := result and (data2 = s); - finally - des.free; - end; - //CFB-block - des := TSyna3Des.Create(key); - try - s := des.EncryptCFBblock(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671'); - des.Reset; - s := des.DecryptCFBblock(s); - result := result and (data2 = s); - finally - des.free; - end; - //OFB - des := TSyna3Des.Create(key); - try - s := des.EncryptOFB(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20'); - des.Reset; - s := des.DecryptOFB(s); - result := result and (data2 = s); - finally - des.free; - end; - //CTR - des := TSyna3Des.Create(key); - try - s := des.EncryptCTR(data2); - t := strtohex(s); - result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad'); - des.Reset; - s := des.DecryptCTR(s); - result := result and (data2 = s); - finally - des.free; - end; -end; - -function TestAes: boolean; -var - aes: TSynaAes; - s, t: string; -const - key1 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12; - data1= #$50#$68#$12#$A4#$5F#$08#$C8#$89#$B9#$7F#$59#$80#$03#$8B#$83#$59; - key2 = #$A0#$A1#$A2#$A3#$A5#$A6#$A7#$A8#$AA#$AB#$AC#$AD#$AF#$B0#$B1#$B2#$B4#$B5#$B6#$B7#$B9#$BA#$BB#$BC; - data2= #$4F#$1C#$76#$9D#$1E#$5B#$05#$52#$C7#$EC#$A8#$4D#$EA#$26#$A5#$49; - key3 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12#$14#$15#$16#$17#$19#$1A#$1B#$1C#$1E#$1F#$20#$21#$23#$24#$25#$26; - data3= #$5E#$25#$CA#$78#$F0#$DE#$55#$80#$25#$24#$D3#$8D#$A3#$FE#$44#$56; -begin - //ECB - aes := TSynaAes.Create(key1); - try - t := aes.EncryptECB(data1); - result := t = #$D8#$F5#$32#$53#$82#$89#$EF#$7D#$06#$B5#$06#$A4#$FD#$5B#$E9#$C9; - s := aes.DecryptECB(t); - result := result and (data1 = s); - finally - aes.free; - end; - aes := TSynaAes.Create(key2); - try - t := aes.EncryptECB(data2); - result := result and (t = #$F3#$84#$72#$10#$D5#$39#$1E#$23#$60#$60#$8E#$5A#$CB#$56#$05#$81); - s := aes.DecryptECB(t); - result := result and (data2 = s); - finally - aes.free; - end; - aes := TSynaAes.Create(key3); - try - t := aes.EncryptECB(data3); - result := result and (t = #$E8#$B7#$2B#$4E#$8B#$E2#$43#$43#$8C#$9F#$FF#$1F#$0E#$20#$58#$72); - s := aes.DecryptECB(t); - result := result and (data3 = s); - finally - aes.free; - end; -end; - -{==============================================================================} - -end. diff --git a/synapse/synadbg.pas b/synapse/synadbg.pas deleted file mode 100644 index 6f60f4c..0000000 --- a/synapse/synadbg.pas +++ /dev/null @@ -1,156 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.002 | -|==============================================================================| -| Content: Socket debug tools | -|==============================================================================| -| Copyright (c)2008-2011, 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)2008-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Socket debug tools) - -Routines for help with debugging of events on the Sockets. -} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synadbg; - -interface - -uses - blcksock, synsock, synautil, classes, sysutils, synafpc; - -type - TSynaDebug = class(TObject) - class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); - class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); - end; - -procedure AppendToLog(const value: Ansistring); - -var - LogFile: string; - -implementation - -procedure AppendToLog(const value: Ansistring); -var - st: TFileStream; - s: string; - h, m, ss, ms: word; - dt: Tdatetime; -begin - if fileexists(LogFile) then - st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) - else - st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); - try - st.Position := st.Size; - dt := now; - decodetime(dt, h, m, ss, ms); - s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; - WriteStrToStream(st, s); - finally - st.free; - end; -end; - -class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); -var - s: string; -begin - case Reason of - HR_ResolvingBegin: - s := 'HR_ResolvingBegin'; - HR_ResolvingEnd: - s := 'HR_ResolvingEnd'; - HR_SocketCreate: - s := 'HR_SocketCreate'; - HR_SocketClose: - s := 'HR_SocketClose'; - HR_Bind: - s := 'HR_Bind'; - HR_Connect: - s := 'HR_Connect'; - HR_CanRead: - s := 'HR_CanRead'; - HR_CanWrite: - s := 'HR_CanWrite'; - HR_Listen: - s := 'HR_Listen'; - HR_Accept: - s := 'HR_Accept'; - HR_ReadCount: - s := 'HR_ReadCount'; - HR_WriteCount: - s := 'HR_WriteCount'; - HR_Wait: - s := 'HR_Wait'; - HR_Error: - s := 'HR_Error'; - else - s := '-unknown-'; - end; - s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF; - AppendToLog(s); -end; - -class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); -var - s, d: Ansistring; -begin - setlength(s, len); - move(Buffer^, pointer(s)^, len); - if writing then - d := '-> ' - else - d := '<- '; - s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF; - AppendToLog(s); -end; - -initialization -begin - Logfile := changefileext(paramstr(0), '.slog'); -end; - -end. diff --git a/synapse/synafpc.pas b/synapse/synafpc.pas deleted file mode 100644 index 04e8358..0000000 --- a/synapse/synafpc.pas +++ /dev/null @@ -1,141 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.000 | -|==============================================================================| -| Content: Utils for FreePascal compatibility | -|==============================================================================| -| Copyright (c)1999-2011, 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-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -unit synafpc; - -interface - -uses -{$IFDEF FPC} - dynlibs, sysutils; -{$ELSE} - {$IFDEF MSWINDOWS} - Windows; - {$ELSE} - SysUtils; - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} -type - TLibHandle = dynlibs.TLibHandle; - -function LoadLibrary(ModuleName: PChar): TLibHandle; -function FreeLibrary(Module: TLibHandle): LongBool; -function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; -function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; -{$ELSE} -type - {$IFDEF CIL} - TLibHandle = Integer; - PtrInt = Integer; - {$ELSE} - TLibHandle = HModule; - {$IFNDEF WIN64} - PtrInt = Integer; - {$ENDIF} - {$ENDIF} - {$IFDEF VER100} - LongWord = DWord; - {$ENDIF} -{$ENDIF} - -procedure Sleep(milliseconds: Cardinal); - - -implementation - -{==============================================================================} -{$IFDEF FPC} -function LoadLibrary(ModuleName: PChar): TLibHandle; -begin - Result := dynlibs.LoadLibrary(Modulename); -end; - -function FreeLibrary(Module: TLibHandle): LongBool; -begin - Result := dynlibs.UnloadLibrary(Module); -end; - -function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; -begin - Result := dynlibs.GetProcedureAddress(Module, Proc); -end; - -function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; -begin - Result := 0; -end; - -{$ELSE} -{$ENDIF} - -procedure Sleep(milliseconds: Cardinal); -begin -{$IFDEF MSWINDOWS} - {$IFDEF FPC} - sysutils.sleep(milliseconds); - {$ELSE} - windows.sleep(milliseconds); - {$ENDIF} -{$ELSE} - sysutils.sleep(milliseconds); -{$ENDIF} - -end; - -end. diff --git a/synapse/synaicnv.pas b/synapse/synaicnv.pas deleted file mode 100644 index 3dd79c5..0000000 --- a/synapse/synaicnv.pas +++ /dev/null @@ -1,363 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.001.001 | -|==============================================================================| -| Content: ICONV support for Win32, Linux and .NET | -|==============================================================================| -| Copyright (c)2004-2010, 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-2010. | -| 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+} -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{:@abstract(LibIconv support) - -This unit is Pascal interface to LibIconv library for charset translations. -LibIconv is loaded dynamicly on-demand. If this library is not found in system, -requested LibIconv function just return errorcode. -} -unit synaicnv; - -interface - -uses -{$IFDEF CIL} - System.Runtime.InteropServices, - System.Text, -{$ENDIF} - synafpc, -{$IFNDEF MSWINDOWS} - {$IFNDEF FPC} - Libc, - {$ENDIF} - SysUtils; -{$ELSE} - Windows; -{$ENDIF} - - -const - {$IFNDEF MSWINDOWS} - 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: TLibHandle = 0; - -function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; -function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; -function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): 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: pAnsichar; fromcode: pAnsichar): 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: Ansistring): 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(PAnsiChar(tocode), PAnsiChar(fromcode)) - else - Result := iconv_t(-1); -{$ENDIF} -end; - -function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; -begin - Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); -end; - -function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): 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, cardinal(Length(Outbuf)) - ox); - Result := Cardinal(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, PAnsiChar(AnsiString('libiconv_open'))); - _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); - _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); - _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('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/synapse/synaip.pas b/synapse/synaip.pas deleted file mode 100644 index 82a7da4..0000000 --- a/synapse/synaip.pas +++ /dev/null @@ -1,422 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.002.001 | -|==============================================================================| -| Content: IP address support procedures and functions | -|==============================================================================| -| Copyright (c)2006-2010, 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) 2006-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(IP adress support procedures and functions)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synaip; - -interface - -uses - SysUtils, SynaUtil; - -type -{:binary form of IPv6 adress (for string conversion routines)} - TIp6Bytes = array [0..15] of Byte; -{:binary form of IPv6 adress (for string conversion routines)} - TIp6Words = array [0..7] of Word; - -{: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): Ansistring; - -{:Convert IPv6 address from their string form to binary byte array.} -function StrToIp6(value: string): TIp6Bytes; - -{:Convert IPv6 address from binary byte array to string form.} -function Ip6ToStr(value: TIp6Bytes): string; - -{:Convert IPv4 address from their string form to binary.} -function StrToIp(value: string): integer; - -{:Convert IPv4 address from binary to string form.} -function IpToStr(value: integer): string; - -{:Convert IPv4 address to reverse form.} -function ReverseIP(Value: AnsiString): AnsiString; - -{:Convert IPv6 address to reverse form.} -function ReverseIP6(Value: AnsiString): AnsiString; - -{:Expand short form of IPv6 address to long form.} -function ExpandIP6(Value: AnsiString): AnsiString; - - -implementation - -{==============================================================================} - -function IsIP(const Value: string): Boolean; -var - TempIP: string; - function ByteIsOk(const Value: string): Boolean; - var - x, n: integer; - begin - x := StrToIntDef(Value, -1); - Result := (x >= 0) and (x < 256); - // X may be in correct range, but value still may not be correct value! - // i.e. "$80" - if Result then - for n := 1 to length(Value) do - if not (AnsiChar(Value[n]) in ['0'..'9']) then - begin - Result := False; - Break; - end; - end; -begin - TempIP := Value; - Result := False; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if ByteIsOk(TempIP) then - Result := True; -end; - -{==============================================================================} - -function IsIP6(const Value: string): Boolean; -var - TempIP: string; - s,t: string; - x: integer; - partcount: integer; - zerocount: integer; - First: Boolean; -begin - TempIP := Value; - Result := False; - if Value = '::' then - begin - Result := True; - Exit; - end; - partcount := 0; - zerocount := 0; - First := True; - while tempIP <> '' do - begin - s := fetch(TempIP, ':'); - if not(First) and (s = '') then - Inc(zerocount); - First := False; - if zerocount > 1 then - break; - Inc(partCount); - if s = '' then - Continue; - if partCount > 8 then - break; - if tempIP = '' then - begin - t := SeparateRight(s, '%'); - s := SeparateLeft(s, '%'); - x := StrToIntDef('$' + t, -1); - if (x < 0) or (x > $ffff) then - break; - end; - x := StrToIntDef('$' + s, -1); - if (x < 0) or (x > $ffff) then - break; - if tempIP = '' then - if not((PartCount = 1) and (ZeroCount = 0)) then - Result := True; - end; -end; - -{==============================================================================} -function IPToID(Host: string): Ansistring; -var - s: string; - i, x: Integer; -begin - Result := ''; - for x := 0 to 3 do - begin - s := Fetch(Host, '.'); - i := StrToIntDef(s, 0); - Result := Result + AnsiChar(i); - end; -end; - -{==============================================================================} - -function StrToIp(value: string): integer; -var - s: string; - i, x: Integer; -begin - Result := 0; - for x := 0 to 3 do - begin - s := Fetch(value, '.'); - i := StrToIntDef(s, 0); - Result := (256 * Result) + i; - end; -end; - -{==============================================================================} - -function IpToStr(value: integer): string; -var - x1, x2: word; - y1, y2: byte; -begin - Result := ''; - x1 := value shr 16; - x2 := value and $FFFF; - y1 := x1 div $100; - y2 := x1 mod $100; - Result := inttostr(y1) + '.' + inttostr(y2) + '.'; - y1 := x2 div $100; - y2 := x2 mod $100; - Result := Result + inttostr(y1) + '.' + inttostr(y2); -end; - -{==============================================================================} - -function ExpandIP6(Value: AnsiString): AnsiString; -var - n: integer; - s: ansistring; - x: integer; -begin - Result := ''; - if value = '' then - exit; - x := countofchar(value, ':'); - if x > 7 then - exit; - if value[1] = ':' then - value := '0' + value; - if value[length(value)] = ':' then - value := value + '0'; - x := 8 - x; - s := ''; - for n := 1 to x do - s := s + ':0'; - s := s + ':'; - Result := replacestring(value, '::', s); -end; -{==============================================================================} - -function StrToIp6(Value: string): TIp6Bytes; -var - IPv6: TIp6Words; - Index: Integer; - n: integer; - b1, b2: byte; - s: string; - x: integer; -begin - for n := 0 to 15 do - Result[n] := 0; - for n := 0 to 7 do - Ipv6[n] := 0; - Index := 0; - Value := ExpandIP6(value); - if value = '' then - exit; - while Value <> '' do - begin - if Index > 7 then - Exit; - s := fetch(value, ':'); - if s = '@' then - break; - if s = '' then - begin - IPv6[Index] := 0; - end - else - begin - x := StrToIntDef('$' + s, -1); - if (x > 65535) or (x < 0) then - Exit; - IPv6[Index] := x; - end; - Inc(Index); - end; - for n := 0 to 7 do - begin - b1 := ipv6[n] div 256; - b2 := ipv6[n] mod 256; - Result[n * 2] := b1; - Result[(n * 2) + 1] := b2; - end; -end; - -{==============================================================================} -//based on routine by the Free Pascal development team -function Ip6ToStr(value: TIp6Bytes): string; -var - i, x: byte; - zr1,zr2: set of byte; - zc1,zc2: byte; - have_skipped: boolean; - ip6w: TIp6words; -begin - zr1 := []; - zr2 := []; - zc1 := 0; - zc2 := 0; - for i := 0 to 7 do - begin - x := i * 2; - ip6w[i] := value[x] * 256 + value[x + 1]; - if ip6w[i] = 0 then - begin - include(zr2, i); - inc(zc2); - end - else - begin - if zc1 < zc2 then - begin - zc1 := zc2; - zr1 := zr2; - zc2 := 0; - zr2 := []; - end; - end; - end; - if zc1 < zc2 then - begin - zr1 := zr2; - end; - SetLength(Result, 8*5-1); - SetLength(Result, 0); - have_skipped := false; - for i := 0 to 7 do - begin - if not(i in zr1) then - begin - if have_skipped then - begin - if Result = '' then - Result := '::' - else - Result := Result + ':'; - have_skipped := false; - end; - Result := Result + IntToHex(Ip6w[i], 1) + ':'; - end - else - begin - have_skipped := true; - end; - end; - if have_skipped then - if Result = '' then - Result := '::0' - else - Result := Result + ':'; - - if Result = '' then - Result := '::0'; - if not (7 in zr1) then - SetLength(Result, Length(Result)-1); - Result := LowerCase(result); -end; - -{==============================================================================} -function ReverseIP(Value: AnsiString): AnsiString; -var - x: Integer; -begin - Result := ''; - repeat - x := LastDelimiter('.', Value); - Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); - Delete(Value, x, Length(Value) - x + 1); - until x < 1; - if Length(Result) > 0 then - if Result[1] = '.' then - Delete(Result, 1, 1); -end; - -{==============================================================================} -function ReverseIP6(Value: AnsiString): AnsiString; -var - ip6: TIp6bytes; - n: integer; - x, y: integer; -begin - ip6 := StrToIP6(Value); - x := ip6[15] div 16; - y := ip6[15] mod 16; - Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); - for n := 14 downto 0 do - begin - x := ip6[n] div 16; - y := ip6[n] mod 16; - Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); - end; -end; - -{==============================================================================} -end. diff --git a/synapse/synamisc.pas b/synapse/synamisc.pas deleted file mode 100644 index 7b06523..0000000 --- a/synapse/synamisc.pas +++ /dev/null @@ -1,406 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.003.001 | -|==============================================================================| -| Content: misc. procedures and functions | -|==============================================================================| -| Copyright (c)1999-2010, 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) 2002-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Misc. network based utilities)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$H+} - -//Kylix does not known UNIX define -{$IFDEF LINUX} - {$IFNDEF UNIX} - {$DEFINE UNIX} - {$ENDIF} -{$ENDIF} - -{$TYPEDADDRESS OFF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit synamisc; - -interface - -{$IFDEF VER125} - {$DEFINE BCB} -{$ENDIF} -{$IFDEF BCB} - {$ObjExportAll On} - {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} -{$ENDIF} - -uses - synautil, blcksock, SysUtils, Classes -{$IFDEF UNIX} - {$IFNDEF FPC} - , Libc - {$ENDIF} -{$ELSE} - , 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; - -{:Return all known IP addresses on local system. Addresses are divided by comma.} -function GetLocalIPs: string; - -implementation - -{==============================================================================} -procedure WakeOnLan(MAC, IP: string); -var - sock: TUDPBlockSocket; - HexMac: Ansistring; - data: Ansistring; - n: integer; - b: Byte; -begin - if MAC <> '' then - begin - MAC := ReplaceString(MAC, '-', ''); - MAC := ReplaceString(MAC, ':', ''); - if Length(MAC) < 12 then - Exit; - HexMac := ''; - for n := 0 to 5 do - begin - b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); - HexMac := HexMac + char(b); - end; - if IP = '' then - IP := cBroadcast; - sock := TUDPBlockSocket.Create; - try - sock.CreateSocket; - sock.EnableBroadcast(true); - sock.Connect(IP, '9'); - data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; - for n := 1 to 16 do - data := data + HexMac; - sock.SendString(data); - finally - sock.Free; - end; - end; -end; - -{==============================================================================} - -{$IFNDEF UNIX} -function GetDNSbyIpHlp: string; -type - PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; - TIP_ADDRESS_STRING = array[0..15] of Ansichar; - PTIP_ADDR_STRING = ^TIP_ADDR_STRING; - TIP_ADDR_STRING = packed record - Next: PTIP_ADDR_STRING; - IpAddress: TIP_ADDRESS_STRING; - IpMask: TIP_ADDRESS_STRING; - Context: DWORD; - end; - PTFixedInfo = ^TFixedInfo; - TFixedInfo = packed record - HostName: array[1..128 + 4] of Ansichar; - DomainName: array[1..128 + 4] of Ansichar; - CurrentDNSServer: PTIP_ADDR_STRING; - DNSServerList: TIP_ADDR_STRING; - NodeType: UINT; - ScopeID: array[1..256 + 4] of Ansichar; - EnableRouting: UINT; - EnableProxy: UINT; - EnableDNS: UINT; - end; -const - IpHlpDLL = 'IPHLPAPI.DLL'; -var - IpHlpModule: THandle; - FixedInfo: PTFixedInfo; - InfoSize: Longint; - PDnsServer: PTIP_ADDR_STRING; - err: integer; - GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; -begin - InfoSize := 0; - Result := '...'; - IpHlpModule := LoadLibrary(IpHlpDLL); - if IpHlpModule = 0 then - exit; - try - GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); - if @GetNetworkParams = nil then - Exit; - err := GetNetworkParams(Nil, @InfoSize); - if err <> ERROR_BUFFER_OVERFLOW then - Exit; - Result := ''; - GetMem (FixedInfo, InfoSize); - try - err := GetNetworkParams(FixedInfo, @InfoSize); - if err <> ERROR_SUCCESS then - exit; - with FixedInfo^ do - begin - Result := DnsServerList.IpAddress; - PDnsServer := DnsServerList.Next; - while PDnsServer <> Nil do - begin - if Result <> '' then - Result := Result + ','; - Result := Result + PDnsServer^.IPAddress; - PDnsServer := PDnsServer.Next; - end; - end; - finally - FreeMem(FixedInfo); - end; - finally - FreeLibrary(IpHlpModule); - end; -end; - -function ReadReg(SubKey, Vn: PChar): string; -var - OpenKey: HKEY; - DataType, DataSize: integer; - Temp: array [0..2048] of char; -begin - Result := ''; - if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, - KEY_READ, OpenKey) = ERROR_SUCCESS then - begin - DataType := REG_SZ; - DataSize := SizeOf(Temp); - if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then - SetString(Result, Temp, DataSize div SizeOf(Char) - 1); - RegCloseKey(OpenKey); - end; -end ; -{$ENDIF} - -function GetDNS: string; -{$IFDEF UNIX} -var - l: TStringList; - n: integer; -begin - Result := ''; - l := TStringList.Create; - try - l.LoadFromFile('/etc/resolv.conf'); - for n := 0 to l.Count - 1 do - if Pos('NAMESERVER', uppercase(l[n])) = 1 then - begin - if Result <> '' then - Result := Result + ','; - Result := Result + SeparateRight(l[n], ' '); - end; - finally - l.Free; - end; -end; -{$ELSE} -const - NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; - NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; - W9xfix = 'System\CurrentControlSet\Services\MSTCP'; -begin - Result := GetDNSbyIpHlp; - if Result = '...' then - begin - if Win32Platform = VER_PLATFORM_WIN32_NT then - begin - Result := ReadReg(NTdyn, 'NameServer'); - if result = '' then - Result := ReadReg(NTfix, 'NameServer'); - if result = '' then - Result := ReadReg(NTfix, 'DhcpNameServer'); - end - else - Result := ReadReg(W9xfix, 'NameServer'); - Result := ReplaceString(trim(Result), ' ', ','); - end; -end; -{$ENDIF} - -{==============================================================================} - -function GetIEProxy(protocol: string): TProxySetting; -{$IFDEF UNIX} -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; - Proxy: string; - 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 := ''; - WininetModule := LoadLibrary(WininetDLL); - if WininetModule = 0 then - exit; - try - InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('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 - ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); - Proxy := ''; - DefProxy := ''; - for n := 0 to ProxyList.Count -1 do - begin - 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 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; - finally - ProxyList.Free; - FreeMem(ProxyInfo); - end; - finally - FreeLibrary(WininetModule); - end; -end; -{$ENDIF} - -{==============================================================================} - -function GetLocalIPs: string; -var - TcpSock: TTCPBlockSocket; - ipList: TStringList; -begin - Result := ''; - ipList := TStringList.Create; - try - TcpSock := TTCPBlockSocket.create; - try - TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); - Result := ipList.CommaText; - finally - TcpSock.Free; - end; - finally - ipList.Free; - end; -end; - -{==============================================================================} - -end. diff --git a/synapse/synaser.pas b/synapse/synaser.pas deleted file mode 100644 index 3628a36..0000000 --- a/synapse/synaser.pas +++ /dev/null @@ -1,2339 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 007.005.002 | -|==============================================================================| -| Content: Serial port support | -|==============================================================================| -| Copyright (c)2001-2011, 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)2001-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes) | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{: @abstract(Serial port communication library) -This unit contains a class that implements serial port communication - for Windows, Linux, Unix or MacOSx. This class provides numerous methods with - same name and functionality as methods of the Ararat Synapse TCP/IP library. - -The following is a small example how establish a connection by modem (in this -case with my USB modem): -@longcode(# - ser:=TBlockSerial.Create; - try - ser.Connect('COM3'); - ser.config(460800,8,'N',0,false,true); - ser.ATCommand('AT'); - if (ser.LastError <> 0) or (not ser.ATResult) then - Exit; - ser.ATConnect('ATDT+420971200111'); - if (ser.LastError <> 0) or (not ser.ATResult) then - Exit; - // you are now connected to a modem at +420971200111 - // you can transmit or receive data now - finally - ser.free; - end; -#) -} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -//Kylix does not known UNIX define -{$IFDEF LINUX} - {$IFNDEF UNIX} - {$DEFINE UNIX} - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} - {$MODE DELPHI} - {$IFDEF MSWINDOWS} - {$ASMMODE intel} - {$ENDIF} - {define working mode w/o LIBC for fpc} - {$DEFINE NO_LIBC} -{$ENDIF} -{$Q-} -{$H+} -{$M+} - -unit synaser; - -interface - -uses -{$IFNDEF MSWINDOWS} - {$IFNDEF NO_LIBC} - Libc, - KernelIoctl, - {$ELSE} - termio, baseunix, unix, - {$ENDIF} - {$IFNDEF FPC} - Types, - {$ENDIF} -{$ELSE} - Windows, registry, - {$IFDEF FPC} - winver, - {$ENDIF} -{$ENDIF} - synafpc, - Classes, SysUtils, synautil; - -const - CR = #$0d; - LF = #$0a; - CRLF = CR + LF; - cSerialChunk = 8192; - - LockfileDirectory = '/var/lock'; {HGJ} - PortIsClosed = -1; {HGJ} - ErrAlreadyOwned = 9991; {HGJ} - ErrAlreadyInUse = 9992; {HGJ} - ErrWrongParameter = 9993; {HGJ} - ErrPortNotOpen = 9994; {HGJ} - ErrNoDeviceAnswer = 9995; {HGJ} - ErrMaxBuffer = 9996; - ErrTimeout = 9997; - ErrNotRead = 9998; - ErrFrame = 9999; - ErrOverrun = 10000; - ErrRxOver = 10001; - ErrRxParity = 10002; - ErrTxFull = 10003; - - dcb_Binary = $00000001; - dcb_ParityCheck = $00000002; - dcb_OutxCtsFlow = $00000004; - dcb_OutxDsrFlow = $00000008; - dcb_DtrControlMask = $00000030; - dcb_DtrControlDisable = $00000000; - dcb_DtrControlEnable = $00000010; - dcb_DtrControlHandshake = $00000020; - dcb_DsrSensivity = $00000040; - dcb_TXContinueOnXoff = $00000080; - dcb_OutX = $00000100; - dcb_InX = $00000200; - dcb_ErrorChar = $00000400; - dcb_NullStrip = $00000800; - dcb_RtsControlMask = $00003000; - dcb_RtsControlDisable = $00000000; - dcb_RtsControlEnable = $00001000; - dcb_RtsControlHandshake = $00002000; - dcb_RtsControlToggle = $00003000; - dcb_AbortOnError = $00004000; - dcb_Reserveds = $FFFF8000; - - {:stopbit value for 1 stopbit} - SB1 = 0; - {:stopbit value for 1.5 stopbit} - SB1andHalf = 1; - {:stopbit value for 2 stopbits} - SB2 = 2; - -{$IFNDEF MSWINDOWS} -const - INVALID_HANDLE_VALUE = THandle(-1); - CS7fix = $0000020; - -type - TDCB = record - DCBlength: DWORD; - BaudRate: DWORD; - Flags: Longint; - wReserved: Word; - XonLim: Word; - XoffLim: Word; - ByteSize: Byte; - Parity: Byte; - StopBits: Byte; - XonChar: CHAR; - XoffChar: CHAR; - ErrorChar: CHAR; - EofChar: CHAR; - EvtChar: CHAR; - wReserved1: Word; - end; - PDCB = ^TDCB; - -const -{$IFDEF UNIX} - {$IFDEF DARWIN} - MaxRates = 18; //MAC - {$ELSE} - MaxRates = 30; //UNIX - {$ENDIF} -{$ELSE} - MaxRates = 19; //WIN -{$ENDIF} - Rates: array[0..MaxRates, 0..1] of cardinal = - ( - (0, B0), - (50, B50), - (75, B75), - (110, B110), - (134, B134), - (150, B150), - (200, B200), - (300, B300), - (600, B600), - (1200, B1200), - (1800, B1800), - (2400, B2400), - (4800, B4800), - (9600, B9600), - (19200, B19200), - (38400, B38400), - (57600, B57600), - (115200, B115200), - (230400, B230400) -{$IFNDEF DARWIN} - ,(460800, B460800) - {$IFDEF UNIX} - ,(500000, B500000), - (576000, B576000), - (921600, B921600), - (1000000, B1000000), - (1152000, B1152000), - (1500000, B1500000), - (2000000, B2000000), - (2500000, B2500000), - (3000000, B3000000), - (3500000, B3500000), - (4000000, B4000000) - {$ENDIF} -{$ENDIF} - ); -{$ENDIF} - -{$IFDEF DARWIN} -const // From fcntl.h - O_SYNC = $0080; { synchronous writes } -{$ENDIF} - -const - sOK = 0; - sErr = integer(-1); - -type - - {:Possible status event types for @link(THookSerialStatus)} - THookSerialReason = ( - HR_SerialClose, - HR_Connect, - HR_CanRead, - HR_CanWrite, - HR_ReadCount, - HR_WriteCount, - HR_Wait - ); - - {:procedural prototype for status event hooking} - THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason; - const Value: string) of object; - - {:@abstract(Exception type for SynaSer errors)} - ESynaSerError = class(Exception) - public - ErrorCode: integer; - ErrorMessage: string; - end; - - {:@abstract(Main class implementing all communication routines)} - TBlockSerial = class(TObject) - protected - FOnStatus: THookSerialStatus; - Fhandle: THandle; - FTag: integer; - FDevice: string; - FLastError: integer; - FLastErrorDesc: string; - FBuffer: AnsiString; - FRaiseExcept: boolean; - FRecvBuffer: integer; - FSendBuffer: integer; - FModemWord: integer; - FRTSToggle: Boolean; - FDeadlockTimeout: integer; - FInstanceActive: boolean; {HGJ} - FTestDSR: Boolean; - FTestCTS: Boolean; - FLastCR: Boolean; - FLastLF: Boolean; - FMaxLineLength: Integer; - FLinuxLock: Boolean; - FMaxSendBandwidth: Integer; - FNextSend: LongWord; - FMaxRecvBandwidth: Integer; - FNextRecv: LongWord; - FConvertLineEnd: Boolean; - FATResult: Boolean; - FAtTimeout: integer; - FInterPacketTimeout: Boolean; - FComNr: integer; -{$IFDEF MSWINDOWS} - FPortAddr: Word; - function CanEvent(Event: dword; Timeout: integer): boolean; - procedure DecodeCommError(Error: DWord); virtual; - function GetPortAddr: Word; virtual; - function ReadTxEmpty(PortAddr: Word): Boolean; virtual; -{$ENDIF} - procedure SetSizeRecvBuffer(size: integer); virtual; - function GetDSR: Boolean; virtual; - procedure SetDTRF(Value: Boolean); virtual; - function GetCTS: Boolean; virtual; - procedure SetRTSF(Value: Boolean); virtual; - function GetCarrier: Boolean; virtual; - function GetRing: Boolean; virtual; - procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual; - procedure GetComNr(Value: string); virtual; - function PreTestFailing: boolean; virtual;{HGJ} - function TestCtrlLine: Boolean; virtual; -{$IFDEF UNIX} - procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; - procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; - function ReadLockfile: integer; virtual; - function LockfileName: String; virtual; - procedure CreateLockfile(PidNr: integer); virtual; -{$ENDIF} - procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual; - procedure SetBandwidth(Value: Integer); virtual; - public - {: data Control Block with communication parameters. Usable only when you - need to call API directly.} - DCB: Tdcb; -{$IFDEF UNIX} - TermiosStruc: termios; -{$ENDIF} - {:Object constructor.} - constructor Create; - {:Object destructor.} - destructor Destroy; override; - - {:Returns a string containing the version number of the library.} - class function GetVersion: string; virtual; - - {:Destroy handle in use. It close connection to serial port.} - procedure CloseSocket; virtual; - - {:Reconfigure communication parameters on the fly. You must be connected to - port before! - @param(baud Define connection speed. Baud rate can be from 50 to 4000000 - bits per second. (it depends on your hardware!)) - @param(bits Number of bits in communication.) - @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).) - @param(stop Define number of stopbits. Use constants @link(SB1), - @link(SB1andHalf) and @link(SB2).) - @param(softflow Enable XON/XOFF handshake.) - @param(hardflow Enable CTS/RTS handshake.)} - procedure Config(baud, bits: integer; parity: char; stop: integer; - softflow, hardflow: boolean); virtual; - - {:Connects to the port indicated by comport. Comport can be used in Windows - style (COM2), or in Linux style (/dev/ttyS1). When you use windows style - in Linux, then it will be converted to Linux name. And vice versa! However - you can specify any device name! (other device names then standart is not - converted!) - - After successfull connection the DTR signal is set (if you not set hardware - handshake, then the RTS signal is set, too!) - - Connection parameters is predefined by your system configuration. If you - need use another parameters, then you can use Config method after. - Notes: - - - Remember, the commonly used serial Laplink cable does not support - hardware handshake. - - - Before setting any handshake you must be sure that it is supported by - your hardware. - - - Some serial devices are slow. In some cases you must wait up to a few - seconds after connection for the device to respond. - - - when you connect to a modem device, then is best to test it by an empty - AT command. (call ATCommand('AT'))} - procedure Connect(comport: string); virtual; - - {:Set communication parameters from the DCB structure (the DCB structure is - simulated under Linux).} - procedure SetCommState; virtual; - - {:Read communication parameters into the DCB structure (DCB structure is - simulated under Linux).} - procedure GetCommState; virtual; - - {:Sends Length bytes of data from Buffer through the connected port.} - function SendBuffer(buffer: pointer; length: integer): integer; virtual; - - {:One data BYTE is sent.} - procedure SendByte(data: byte); virtual; - - {:Send the string in the data parameter. No terminator is appended by this - method. If you need to send a string with CR/LF terminator, you must append - the CR/LF characters to the data string! - - Since no terminator is appended, you can use this function for sending - binary data too.} - procedure SendString(data: AnsiString); virtual; - - {:send four bytes as integer.} - procedure SendInteger(Data: integer); virtual; - - {:send data as one block. Each block begins with integer value with Length - of block.} - procedure SendBlock(const Data: AnsiString); virtual; - - {:send content of stream from current position} - procedure SendStreamRaw(const Stream: TStream); virtual; - - {:send content of stream as block. see @link(SendBlock)} - procedure SendStream(const Stream: TStream); virtual; - - {:send content of stream as block, but this is compatioble with Indy library. - (it have swapped lenght of block). See @link(SendStream)} - procedure SendStreamIndy(const Stream: TStream); virtual; - - {:Waits until the allocated buffer is filled by received data. Returns number - of data bytes received, which equals to the Length value under normal - operation. If it is not equal, the communication channel is possibly broken. - - This method not using any internal buffering, like all others receiving - methods. You cannot freely combine this method with all others receiving - methods!} - function RecvBuffer(buffer: pointer; length: integer): integer; virtual; - - {:Method waits until data is received. If no data is received within - the Timeout (in milliseconds) period, @link(LastError) is set to - @link(ErrTimeout). This method is used to read any amount of data - (e. g. 1MB), and may be freely combined with all receviving methods what - have Timeout parameter, like the @link(RecvString), @link(RecvByte) or - @link(RecvTerminated) methods.} - function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual; - - {:It is like recvBufferEx, but data is readed to dynamicly allocated binary - string.} - function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual; - - {:Read all available data and return it in the function result string. This - function may be combined with @link(RecvString), @link(RecvByte) or related - methods.} - function RecvPacket(Timeout: Integer): AnsiString; virtual; - - {:Waits until one data byte is received which is returned as the function - result. If no data is received within the Timeout (in milliseconds) period, - @link(LastError) is set to @link(ErrTimeout).} - function RecvByte(timeout: integer): byte; virtual; - - {:This method waits until a terminated data string is received. This string - is terminated by the Terminator string. The resulting string is returned - without this termination string! If no data is received within the Timeout - (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).} - function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual; - - {:This method waits until a terminated data string is received. The string - is terminated by a CR/LF sequence. The resulting string is returned without - the terminator (CR/LF)! If no data is received within the Timeout (in - milliseconds) period, @link(LastError) is set to @link(ErrTimeout). - - If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly - CR/LF. See the description of @link(ConvertLineEnd). - - This method serves for line protocol implementation and uses its own - buffers to maximize performance. Therefore do NOT use this method with the - @link(RecvBuffer) method to receive data as it may cause data loss.} - function Recvstring(timeout: integer): AnsiString; virtual; - - {:Waits until four data bytes are received which is returned as the function - integer result. If no data is received within the Timeout (in milliseconds) period, - @link(LastError) is set to @link(ErrTimeout).} - function RecvInteger(Timeout: Integer): Integer; virtual; - - {:Waits until one data block is received. See @link(sendblock). If no data - is received within the Timeout (in milliseconds) period, @link(LastError) - is set to @link(ErrTimeout).} - function RecvBlock(Timeout: Integer): AnsiString; virtual; - - {:Receive all data to stream, until some error occured. (for example timeout)} - procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual; - - {:receive requested count of bytes to stream} - procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual; - - {:receive block of data to stream. (Data can be sended by @link(sendstream)} - procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; - - {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)} - procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual; - - {:Returns the number of received bytes waiting for reading. 0 is returned - when there is no data waiting.} - function WaitingData: integer; virtual; - - {:Same as @link(WaitingData), but in respect to data in the internal - @link(LineBuffer).} - function WaitingDataEx: integer; virtual; - - {:Returns the number of bytes waiting to be sent in the output buffer. - 0 is returned when the output buffer is empty.} - function SendingData: integer; virtual; - - {:Enable or disable RTS driven communication (half-duplex). It can be used - to communicate with RS485 converters, or other special equipment. If you - enable this feature, the system automatically controls the RTS signal. - - Notes: - - - On Windows NT (or higher) ir RTS signal driven by system driver. - - - On Win9x family is used special code for waiting until last byte is - sended from your UART. - - - On Linux you must have kernel 2.1 or higher!} - procedure EnableRTSToggle(value: boolean); virtual; - - {:Waits until all data to is sent and buffers are emptied. - Warning: On Windows systems is this method returns when all buffers are - flushed to the serial port controller, before the last byte is sent!} - procedure Flush; virtual; - - {:Unconditionally empty all buffers. It is good when you need to interrupt - communication and for cleanups.} - procedure Purge; virtual; - - {:Returns @True, if you can from read any data from the port. Status is - tested for a period of time given by the Timeout parameter (in milliseconds). - If the value of the Timeout parameter is 0, the status is tested only once - and the function returns immediately. If the value of the Timeout parameter - is set to -1, the function returns only after it detects data on the port - (this may cause the process to hang).} - function CanRead(Timeout: integer): boolean; virtual; - - {:Returns @True, if you can write any data to the port (this function is not - sending the contents of the buffer). Status is tested for a period of time - given by the Timeout parameter (in milliseconds). If the value of - the Timeout parameter is 0, the status is tested only once and the function - returns immediately. If the value of the Timeout parameter is set to -1, - the function returns only after it detects that it can write data to - the port (this may cause the process to hang).} - function CanWrite(Timeout: integer): boolean; virtual; - - {:Same as @link(CanRead), but the test is against data in the internal - @link(LineBuffer) too.} - function CanReadEx(Timeout: integer): boolean; virtual; - - {:Returns the status word of the modem. Decoding the status word could yield - the status of carrier detect signaland other signals. This method is used - internally by the modem status reading properties. You usually do not need - to call this method directly.} - function ModemStatus: integer; virtual; - - {:Send a break signal to the communication device for Duration milliseconds.} - procedure SetBreak(Duration: integer); virtual; - - {:This function is designed to send AT commands to the modem. The AT command - is sent in the Value parameter and the response is returned in the function - return value (may contain multiple lines!). - If the AT command is processed successfully (modem returns OK), then the - @link(ATResult) property is set to True. - - This function is designed only for AT commands that return OK or ERROR - response! To call connection commands the @link(ATConnect) method. - Remember, when you connect to a modem device, it is in AT command mode. - Now you can send AT commands to the modem. If you need to transfer data to - the modem on the other side of the line, you must first switch to data mode - using the @link(ATConnect) method.} - function ATCommand(value: AnsiString): AnsiString; virtual; - - {:This function is used to send connect type AT commands to the modem. It is - for commands to switch to connected state. (ATD, ATA, ATO,...) - It sends the AT command in the Value parameter and returns the modem's - response (may be multiple lines - usually with connection parameters info). - If the AT command is processed successfully (the modem returns CONNECT), - then the ATResult property is set to @True. - - This function is designed only for AT commands which respond by CONNECT, - BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the - @link(ATCommand) method. - - The connect timeout is 90*@link(ATTimeout). If this command is successful - (@link(ATresult) is @true), then the modem is in data state. When you now - send or receive some data, it is not to or from your modem, but from the - modem on other side of the line. Now you can transfer your data. - If the connection attempt failed (@link(ATResult) is @False), then the - modem is still in AT command mode.} - function ATConnect(value: AnsiString): AnsiString; virtual; - - {:If you "manually" call API functions, forward their return code in - the SerialResult parameter to this function, which evaluates it and sets - @link(LastError) and @link(LastErrorDesc).} - function SerialCheck(SerialResult: integer): integer; virtual; - - {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure - raises an exception. This method is used internally. You may need it only - in special cases.} - procedure ExceptCheck; virtual; - - {:Set Synaser to error state with ErrNumber code. Usually used by internal - routines.} - procedure SetSynaError(ErrNumber: integer); virtual; - - {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} - procedure RaiseSynaError(ErrNumber: integer); virtual; -{$IFDEF UNIX} - function cpomComportAccessible: boolean; virtual;{HGJ} - procedure cpomReleaseComport; virtual; {HGJ} -{$ENDIF} - {:True device name of currently used port} - property Device: string read FDevice; - - {:Error code of last operation. Value is defined by the host operating - system, but value 0 is always OK.} - property LastError: integer read FLastError; - - {:Human readable description of LastError code.} - property LastErrorDesc: string read FLastErrorDesc; - - {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful} - property ATResult: Boolean read FATResult; - - {:Read the value of the RTS signal.} - property RTS: Boolean write SetRTSF; - - {:Indicates the presence of the CTS signal} - property CTS: boolean read GetCTS; - - {:Use this property to set the value of the DTR signal.} - property DTR: Boolean write SetDTRF; - - {:Exposes the status of the DSR signal.} - property DSR: boolean read GetDSR; - - {:Indicates the presence of the Carrier signal} - property Carrier: boolean read GetCarrier; - - {:Reflects the status of the Ring signal.} - property Ring: boolean read GetRing; - - {:indicates if this instance of SynaSer is active. (Connected to some port)} - property InstanceActive: boolean read FInstanceActive; {HGJ} - - {:Defines maximum bandwidth for all sending operations in bytes per second. - If this value is set to 0 (default), bandwidth limitation is not used.} - property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth; - - {:Defines maximum bandwidth for all receiving operations in bytes per second. - If this value is set to 0 (default), bandwidth limitation is not used.} - property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth; - - {:Defines maximum bandwidth for all sending and receiving operations - in bytes per second. If this value is set to 0 (default), bandwidth - limitation is not used.} - property MaxBandwidth: Integer Write SetBandwidth; - - {:Size of the Windows internal receive buffer. Default value is usually - 4096 bytes. Note: Valid only in Windows versions!} - property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer; - published - {:Returns the descriptive text associated with ErrorCode. You need this - method only in special cases. Description of LastError is now accessible - through the LastErrorDesc property.} - class function GetErrorDesc(ErrorCode: integer): string; - - {:Freely usable property} - property Tag: integer read FTag write FTag; - - {:Contains the handle of the open communication port. - You may need this value to directly call communication functions outside - SynaSer.} - property Handle: THandle read Fhandle write FHandle; - - {:Internally used read buffer.} - property LineBuffer: AnsiString read FBuffer write FBuffer; - - {:If @true, communication errors raise exceptions. If @false (default), only - the @link(LastError) value is set.} - property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept; - - {:This event is triggered when the communication status changes. It can be - used to monitor communication status.} - property OnStatus: THookSerialStatus read FOnStatus write FOnStatus; - - {:If you set this property to @true, then the value of the DSR signal - is tested before every data transfer. It can be used to detect the presence - of a communications device.} - property TestDSR: boolean read FTestDSR write FTestDSR; - - {:If you set this property to @true, then the value of the CTS signal - is tested before every data transfer. It can be used to detect the presence - of a communications device. Warning: This property cannot be used if you - need hardware handshake!} - property TestCTS: boolean read FTestCTS write FTestCTS; - - {:Use this property you to limit the maximum size of LineBuffer - (as a protection against unlimited memory allocation for LineBuffer). - Default value is 0 - no limit.} - property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength; - - {:This timeout value is used as deadlock protection when trying to send data - to (or receive data from) a device that stopped communicating during data - transmission (e.g. by physically disconnecting the device). - The timeout value is in milliseconds. The default value is 30,000 (30 seconds).} - property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout; - - {:If set to @true (default value), port locking is enabled (under Linux only). - WARNING: To use this feature, the application must run by a user with full - permission to the /var/lock directory!} - property LinuxLock: Boolean read FLinuxLock write FLinuxLock; - - {:Indicates if non-standard line terminators should be converted to a CR/LF pair - (standard DOS line terminator). If @TRUE, line terminators CR, single LF - or LF/CR are converted to CR/LF. Defaults to @FALSE. - This property has effect only on the behavior of the RecvString method.} - property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd; - - {:Timeout for AT modem based operations} - property AtTimeout: integer read FAtTimeout Write FAtTimeout; - - {:If @true (default), then all timeouts is timeout between two characters. - If @False, then timeout is overall for whoole reading operation.} - property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; - end; - -{:Returns list of existing computer serial ports. Working properly only in Windows!} -function GetSerialPortNames: string; - -implementation - -constructor TBlockSerial.Create; -begin - inherited create; - FRaiseExcept := false; - FHandle := INVALID_HANDLE_VALUE; - FDevice := ''; - FComNr:= PortIsClosed; {HGJ} - FInstanceActive:= false; {HGJ} - Fbuffer := ''; - FRTSToggle := False; - FMaxLineLength := 0; - FTestDSR := False; - FTestCTS := False; - FDeadlockTimeout := 30000; - FLinuxLock := True; - FMaxSendBandwidth := 0; - FNextSend := 0; - FMaxRecvBandwidth := 0; - FNextRecv := 0; - FConvertLineEnd := False; - SetSynaError(sOK); - FRecvBuffer := 4096; - FLastCR := False; - FLastLF := False; - FAtTimeout := 1000; - FInterPacketTimeout := True; -end; - -destructor TBlockSerial.Destroy; -begin - CloseSocket; - inherited destroy; -end; - -class function TBlockSerial.GetVersion: string; -begin - Result := 'SynaSer 7.5.0'; -end; - -procedure TBlockSerial.CloseSocket; -begin - if Fhandle <> INVALID_HANDLE_VALUE then - begin - Purge; - RTS := False; - DTR := False; - FileClose(FHandle); - end; - if InstanceActive then - begin - {$IFDEF UNIX} - if FLinuxLock then - cpomReleaseComport; - {$ENDIF} - FInstanceActive:= false - end; - Fhandle := INVALID_HANDLE_VALUE; - FComNr:= PortIsClosed; - SetSynaError(sOK); - DoStatus(HR_SerialClose, FDevice); -end; - -{$IFDEF MSWINDOWS} -function TBlockSerial.GetPortAddr: Word; -begin - Result := 0; - if Win32Platform <> VER_PLATFORM_WIN32_NT then - begin - EscapeCommFunction(FHandle, 10); - asm - MOV @Result, DX; - end; - end; -end; - -function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean; -begin - Result := True; - if Win32Platform <> VER_PLATFORM_WIN32_NT then - begin - asm - MOV DX, PortAddr; - ADD DX, 5; - IN AL, DX; - AND AL, $40; - JZ @K; - MOV AL,1; - @K: MOV @Result, AL; - end; - end; -end; -{$ENDIF} - -procedure TBlockSerial.GetComNr(Value: string); -begin - FComNr := PortIsClosed; - if pos('COM', uppercase(Value)) = 1 then - FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1; - if pos('/DEV/TTYS', uppercase(Value)) = 1 then - FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1); -end; - -procedure TBlockSerial.SetBandwidth(Value: Integer); -begin - MaxSendBandwidth := Value; - MaxRecvBandwidth := Value; -end; - -procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); -var - x: LongWord; - y: LongWord; -begin - if MaxB > 0 then - begin - y := GetTick; - if Next > y then - begin - x := Next - y; - if x > 0 then - begin - DoStatus(HR_Wait, IntToStr(x)); - sleep(x); - end; - end; - Next := GetTick + Trunc((Length / MaxB) * 1000); - end; -end; - -procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer; - softflow, hardflow: boolean); -begin - FillChar(dcb, SizeOf(dcb), 0); - GetCommState; - dcb.DCBlength := SizeOf(dcb); - dcb.BaudRate := baud; - dcb.ByteSize := bits; - case parity of - 'N', 'n': dcb.parity := 0; - 'O', 'o': dcb.parity := 1; - 'E', 'e': dcb.parity := 2; - 'M', 'm': dcb.parity := 3; - 'S', 's': dcb.parity := 4; - end; - dcb.StopBits := stop; - dcb.XonChar := #17; - dcb.XoffChar := #19; - dcb.XonLim := FRecvBuffer div 4; - dcb.XoffLim := FRecvBuffer div 4; - dcb.Flags := dcb_Binary; - if softflow then - dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; - if hardflow then - dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake - else - dcb.Flags := dcb.Flags or dcb_RtsControlEnable; - dcb.Flags := dcb.Flags or dcb_DtrControlEnable; - if dcb.Parity > 0 then - dcb.Flags := dcb.Flags or dcb_ParityCheck; - SetCommState; -end; - -procedure TBlockSerial.Connect(comport: string); -{$IFDEF MSWINDOWS} -var - CommTimeouts: TCommTimeouts; -{$ENDIF} -begin - // Is this TBlockSerial Instance already busy? - if InstanceActive then {HGJ} - begin {HGJ} - RaiseSynaError(ErrAlreadyInUse); - Exit; {HGJ} - end; {HGJ} - FBuffer := ''; - FDevice := comport; - GetComNr(comport); -{$IFDEF MSWINDOWS} - SetLastError (sOK); -{$ELSE} - {$IFNDEF FPC} - SetLastError (sOK); - {$ELSE} - fpSetErrno(sOK); - {$ENDIF} -{$ENDIF} -{$IFNDEF MSWINDOWS} - if FComNr <> PortIsClosed then - FDevice := '/dev/ttyS' + IntToStr(FComNr); - // Comport already owned by another process? {HGJ} - if FLinuxLock then - if not cpomComportAccessible then - begin - RaiseSynaError(ErrAlreadyOwned); - Exit; - end; -{$IFNDEF FPC} - FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); -{$ELSE} - FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC)); -{$ENDIF} - if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! - SerialCheck(-1) - else - SerialCheck(0); - {$IFDEF UNIX} - if FLastError <> sOK then - if FLinuxLock then - cpomReleaseComport; - {$ENDIF} - ExceptCheck; - if FLastError <> sOK then - Exit; -{$ELSE} - if FComNr <> PortIsClosed then - FDevice := '\\.\COM' + IntToStr(FComNr + 1); - FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE, - 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0)); - if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! - SerialCheck(-1) - else - SerialCheck(0); - ExceptCheck; - if FLastError <> sOK then - Exit; - SetCommMask(FHandle, 0); - SetupComm(Fhandle, FRecvBuffer, 0); - CommTimeOuts.ReadIntervalTimeout := MAXWORD; - CommTimeOuts.ReadTotalTimeoutMultiplier := 0; - CommTimeOuts.ReadTotalTimeoutConstant := 0; - CommTimeOuts.WriteTotalTimeoutMultiplier := 0; - CommTimeOuts.WriteTotalTimeoutConstant := 0; - SetCommTimeOuts(FHandle, CommTimeOuts); - FPortAddr := GetPortAddr; -{$ENDIF} - SetSynaError(sOK); - if not TestCtrlLine then {HGJ} - begin - SetSynaError(ErrNoDeviceAnswer); - FileClose(FHandle); {HGJ} - {$IFDEF UNIX} - if FLinuxLock then - cpomReleaseComport; {HGJ} - {$ENDIF} {HGJ} - Fhandle := INVALID_HANDLE_VALUE; {HGJ} - FComNr:= PortIsClosed; {HGJ} - end - else - begin - FInstanceActive:= True; - RTS := True; - DTR := True; - Purge; - end; - ExceptCheck; - DoStatus(HR_Connect, FDevice); -end; - -function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer; -{$IFDEF MSWINDOWS} -var - Overlapped: TOverlapped; - x, y, Err: DWord; -{$ENDIF} -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - if FRTSToggle then - begin - Flush; - RTS := True; - end; -{$IFNDEF MSWINDOWS} - result := FileWrite(Fhandle, Buffer^, Length); - serialcheck(result); -{$ELSE} - FillChar(Overlapped, Sizeof(Overlapped), 0); - SetSynaError(sOK); - y := 0; - if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - x := WaitForSingleObject(FHandle, FDeadlockTimeout); - if x = WAIT_TIMEOUT then - begin - PurgeComm(FHandle, PURGE_TXABORT); - SetSynaError(ErrTimeout); - end; - GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); - end - else - SetSynaError(y); - ClearCommError(FHandle, err, nil); - if err <> 0 then - DecodeCommError(err); -{$ENDIF} - if FRTSToggle then - begin - Flush; - CanWrite(255); - RTS := False; - end; - ExceptCheck; - DoStatus(HR_WriteCount, IntToStr(Result)); -end; - -procedure TBlockSerial.SendByte(data: byte); -begin - SendBuffer(@Data, 1); -end; - -procedure TBlockSerial.SendString(data: AnsiString); -begin - SendBuffer(Pointer(Data), Length(Data)); -end; - -procedure TBlockSerial.SendInteger(Data: integer); -begin - SendBuffer(@data, SizeOf(Data)); -end; - -procedure TBlockSerial.SendBlock(const Data: AnsiString); -begin - SendInteger(Length(data)); - SendString(Data); -end; - -procedure TBlockSerial.SendStreamRaw(const Stream: TStream); -var - si: integer; - x, y, yr: integer; - s: AnsiString; -begin - si := Stream.Size - Stream.Position; - x := 0; - while x < si do - begin - y := si - x; - if y > cSerialChunk then - y := cSerialChunk; - Setlength(s, y); - yr := Stream.read(PAnsiChar(s)^, y); - if yr > 0 then - begin - SetLength(s, yr); - SendString(s); - Inc(x, yr); - end - else - break; - end; -end; - -procedure TBlockSerial.SendStreamIndy(const Stream: TStream); -var - si: integer; -begin - si := Stream.Size - Stream.Position; - si := Swapbytes(si); - SendInteger(si); - SendStreamRaw(Stream); -end; - -procedure TBlockSerial.SendStream(const Stream: TStream); -var - si: integer; -begin - si := Stream.Size - Stream.Position; - SendInteger(si); - SendStreamRaw(Stream); -end; - -function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer; -{$IFNDEF MSWINDOWS} -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - result := FileRead(FHandle, Buffer^, length); - serialcheck(result); -{$ELSE} -var - Overlapped: TOverlapped; - x, y, Err: DWord; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - FillChar(Overlapped, Sizeof(Overlapped), 0); - SetSynaError(sOK); - y := 0; - if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - x := WaitForSingleObject(FHandle, FDeadlockTimeout); - if x = WAIT_TIMEOUT then - begin - PurgeComm(FHandle, PURGE_RXABORT); - SetSynaError(ErrTimeout); - end; - GetOverlappedResult(FHandle, Overlapped, Dword(Result), False); - end - else - SetSynaError(y); - ClearCommError(FHandle, err, nil); - if err <> 0 then - DecodeCommError(err); -{$ENDIF} - ExceptCheck; - DoStatus(HR_ReadCount, IntToStr(Result)); -end; - -function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; -var - s: AnsiString; - rl, l: integer; - ti: LongWord; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - rl := 0; - repeat - ti := GetTick; - s := RecvPacket(Timeout); - l := System.Length(s); - if (rl + l) > Length then - l := Length - rl; - Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); - rl := rl + l; - if FLastError <> sOK then - Break; - if rl >= Length then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - SetSynaError(ErrTimeout); - Break; - end; - end; - until False; - delete(s, 1, l); - FBuffer := s; - Result := rl; -end; - -function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if Length > 0 then - begin - Setlength(Result, Length); - x := RecvBufferEx(PAnsiChar(Result), Length , Timeout); - if FLastError = sOK then - SetLength(Result, x) - else - Result := ''; - end; -end; - -function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if FBuffer <> '' then - begin - Result := FBuffer; - FBuffer := ''; - end - else - begin - //not drain CPU on large downloads... - Sleep(0); - x := WaitingData; - if x > 0 then - begin - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - end - else - begin - if CanRead(Timeout) then - begin - x := WaitingData; - if x = 0 then - SetSynaError(ErrTimeout); - if x > 0 then - begin - SetLength(Result, x); - x := RecvBuffer(Pointer(Result), x); - if x >= 0 then - SetLength(Result, x); - end; - end - else - SetSynaError(ErrTimeout); - end; - end; - ExceptCheck; -end; - - -function TBlockSerial.RecvByte(timeout: integer): byte; -begin - Result := 0; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - if FBuffer = '' then - FBuffer := RecvPacket(Timeout); - if (FLastError = sOK) and (FBuffer <> '') then - begin - Result := Ord(FBuffer[1]); - System.Delete(FBuffer, 1, 1); - end; - ExceptCheck; -end; - -function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; -var - x: Integer; - s: AnsiString; - l: Integer; - CorCRLF: Boolean; - t: ansistring; - tl: integer; - ti: LongWord; -begin - Result := ''; - if PreTestFailing then {HGJ} - Exit; {HGJ} - SetSynaError(sOK); - l := system.Length(Terminator); - if l = 0 then - Exit; - tl := l; - CorCRLF := FConvertLineEnd and (Terminator = CRLF); - s := ''; - x := 0; - repeat - ti := GetTick; - //get rest of FBuffer or incomming new data... - s := s + RecvPacket(Timeout); - if FLastError <> sOK then - Break; - x := 0; - if Length(s) > 0 then - if CorCRLF then - begin - if FLastCR and (s[1] = LF) then - Delete(s, 1, 1); - if FLastLF and (s[1] = CR) then - Delete(s, 1, 1); - FLastCR := False; - FLastLF := False; - t := ''; - x := PosCRLF(s, t); - tl := system.Length(t); - if t = CR then - FLastCR := True; - if t = LF then - FLastLF := True; - end - else - begin - x := pos(Terminator, s); - tl := l; - end; - if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then - begin - SetSynaError(ErrMaxBuffer); - Break; - end; - if x > 0 then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - SetSynaError(ErrTimeout); - Break; - end; - end; - until False; - if x > 0 then - begin - Result := Copy(s, 1, x - 1); - System.Delete(s, 1, x + tl - 1); - end; - FBuffer := s; - ExceptCheck; -end; - - -function TBlockSerial.RecvString(Timeout: Integer): AnsiString; -var - s: AnsiString; -begin - Result := ''; - s := RecvTerminated(Timeout, #13 + #10); - if FLastError = sOK then - Result := s; -end; - -function TBlockSerial.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 TBlockSerial.RecvBlock(Timeout: Integer): AnsiString; -var - x: integer; -begin - Result := ''; - x := RecvInteger(Timeout); - if FLastError = 0 then - Result := RecvBufferStr(x, Timeout); -end; - -procedure TBlockSerial.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 TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); -var - s: AnsiString; - n: integer; -begin - for n := 1 to (Size div cSerialChunk) do - begin - s := RecvBufferStr(cSerialChunk, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(PAnsichar(s)^, cSerialChunk); - end; - n := Size mod cSerialChunk; - if n > 0 then - begin - s := RecvBufferStr(n, Timeout); - if FLastError <> 0 then - Exit; - Stream.Write(PAnsichar(s)^, n); - end; -end; - -procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - x := SwapBytes(x); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer); -var - x: integer; -begin - x := RecvInteger(Timeout); - if FLastError = 0 then - RecvStreamSize(Stream, Timeout, x); -end; - -{$IFNDEF MSWINDOWS} -function TBlockSerial.WaitingData: integer; -begin -{$IFNDEF FPC} - serialcheck(ioctl(FHandle, FIONREAD, @result)); -{$ELSE} - serialcheck(fpIoctl(FHandle, FIONREAD, @result)); -{$ENDIF} - if FLastError <> 0 then - Result := 0; - ExceptCheck; -end; -{$ELSE} -function TBlockSerial.WaitingData: integer; -var - stat: TComStat; - err: DWORD; -begin - if ClearCommError(FHandle, err, @stat) then - begin - SetSynaError(sOK); - Result := stat.cbInQue; - end - else - begin - SerialCheck(sErr); - Result := 0; - end; - ExceptCheck; -end; -{$ENDIF} - -function TBlockSerial.WaitingDataEx: integer; -begin - if FBuffer <> '' then - Result := Length(FBuffer) - else - Result := Waitingdata; -end; - -{$IFNDEF MSWINDOWS} -function TBlockSerial.SendingData: integer; -begin - SetSynaError(sOK); - Result := 0; -end; -{$ELSE} -function TBlockSerial.SendingData: integer; -var - stat: TComStat; - err: DWORD; -begin - SetSynaError(sOK); - if not ClearCommError(FHandle, err, @stat) then - serialcheck(sErr); - ExceptCheck; - result := stat.cbOutQue; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios); -var - n: integer; - x: cardinal; -begin - //others - cfmakeraw(term); - term.c_cflag := term.c_cflag or CREAD; - term.c_cflag := term.c_cflag or CLOCAL; - term.c_cflag := term.c_cflag or HUPCL; - //hardware handshake - if (dcb.flags and dcb_RtsControlHandshake) > 0 then - term.c_cflag := term.c_cflag or CRTSCTS - else - term.c_cflag := term.c_cflag and (not CRTSCTS); - //software handshake - if (dcb.flags and dcb_OutX) > 0 then - term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY - else - term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY)); - //size of byte - term.c_cflag := term.c_cflag and (not CSIZE); - case dcb.bytesize of - 5: - term.c_cflag := term.c_cflag or CS5; - 6: - term.c_cflag := term.c_cflag or CS6; - 7: -{$IFDEF FPC} - term.c_cflag := term.c_cflag or CS7; -{$ELSE} - term.c_cflag := term.c_cflag or CS7fix; -{$ENDIF} - 8: - term.c_cflag := term.c_cflag or CS8; - end; - //parity - if (dcb.flags and dcb_ParityCheck) > 0 then - term.c_cflag := term.c_cflag or PARENB - else - term.c_cflag := term.c_cflag and (not PARENB); - case dcb.parity of - 1: //'O' - term.c_cflag := term.c_cflag or PARODD; - 2: //'E' - term.c_cflag := term.c_cflag and (not PARODD); - end; - //stop bits - if dcb.stopbits > 0 then - term.c_cflag := term.c_cflag or CSTOPB - else - term.c_cflag := term.c_cflag and (not CSTOPB); - //set baudrate; - x := 0; - for n := 0 to Maxrates do - if rates[n, 0] = dcb.BaudRate then - begin - x := rates[n, 1]; - break; - end; - cfsetospeed(term, x); - cfsetispeed(term, x); -end; - -procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB); -var - n: integer; - x: cardinal; -begin - //set baudrate; - dcb.baudrate := 0; - {$IFDEF FPC} - //why FPC not have cfgetospeed??? - x := term.c_oflag and $0F; - {$ELSE} - x := cfgetospeed(term); - {$ENDIF} - for n := 0 to Maxrates do - if rates[n, 1] = x then - begin - dcb.baudrate := rates[n, 0]; - break; - end; - //hardware handshake - if (term.c_cflag and CRTSCTS) > 0 then - dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow - else - dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow)); - //software handshake - if (term.c_cflag and IXOFF) > 0 then - dcb.flags := dcb.flags or dcb_OutX or dcb_InX - else - dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX)); - //size of byte - case term.c_cflag and CSIZE of - CS5: - dcb.bytesize := 5; - CS6: - dcb.bytesize := 6; - CS7fix: - dcb.bytesize := 7; - CS8: - dcb.bytesize := 8; - end; - //parity - if (term.c_cflag and PARENB) > 0 then - dcb.flags := dcb.flags or dcb_ParityCheck - else - dcb.flags := dcb.flags and (not dcb_ParityCheck); - dcb.parity := 0; - if (term.c_cflag and PARODD) > 0 then - dcb.parity := 1 - else - dcb.parity := 2; - //stop bits - if (term.c_cflag and CSTOPB) > 0 then - dcb.stopbits := 2 - else - dcb.stopbits := 0; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.SetCommState; -begin - DcbToTermios(dcb, termiosstruc); - SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); - ExceptCheck; -end; -{$ELSE} -procedure TBlockSerial.SetCommState; -begin - SetSynaError(sOK); - if not windows.SetCommState(Fhandle, dcb) then - SerialCheck(sErr); - ExceptCheck; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.GetCommState; -begin - SerialCheck(tcgetattr(FHandle, termiosstruc)); - ExceptCheck; - TermiostoDCB(termiosstruc, dcb); -end; -{$ELSE} -procedure TBlockSerial.GetCommState; -begin - SetSynaError(sOK); - if not windows.GetCommState(Fhandle, dcb) then - SerialCheck(sErr); - ExceptCheck; -end; -{$ENDIF} - -procedure TBlockSerial.SetSizeRecvBuffer(size: integer); -begin -{$IFDEF MSWINDOWS} - SetupComm(Fhandle, size, 0); - GetCommState; - dcb.XonLim := size div 4; - dcb.XoffLim := size div 4; - SetCommState; -{$ENDIF} - FRecvBuffer := size; -end; - -function TBlockSerial.GetDSR: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_DSR) > 0; -{$ELSE} - Result := (FModemWord and MS_DSR_ON) > 0; -{$ENDIF} -end; - -procedure TBlockSerial.SetDTRF(Value: Boolean); -begin -{$IFNDEF MSWINDOWS} - ModemStatus; - if Value then - FModemWord := FModemWord or TIOCM_DTR - else - FModemWord := FModemWord and not TIOCM_DTR; - {$IFNDEF FPC} - ioctl(FHandle, TIOCMSET, @FModemWord); - {$ELSE} - fpioctl(FHandle, TIOCMSET, @FModemWord); - {$ENDIF} -{$ELSE} - if Value then - EscapeCommFunction(FHandle, SETDTR) - else - EscapeCommFunction(FHandle, CLRDTR); -{$ENDIF} -end; - -function TBlockSerial.GetCTS: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_CTS) > 0; -{$ELSE} - Result := (FModemWord and MS_CTS_ON) > 0; -{$ENDIF} -end; - -procedure TBlockSerial.SetRTSF(Value: Boolean); -begin -{$IFNDEF MSWINDOWS} - ModemStatus; - if Value then - FModemWord := FModemWord or TIOCM_RTS - else - FModemWord := FModemWord and not TIOCM_RTS; - {$IFNDEF FPC} - ioctl(FHandle, TIOCMSET, @FModemWord); - {$ELSE} - fpioctl(FHandle, TIOCMSET, @FModemWord); - {$ENDIF} -{$ELSE} - if Value then - EscapeCommFunction(FHandle, SETRTS) - else - EscapeCommFunction(FHandle, CLRRTS); -{$ENDIF} -end; - -function TBlockSerial.GetCarrier: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_CAR) > 0; -{$ELSE} - Result := (FModemWord and MS_RLSD_ON) > 0; -{$ENDIF} -end; - -function TBlockSerial.GetRing: Boolean; -begin - ModemStatus; -{$IFNDEF MSWINDOWS} - Result := (FModemWord and TIOCM_RNG) > 0; -{$ELSE} - Result := (FModemWord and MS_RING_ON) > 0; -{$ENDIF} -end; - -{$IFDEF MSWINDOWS} -function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean; -var - ex: DWord; - y: Integer; - Overlapped: TOverlapped; -begin - FillChar(Overlapped, Sizeof(Overlapped), 0); - Overlapped.hEvent := CreateEvent(nil, True, False, nil); - try - SetCommMask(FHandle, Event); - SetSynaError(sOK); - if (Event = EV_RXCHAR) and (Waitingdata > 0) then - Result := True - else - begin - y := 0; - if not WaitCommEvent(FHandle, ex, @Overlapped) then - y := GetLastError; - if y = ERROR_IO_PENDING then - begin - //timedout - WaitForSingleObject(Overlapped.hEvent, Timeout); - SetCommMask(FHandle, 0); - GetOverlappedResult(FHandle, Overlapped, DWord(y), True); - end; - Result := (ex and Event) = Event; - end; - finally - SetCommMask(FHandle, 0); - CloseHandle(Overlapped.hEvent); - end; -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -function TBlockSerial.CanRead(Timeout: integer): boolean; -var - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - {$IFNDEF FPC} - FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); - x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); - {$ELSE} - fpFD_ZERO(FDSet); - fpFD_SET(FHandle, FDSet); - x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal); - {$ENDIF} - SerialCheck(x); - if FLastError <> sOK then - x := 0; - Result := x > 0; - ExceptCheck; - if Result then - DoStatus(HR_CanRead, ''); -end; -{$ELSE} -function TBlockSerial.CanRead(Timeout: integer): boolean; -begin - Result := WaitingData > 0; - if not Result then - Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0); - //check WaitingData again due some broken virtual ports - if Result then - DoStatus(HR_CanRead, ''); -end; -{$ENDIF} - -{$IFNDEF MSWINDOWS} -function TBlockSerial.CanWrite(Timeout: integer): boolean; -var - FDSet: TFDSet; - TimeVal: PTimeVal; - TimeV: TTimeVal; - x: Integer; -begin - TimeV.tv_usec := (Timeout mod 1000) * 1000; - TimeV.tv_sec := Timeout div 1000; - TimeVal := @TimeV; - if Timeout = -1 then - TimeVal := nil; - {$IFNDEF FPC} - FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); - x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); - {$ELSE} - fpFD_ZERO(FDSet); - fpFD_SET(FHandle, FDSet); - x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal); - {$ENDIF} - SerialCheck(x); - if FLastError <> sOK then - x := 0; - Result := x > 0; - ExceptCheck; - if Result then - DoStatus(HR_CanWrite, ''); -end; -{$ELSE} -function TBlockSerial.CanWrite(Timeout: integer): boolean; -var - t: LongWord; -begin - Result := SendingData = 0; - if not Result then - Result := CanEvent(EV_TXEMPTY, Timeout); - if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then - begin - t := GetTick; - while not ReadTxEmpty(FPortAddr) do - begin - if TickDelta(t, GetTick) > 255 then - Break; - Sleep(0); - end; - end; - if Result then - DoStatus(HR_CanWrite, ''); -end; -{$ENDIF} - -function TBlockSerial.CanReadEx(Timeout: integer): boolean; -begin - if Fbuffer <> '' then - Result := True - else - Result := CanRead(Timeout); -end; - -procedure TBlockSerial.EnableRTSToggle(Value: boolean); -begin - SetSynaError(sOK); -{$IFNDEF MSWINDOWS} - FRTSToggle := Value; - if Value then - RTS:=False; -{$ELSE} - if Win32Platform = VER_PLATFORM_WIN32_NT then - begin - GetCommState; - if value then - dcb.Flags := dcb.Flags or dcb_RtsControlToggle - else - dcb.flags := dcb.flags and (not dcb_RtsControlToggle); - SetCommState; - end - else - begin - FRTSToggle := Value; - if Value then - RTS:=False; - end; -{$ENDIF} -end; - -procedure TBlockSerial.Flush; -begin -{$IFNDEF MSWINDOWS} - SerialCheck(tcdrain(FHandle)); -{$ELSE} - SetSynaError(sOK); - if not Flushfilebuffers(FHandle) then - SerialCheck(sErr); -{$ENDIF} - ExceptCheck; -end; - -{$IFNDEF MSWINDOWS} -procedure TBlockSerial.Purge; -begin - {$IFNDEF FPC} - SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH)); - {$ELSE} - {$IFDEF DARWIN} - SerialCheck(fpioctl(FHandle, TCIOflush, TCIOFLUSH)); - {$ELSE} - SerialCheck(fpioctl(FHandle, TCFLSH, Pointer(PtrInt(TCIOFLUSH)))); - {$ENDIF} - {$ENDIF} - FBuffer := ''; - ExceptCheck; -end; -{$ELSE} -procedure TBlockSerial.Purge; -var - x: integer; -begin - SetSynaError(sOK); - x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR; - if not PurgeComm(FHandle, x) then - SerialCheck(sErr); - FBuffer := ''; - ExceptCheck; -end; -{$ENDIF} - -function TBlockSerial.ModemStatus: integer; -begin - Result := 0; -{$IFNDEF MSWINDOWS} - {$IFNDEF FPC} - SerialCheck(ioctl(FHandle, TIOCMGET, @Result)); - {$ELSE} - SerialCheck(fpioctl(FHandle, TIOCMGET, @Result)); - {$ENDIF} -{$ELSE} - SetSynaError(sOK); - if not GetCommModemStatus(FHandle, dword(Result)) then - SerialCheck(sErr); -{$ENDIF} - ExceptCheck; - FModemWord := Result; -end; - -procedure TBlockSerial.SetBreak(Duration: integer); -begin -{$IFNDEF MSWINDOWS} - SerialCheck(tcsendbreak(FHandle, Duration)); -{$ELSE} - SetCommBreak(FHandle); - Sleep(Duration); - SetSynaError(sOK); - if not ClearCommBreak(FHandle) then - SerialCheck(sErr); -{$ENDIF} -end; - -{$IFDEF MSWINDOWS} -procedure TBlockSerial.DecodeCommError(Error: DWord); -begin - if (Error and DWord(CE_FRAME)) > 1 then - FLastError := ErrFrame; - if (Error and DWord(CE_OVERRUN)) > 1 then - FLastError := ErrOverrun; - if (Error and DWord(CE_RXOVER)) > 1 then - FLastError := ErrRxOver; - if (Error and DWord(CE_RXPARITY)) > 1 then - FLastError := ErrRxParity; - if (Error and DWord(CE_TXFULL)) > 1 then - FLastError := ErrTxFull; -end; -{$ENDIF} - -//HGJ -function TBlockSerial.PreTestFailing: Boolean; -begin - if not FInstanceActive then - begin - RaiseSynaError(ErrPortNotOpen); - result:= true; - Exit; - end; - Result := not TestCtrlLine; - if result then - RaiseSynaError(ErrNoDeviceAnswer) -end; - -function TBlockSerial.TestCtrlLine: Boolean; -begin - result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS); -end; - -function TBlockSerial.ATCommand(value: AnsiString): AnsiString; -var - s: AnsiString; - ConvSave: Boolean; -begin - result := ''; - FAtResult := False; - ConvSave := FConvertLineEnd; - try - FConvertLineEnd := True; - SendString(value + #$0D); - repeat - s := RecvString(FAtTimeout); - if s <> Value then - result := result + s + CRLF; - if s = 'OK' then - begin - FAtResult := True; - break; - end; - if s = 'ERROR' then - break; - until FLastError <> sOK; - finally - FConvertLineEnd := Convsave; - end; -end; - - -function TBlockSerial.ATConnect(value: AnsiString): AnsiString; -var - s: AnsiString; - ConvSave: Boolean; -begin - result := ''; - FAtResult := False; - ConvSave := FConvertLineEnd; - try - FConvertLineEnd := True; - SendString(value + #$0D); - repeat - s := RecvString(90 * FAtTimeout); - if s <> Value then - result := result + s + CRLF; - if s = 'NO CARRIER' then - break; - if s = 'ERROR' then - break; - if s = 'BUSY' then - break; - if s = 'NO DIALTONE' then - break; - if Pos('CONNECT', s) = 1 then - begin - FAtResult := True; - break; - end; - until FLastError <> sOK; - finally - FConvertLineEnd := Convsave; - end; -end; - -function TBlockSerial.SerialCheck(SerialResult: integer): integer; -begin - if SerialResult = integer(INVALID_HANDLE_VALUE) then -{$IFDEF MSWINDOWS} - result := GetLastError -{$ELSE} - {$IFNDEF FPC} - result := GetLastError - {$ELSE} - result := fpGetErrno - {$ENDIF} -{$ENDIF} - else - result := sOK; - FLastError := result; - FLastErrorDesc := GetErrorDesc(FLastError); -end; - -procedure TBlockSerial.ExceptCheck; -var - e: ESynaSerError; - s: string; -begin - if FRaiseExcept and (FLastError <> sOK) then - begin - s := GetErrorDesc(FLastError); - e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]); - e.ErrorCode := FLastError; - e.ErrorMessage := s; - raise e; - end; -end; - -procedure TBlockSerial.SetSynaError(ErrNumber: integer); -begin - FLastError := ErrNumber; - FLastErrorDesc := GetErrorDesc(FLastError); -end; - -procedure TBlockSerial.RaiseSynaError(ErrNumber: integer); -begin - SetSynaError(ErrNumber); - ExceptCheck; -end; - -procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string); -begin - if assigned(OnStatus) then - OnStatus(Self, Reason, Value); -end; - -{======================================================================} - -class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string; -begin - Result:= ''; - case ErrorCode of - sOK: Result := 'OK'; - ErrAlreadyOwned: Result := 'Port owned by other process';{HGJ} - ErrAlreadyInUse: Result := 'Instance already in use'; {HGJ} - ErrWrongParameter: Result := 'Wrong parameter at call'; {HGJ} - ErrPortNotOpen: Result := 'Instance not yet connected'; {HGJ} - ErrNoDeviceAnswer: Result := 'No device answer detected'; {HGJ} - ErrMaxBuffer: Result := 'Maximal buffer length exceeded'; - ErrTimeout: Result := 'Timeout during operation'; - ErrNotRead: Result := 'Reading of data failed'; - ErrFrame: Result := 'Receive framing error'; - ErrOverrun: Result := 'Receive Overrun Error'; - ErrRxOver: Result := 'Receive Queue overflow'; - ErrRxParity: Result := 'Receive Parity Error'; - ErrTxFull: Result := 'Tranceive Queue is full'; - end; - if Result = '' then - begin - Result := SysErrorMessage(ErrorCode); - end; -end; - - -{---------- cpom Comport Ownership Manager Routines ------------- - by Hans-Georg Joepgen of Stuttgart, Germany. - Copyright (c) 2002, by Hans-Georg Joepgen - - Stefan Krauss of Stuttgart, Germany, contributed literature and Internet - research results, invaluable advice and excellent answers to the Comport - Ownership Manager. -} - -{$IFDEF UNIX} - -function TBlockSerial.LockfileName: String; -var - s: string; -begin - s := SeparateRight(FDevice, '/dev/'); - result := LockfileDirectory + '/LCK..' + s; -end; - -procedure TBlockSerial.CreateLockfile(PidNr: integer); -var - f: TextFile; - s: string; -begin - // Create content for file - s := IntToStr(PidNr); - while length(s) < 10 do - s := ' ' + s; - // Create file - try - AssignFile(f, LockfileName); - try - Rewrite(f); - writeln(f, s); - finally - CloseFile(f); - end; - // Allow all users to enjoy the benefits of cpom - s := 'chmod a+rw ' + LockfileName; -{$IFNDEF FPC} - FileSetReadOnly( LockfileName, False ) ; - // Libc.system(pchar(s)); -{$ELSE} - fpSystem(s); -{$ENDIF} - except - // not raise exception, if you not have write permission for lock. - on Exception do - ; - end; -end; - -function TBlockSerial.ReadLockfile: integer; -{Returns PID from Lockfile. Lockfile must exist.} -var - f: TextFile; - s: string; -begin - AssignFile(f, LockfileName); - Reset(f); - try - readln(f, s); - finally - CloseFile(f); - end; - Result := StrToIntDef(s, -1) -end; - -function TBlockSerial.cpomComportAccessible: boolean; -var - MyPid: integer; - Filename: string; -begin - Filename := LockfileName; - {$IFNDEF FPC} - MyPid := Libc.getpid; - {$ELSE} - MyPid := fpGetPid; - {$ENDIF} - // Make sure, the Lock Files Directory exists. We need it. - if not DirectoryExists(LockfileDirectory) then - CreateDir(LockfileDirectory); - // Check the Lockfile - if not FileExists (Filename) then - begin // comport is not locked. Lock it for us. - CreateLockfile(MyPid); - result := true; - exit; // done. - end; - // Is port owned by orphan? Then it's time for error recovery. - //FPC forgot to add getsid.. :-( - {$IFNDEF FPC} - if Libc.getsid(ReadLockfile) = -1 then - begin // Lockfile was left from former desaster - DeleteFile(Filename); // error recovery - CreateLockfile(MyPid); - result := true; - exit; - end; - {$ENDIF} - result := false // Sorry, port is owned by living PID and locked -end; - -procedure TBlockSerial.cpomReleaseComport; -begin - DeleteFile(LockfileName); -end; - -{$ENDIF} -{----------------------------------------------------------------} - -{$IFDEF MSWINDOWS} -function GetSerialPortNames: string; -var - reg: TRegistry; - l, v: TStringList; - n: integer; -begin - l := TStringList.Create; - v := TStringList.Create; - reg := TRegistry.Create; - try -{$IFNDEF VER100} -{$IFNDEF VER120} - reg.Access := KEY_READ; -{$ENDIF} -{$ENDIF} - reg.RootKey := HKEY_LOCAL_MACHINE; - reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false); - reg.GetValueNames(l); - for n := 0 to l.Count - 1 do - v.Add(reg.ReadString(l[n])); - Result := v.CommaText; - finally - reg.Free; - l.Free; - v.Free; - end; -end; -{$ENDIF} -{$IFNDEF MSWINDOWS} -function GetSerialPortNames: string; -var - Index: Integer; - Data: string; - TmpPorts: String; - sr : TSearchRec; -begin - try - TmpPorts := ''; - if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then - begin - repeat - if (sr.Attr and $FFFFFFFF) = Sr.Attr then - begin - data := sr.Name; - index := length(data); - while (index > 1) and (data[index] <> '/') do - index := index - 1; - TmpPorts := TmpPorts + ' ' + copy(data, 1, index + 1); - end; - until FindNext(sr) <> 0; - end; - FindClose(sr); - finally - Result:=TmpPorts; - end; -end; -{$ENDIF} - -end. diff --git a/synapse/synautil.pas b/synapse/synautil.pas deleted file mode 100644 index 7b564f7..0000000 --- a/synapse/synautil.pas +++ /dev/null @@ -1,2065 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 004.015.000 | -|==============================================================================| -| Content: support procedures and functions | -|==============================================================================| -| Copyright (c)1999-2012, 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) 1999-2012. | -| Portions created by Hernan Sanchez are Copyright (c) 2000. | -| Portions created by Petr Fejfar are Copyright (c)2011-2012. | -| 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/) | -|==============================================================================} - -{:@abstract(Support procedures and functions)} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$Q-} -{$R-} -{$H+} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} - {$WARN SUSPICIOUS_TYPECAST OFF} -{$ENDIF} - -unit synautil; - -interface - -uses -{$IFDEF MSWINDOWS} - Windows, -{$ELSE} - {$IFDEF FPC} - UnixUtil, Unix, BaseUnix, - {$ELSE} - Libc, - {$ENDIF} -{$ENDIF} -{$IFDEF CIL} - System.IO, -{$ENDIF} - SysUtils, Classes, SynaFpc; - -{$IFDEF VER100} -type - int64 = integer; -{$ENDIF} - -{: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; - -{: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: String): 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: LongWord; - -{: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: LongWord): LongWord; - -{: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; - -{: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; - -{: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: AnsiString): AnsiString; - -{: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: AnsiString): Boolean; - -{: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; - -{:Remove quotation from Value string. If Value is not quoted, then return same - string without any modification. } -function UnquoteStr(const Value: string; Quote: Char): string; - -{:Quote Value string. If Value contains some Quote chars, then it is doubled.} -function QuoteStr(const 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); - -{:Return filename of new temporary file in Dir (if empty, then default temporary - directory is used) and with optional filename prefix.} -function GetTempFile(const Dir, prefix: AnsiString): AnsiString; - -{:Return padded string. If length is greater, string is truncated. If length is - smaller, string is padded by Pad character.} -function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; - -{:XOR each byte in the strings} -function XorString(Indata1, Indata2: AnsiString): AnsiString; - -{: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; - -{pf} -{:Search for one of line terminators CR, LF or NUL. Return position of the - line beginning and length of text.} -procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); -{:Skip both line terminators CR LF (if any). Move APtr position forward.} -procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar); -{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.} -procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar); -{:Copy all lines from a buffer starting at APtr to ALines until empty line - or end of the buffer is reached. Move APtr position forward).} -procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); -{:Copy all lines from a buffer starting at APtr to ALines until ABoundary - or end of the buffer is reached. Move APtr position forward).} -procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); -{:Search ABoundary in a buffer starting at APtr. - Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).} -function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar; -{:Compare a text at position ABOL with ABoundary and return position behind the - match (including a trailing CRLF if any).} -function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; -{:Compare a text at position ABOL with ABoundary + the last boundary suffix - and return position behind the match (including a trailing CRLF if any).} -function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; -{:Copy data from a buffer starting at position APtr and delimited by AEtx - position into ANSIString.} -function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString; -{/pf} - -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 AnsiString = - ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); -var - MyMonthNames: array[0..6, 1..12] of String = - ( - ('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') - ); - - -{==============================================================================} - -function TimeZoneBias: integer; -{$IFNDEF MSWINDOWS} -{$IFNDEF FPC} -var - t: TTime_T; - UT: TUnixTime; -begin - __time(@T); - localtime_r(@T, UT); - Result := ut.__tm_gmtoff div 60; -{$ELSE} -begin - Result := TZSeconds div 60; -{$ENDIF} -{$ELSE} -var - zoneinfo: TTimeZoneInformation; - bias: Integer; -begin - case GetTimeZoneInformation(Zoneinfo) of - 2: - bias := zoneinfo.Bias + zoneinfo.DaylightBias; - 1: - bias := zoneinfo.Bias + zoneinfo.StandardBias; - else - bias := zoneinfo.Bias; - end; - Result := bias * (-1); -{$ENDIF} -end; - -{==============================================================================} - -function TimeZone: string; -var - bias: Integer; - h, m: Integer; -begin - bias := TimeZoneBias; - if bias >= 0 then - Result := '+' - else - Result := '-'; - bias := Abs(bias); - h := bias div 60; - m := bias mod 60; - Result := Result + Format('%.2d%.2d', [h, m]); -end; - -{==============================================================================} - -function Rfc822DateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay, - MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]); -end; - -{==============================================================================} - -function CDateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay, - FormatDateTime('hh":"nn":"ss', t)]); -end; - -{==============================================================================} - -function SimpleDateTime(t: TDateTime): string; -begin - Result := FormatDateTime('yymmdd hhnnss', t); -end; - -{==============================================================================} - -function AnsiCDateTime(t: TDateTime): string; -var - wYear, wMonth, wDay: word; -begin - DecodeDate(t, wYear, wMonth, wDay); - Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth], - wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]); -end; - -{==============================================================================} - -function DecodeTimeZone(Value: string; var Zone: integer): Boolean; -var - x: integer; - zh, zm: integer; - s: string; -begin - Result := false; - s := Value; - if (Pos('+', s) = 1) or (Pos('-',s) = 1) then - begin - if s = '-0000' then - Zone := TimeZoneBias - else - if Length(s) > 4 then - begin - zh := StrToIntdef(s[2] + s[3], 0); - zm := StrToIntdef(s[4] + s[5], 0); - zone := zh * 60 + zm; - if s[1] = '-' then - zone := zone * (-1); - end; - Result := True; - end - else - begin - x := 32767; - if s = 'NZDT' then x := 13; - if s = 'IDLE' then x := 12; - if s = 'NZST' then x := 12; - if s = 'NZT' then x := 12; - if s = 'EADT' then x := 11; - if s = 'GST' then x := 10; - if s = 'JST' then x := 9; - if s = 'CCT' then x := 8; - if s = 'WADT' then x := 8; - if s = 'WAST' then x := 7; - if s = 'ZP6' then x := 6; - if s = 'ZP5' then x := 5; - if s = 'ZP4' then x := 4; - if s = 'BT' then x := 3; - if s = 'EET' then x := 2; - if s = 'MEST' then x := 2; - if s = 'MESZ' then x := 2; - if s = 'SST' then x := 2; - if s = 'FST' then x := 2; - if s = 'CEST' then x := 2; - if s = 'CET' then x := 1; - if s = 'FWT' then x := 1; - if s = 'MET' then x := 1; - if s = 'MEWT' then x := 1; - if s = 'SWT' then x := 1; - if s = 'UT' then x := 0; - if s = 'UTC' then x := 0; - if s = 'GMT' then x := 0; - if s = 'WET' then x := 0; - if s = 'WAT' then x := -1; - if s = 'BST' then x := -1; - if s = 'AT' then x := -2; - if s = 'ADT' then x := -3; - if s = 'AST' then x := -4; - if s = 'EDT' then x := -4; - if s = 'EST' then x := -5; - if s = 'CDT' then x := -5; - if s = 'CST' then x := -6; - if s = 'MDT' then x := -6; - if s = 'MST' then x := -7; - if s = 'PDT' then x := -7; - if s = 'PST' then x := -8; - if s = 'YDT' then x := -8; - if s = 'YST' then x := -9; - if s = 'HDT' then x := -9; - if s = 'AHST' then x := -10; - if s = 'CAT' then x := -10; - if s = 'HST' then x := -10; - if s = 'EAST' then x := -10; - if s = 'NT' then x := -11; - if s = 'IDLW' then x := -12; - if x <> 32767 then - begin - zone := x * 60; - Result := True; - end; - end; -end; - -{==============================================================================} - -function GetMonthNumber(Value: String): integer; -var - n: integer; - function TestMonth(Value: String; 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 := AnsiUppercase(Value); - for n := 1 to 12 do - if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then - begin - Result := n; - Break; - end; -end; - -{==============================================================================} - -function GetTimeFromStr(Value: string): TDateTime; -var - x: integer; -begin - x := rpos(':', Value); - if (x > 0) and ((Length(Value) - x) > 2) then - Value := Copy(Value, 1, x + 2); - Value := ReplaceString(Value, ':', TimeSeparator); - Result := -1; - try - Result := StrToTime(Value); - except - on Exception do ; - end; -end; - -{==============================================================================} - -function GetDateMDYFromStr(Value: string): TDateTime; -var - wYear, wMonth, wDay: word; - s: string; -begin - Result := 0; - s := Fetch(Value, '-'); - wMonth := StrToIntDef(s, 12); - s := Fetch(Value, '-'); - wDay := StrToIntDef(s, 30); - wYear := StrToIntDef(Value, 1899); - if wYear < 1000 then - if (wYear > 99) then - wYear := wYear + 1900 - else - if wYear > 50 then - wYear := wYear + 1900 - else - wYear := wYear + 2000; - try - Result := EncodeDate(wYear, wMonth, wDay); - except - on Exception do ; - end; -end; - -{==============================================================================} - -function DecodeRfcDateTime(Value: string): TDateTime; -var - day, month, year: Word; - zone: integer; - x, y: integer; - s: string; - t: TDateTime; -begin -// 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 -// 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 - - Result := 0; - if Value = '' then - Exit; - day := 0; - month := 0; - year := 0; - zone := 0; - Value := ReplaceString(Value, ' -', ' #'); - Value := ReplaceString(Value, '-', ' '); - Value := ReplaceString(Value, ' #', ' -'); - while Value <> '' do - begin - s := Fetch(Value, ' '); - s := uppercase(s); - // timezone - if DecodetimeZone(s, x) then - begin - zone := x; - continue; - end; - x := StrToIntDef(s, 0); - // day or year - if x > 0 then - if (x < 32) and (day = 0) then - begin - day := x; - continue; - end - else - begin - if (year = 0) and ((month > 0) or (x > 12)) then - begin - year := x; - if year < 32 then - year := year + 2000; - if year < 1000 then - year := year + 1900; - continue; - end; - end; - // time - if rpos(':', s) > Pos(':', s) then - begin - t := GetTimeFromStr(s); - if t <> -1 then - Result := t; - continue; - end; - //timezone daylight saving time - if s = 'DST' then - begin - zone := zone + 60; - continue; - end; - // month - y := GetMonthNumber(s); - if (y > 0) and (month = 0) then - month := y; - end; - if year = 0 then - year := 1980; - if month < 1 then - month := 1; - if month > 12 then - month := 12; - if day < 1 then - day := 1; - x := MonthDays[IsLeapYear(year), month]; - if day > x then - day := x; - Result := Result + Encodedate(year, month, day); - zone := zone - TimeZoneBias; - x := zone div 1440; - Result := Result - x; - zone := zone mod 1440; - t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0); - if zone < 0 then - t := 0 - t; - Result := Result - t; -end; - -{==============================================================================} - -function GetUTTime: TDateTime; -{$IFDEF MSWINDOWS} -{$IFNDEF FPC} -var - st: TSystemTime; -begin - GetSystemTime(st); - result := SystemTimeToDateTime(st); -{$ELSE} -var - st: SysUtils.TSystemTime; - stw: Windows.TSystemTime; -begin - GetSystemTime(stw); - st.Year := stw.wYear; - st.Month := stw.wMonth; - st.Day := stw.wDay; - st.Hour := stw.wHour; - st.Minute := stw.wMinute; - st.Second := stw.wSecond; - st.Millisecond := stw.wMilliseconds; - result := SystemTimeToDateTime(st); -{$ENDIF} -{$ELSE} -{$IFNDEF FPC} -var - TV: TTimeVal; -begin - gettimeofday(TV, nil); - Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ELSE} -var - TV: TimeVal; -begin - fpgettimeofday(@TV, nil); - Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -function SetUTTime(Newdt: TDateTime): Boolean; -{$IFDEF MSWINDOWS} -{$IFNDEF FPC} -var - st: TSystemTime; -begin - DateTimeToSystemTime(newdt,st); - Result := SetSystemTime(st); -{$ELSE} -var - st: SysUtils.TSystemTime; - stw: Windows.TSystemTime; -begin - DateTimeToSystemTime(newdt,st); - stw.wYear := st.Year; - stw.wMonth := st.Month; - stw.wDay := st.Day; - stw.wHour := st.Hour; - stw.wMinute := st.Minute; - stw.wSecond := st.Second; - stw.wMilliseconds := st.Millisecond; - Result := SetSystemTime(stw); -{$ENDIF} -{$ELSE} -{$IFNDEF FPC} -var - TV: TTimeVal; - d: double; - TZ: Ttimezone; - PZ: PTimeZone; -begin - TZ.tz_minuteswest := 0; - TZ.tz_dsttime := 0; - PZ := @TZ; - gettimeofday(TV, PZ); - d := (newdt - UnixDateDelta) * 86400; - TV.tv_sec := trunc(d); - TV.tv_usec := trunc(frac(d) * 1000000); - Result := settimeofday(TV, TZ) <> -1; -{$ELSE} -var - TV: TimeVal; - d: double; -begin - d := (newdt - UnixDateDelta) * 86400; - TV.tv_sec := trunc(d); - TV.tv_usec := trunc(frac(d) * 1000000); - Result := fpsettimeofday(@TV, nil) <> -1; -{$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -{$IFNDEF MSWINDOWS} -function GetTick: LongWord; -var - Stamp: TTimeStamp; -begin - Stamp := DateTimeToTimeStamp(Now); - Result := Stamp.Time; -end; -{$ELSE} -function GetTick: LongWord; -var - tick, freq: TLargeInteger; -{$IFDEF VER100} - x: TLargeInteger; -{$ENDIF} -begin - if Windows.QueryPerformanceFrequency(freq) then - begin - Windows.QueryPerformanceCounter(tick); -{$IFDEF VER100} - x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000; - Result := x.LowPart; -{$ELSE} - Result := Trunc((tick / freq) * 1000) and High(LongWord) -{$ENDIF} - end - else - Result := Windows.GetTickCount; -end; -{$ENDIF} - -{==============================================================================} - -function TickDelta(TickOld, TickNew: LongWord): LongWord; -begin -//if DWord is signed type (older Deplhi), -// then it not work properly on differencies larger then maxint! - Result := 0; - if TickOld <> TickNew then - begin - if TickNew < TickOld then - begin - TickNew := TickNew + LongWord(MaxInt) + 1; - TickOld := TickOld + LongWord(MaxInt) + 1; - end; - Result := TickNew - TickOld; - if TickNew < TickOld then - if Result > 0 then - Result := 0 - Result; - end; -end; - -{==============================================================================} - -function CodeInt(Value: Word): Ansistring; -begin - 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: Ansistring; Index: Integer): Word; -var - x, y: 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; - Result := x * 256 + y; -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 DumpStr(const Buffer: Ansistring): string; -var - n: Integer; -begin - Result := ''; - for n := 1 to Length(Buffer) do - Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); -end; - -{==============================================================================} - -function DumpExStr(const Buffer: Ansistring): string; -var - n: Integer; - x: Byte; -begin - Result := ''; - for n := 1 to Length(Buffer) do - begin - x := Ord(Buffer[n]); - if x in [65..90, 97..122] then - Result := Result + ' +''' + char(x) + '''' - else - Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2); - end; -end; - -{==============================================================================} - -procedure Dump(const Buffer: AnsiString; DumpFile: string); -var - f: Text; -begin - AssignFile(f, DumpFile); - if FileExists(DumpFile) then - DeleteFile(DumpFile); - Rewrite(f); - try - Writeln(f, DumpStr(Buffer)); - finally - CloseFile(f); - end; -end; - -{==============================================================================} - -procedure DumpEx(const Buffer: AnsiString; DumpFile: string); -var - f: Text; -begin - AssignFile(f, DumpFile); - if FileExists(DumpFile) then - DeleteFile(DumpFile); - Rewrite(f); - try - Writeln(f, DumpExStr(Buffer)); - finally - CloseFile(f); - end; -end; - -{==============================================================================} - -function TrimSPLeft(const S: string): string; -var - I, L: Integer; -begin - Result := ''; - if S = '' then - Exit; - 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 - Result := ''; - if S = '' then - Exit; - 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 := Value - else - Result := Copy(Value, 1, x - 1); -end; - -{==============================================================================} - -function SeparateRight(const Value, Delimiter: string): string; -var - x: Integer; -begin - x := Pos(Delimiter, Value); - if x > 0 then - x := x + Length(Delimiter) - 1; - Result := Copy(Value, x + 1, Length(Value) - x); -end; - -{==============================================================================} - -function GetParameter(const Value, Parameter: string): string; -var - s: string; - v: string; -begin - Result := ''; - v := Value; - while v <> '' do - begin - s := Trim(FetchEx(v, ';', '"')); - if Pos(Uppercase(parameter), Uppercase(s)) = 1 then - begin - 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; - -{==============================================================================} - -procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings); -var - s: string; -begin - Parameters.Clear; - while Value <> '' do - begin - s := Trim(FetchEx(Value, Delimiter, '"')); - Parameters.Add(s); - end; -end; - -{==============================================================================} - -procedure ParseParameters(Value: string; const Parameters: TStrings); -begin - ParseParametersEx(Value, ';', Parameters); -end; - -{==============================================================================} - -function IndexByBegin(Value: string; const List: TStrings): integer; -var - n: integer; - s: string; -begin - Result := -1; - Value := uppercase(Value); - for n := 0 to List.Count -1 do - begin - s := UpperCase(List[n]); - if Pos(Value, s) = 1 then - begin - Result := n; - Break; - end; - end; -end; - -{==============================================================================} - -function GetEmailAddr(const Value: string): string; -var - s: string; -begin - s := SeparateRight(Value, '<'); - s := SeparateLeft(s, '>'); - Result := Trim(s); -end; - -{==============================================================================} - -function GetEmailDesc(Value: string): string; -var - s: string; -begin - Value := Trim(Value); - s := SeparateRight(Value, '"'); - if s <> Value then - s := SeparateLeft(s, '"') - else - begin - s := SeparateLeft(Value, '<'); - if s = Value then - begin - s := SeparateRight(Value, '('); - if s <> Value then - s := SeparateLeft(s, ')') - else - s := ''; - end; - end; - Result := Trim(s); -end; - -{==============================================================================} - -function StrToHex(const Value: Ansistring): string; -var - n: Integer; -begin - Result := ''; - for n := 1 to Length(Value) do - Result := Result + IntToHex(Byte(Value[n]), 2); - Result := LowerCase(Result); -end; - -{==============================================================================} - -function IntToBin(Value: Integer; Digits: Byte): string; -var - x, y, n: Integer; -begin - Result := ''; - x := Value; - repeat - y := x mod 2; - x := x div 2; - if y > 0 then - Result := '1' + Result - else - Result := '0' + Result; - until x = 0; - x := Length(Result); - for n := x to Digits - 1 do - Result := '0' + Result; -end; - -{==============================================================================} - -function BinToInt(const Value: string): Integer; -var - n: Integer; -begin - Result := 0; - for n := 1 to Length(Value) do - begin - if Value[n] = '0' then - Result := Result * 2 - else - if Value[n] = '1' then - Result := Result * 2 + 1 - else - Break; - end; -end; - -{==============================================================================} - -function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path, - Para: string): string; -var - x, y: Integer; - sURL: string; - s: string; - s1, s2: string; -begin - Prot := 'http'; - User := ''; - Pass := ''; - Port := '80'; - Para := ''; - - x := Pos('://', URL); - if x > 0 then - begin - Prot := SeparateLeft(URL, '://'); - sURL := SeparateRight(URL, '://'); - end - else - sURL := URL; - if UpperCase(Prot) = 'HTTPS' then - Port := '443'; - if UpperCase(Prot) = 'FTP' then - Port := '21'; - x := Pos('@', sURL); - y := Pos('/', sURL); - if (x > 0) and ((x < y) or (y < 1))then - begin - s := SeparateLeft(sURL, '@'); - sURL := SeparateRight(sURL, '@'); - x := Pos(':', s); - if x > 0 then - begin - User := SeparateLeft(s, ':'); - Pass := SeparateRight(s, ':'); - end - else - User := s; - end; - x := Pos('/', sURL); - if x > 0 then - begin - s1 := SeparateLeft(sURL, '/'); - s2 := SeparateRight(sURL, '/'); - end - else - begin - s1 := sURL; - s2 := ''; - end; - if Pos('[', s1) = 1 then - begin - Host := Separateleft(s1, ']'); - Delete(Host, 1, 1); - s1 := SeparateRight(s1, ']'); - if Pos(':', s1) = 1 then - Port := SeparateRight(s1, ':'); - end - else - begin - x := Pos(':', s1); - if x > 0 then - begin - Host := SeparateLeft(s1, ':'); - Port := SeparateRight(s1, ':'); - end - else - Host := s1; - end; - Result := '/' + s2; - x := Pos('?', s2); - if x > 0 then - begin - Path := '/' + SeparateLeft(s2, '?'); - Para := SeparateRight(s2, '?'); - end - else - Path := '/' + s2; - if Host = '' then - Host := 'localhost'; -end; - -{==============================================================================} - -function ReplaceString(Value, Search, Replace: AnsiString): AnsiString; -var - x, l, ls, lr: Integer; -begin - if (Value = '') or (Search = '') then - begin - Result := Value; - Exit; - end; - ls := Length(Search); - lr := Length(Replace); - Result := ''; - 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); - {$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); - {$ELSE} - Result:=Result+Replace; - {$ENDIF} - Delete(Value, 1, x - 1 + ls); - x := Pos(Search, Value); - end; - Result := Result + Value; -end; - -{==============================================================================} - -function RPosEx(const Sub, Value: string; From: integer): Integer; -var - n: Integer; - l: Integer; -begin - result := 0; - l := Length(Sub); - for n := From - l + 1 downto 1 do - begin - if Copy(Value, n, l) = Sub then - begin - result := n; - break; - end; - end; -end; - -{==============================================================================} - -function RPos(const Sub, Value: String): Integer; -begin - Result := RPosEx(Sub, Value, Length(Value)); -end; - -{==============================================================================} - -function FetchBin(var Value: string; const Delimiter: string): string; -var - s: string; -begin - Result := SeparateLeft(Value, Delimiter); - s := SeparateRight(Value, Delimiter); - if s = Value then - Value := '' - else - Value := s; -end; - -{==============================================================================} - -function Fetch(var Value: string; const Delimiter: string): string; -begin - Result := FetchBin(Value, Delimiter); - Result := TrimSP(Result); - Value := TrimSP(Value); -end; - -{==============================================================================} - -function FetchEx(var Value: string; const Delimiter, Quotation: string): string; -var - b: Boolean; -begin - Result := ''; - b := False; - while Length(Value) > 0 do - begin - if b then - begin - if Pos(Quotation, Value) = 1 then - b := False; - Result := Result + Value[1]; - Delete(Value, 1, 1); - end - else - begin - if Pos(Delimiter, Value) = 1 then - begin - Delete(Value, 1, Length(delimiter)); - break; - end; - b := Pos(Quotation, Value) = 1; - Result := Result + Value[1]; - Delete(Value, 1, 1); - end; - end; -end; - -{==============================================================================} - -function IsBinaryString(const Value: AnsiString): Boolean; -var - n: integer; -begin - Result := False; - for n := 1 to Length(Value) do - if Value[n] in [#0..#8, #10..#31] then - //ignore null-terminated strings - if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then - begin - Result := True; - Break; - end; -end; - -{==============================================================================} - -function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; -var - n, l: integer; -begin - Result := -1; - Terminator := ''; - l := length(value); - for n := 1 to l do - if value[n] in [#$0d, #$0a] then - begin - Result := n; - Terminator := Value[n]; - if n <> l then - case value[n] of - #$0d: - if value[n + 1] = #$0a then - Terminator := #$0d + #$0a; - #$0a: - if value[n + 1] = #$0d then - Terminator := #$0a + #$0d; - end; - Break; - end; -end; - -{==============================================================================} - -Procedure StringsTrim(const Value: TStrings); -var - n: integer; -begin - for n := Value.Count - 1 downto 0 do - if Value[n] = '' then - Value.Delete(n) - else - Break; -end; - -{==============================================================================} - -function PosFrom(const SubStr, Value: String; From: integer): integer; -var - ls,lv: integer; -begin - Result := 0; - ls := Length(SubStr); - lv := Length(Value); - if (ls = 0) or (lv = 0) then - Exit; - if From < 1 then - 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; - end - else - inc(from); - end; -end; - -{==============================================================================} - -{$IFNDEF CIL} -function IncPoint(const p: pointer; Value: integer): pointer; -begin - Result := PAnsiChar(p) + Value; -end; -{$ENDIF} - -{==============================================================================} -//improved by 'DoggyDawg' -function GetBetween(const PairBegin, PairEnd, Value: string): string; -var - n: integer; - x: integer; - s: string; - lenBegin: integer; - lenEnd: integer; - str: string; - max: integer; -begin - lenBegin := Length(PairBegin); - lenEnd := Length(PairEnd); - n := Length(Value); - if (Value = PairBegin + PairEnd) then - begin - Result := '';//nothing between - exit; - end; - if (n < lenBegin + lenEnd) then - begin - Result := Value; - exit; - end; - s := SeparateRight(Value, PairBegin); - if (s = Value) then - begin - Result := Value; - exit; - end; - n := Pos(PairEnd, s); - if (n = 0) then - begin - Result := Value; - exit; - end; - Result := ''; - x := 1; - max := Length(s) - lenEnd + 1; - for n := 1 to max do - begin - str := copy(s, n, lenEnd); - if (str = PairEnd) then - begin - Dec(x); - if (x <= 0) then - Break; - end; - str := copy(s, n, lenBegin); - if (str = PairBegin) then - Inc(x); - Result := Result + s[n]; - end; -end; - -{==============================================================================} - -function CountOfChar(const Value: string; Chr: char): integer; -var - n: integer; -begin - Result := 0; - for n := 1 to Length(Value) do - if Value[n] = chr then - Inc(Result); -end; - -{==============================================================================} -// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application! -function UnquoteStr(const Value: string; Quote: Char): string; -var - n: integer; - inq, dq: Boolean; - c, cn: char; -begin - Result := ''; - if Value = '' then - Exit; - if Value = Quote + Quote then - Exit; - inq := False; - dq := False; - for n := 1 to Length(Value) do - begin - c := Value[n]; - if n <> Length(Value) then - cn := Value[n + 1] - else - cn := #0; - if c = quote then - if dq then - dq := False - else - if not inq then - inq := True - else - if cn = quote then - begin - Result := Result + Quote; - dq := True; - end - else - inq := False - else - Result := Result + c; - end; -end; - -{==============================================================================} - -function QuoteStr(const Value: string; Quote: Char): string; -var - n: integer; -begin - Result := ''; - for n := 1 to length(value) do - begin - Result := result + Value[n]; - if value[n] = Quote then - Result := Result + Quote; - end; - Result := Quote + Result + Quote; -end; - -{==============================================================================} - -procedure HeadersToList(const Value: TStrings); -var - n, x, y: integer; - s: string; -begin - for n := 0 to Value.Count -1 do - begin - s := Value[n]; - x := Pos(':', s); - if x > 0 then - begin - y:= Pos('=',s); - if not ((y > 0) and (y < x)) then - begin - s[x] := '='; - Value[n] := s; - end; - 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: AnsiString; - 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(PAnsiChar(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(PAnsiChar(Value)^, Length(Value)); -{$ENDIF} -end; - -{==============================================================================} -function GetTempFile(const Dir, prefix: AnsiString): AnsiString; -{$IFNDEF FPC} -{$IFDEF MSWINDOWS} -var - Path: AnsiString; - x: integer; -{$ENDIF} -{$ENDIF} -begin -{$IFDEF FPC} - Result := GetTempFileName(Dir, Prefix); -{$ELSE} - {$IFNDEF MSWINDOWS} - Result := tempnam(Pointer(Dir), Pointer(prefix)); - {$ELSE} - {$IFDEF CIL} - Result := System.IO.Path.GetTempFileName; - {$ELSE} - if Dir = '' then - begin - SetLength(Path, MAX_PATH); - x := GetTempPath(Length(Path), PChar(Path)); - SetLength(Path, x); - end - else - Path := Dir; - x := Length(Path); - if Path[x] <> '\' then - Path := Path + '\'; - SetLength(Result, MAX_PATH + 1); - GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result)); - Result := PChar(Result); - SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY); - {$ENDIF} - {$ENDIF} -{$ENDIF} -end; - -{==============================================================================} - -function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString; -begin - if length(value) >= len then - Result := Copy(value, 1, len) - else - Result := Value + StringOfChar(Pad, len - length(value)); -end; - -{==============================================================================} - -function XorString(Indata1, Indata2: AnsiString): AnsiString; -var - i: integer; -begin - Indata2 := PadString(Indata2, length(Indata1), #0); - Result := ''; - for i := 1 to length(Indata1) do - Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i])); -end; - -{==============================================================================} - -function NormalizeHeader(Value: TStrings; var Index: Integer): string; -var - s, t: string; - n: Integer; -begin - s := Value[Index]; - Inc(Index); - if s <> '' then - while (Value.Count - 1) > Index do - begin - t := Value[Index]; - if t = '' then - Break; - for n := 1 to Length(t) do - if t[n] = #9 then - t[n] := ' '; - if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then - Break - else - begin - s := s + ' ' + Trim(t); - Inc(Index); - end; - end; - Result := TrimRight(s); -end; - -{==============================================================================} - -{pf} -procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); -begin - ABol := APtr; - while (APtr0 then - begin - APtr := bol; - Break; - end; - end; -end; -{/pf} - -{pf} -procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings); -var - bol: PANSIChar; - lng: integer; - s: ANSIString; -begin - // Copying until body separator will be reached - while (APtr#0) do - begin - SearchForLineBreak(APtr,AEtx,bol,lng); - SkipLineBreak(APtr,AEtx); - if lng=0 then - Break; - SetString(s,bol,lng); - ALines.Add(s); - end; -end; -{/pf} - -{pf} -procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString); -var - bol: PANSIChar; - lng: integer; - s: ANSIString; - BackStop: ANSIString; - eob1: PANSIChar; - eob2: PANSIChar; -begin - BackStop := '--'+ABoundary; - eob2 := nil; - // Copying until Boundary will be reached - while (APtrAETX then - exit; - if strlcomp(MatchPos,#13#10,2)=0 then - inc(MatchPos,2); - if (MatchPos+2+Lng)>AETX then - exit; - if strlcomp(MatchPos,'--',2)<>0 then - exit; - inc(MatchPos,2); - if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then - exit; - inc(MatchPos,Lng); - if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then - inc(MatchPos,2); - Result := MatchPos; -end; -{/pf} - -{pf} -function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar; -var - MatchPos: PANSIChar; -begin - Result := nil; - MatchPos := MatchBoundary(ABOL,AETX,ABoundary); - if not Assigned(MatchPos) then - exit; - if strlcomp(MatchPos,'--',2)<>0 then - exit; - inc(MatchPos,2); - if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then - inc(MatchPos,2); - Result := MatchPos; -end; -{/pf} - -{pf} -function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString; -var - lng: integer; -begin - Lng := 0; - if Assigned(AStx) and Assigned(AEtx) then - begin - Lng := AEtx-AStx; - if Lng<0 then - Lng := 0; - end; - SetString(Result,AStx,lng); -end; -{/pf} - - - - -{==============================================================================} -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/synapse/synsock.pas b/synapse/synsock.pas deleted file mode 100644 index 8ed9e5b..0000000 --- a/synapse/synsock.pas +++ /dev/null @@ -1,77 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 005.002.001 | -|==============================================================================| -| Content: Socket Independent Platform Layer | -|==============================================================================| -| Copyright (c)1999-2011, 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)2001-2011. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@exclude} - -unit synsock; - -{$MINENUMSIZE 4} - -//old Delphi does not have MSWINDOWS define. -{$IFDEF WIN32} - {$IFNDEF MSWINDOWS} - {$DEFINE MSWINDOWS} - {$ENDIF} -{$ENDIF} - -{$IFDEF CIL} - {$I ssdotnet.inc} -{$ELSE} - {$IFDEF MSWINDOWS} - {$I sswin32.inc} - {$ELSE} - {$IFDEF WINCE} - {$I sswin32.inc} //not complete yet! - {$ELSE} - {$IFDEF FPC} - {$I ssfpc.inc} - {$ELSE} - {$I sslinux.inc} - {$ENDIF} - {$ENDIF} - {$ENDIF} -{$ENDIF} - -end. - diff --git a/synapse/tlntsend.pas b/synapse/tlntsend.pas deleted file mode 100644 index 557266c..0000000 --- a/synapse/tlntsend.pas +++ /dev/null @@ -1,364 +0,0 @@ -{==============================================================================| -| Project : Ararat Synapse | 001.003.001 | -|==============================================================================| -| Content: TELNET and SSH2 client | -|==============================================================================| -| Copyright (c)1999-2010, 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)2002-2010. | -| All Rights Reserved. | -|==============================================================================| -| Contributor(s): | -|==============================================================================| -| History: see HISTORY.HTM from distribution package | -| (Found at URL: http://www.ararat.cz/synapse/) | -|==============================================================================} - -{:@abstract(Telnet script client) - -Used RFC: RFC-854 -} - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} -{$H+} - -{$IFDEF UNICODE} - {$WARN IMPLICIT_STRING_CAST OFF} - {$WARN IMPLICIT_STRING_CAST_LOSS OFF} -{$ENDIF} - -unit tlntsend; - -interface - -uses - SysUtils, Classes, - blcksock, synautil; - -const - cTelnetProtocol = '23'; - cSSHProtocol = '22'; - - TLNT_EOR = #239; - TLNT_SE = #240; - TLNT_NOP = #241; - TLNT_DATA_MARK = #242; - TLNT_BREAK = #243; - TLNT_IP = #244; - TLNT_AO = #245; - TLNT_AYT = #246; - TLNT_EC = #247; - TLNT_EL = #248; - TLNT_GA = #249; - TLNT_SB = #250; - TLNT_WILL = #251; - TLNT_WONT = #252; - TLNT_DO = #253; - TLNT_DONT = #254; - 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/SSH 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; - FBuffer: Ansistring; - FState: TTelnetState; - FSessionLog: Ansistring; - FSubNeg: Ansistring; - FSubType: Ansichar; - FTermType: Ansistring; - function Connect: Boolean; - function Negotiate(const Buf: Ansistring): Ansistring; - procedure FilterHook(Sender: TObject; var Value: AnsiString); - public - constructor Create; - destructor Destroy; override; - - {:Connects to Telnet server.} - function Login: Boolean; - - {:Connects to SSH2 server and login by Username and Password properties. - - You must use some of SSL plugins with SSH support. For exammple CryptLib.} - function SSHLogin: 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: Ansistring read FSessionLog write FSessionLog; - - {:Terminal type indentification. By default is 'SYNAPSE'.} - property TermType: Ansistring read FTermType write FTermType; - end; - -implementation - -constructor TTelnetSend.Create; -begin - inherited Create; - FSock := TTCPBlockSocket.Create; - FSock.Owner := self; - FSock.OnReadFilter := FilterHook; - FTimeout := 60000; - FTargetPort := cTelnetProtocol; - FSubNeg := ''; - FSubType := #0; - FTermType := 'SYNAPSE'; -end; - -destructor TTelnetSend.Destroy; -begin - FSock.Free; - inherited Destroy; -end; - -function TTelnetSend.Connect: Boolean; -begin - // Do not call this function! It is calling by LOGIN method! - FBuffer := ''; - FSessionLog := ''; - FState := tsDATA; - FSock.CloseSocket; - FSock.LineBuffer := ''; - FSock.Bind(FIPInterface, cAnyPort); - FSock.Connect(FTargetHost, FTargetPort); - Result := FSock.LastError = 0; -end; - -function TTelnetSend.RecvTerminated(const Terminator: string): string; -begin - Result := FSock.RecvTerminated(FTimeout, Terminator); -end; - -function TTelnetSend.RecvString: string; -begin - Result := FSock.RecvTerminated(FTimeout, CRLF); -end; - -function TTelnetSend.WaitFor(const Value: string): Boolean; -begin - Result := FSock.RecvTerminated(FTimeout, Value) <> ''; -end; - -procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); -begin - Value := Negotiate(Value); - FSessionLog := FSessionLog + Value; -end; - -function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; -var - n: integer; - c: Ansichar; - Reply: Ansistring; - SubReply: Ansistring; -begin - Result := ''; - for n := 1 to Length(Buf) do - begin - c := Buf[n]; - Reply := ''; - case FState of - tsData: - if c = TLNT_IAC then - FState := tsIAC - else - Result := Result + c; - - tsIAC: - case c of - TLNT_IAC: - begin - FState := tsData; - Result := Result + TLNT_IAC; - end; - TLNT_WILL: - FState := tsIAC_WILL; - TLNT_WONT: - FState := tsIAC_WONT; - TLNT_DONT: - FState := tsIAC_DONT; - TLNT_DO: - FState := tsIAC_DO; - TLNT_EOR: - FState := tsDATA; - TLNT_SB: - begin - FState := tsIAC_SB; - FSubType := #0; - FSubNeg := ''; - end; - else - FState := tsData; - end; - - tsIAC_WILL: - begin - case c of - #3: //suppress GA - Reply := TLNT_DO; - else - Reply := TLNT_DONT; - end; - FState := tsData; - end; - - tsIAC_WONT: - begin - Reply := TLNT_DONT; - FState := tsData; - end; - - tsIAC_DO: - begin - case c of - #24: //termtype - Reply := TLNT_WILL; - else - Reply := TLNT_WONT; - end; - FState := tsData; - end; - - tsIAC_DONT: - begin - Reply := TLNT_WONT; - FState := tsData; - end; - - tsIAC_SB: - begin - FSubType := c; - FState := tsIAC_SBDATA; - end; - - tsIAC_SBDATA: - begin - if c = TLNT_IAC then - FState := tsSBDATA_IAC - else - FSubNeg := FSubNeg + c; - end; - - tsSBDATA_IAC: - case c of - TLNT_IAC: - begin - FState := tsIAC_SBDATA; - FSubNeg := FSubNeg + c; - end; - TLNT_SE: - begin - SubReply := ''; - case FSubType of - #24: //termtype - begin - if (FSubNeg <> '') and (FSubNeg[1] = #1) then - SubReply := #0 + FTermType; - end; - end; - Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); - FState := tsDATA; - end; - else - FState := tsDATA; - end; - - else - FState := tsData; - end; - if Reply <> '' then - Sock.SendString(TLNT_IAC + Reply + c); - end; - -end; - -procedure TTelnetSend.Send(const Value: string); -begin - Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); -end; - -function TTelnetSend.Login: Boolean; -begin - Result := False; - if not Connect then - Exit; - Result := True; -end; - -function TTelnetSend.SSHLogin: Boolean; -begin - Result := False; - if Connect then - begin - FSock.SSL.SSLType := LT_SSHv2; - FSock.SSL.Username := FUsername; - FSock.SSL.Password := FPassword; - FSock.SSLDoConnect; - Result := FSock.LastError = 0; - end; -end; - -procedure TTelnetSend.Logout; -begin - FSock.CloseSocket; -end; - - -end.