diff -Nru cqrprop-0.0.7/CHANGELOG cqrprop-0.0.8/CHANGELOG --- cqrprop-0.0.7/CHANGELOG 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/CHANGELOG 2023-04-10 12:51:00.000000000 +0000 @@ -4,6 +4,9 @@ - bugfix -------------------- +0.0.8 (2023-04-10) + - loading images over ssl fixed + 0.0.7 (2021-10-07) - loading images fixed diff -Nru cqrprop-0.0.7/debian/changelog cqrprop-0.0.8/debian/changelog --- cqrprop-0.0.7/debian/changelog 2021-10-07 19:06:14.000000000 +0000 +++ cqrprop-0.0.8/debian/changelog 2023-04-10 12:55:42.000000000 +0000 @@ -1,4 +1,10 @@ -cqrprop (0.0.7-1~focal) focal; urgency=low +cqrprop (0.0.8-1~focal) focal; urgency=low + + * loading images fixed + + -- Petr Hlozek Mon, 10 Apr 2023 14:41:35 +0100 + +cqrprop (0.0.7-1) unstable; urgency=low * loading images fixed diff -Nru cqrprop-0.0.7/src/fShowPropForm.lfm cqrprop-0.0.8/src/fShowPropForm.lfm --- cqrprop-0.0.7/src/fShowPropForm.lfm 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/fShowPropForm.lfm 2023-04-10 12:51:00.000000000 +0000 @@ -37,8 +37,8 @@ end end object popMenu: TPopupMenu[1] - left = 24 - top = 40 + Left = 24 + Top = 40 object MenuItem1: TMenuItem Action = acOptions end @@ -59,8 +59,8 @@ end end object acProp: TActionList[2] - left = 16 - top = 120 + Left = 16 + Top = 120 object acOptions: TAction Caption = 'Options' OnExecute = acOptionsExecute @@ -81,13 +81,13 @@ object tmrImageDownload: TTimer[3] Enabled = False OnTimer = tmrImageDownloadTimer - left = 64 - top = 192 + Left = 64 + Top = 192 end object tmrWait: TTimer[4] Enabled = False OnTimer = tmrWaitTimer - left = 64 - top = 256 + Left = 64 + Top = 256 end end diff -Nru cqrprop-0.0.7/src/fShowPropForm.pas cqrprop-0.0.8/src/fShowPropForm.pas --- cqrprop-0.0.7/src/fShowPropForm.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/fShowPropForm.pas 2023-04-10 12:51:00.000000000 +0000 @@ -6,7 +6,8 @@ uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, - Menus, ActnList, fCommon, httpsend, IniFiles, LazFileUtils, ssl_openssl_lib; + Menus, ActnList, fCommon, httpsend, IniFiles, LazFileUtils, ssl_openssl_lib, + ssl_openssl11, ssl_openssl11_lib, openssl, ssl_openssl; const USER_AGENT = 'Mozilla/5.0 (X11; Ubuntu; Linux x86_64; rv:93.0) Gecko/20100101 Firefox/93.0'; @@ -131,6 +132,9 @@ Mem.Seek(0, soFromBeginning); Mem.CopyFrom(Http.Document, 0); end + else begin + Writeln('DEBUG:', http.Sock.LastErrorDesc); + end; finally FreeAndNil(Http); FreeAndNil(Mem) diff -Nru cqrprop-0.0.7/src/synapse/asn1util.pas cqrprop-0.0.8/src/synapse/asn1util.pas --- cqrprop-0.0.7/src/synapse/asn1util.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/asn1util.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,521 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.001.001 | +|==============================================================================| +| Content: support for ASN.1 BER coding and decoding | +|==============================================================================| +| Copyright (c)1999-2021, 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-2021 | +| 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; + ASN1_COUNTER64 = $46; + +{:Encodes OID item to binary form.} +function ASNEncOIDItem(Value: Int64): AnsiString; + +{:Decodes an OID item of the next element in the "Buffer" from the "Start" + position.} +function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64; + +{: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: Int64): 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: Int64): AnsiString; +var + x: Int64; + xm: Byte; + 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): Int64; +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: Int64): AnsiString; +var + x: Int64; + y: byte; + neg: Boolean; +begin + neg := Value < 0; + x := Abs(Value); + if neg then + x := x - 1; + Result := ''; + repeat + y := x mod 256; + x := x div 256; + if neg then + y := not y; + Result := AnsiChar(y) + Result; + until x = 0; + if (not neg) and (Result[1] > #$7F) then + Result := #0 + Result; + if (neg) and (Result[1] < #$80) then + Result := #$FF + 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: int64; + 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, ASN1_COUNTER64: + 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: int64; + + function WalkInt(var s: String): int64; + 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 := StrToInt64Def(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: int64; + 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: '; + ASN1_COUNTER64: + Result := Result + ' COUNTER64: '; + 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 -Nru cqrprop-0.0.7/src/synapse/blcksock.pas cqrprop-0.0.8/src/synapse/blcksock.pas --- cqrprop-0.0.7/src/synapse/blcksock.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/blcksock.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 009.010.000 | +| Project : Ararat Synapse | 009.010.002 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2017, Lukas Gebauer | +| Copyright (c)1999-2021, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2017. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2021. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -96,6 +96,10 @@ {$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$ENDIF} +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + unit blcksock; interface @@ -104,11 +108,14 @@ SysUtils, Classes, synafpc, synsock, synautil, synacode, synaip -{$IFDEF CIL} - ,System.Net - ,System.Net.Sockets - ,System.Text -{$ENDIF} + {$IFDEF POSIX} + ,System.Generics.Collections, System.Generics.Defaults + {$ENDIF} + {$IfDef CIL} + ,System.Net + ,System.Net.Sockets + ,System.Text + {$EndIf} ; const @@ -245,6 +252,7 @@ LT_TLSv1, LT_TLSv1_1, LT_TLSv1_2, + LT_TLSv1_3, LT_SSHv2 ); @@ -274,6 +282,16 @@ TCustomSSL = class; TSSLClass = class of TCustomSSL; + TBlockSocket = class; + +{$IFDEF POSIX} + TOptionList = TList; + TSocketList = TList; +{$ELSE} + TOptionList = TList; + TSocketList = TList; +{$ENDIF} + {:@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), @@ -304,13 +322,13 @@ FFamilySave: TSocketFamily; FIP6used: Boolean; FPreferIP4: Boolean; - FDelayedOptions: TList; + FDelayedOptions: TOptionList; FInterPacketTimeout: Boolean; {$IFNDEF CIL} FFDSet: TFDSet; {$ENDIF} - FRecvCounter: Integer; - FSendCounter: Integer; + FRecvCounter: int64; + FSendCounter: int64; FSendMaxChunk: Integer; FStopFlag: Boolean; FNonblockSendTimeout: Integer; @@ -394,7 +412,7 @@ 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); + procedure Bind(const 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 @@ -422,7 +440,7 @@ {:Sends data of LENGTH from BUFFER address via connected socket. System automatically splits data to packets.} - function SendBuffer(Buffer: Tmemory; Length: Integer): Integer; virtual; + function SendBuffer(const Buffer: Tmemory; Length: Integer): Integer; virtual; {:One data BYTE is sent via connected socket.} procedure SendByte(Data: Byte); virtual; @@ -543,7 +561,7 @@ 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); + procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: int64); {:Receive data to stream. It using @link(RecvBlock) method.} procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual; @@ -663,7 +681,7 @@ {: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; + function SendBufferTo(const 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! @@ -683,8 +701,8 @@ 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; + function GroupCanRead(const SocketList: TSocketList; Timeout: Integer; + const CanReadList: TSocketList): 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 @@ -762,11 +780,11 @@ {:Return count of received bytes on this socket from begin of current connection.} - property RecvCounter: Integer read FRecvCounter; + property RecvCounter: int64 read FRecvCounter; {:Return count of sended bytes on this socket from begin of current connection.} - property SendCounter: Integer read FSendCounter; + property SendCounter: int64 read FSendCounter; published {:Return descriptive string for given error code. This is class function. You may call it without created object!} @@ -1039,7 +1057,7 @@ function GetRemoteSinPort: Integer; override; {:See @link(TBlockSocket.SendBuffer)} - function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override; {:See @link(TBlockSocket.RecvBuffer)} function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; @@ -1097,7 +1115,7 @@ procedure Connect(IP, Port: string); override; {:Silently redirected to @link(TBlockSocket.SendBufferTo).} - function SendBuffer(Buffer: TMemory; Length: Integer): Integer; override; + function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override; {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).} function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override; @@ -1126,7 +1144,7 @@ procedure EnableBroadcast(Value: Boolean); {:See @link(TBlockSocket.SendBufferTo)} - function SendBufferTo(Buffer: TMemory; Length: Integer): Integer; override; + function SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; override; {:See @link(TBlockSocket.RecvBufferFrom)} function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override; @@ -1320,8 +1338,8 @@ for fast remote side authentication.} function GetPeerNameHash: cardinal; virtual; - {:Return fingerprint of remote SSL peer.} - function GetPeerFingerprint: string; virtual; + {:Return fingerprint of remote SSL peer. (As binary nonprintable string!)} + function GetPeerFingerprint: AnsiString; virtual; {:Return all detailed information about certificate from remote side of SSL/TLS connection. Result string can be multilined! Each plugin can return @@ -1526,7 +1544,7 @@ {$ENDIF} begin inherited Create; - FDelayedOptions := TList.Create; + FDelayedOptions := TOptionList.Create; FRaiseExcept := False; {$IFDEF RAISEEXCEPT} FRaiseExcept := True; @@ -1749,7 +1767,7 @@ synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)); end; end; - Value.free; + Value.Free; end; procedure TBlockSocket.DelayedOption(const Value: TSynaOption); @@ -1896,7 +1914,7 @@ DoStatus(HR_SocketClose, ''); end; -procedure TBlockSocket.Bind(IP, Port: string); +procedure TBlockSocket.Bind(const IP, Port: string); var Sin: TVarSin; begin @@ -2015,7 +2033,7 @@ sleep(250); end; end; - Next := GetTick + Trunc((Length / MaxB) * 1000); + Next := GetTick + LongWord(Trunc((Length / MaxB) * 1000)); end; end; @@ -2032,7 +2050,7 @@ end; -function TBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +function TBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; {$IFNDEF CIL} var x, y: integer; @@ -2505,15 +2523,16 @@ until FLastError <> 0; end; -procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); +procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: int64); var s: AnsiString; - n: integer; + n: int64; {$IFDEF CIL} buf: TMemory; {$ENDIF} begin - for n := 1 to (Size div FSendMaxChunk) do + n := Size div int64(FSendMaxChunk); + while n > 0 do begin {$IFDEF CIL} SetLength(buf, FSendMaxChunk); @@ -2527,8 +2546,9 @@ Exit; WriteStrToStream(Stream, s); {$ENDIF} + dec(n); end; - n := Size mod FSendMaxChunk; + n := Size mod int64(FSendMaxChunk); if n > 0 then begin {$IFDEF CIL} @@ -2870,7 +2890,7 @@ Result := CanRead(Timeout); end; -function TBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; +function TBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; begin Result := 0; if TestStopFlag then @@ -2995,8 +3015,8 @@ end; {$IFNDEF CIL} -function TBlockSocket.GroupCanRead(const SocketList: TList; Timeout: Integer; - const CanReadList: TList): boolean; +function TBlockSocket.GroupCanRead(const SocketList: TSocketList; Timeout: Integer; + const CanReadList: TSocketList): boolean; var FDSet: TFDSet; TimeVal: PTimeVal; @@ -3554,7 +3574,7 @@ Result := RecvBufferFrom(Buffer, Length); end; -function TDgramBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +function TDgramBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; begin Result := SendBufferTo(Buffer, Length); end; @@ -3614,7 +3634,7 @@ end; end; -function TUDPBlockSocket.SendBufferTo(Buffer: TMemory; Length: Integer): Integer; +function TUDPBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; var SIp: string; SPort: integer; @@ -3676,7 +3696,7 @@ begin ip6 := StrToIp6(MCastIP); for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; + Multicast6.ipv6mr_multiaddr.{$IFDEF POSIX}s6_addr{$ELSE}u6_addr8{$ENDIF}[n] := Ip6[n]; Multicast6.ipv6mr_interface := 0; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, PAnsiChar(@Multicast6), SizeOf(Multicast6))); @@ -3703,7 +3723,7 @@ begin ip6 := StrToIp6(MCastIP); for n := 0 to 15 do - Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; + Multicast6.ipv6mr_multiaddr.{$IFDEF POSIX}s6_addr{$ELSE}u6_addr8{$ENDIF}[n] := Ip6[n]; Multicast6.ipv6mr_interface := 0; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, PAnsiChar(@Multicast6), SizeOf(Multicast6))); @@ -4020,7 +4040,7 @@ Result := inherited RecvBuffer(Buffer, Len); end; -function TTCPBlockSocket.SendBuffer(Buffer: TMemory; Length: Integer): Integer; +function TTCPBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer; var x, y: integer; l, r: integer; @@ -4308,7 +4328,7 @@ Result := ''; end; -function TCustomSSL.GetPeerFingerprint: string; +function TCustomSSL.GetPeerFingerprint: AnsiString; begin Result := ''; end; diff -Nru cqrprop-0.0.7/src/synapse/clamsend.pas cqrprop-0.0.8/src/synapse/clamsend.pas --- cqrprop-0.0.7/src/synapse/clamsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/clamsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,277 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/Crypt32.pas cqrprop-0.0.8/src/synapse/Crypt32.pas --- cqrprop-0.0.7/src/synapse/Crypt32.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/Crypt32.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,675 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: minimal support for crypt32 windows API | +|==============================================================================| +| Copyright (c)2018, Pepak | +| 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 Pepak (Czech Republic). | +| Portions created by Pepak are Copyright (c)2018. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +unit Crypt32; +// Pozor, tohle je naprosto minimalni mnozina toho, co Crypt32.dll nabizi. +// Prevedl jsem jen to, co jsem potreboval. + +interface + +uses + Windows; + +const + AdvapiLib = 'advapi32.dll'; + CryptoLib = 'crypt32.dll'; + CryptDlgLib = 'cryptdlg.dll'; + +type + HCERTSTORE = THandle; + HCRYPTPROV = THandle; + HCRYPTKEY = THandle; + PCRYPT_DATA_BLOB = ^CRYPT_DATA_BLOB; + CRYPT_DATA_BLOB = record + cbData: DWORD; + pbData: PByte; + end; + +const + CRYPT_EXPORTABLE = $00000001; + CRYPT_USER_PROTECTED = $00000002; + CRYPT_MACHINE_KEYSET = $00000020; + CRYPT_USER_KEYSET = $00001000; + +const + PKCS12_PREFER_CNG_KSP = $00000100; + PKCS12_ALWAYS_CNG_KSP = $00000200; + PKCS12_ALLOW_OVERWRITE_KEY = $00004000; + PKCS12_NO_PERSIST_KEY = $00008000; + PKCS12_INCLUDE_EXTENDED_PROPERTIES = $0010; + +type + CRYPT_ALGORITHM_IDENTIFIER = record + pszObjId: PAnsiChar; + Parameters: CRYPT_DATA_BLOB; + end; + CERT_PUBLIC_KEY_INFO = record + Algorithm: CRYPT_ALGORITHM_IDENTIFIER; + PublicKey: CRYPT_DATA_BLOB; + end; + PCERT_EXTENSION = ^CERT_EXTENSION; + CERT_EXTENSION = record + pszObjId: PAnsiChar; + bCritical: BOOL; + Value: CRYPT_DATA_BLOB; + end; + PCERT_INFO = ^CERT_INFO; + CERT_INFO = record + dwVersion: DWORD; + SerialNumber: CRYPT_DATA_BLOB; + SignatureAlgorithm: CRYPT_ALGORITHM_IDENTIFIER; + Issuer: CRYPT_DATA_BLOB; + NotBefore: FILETIME; + NotAfter: FILETIME; + Subject: CRYPT_DATA_BLOB; + SubjectPublicKeyInfo: CERT_PUBLIC_KEY_INFO; + IssuerUniqueId: CRYPT_DATA_BLOB; + SubjectUniqueId: CRYPT_DATA_BLOB; + cExtension: DWORD; + rgExtension: PCERT_EXTENSION; + end; + PPCCERT_CONTEXT = ^PCCERT_CONTEXT; + PCCERT_CONTEXT = ^CERT_CONTEXT; + CERT_CONTEXT = record + dwCertEncodingType: DWORD; + pbCertEncoded: PByte; + cbCertEncoded: DWORD; + pCertInfo: PCERT_INFO; + hCertStore: HCERTSTORE; + end; + PCRYPT_KEY_PROV_PARAM = ^CRYPT_KEY_PROV_PARAM; + CRYPT_KEY_PROV_PARAM = record + dwParam: DWORD; + pbData: PByte; + cbData: DWORD; + dwFlags: DWORD; + end; + PCRYPT_KEY_PROV_INFO = ^CRYPT_KEY_PROV_INFO; + CRYPT_KEY_PROV_INFO = record + pwszContainerName: PWideChar; + pwszProvName: PWideChar; + dwProvType: DWORD; + dwFlags: DWORD; + cProvParam: DWORD; + rgProvParam: PCRYPT_KEY_PROV_PARAM; + dwKeySpec: DWORD; + __dummy: array[0..65535] of byte; + end; + PCRYPT_HASH_BLOB = ^CRYPT_HASH_BLOB; + CRYPT_HASH_BLOB = record + cbData: DWORD; + pbData: Pointer; + end; + PCRL_ENTRY = ^CRL_ENTRY; + CRL_ENTRY = record + SerialNumber: CRYPT_DATA_BLOB; + RevocationDate: FILETIME; + cExtension: DWORD; + rgExtension: PCERT_EXTENSION; + end; + PCRL_INFO = ^CRL_INFO; + CRL_INFO = record + dwVersion: DWORD; + SignatureAlgorithm: CRYPT_ALGORITHM_IDENTIFIER; + Issuer: CRYPT_DATA_BLOB; + ThisUpdate: FILETIME; + NextUpdate: FILETIME; + cCRLEntry: DWORD; + rgCRLEntry: PCRL_ENTRY; + cExtension: DWORD; + rgExtension: PCERT_EXTENSION; + end; + PCCRL_CONTEXT = ^CRL_CONTEXT; + CRL_CONTEXT = record + dwCertEncodingType: DWORD; + pbCrlEncoded: Pointer; + cbCrlEncoded: DWORD; + pCrlInfo: PCRL_INFO; + hCertStore: HCERTSTORE; + end; + PCRYPT_ATTRIBUTE = ^CRYPT_ATTRIBUTE; + CRYPT_ATTRIBUTE = record + pszObjId: LPSTR; + cValue: DWORD; + rgValue: PCRYPT_DATA_BLOB; + end; + PCRYPT_SIGN_MESSAGE_PARA = ^CRYPT_SIGN_MESSAGE_PARA; + CRYPT_SIGN_MESSAGE_PARA = record + cbSize: DWORD; + dwMsgEncodingType: DWORD; + pSigningCert: PCCERT_CONTEXT; + HashAlgorithm: CRYPT_ALGORITHM_IDENTIFIER; + pvHashAuxInfo: Pointer; + cMsgCert: DWORD; + rgpMsgCert: PCCERT_CONTEXT; + cMsgCrl: DWORD; + rgpMsgCrl: PCCRL_CONTEXT; + cAuthAttr: DWORD; + rgAuthAttr: PCRYPT_ATTRIBUTE; + cUnauthAttr: DWORD; + rgUnauthAttr: PCRYPT_ATTRIBUTE; + dwFlags: DWORD; + dwInnerContentType: DWORD; + HashEncryptionAlgorithm: CRYPT_ALGORITHM_IDENTIFIER; + pvHashEncryptionAuxInfo: Pointer; + end; + PPtrArray = ^TPtrArray; + TPtrArray = array[0..32767] of Pointer; + PDWORDArray = ^TDWORDArray; + TDWORDArray = array[0..32767] of DWORD; + +const + CERT_STORE_PROV_MSG = LPCSTR(1); + CERT_STORE_PROV_MEMORY = LPCSTR(2); + CERT_STORE_PROV_FILE = LPCSTR(3); + CERT_STORE_PROV_REG = LPCSTR(4); + CERT_STORE_PROV_PKCS7 = LPCSTR(5); + CERT_STORE_PROV_SERIALIZED = LPCSTR(6); + CERT_STORE_PROV_FILENAME_A = LPCSTR(7); + CERT_STORE_PROV_FILENAME_W = LPCSTR(8); + CERT_STORE_PROV_FILENAME = CERT_STORE_PROV_FILENAME_W; + CERT_STORE_PROV_SYSTEM_A = LPCSTR(9); + CERT_STORE_PROV_SYSTEM_W = LPCSTR(10); + CERT_STORE_PROV_SYSTEM = CERT_STORE_PROV_SYSTEM_W; + CERT_STORE_PROV_COLLECTION = LPCSTR(11); + CERT_STORE_PROV_SYSTEM_REGISTRY_A = LPCSTR(12); + CERT_STORE_PROV_SYSTEM_REGISTRY_W = LPCSTR(13); + CERT_STORE_PROV_SYSTEM_REGISTRY = CERT_STORE_PROV_SYSTEM_REGISTRY_W; + CERT_STORE_PROV_PHYSICAL_W = LPCSTR(14); + CERT_STORE_PROV_PHYSICAL = CERT_STORE_PROV_PHYSICAL_W; + CERT_STORE_PROV_SMART_CARD_W = LPCSTR(15); + CERT_STORE_PROV_SMART_CARD = CERT_STORE_PROV_SMART_CARD_W; + CERT_STORE_PROV_LDAP_W = LPCSTR(16); + CERT_STORE_PROV_LDAP = CERT_STORE_PROV_LDAP_W; + sz_CERT_STORE_PROV_MEMORY = 'Memory'; + sz_CERT_STORE_PROV_FILENAME_W = 'File'; + sz_CERT_STORE_PROV_FILENAME = sz_CERT_STORE_PROV_FILENAME_W; + sz_CERT_STORE_PROV_SYSTEM_W = 'System'; + sz_CERT_STORE_PROV_SYSTEM = sz_CERT_STORE_PROV_SYSTEM_W; + sz_CERT_STORE_PROV_PKCS7 = 'PKCS7'; + sz_CERT_STORE_PROV_SERIALIZED = 'Serialized'; + sz_CERT_STORE_PROV_COLLECTION = 'Collection'; + sz_CERT_STORE_PROV_SYSTEM_REGISTRY_W = 'SystemRegistry'; + sz_CERT_STORE_PROV_SYSTEM_REGISTRY = sz_CERT_STORE_PROV_SYSTEM_REGISTRY_W; + sz_CERT_STORE_PROV_PHYSICAL_W = 'Physical'; + sz_CERT_STORE_PROV_PHYSICAL = sz_CERT_STORE_PROV_PHYSICAL_W; + sz_CERT_STORE_PROV_SMART_CARD_W = 'SmartCard'; + sz_CERT_STORE_PROV_SMART_CARD = sz_CERT_STORE_PROV_SMART_CARD_W; + sz_CERT_STORE_PROV_LDAP_W = 'Ldap'; + sz_CERT_STORE_PROV_LDAP = sz_CERT_STORE_PROV_LDAP_W; + +const + X509_ASN_ENCODING = 1; + PKCS_7_ASN_ENCODING = 65536; + +const + CERT_SYSTEM_STORE_UNPROTECTED_FLAG = $40000000; + CERT_SYSTEM_STORE_LOCATION_MASK = $ff0000; + CERT_SYSTEM_STORE_LOCATION_SHIFT = 16; + CERT_SYSTEM_STORE_CURRENT_USER_ID = 1; + CERT_SYSTEM_STORE_LOCAL_MACHINE_ID = 2; + CERT_SYSTEM_STORE_CURRENT_SERVICE_ID = 4; + CERT_SYSTEM_STORE_SERVICES_ID = 5; + CERT_SYSTEM_STORE_USERS_ID = 6; + CERT_SYSTEM_STORE_CURRENT_USER_GROUP_POLICY_ID = 7; + CERT_SYSTEM_STORE_LOCAL_MACHINE_GROUP_POLICY_ID = 8; + CERT_SYSTEM_STORE_LOCAL_MACHINE_ENTERPRISE_ID = 9; + CERT_SYSTEM_STORE_CURRENT_USER = (CERT_SYSTEM_STORE_CURRENT_USER_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_LOCAL_MACHINE = (CERT_SYSTEM_STORE_LOCAL_MACHINE_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_CURRENT_SERVICE = (CERT_SYSTEM_STORE_CURRENT_SERVICE_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_SERVICES = (CERT_SYSTEM_STORE_SERVICES_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_USERS = (CERT_SYSTEM_STORE_USERS_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_CURRENT_USER_GROUP_POLICY = (CERT_SYSTEM_STORE_CURRENT_USER_GROUP_POLICY_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_LOCAL_MACHINE_GROUP_POLICY = (CERT_SYSTEM_STORE_LOCAL_MACHINE_GROUP_POLICY_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_SYSTEM_STORE_LOCAL_MACHINE_ENTERPRISE = (CERT_SYSTEM_STORE_LOCAL_MACHINE_ENTERPRISE_ID shl CERT_SYSTEM_STORE_LOCATION_SHIFT); + CERT_STORE_READONLY_FLAG = $8000; + +const + CERT_FIND_ANY = 0; + CERT_FIND_CERT_ID = 1048576; + CERT_FIND_CTL_USAGE = 655360; + CERT_FIND_ENHKEY_USAGE = 655360; + CERT_FIND_EXISTING = 851968; + CERT_FIND_HASH = 65536; + CERT_FIND_ISSUER_ATTR = 196612; + CERT_FIND_ISSUER_NAME = 131076; + CERT_FIND_ISSUER_OF = 786432; + CERT_FIND_KEY_IDENTIFIER = 983040; + CERT_FIND_KEY_SPEC = 589824; + CERT_FIND_MD5_HASH = 262144; + CERT_FIND_PROPERTY = 327680; + CERT_FIND_PUBLIC_KEY = 393216; + CERT_FIND_SHA1_HASH = 65536; + CERT_FIND_SIGNATURE_HASH = 917504; + CERT_FIND_SUBJECT_ATTR = 196615; + CERT_FIND_SUBJECT_CERT = 720896; + CERT_FIND_SUBJECT_NAME = 131079; + CERT_FIND_SUBJECT_STR_A = 458759; + CERT_FIND_SUBJECT_STR_W = 524295; + CERT_FIND_ISSUER_STR_A = 458756; + CERT_FIND_ISSUER_STR_W = 524292; + CERT_FIND_OR_ENHKEY_USAGE_FLAG = 16; + CERT_FIND_OPTIONAL_ENHKEY_USAGE_FLAG = 1; + CERT_FIND_NO_ENHKEY_USAGE_FLAG = 8; + CERT_FIND_VALID_ENHKEY_USAGE_FLAG = 32; + CERT_FIND_EXT_ONLY_ENHKEY_USAGE_FLAG = 2; + +const + CERT_NAME_EMAIL_TYPE = 1; + CERT_NAME_RDN_TYPE = 2; + CERT_NAME_ATTR_TYPE = 3; + CERT_NAME_SIMPLE_DISPLAY_TYPE = 4; + CERT_NAME_FRIENDLY_DISPLAY_TYPE = 5; + CERT_NAME_DNS_TYPE = 6; + CERT_NAME_URL_TYPE = 7; + CERT_NAME_UPN_TYPE = 8; + +const + CERT_NAME_ISSUER_FLAG = 1; + +const + CERT_KEY_PROV_HANDLE_PROP_ID = 1; + CERT_KEY_PROV_INFO_PROP_ID = 2; + CERT_SHA1_HASH_PROP_ID = 3; + CERT_MD5_HASH_PROP_ID = 4; + CERT_HASH_PROP_ID = CERT_SHA1_HASH_PROP_ID; + CERT_KEY_CONTEXT_PROP_ID = 5; + CERT_KEY_SPEC_PROP_ID = 6; + CERT_IE30_RESERVED_PROP_ID = 7; + CERT_PUBKEY_HASH_RESERVED_PROP_ID = 8; + CERT_ENHKEY_USAGE_PROP_ID = 9; + CERT_CTL_USAGE_PROP_ID = CERT_ENHKEY_USAGE_PROP_ID; + CERT_NEXT_UPDATE_LOCATION_PROP_ID = 10; + CERT_FRIENDLY_NAME_PROP_ID = 11; + CERT_PVK_FILE_PROP_ID = 12; + CERT_DESCRIPTION_PROP_ID = 13; + CERT_ACCESS_STATE_PROP_ID = 14; + CERT_SIGNATURE_HASH_PROP_ID = 15; + CERT_SMART_CARD_DATA_PROP_ID = 16; + CERT_EFS_PROP_ID = 17; + CERT_FORTEZZA_DATA_PROP_ID = 18; + CERT_ARCHIVED_PROP_ID = 19; + CERT_KEY_IDENTIFIER_PROP_ID = 20; + CERT_AUTO_ENROLL_PROP_ID = 21; + CERT_PUBKEY_ALG_PARA_PROP_ID = 22; + CERT_CROSS_CERT_DIST_POINTS_PROP_ID = 23; + CERT_ISSUER_PUBLIC_KEY_MD5_HASH_PROP_ID = 24; + CERT_SUBJECT_PUBLIC_KEY_MD5_HASH_PROP_ID = 25; + CERT_ENROLLMENT_PROP_ID = 26; + CERT_DATE_STAMP_PROP_ID = 27; + CERT_ISSUER_SERIAL_NUMBER_MD5_HASH_PROP_ID = 28; + CERT_SUBJECT_NAME_MD5_HASH_PROP_ID = 29; + CERT_EXTENDED_ERROR_INFO_PROP_ID = 30; + CERT_RENEWAL_PROP_ID = 64; + CERT_ARCHIVED_KEY_HASH_PROP_ID = 65; + CERT_AUTO_ENROLL_RETRY_PROP_ID = 66; + CERT_AIA_URL_RETRIEVED_PROP_ID = 67; + CERT_AUTHORITY_INFO_ACCESS_PROP_ID = 68; + CERT_BACKED_UP_PROP_ID = 69; + CERT_OCSP_RESPONSE_PROP_ID = 70; + CERT_REQUEST_ORIGINATOR_PROP_ID = 71; + CERT_SOURCE_LOCATION_PROP_ID = 72; + CERT_SOURCE_URL_PROP_ID = 73; + CERT_NEW_KEY_PROP_ID = 74; + CERT_OCSP_CACHE_PREFIX_PROP_ID = 75; + CERT_SMART_CARD_ROOT_INFO_PROP_ID = 76; + CERT_NO_AUTO_EXPIRE_CHECK_PROP_ID = 77; + CERT_NCRYPT_KEY_HANDLE_PROP_ID = 78; + CERT_HCRYPTPROV_OR_NCRYPT_KEY_HANDLE_PROP_ID = 79; + CERT_SUBJECT_INFO_ACCESS_PROP_ID = 80; + CERT_CA_OCSP_AUTHORITY_INFO_ACCESS_PROP_ID = 81; + CERT_CA_DISABLE_CRL_PROP_ID = 82; + CERT_ROOT_PROGRAM_CERT_POLICIES_PROP_ID = 83; + CERT_ROOT_PROGRAM_NAME_CONSTRAINTS_PROP_ID = 84; + CERT_SUBJECT_OCSP_AUTHORITY_INFO_ACCESS_PROP_ID = 85; + CERT_SUBJECT_DISABLE_CRL_PROP_ID = 86; + CERT_CEP_PROP_ID = 87; + CERT_SIGN_HASH_CNG_ALG_PROP_ID = 89; + CERT_SCARD_PIN_ID_PROP_ID = 90; + CERT_SCARD_PIN_INFO_PROP_ID = 91; + CERT_SUBJECT_PUB_KEY_BIT_LENGTH_PROP_ID = 92; + CERT_PUB_KEY_CNG_ALG_BIT_LENGTH_PROP_ID = 93; + CERT_ISSUER_PUB_KEY_BIT_LENGTH_PROP_ID = 94; + CERT_ISSUER_CHAIN_SIGN_HASH_CNG_ALG_PROP_ID = 95; + CERT_ISSUER_CHAIN_PUB_KEY_CNG_ALG_BIT_LENGTH_PROP_ID = 96; + CERT_NO_EXPIRE_NOTIFICATION_PROP_ID = 97; + CERT_AUTH_ROOT_SHA256_HASH_PROP_ID = 98; + CERT_NCRYPT_KEY_HANDLE_TRANSFER_PROP_ID = 99; + CERT_HCRYPTPROV_TRANSFER_PROP_ID = 100; + CERT_SMART_CARD_READER_PROP_ID = 101; + CERT_SEND_AS_TRUSTED_ISSUER_PROP_ID = 102; + CERT_KEY_REPAIR_ATTEMPTED_PROP_ID = 103; + CERT_DISALLOWED_FILETIME_PROP_ID = 104; + CERT_ROOT_PROGRAM_CHAIN_POLICIES_PROP_ID = 105; + CERT_SMART_CARD_READER_NON_REMOVABLE_PROP_ID = 106; + + CERT_FIRST_RESERVED_PROP_ID = 107; + CERT_LAST_RESERVED_PROP_ID = $00007fff; + CERT_FIRST_USER_PROP_ID = $8000; + CERT_LAST_USER_PROP_ID = $0000ffff; + +const + CRYPT_DELETEKEYSET = 16; + +const + CRYPT_E_NOT_FOUND = $80092004; + +const + CRYPT_ACQUIRE_CACHE_FLAG = $1; + CRYPT_ACQUIRE_USE_PROV_INFO_FLAG = $2; + CRYPT_ACQUIRE_COMPARE_KEY_FLAG = $4; + CRYPT_ACQUIRE_NO_HEALING = $8; + CRYPT_ACQUIRE_SILENT_FLAG = $40; + CRYPT_ACQUIRE_WINDOW_HANDLE_FLAG = $80; + + CRYPT_ACQUIRE_NCRYPT_KEY_FLAGS_MASK = $70000; + CRYPT_ACQUIRE_ALLOW_NCRYPT_KEY_FLAG = $10000; + CRYPT_ACQUIRE_PREFER_NCRYPT_KEY_FLAG = $20000; + CRYPT_ACQUIRE_ONLY_NCRYPT_KEY_FLAG = $40000; + +const + szOID_RSA = '1.2.840.113549'; + szOID_PKCS = '1.2.840.113549.1'; + szOID_RSA_HASH = '1.2.840.113549.2'; + szOID_RSA_ENCRYPT = '1.2.840.113549.3'; + + szOID_PKCS_1 = '1.2.840.113549.1.1'; + szOID_PKCS_2 = '1.2.840.113549.1.2'; + szOID_PKCS_3 = '1.2.840.113549.1.3'; + szOID_PKCS_4 = '1.2.840.113549.1.4'; + szOID_PKCS_5 = '1.2.840.113549.1.5'; + szOID_PKCS_6 = '1.2.840.113549.1.6'; + szOID_PKCS_7 = '1.2.840.113549.1.7'; + szOID_PKCS_8 = '1.2.840.113549.1.8'; + szOID_PKCS_9 = '1.2.840.113549.1.9'; + szOID_PKCS_10 = '1.2.840.113549.1.10'; + szOID_PKCS_12 = '1.2.840.113549.1.12'; + + szOID_RSA_RSA = '1.2.840.113549.1.1.1'; + szOID_RSA_MD2RSA = '1.2.840.113549.1.1.2'; + szOID_RSA_MD4RSA = '1.2.840.113549.1.1.3'; + szOID_RSA_MD5RSA = '1.2.840.113549.1.1.4'; + szOID_RSA_SHA1RSA = '1.2.840.113549.1.1.5'; + szOID_RSA_SETOAEP_RSA = '1.2.840.113549.1.1.6'; + + szOID_RSAES_OAEP = '1.2.840.113549.1.1.7'; + szOID_RSA_MGF1 = '1.2.840.113549.1.1.8'; + szOID_RSA_PSPECIFIED = '1.2.840.113549.1.1.9'; + szOID_RSA_SSA_PSS = '1.2.840.113549.1.1.10'; + szOID_RSA_SHA256RSA = '1.2.840.113549.1.1.11'; + szOID_RSA_SHA384RSA = '1.2.840.113549.1.1.12'; + szOID_RSA_SHA512RSA = '1.2.840.113549.1.1.13'; + + szOID_RSA_DH = '1.2.840.113549.1.3.1'; + + szOID_RSA_data = '1.2.840.113549.1.7.1'; + szOID_RSA_signedData = '1.2.840.113549.1.7.2'; + szOID_RSA_envelopedData = '1.2.840.113549.1.7.3'; + szOID_RSA_signEnvData = '1.2.840.113549.1.7.4'; + szOID_RSA_digestedData = '1.2.840.113549.1.7.5'; + szOID_RSA_hashedData = '1.2.840.113549.1.7.5'; + szOID_RSA_encryptedData = '1.2.840.113549.1.7.6'; + + szOID_RSA_emailAddr = '1.2.840.113549.1.9.1'; + szOID_RSA_unstructName = '1.2.840.113549.1.9.2'; + szOID_RSA_contentType = '1.2.840.113549.1.9.3'; + szOID_RSA_messageDigest = '1.2.840.113549.1.9.4'; + szOID_RSA_signingTime = '1.2.840.113549.1.9.5'; + szOID_RSA_counterSign = '1.2.840.113549.1.9.6'; + szOID_RSA_challengePwd = '1.2.840.113549.1.9.7'; + szOID_RSA_unstructAddr = '1.2.840.113549.1.9.8'; + szOID_RSA_extCertAttrs = '1.2.840.113549.1.9.9'; + szOID_RSA_certExtensions = '1.2.840.113549.1.9.14'; + szOID_RSA_SMIMECapabilities = '1.2.840.113549.1.9.15'; + szOID_RSA_preferSignedData = '1.2.840.113549.1.9.15.1'; + + szOID_TIMESTAMP_TOKEN = '1.2.840.113549.1.9.16.1.4'; + szOID_RFC3161_counterSign = '1.3.6.1.4.1.311.3.3.1'; + + szOID_RSA_SMIMEalg = '1.2.840.113549.1.9.16.3'; + szOID_RSA_SMIMEalgESDH = '1.2.840.113549.1.9.16.3.5'; + szOID_RSA_SMIMEalgCMS3DESwrap = '1.2.840.113549.1.9.16.3.6'; + szOID_RSA_SMIMEalgCMSRC2wrap = '1.2.840.113549.1.9.16.3.7'; + + szOID_RSA_MD2 = '1.2.840.113549.2.2'; + szOID_RSA_MD4 = '1.2.840.113549.2.4'; + szOID_RSA_MD5 = '1.2.840.113549.2.5'; + + szOID_RSA_RC2CBC = '1.2.840.113549.3.2'; + szOID_RSA_RC4 = '1.2.840.113549.3.4'; + szOID_RSA_DES_EDE3_CBC = '1.2.840.113549.3.7'; + szOID_RSA_RC5_CBCPad = '1.2.840.113549.3.9'; + + szOID_ANSI_X942 = '1.2.840.10046'; + szOID_ANSI_X942_DH = '1.2.840.10046.2.1'; + + szOID_X957 = '1.2.840.10040'; + szOID_X957_DSA = '1.2.840.10040.4.1'; + szOID_X957_SHA1DSA = '1.2.840.10040.4.3'; + + szOID_ECC_PUBLIC_KEY = '1.2.840.10045.2.1'; + szOID_ECC_CURVE_P256 = '1.2.840.10045.3.1.7'; + szOID_ECC_CURVE_P384 = '1.3.132.0.34'; + szOID_ECC_CURVE_P521 = '1.3.132.0.35'; + szOID_ECDSA_SHA1 = '1.2.840.10045.4.1'; + szOID_ECDSA_SPECIFIED = '1.2.840.10045.4.3'; + szOID_ECDSA_SHA256 = '1.2.840.10045.4.3.2'; + szOID_ECDSA_SHA384 = '1.2.840.10045.4.3.3'; + szOID_ECDSA_SHA512 = '1.2.840.10045.4.3.4'; + + szOID_NIST_AES128_CBC = '2.16.840.1.101.3.4.1.2'; + szOID_NIST_AES192_CBC = '2.16.840.1.101.3.4.1.22'; + szOID_NIST_AES256_CBC = '2.16.840.1.101.3.4.1.42'; + + szOID_NIST_AES128_WRAP = '2.16.840.1.101.3.4.1.5'; + szOID_NIST_AES192_WRAP = '2.16.840.1.101.3.4.1.25'; + szOID_NIST_AES256_WRAP = '2.16.840.1.101.3.4.1.45'; + + szOID_DH_SINGLE_PASS_STDDH_SHA1_KDF = '1.3.133.16.840.63.0.2'; + szOID_DH_SINGLE_PASS_STDDH_SHA256_KDF = '1.3.132.1.11.1'; + szOID_DH_SINGLE_PASS_STDDH_SHA384_KDF = '1.3.132.1.11.2'; + + szOID_DS = '2.5'; + szOID_DSALG = '2.5.8'; + szOID_DSALG_CRPT = '2.5.8.1'; + szOID_DSALG_HASH = '2.5.8.2'; + szOID_DSALG_SIGN = '2.5.8.3'; + szOID_DSALG_RSA = '2.5.8.1.1'; + + szOID_OIW = '1.3.14'; + + szOID_OIWSEC = '1.3.14.3.2'; + szOID_OIWSEC_md4RSA = '1.3.14.3.2.2'; + szOID_OIWSEC_md5RSA = '1.3.14.3.2.3'; + szOID_OIWSEC_md4RSA2 = '1.3.14.3.2.4'; + szOID_OIWSEC_desECB = '1.3.14.3.2.6'; + szOID_OIWSEC_desCBC = '1.3.14.3.2.7'; + szOID_OIWSEC_desOFB = '1.3.14.3.2.8'; + szOID_OIWSEC_desCFB = '1.3.14.3.2.9'; + szOID_OIWSEC_desMAC = '1.3.14.3.2.10'; + szOID_OIWSEC_rsaSign = '1.3.14.3.2.11'; + szOID_OIWSEC_dsa = '1.3.14.3.2.12'; + szOID_OIWSEC_shaDSA = '1.3.14.3.2.13'; + szOID_OIWSEC_mdc2RSA = '1.3.14.3.2.14'; + szOID_OIWSEC_shaRSA = '1.3.14.3.2.15'; + szOID_OIWSEC_dhCommMod = '1.3.14.3.2.16'; + szOID_OIWSEC_desEDE = '1.3.14.3.2.17'; + szOID_OIWSEC_sha = '1.3.14.3.2.18'; + szOID_OIWSEC_mdc2 = '1.3.14.3.2.19'; + szOID_OIWSEC_dsaComm = '1.3.14.3.2.20'; + szOID_OIWSEC_dsaCommSHA = '1.3.14.3.2.21'; + szOID_OIWSEC_rsaXchg = '1.3.14.3.2.22'; + szOID_OIWSEC_keyHashSeal = '1.3.14.3.2.23'; + szOID_OIWSEC_md2RSASign = '1.3.14.3.2.24'; + szOID_OIWSEC_md5RSASign = '1.3.14.3.2.25'; + szOID_OIWSEC_sha1 = '1.3.14.3.2.26'; + szOID_OIWSEC_dsaSHA1 = '1.3.14.3.2.27'; + szOID_OIWSEC_dsaCommSHA1 = '1.3.14.3.2.28'; + szOID_OIWSEC_sha1RSASign = '1.3.14.3.2.29'; + + szOID_OIWDIR = '1.3.14.7.2'; + szOID_OIWDIR_CRPT = '1.3.14.7.2.1'; + szOID_OIWDIR_HASH = '1.3.14.7.2.2'; + szOID_OIWDIR_SIGN = '1.3.14.7.2.3'; + szOID_OIWDIR_md2 = '1.3.14.7.2.2.1'; + szOID_OIWDIR_md2RSA = '1.3.14.7.2.3.1'; + + szOID_INFOSEC = '2.16.840.1.101.2.1'; + szOID_INFOSEC_sdnsSignature = '2.16.840.1.101.2.1.1.1'; + szOID_INFOSEC_mosaicSignature = '2.16.840.1.101.2.1.1.2'; + szOID_INFOSEC_sdnsConfidentiality = '2.16.840.1.101.2.1.1.3'; + szOID_INFOSEC_mosaicConfidentiality = '2.16.840.1.101.2.1.1.4'; + szOID_INFOSEC_sdnsIntegrity = '2.16.840.1.101.2.1.1.5'; + szOID_INFOSEC_mosaicIntegrity = '2.16.840.1.101.2.1.1.6'; + szOID_INFOSEC_sdnsTokenProtection = '2.16.840.1.101.2.1.1.7'; + szOID_INFOSEC_mosaicTokenProtection = '2.16.840.1.101.2.1.1.8'; + szOID_INFOSEC_sdnsKeyManagement = '2.16.840.1.101.2.1.1.9'; + szOID_INFOSEC_mosaicKeyManagement = '2.16.840.1.101.2.1.1.10'; + szOID_INFOSEC_sdnsKMandSig = '2.16.840.1.101.2.1.1.11'; + szOID_INFOSEC_mosaicKMandSig = '2.16.840.1.101.2.1.1.12'; + szOID_INFOSEC_SuiteASignature = '2.16.840.1.101.2.1.1.13'; + szOID_INFOSEC_SuiteAConfidentiality = '2.16.840.1.101.2.1.1.14'; + szOID_INFOSEC_SuiteAIntegrity = '2.16.840.1.101.2.1.1.15'; + szOID_INFOSEC_SuiteATokenProtection = '2.16.840.1.101.2.1.1.16'; + szOID_INFOSEC_SuiteAKeyManagement = '2.16.840.1.101.2.1.1.17'; + szOID_INFOSEC_SuiteAKMandSig = '2.16.840.1.101.2.1.1.18'; + szOID_INFOSEC_mosaicUpdatedSig = '2.16.840.1.101.2.1.1.19'; + szOID_INFOSEC_mosaicKMandUpdSig = '2.16.840.1.101.2.1.1.20'; + szOID_INFOSEC_mosaicUpdatedInteg = '2.16.840.1.101.2.1.1.21'; + + szOID_NIST_sha256 = '2.16.840.1.101.3.4.2.1'; + szOID_NIST_sha384 = '2.16.840.1.101.3.4.2.2'; + szOID_NIST_sha512 = '2.16.840.1.101.3.4.2.3'; + +const + CERT_STORE_ADD_NEW = 1; + CERT_STORE_ADD_USE_EXISTING = 2; + CERT_STORE_ADD_REPLACE_EXISTING = 3; + CERT_STORE_ADD_ALWAYS = 4; + CERT_STORE_ADD_REPLACE_EXISTING_INHERIT_PROPERTIES = 5; + CERT_STORE_ADD_NEWER = 6; + CERT_STORE_ADD_NEWER_INHERIT_PROPERTIES = 7; + +function PFXImportCertStore(pPFX: PCRYPT_DATA_BLOB; szPassword: PWideChar; dwFlags: DWORD): HCERTSTORE; stdcall; external CryptoLib; +function CertOpenSystemStore(hProv: HCRYPTPROV; szSubsystemProtocol: PChar): HCERTSTORE; stdcall; external CryptoLib name {$IFDEF UNICODE} 'CertOpenSystemStoreW' {$ELSE} 'CertOpenSystemStoreA' {$ENDIF} ; +function CertOpenStore(szStoreProvider: LPCSTR; dwMsgAndCertEncodingType: DWORD; hCryptProv: HCRYPTPROV; dwFlags: DWORD; pvPara: Pointer): HCERTSTORE; stdcall; external CryptoLib name 'CertOpenStore'; +function CertCloseStore(hCertStore: HCERTSTORE; dwFlags: DWORD): BOOL; stdcall; external CryptoLib; +function CertEnumCertificatesInStore(hCertStore: HCERTSTORE; pPrevCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT; stdcall; external CryptoLib; +function CertFindCertificateInStore(hCertStore: HCERTSTORE; dwCertEncodingType: DWORD; dwFindFlags: DWORD; dwFindType: DWORD; pvFindPara: Pointer; pPrevCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT; stdcall; external CryptoLib; +function CertFreeCertificateContext(pCertContext: PCCERT_CONTEXT): BOOL; stdcall; external CryptoLib; +function CertDuplicateCertificateContext(pCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT; stdcall; external CryptoLib; +function CertGetNameStringA(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer; pszNameString: PAnsiChar; cchNameString: DWORD): DWORD; stdcall; external CryptoLib name 'CertGetNameStringA'; +function CertGetNameStringW(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer; pszNameString: PWideChar; cchNameString: DWORD): DWORD; stdcall; external CryptoLib name 'CertGetNameStringW'; +function CertGetNameString(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer; pszNameString: PChar; cchNameString: DWORD): DWORD; stdcall; external CryptoLib name {$IFDEF UNICODE} 'CertGetNameStringW' {$ELSE} 'CertGetNameStringA' {$ENDIF} ; +function GetFriendlyNameOfCert(pCertContext: PCCERT_CONTEXT; pchBuffer: PChar; cchBuffer: DWORD): DWORD; stdcall; external CryptDlgLib name {$IFDEF UNICODE} 'GetFriendlyNameOfCertW' {$ELSE} 'GetFriendlyNameOfCertA' {$ENDIF} ; +function CertGetCertificateContextProperty(pCertContext: PCCERT_CONTEXT; dwPropId: DWORD; pvData: Pointer; var pcbData: DWORD): BOOL; stdcall; external CryptoLib; +function CryptAcquireContextA(var phProv: HCRYPTPROV; pszContainer, pszProvider: PAnsiChar; dwProvType, dwFlags: DWORD): BOOL; stdcall; external AdvapiLib; +function CryptAcquireContextU(var phProv: HCRYPTPROV; pszContainer, pszProvider: PWideChar; dwProvType, dwFlags: DWORD): BOOL; stdcall; external AdvapiLib name 'CryptAcquireContextW'; +function CryptAcquireContextW(var phProv: HCRYPTPROV; pszContainer, pszProvider: PWideChar; dwProvType, dwFlags: DWORD): BOOL; stdcall; external AdvapiLib; +function CryptAcquireContext(var phProv: HCRYPTPROV; pszContainer, pszProvider: PChar; dwProvType, dwFlags: DWORD): BOOL; stdcall; external AdvapiLib name {$IFDEF UNICODE} 'CryptAcquireContextW' {$ELSE} 'CryptAcquireContextA' {$ENDIF} ; +function CryptAcquireCertificatePrivateKey(pCertContext: PCCERT_CONTEXT; dwFlags: DWORD; pvParameters: Pointer; var phCryptProv: HCRYPTPROV; var pdwKeySpec: DWORD; pfCallerFreeProv: PBOOL): BOOL; stdcall; external CryptoLib; +function CertAddCertificateContextToStore(hCertStore: HCERTSTORE; pCertContext: PCCERT_CONTEXT; dwAddDisposition: DWORD; ppStoreContext: PPCCERT_CONTEXT): BOOL; stdcall; external CryptoLib; +function CryptSignMessage(pSignPara: PCRYPT_SIGN_MESSAGE_PARA; fDetachedSignature: BOOL; cToBeSigned: DWORD; rgpbToBeSigned: PPtrArray; rgcbToBeSigned: PDWORDArray; pbSignedBlob: PByte; var pcbSignedBlob: DWORD): BOOL; stdcall external CryptoLib; + +function CertGetNameStringPAS(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer; out Name: string): boolean; overload; +function CertGetNameStringPAS(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer): string; overload; +function CertGetCertificateContextPropertyPAS(pCertContext: PCCERT_CONTEXT; dwPropId: DWORD; out Data: AnsiString): BOOL; overload; +function CertGetCertificateContextPropertyPAS(pCertContext: PCCERT_CONTEXT; dwPropId: DWORD): AnsiString; overload; + +implementation + +function CertGetNameStringPAS(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer; out Name: string): boolean; overload; +var + n: DWORD; +begin + Result := False; + Name := ''; + n := CertGetNameString(pCertContext, dwType, dwFlags, pvTypePara, nil, 0); + if n > 0 then + begin + SetLength(Name, n); + n := CertGetNameString(pCertContext, dwType, dwFlags, pvTypePara, @Name[1], n); + if n > 0 then + begin + SetLength(Name, n-1); + Result := True; + end + else + Name := ''; + end; +end; + +function CertGetNameStringPAS(pCertContext: PCCERT_CONTEXT; dwType, dwFlags: DWORD; pvTypePara: Pointer): string; +begin + if not CertGetNameStringPAS(pCertContext, dwType, dwFlags, pvTypePara, Result) then + Result := ''; +end; + +function CertGetCertificateContextPropertyPAS(pCertContext: PCCERT_CONTEXT; dwPropId: DWORD; out Data: AnsiString): BOOL; +var + n: DWORD; +begin + Result := False; + Data := ''; + n := 0; + if CertGetCertificateContextProperty(pCertContext, dwPropId, nil, n) then + begin + SetLength(Data, n); + if CertGetCertificateContextProperty(pCertContext, dwPropId, @Data[1], n) then + begin + SetLength(Data, n); + Result := True; + end + else + Data := ''; + end; +end; + +function CertGetCertificateContextPropertyPAS(pCertContext: PCCERT_CONTEXT; dwPropId: DWORD): AnsiString; +begin + if not CertGetCertificateContextPropertyPAS(pCertContext, dwPropId, Result) then + Result := ''; +end; + +end. diff -Nru cqrprop-0.0.7/src/synapse/dnssend.pas cqrprop-0.0.8/src/synapse/dnssend.pas --- cqrprop-0.0.7/src/synapse/dnssend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/dnssend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,603 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/ftpsend.pas cqrprop-0.0.8/src/synapse/ftpsend.pas --- cqrprop-0.0.7/src/synapse/ftpsend.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ftpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 004.000.000 | +| Project : Ararat Synapse | 004.001.000 | |==============================================================================| | Content: FTP client | |==============================================================================| @@ -34,10 +34,12 @@ |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | +| Portions created by Jan Fiala are Copyright (c) 2019. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | | Petr Esner | +| Jan Fiala | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -67,7 +69,13 @@ uses SysUtils, Classes, - blcksock, synautil, synaip, synsock; + blcksock, synautil, synaip, synsock + {$IfDef POSIX} + ,System.Generics.Collections, System.Generics.Defaults + {$EndIf} + {$IfDef NEXTGEN} + ,synafpc + {$EndIf}; const cFtpProtocol = '21'; @@ -122,12 +130,18 @@ property Permission: string read FPermission write FPermission; end; + {$IFDEF POSIX} + TFTPRecList = TList; + {$ELSE} + TFTPRecList = TList; + {$ENDIF} + {:@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; + FList: TFTPRecList; FLines: TStringList; FMasks: TStringList; FUnparsedLines: TStringList; @@ -173,9 +187,13 @@ @link(TFTPListRec).} procedure ParseLines; virtual; + {:try to parse MLSD directory listing in @link(lines) to list of + @link(TFTPListRec).} + procedure ParseMLSDLines; 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; + property List: TFTPRecList read FList; {:By this property you have access to list of @link(TFTPListRec).} property Items[Index: Integer]: TFTPListRec read GetListItem; default; @@ -229,6 +247,7 @@ FIsDataTLS: Boolean; FTLSonData: Boolean; FFullSSL: Boolean; + FUseMLSDList: Boolean; function Auth(Mode: integer): Boolean; virtual; function Connect: Boolean; virtual; function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual; @@ -446,6 +465,9 @@ {: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; + + {:Enable MLSD support for directory list.} + property UseMLSDList: Boolean read FUseMLSDList write FUseMLSDList; end; {:A very useful function, and example of use can be found in the TFtpSend object. @@ -466,6 +488,8 @@ implementation +uses DateUtils, StrUtils; + constructor TFTPSend.Create; begin inherited Create; @@ -497,6 +521,7 @@ FIsTLS := False; FIsDataTLS := False; FTLSonData := True; + UseMLSDList := false; end; destructor TFTPSend.Destroy; @@ -986,7 +1011,10 @@ if NameList then x := FTPCommand('NLST' + Directory) else - x := FTPCommand('LIST' + Directory); + if FUseMLSDList then + x := FTPCommand('MLSD' + Directory) + else + x := FTPCommand('LIST' + Directory); if (x div 100) <> 1 then Exit; Result := DataRead(FDataStream); @@ -994,7 +1022,10 @@ begin FDataStream.Position := 0; FFTPList.Lines.LoadFromStream(FDataStream); - FFTPList.ParseLines; + if FUseMLSDList then + FFTPList.ParseMLSDLines + else + FFTPList.ParseLines; end; FDataStream.Position := 0; end; @@ -1217,13 +1248,13 @@ constructor TFTPList.Create; begin inherited Create; - FList := TList.Create; + FList := TFTPRecList.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$hh:mm:ss$YYYY$n*'); //Fiala - pridany dvojtecky do casu + FMasks.add('pppppppppp $!!!S*$DD$TTT$hh:mm:ss$YYYY$n*'); //Fiala - pridany dvojtecky do casu FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*'); //MacOS @@ -1240,8 +1271,20 @@ 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 ss'); + FMasks.add('v*$D TTT YYYY hh mm'); //Fiala + FMasks.add('v*$!DD TTT YYYY hh mm ss'); + //sample: ABB.DIR;1 1/35 18-SEP-2007 10:46:39 [STEVEH] (RWE,RWE,RWE,RWE) + FMasks.add('v*\$!DD TTT YYYY hh mm ss'); + //sample: DELMAS.SQL;7 0/0 6-DEC-2007 10:43:44 [STEVEH] (RWED,RWED,RWED,RWED) + FMasks.add('v*$!D TTT YYYY hh mm ss'); //Fiala + FMasks.add('v*\$!D TTT YYYY hh mm ss'); //Fiala + FMasks.add('v*$!D TTT YYYY hh mm ss'); //Fiala + FMasks.add('n*$ YYYY MM DD hh mm$S*'); //Fiala + //sample: STANS_DIFF.DIR;1 1 13-APR-2006 13:27 [AGR4] (RWE,RWE,RE,E) FMasks.add('v*$!DD TTT YYYY hh mm'); - FMasks.add('n*$ YYYY MM DD hh mm$S*'); +// FMasks.add('n*$ YYYY MM DD hh mm$S*'); + FMasks.add('$!: :n*'); //AS400 FMasks.add('!S*$MM DD YY hh mm ss !n*'); FMasks.add('!S*$DD MM YY hh mm ss !n*'); @@ -1272,9 +1315,35 @@ //BullGCOS8 FMasks.add(' $S* MM DD YY hh mm ss !n*'); FMasks.add('d $S* MM DD YY !n*'); + //IBM AIXs + // sample: -rw---- 1 ITINERA DAT 58 JAN 09 2008 TSITIS009VAJ_COB + FMasks.add('ppppppp $!!!S*$TTT$DD$YYYY$n*'); //Fiala + + FMasks.add('pppppppppp SSSSSSSSSS DD !YYYY n*'); //Fiala + FMasks.add('pppppppppp SSSSSSSSSS DD !hh mm n*'); //Fiala + // drwxr-xr-x 10 hol prog 45056 20 8 10:00 adis30161 + FMasks.add('pppppppppp SSSSSSSSSS DD MM!hh mm n*'); //Fiala + // drwxr-xr-x 2 hol prog 4096 20 1 2005 bin + FMasks.add('pppppppppp SSSSSSSSSS DD MM YYYY n*'); //Fiala + + //IBM VM //Fiala + // MQ_REPTS TESTVIEW V 72 139 1 2009-01-28 11:58:07 - + // NEW DIR - - - 2009-11-04 18:31:50 - + FMasks.add('n*.$n*$ SSSSSSSSSS YYYY-MM-DD hh:mm:ss -'); + FMasks.add('nnnnnnnnnnnnnnnnn d - - - YYYY-MM-DD hh:mm:ss -'); + //sample: Migrated $SRC.AFLG + FMasks.add(' dxx n*'); //Fiala + //VMS - new untouched files (name only) + // ADR10AI2 + FMasks.Add('n*§'); //Fiala + //IBM VM + // MQ_REPTS TESTVIEW V 72 139 1 2009-01-28 11:58:07 - + // NEW DIR - - - 2009-11-04 18:31:50 - + FMasks.add('nnnnnnnnnnnnnnnnn x SSSSSSSSSS YYYY-MM-DD hh:mm:ss -'); + FMasks.add('nnnnnnnnnnnnnnnnn d - - - YYYY-MM-DD hh:mm:ss -'); //BullGCOS7 - FMasks.add(' TTT DD YYYY n*'); - FMasks.add(' d n*'); +// FMasks.add(' TTT DD YYYY n*'); +// FMasks.add(' d n*'); end; destructor TFTPList.Destroy; @@ -1366,16 +1435,17 @@ IMask := 1; Result := 1; LastMaskC := ' '; + Value := TrimRight(Value); //Fiala while Imask <= Length(mask) do begin - if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then + if not (Mask[Imask] in ['*', '\', '§']) and (Ivalue > Length(Value)) then //Fiala begin Result := 0; Exit; end; MaskC := Mask[Imask]; - if Ivalue > Length(Value) then - Exit; +// if Ivalue > Length(Value) then +// Exit; c := Value[Ivalue]; case MaskC of 'n': @@ -1422,6 +1492,8 @@ Result := 0; Exit; end; + 'y': //Fiala + if c <> ' ' then Result := 0; '*': begin s := ''; @@ -1474,6 +1546,12 @@ end; Dec(IValue); end; + '§': //Fiala + if IValue < Length(Value) then + begin + Result := 0; + Break; + end; '$': begin while IValue <= Length(Value) do @@ -1512,6 +1590,12 @@ end; end; end; + ':': //Fiala + if c <> ':' then + begin + Result := 0; + Exit; + end; '\': begin Value := NextValue; @@ -1530,6 +1614,7 @@ x, n: integer; begin Result := false; + if (Trim(FileName) = '') and (Trim(VMSFileName) = '') then Exit; //Fiala if FileName <> '' then begin if pos('?', VMSFilename) > 0 then @@ -1540,15 +1625,15 @@ if VMSFileName <> '' then if pos(';', VMSFilename) <= 0 then Exit; - if (FileName = '') and (VMSFileName = '') then - Exit; +// if (FileName = '') and (VMSFileName = '') then +// Exit; if Permissions <> '' then begin - if length(Permissions) <> 10 then + if (length(Permissions) <> 10) and (length(Permissions) <> 7) then //Fiala 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 + for n := 1 to length(Permissions) do //Fiala + if not (Permissions[n] in + ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-', 'S']) then //Fiala Exit; end; if Day <> '' then @@ -1690,6 +1775,9 @@ {$ENDIF} DecodeDate(Date,myear,mmonth,mday); + myear := YearOf(Date); //Fiala + mMonth := 1; //Fiala + mDay := 1; //Fiala mhours := 0; mminutes := 0; mseconds := 0; @@ -1718,9 +1806,13 @@ 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); + try { osetreni spatneho formatu data } //Fiala + if (Encodedate(myear, mmonth, mday) //tohle kvuli spatnemu casu na FTP serveru + + EncodeTime(mHours, mminutes, 0, 0)) > now then + Dec(mYear); + except //Fiala + mYear := YearOf(Date()); //Fiala + end; end else myear := StrToIntDef(YearTime, 0); @@ -1737,6 +1829,10 @@ if mHours <> 12 then mHours := MHours + 12; end; + { osetrime prechodne roky } //Fiala + if (mday = 29) and (mmonth = 2) and not IsLeapYear(myear) then + Dec(Mday); + Value.FileTime := Encodedate(myear, mmonth, mday) + EncodeTime(mHours, mminutes, mseconds, 0); if Permissions <> '' then @@ -1961,4 +2057,50 @@ end; end; +procedure TFTPList.ParseMLSDLines; +var + flr: TFTPListRec; + i: Integer; + s: string; + ye,mo,da,ho,mi,se: Word; + + function GetPart(const ALine, AName: string): string; + var + i, j: Integer; + begin + i := Pos(AnsiUpperCase(AName), AnsiUpperCase(ALine)); + i := i + Length(AName); + j := PosEx(';', ALine, i); + if j < 1 then j := MaxInt; + Result := Copy(ALine, i, j-i); + end; + +begin + for i := 0 to Lines.Count - 1 do + begin + s := GetPart(Lines[i], 'modify='); + ye := StrToIntDef(Copy(s, 1, 4), 1970); + mo := StrToIntDef(Copy(s, 5, 2), 1); + da := StrToIntDef(Copy(s, 7, 2), 1); + ho := StrToIntDef(Copy(s, 9, 2), 0); + mi := StrToIntDef(Copy(s, 11, 2), 0); + se := StrToIntDef(Copy(s, 13, 2), 0); + + flr := TFTPListRec.create; + flr.OriginalLine := Lines[i]; + { osetrime kraviny, protoze autori FTP serveru nerespektuji RFC, tykajici se MLSD prikazu } + try + flr.FFileTime := EncodeDateTime(ye,mo,da,ho,mi,se, 0); + except + flr.FFileTime := EncodeDateTime(1970,1,1,0,0,0, 0); + end; + flr.FDirectory := AnsiSameText(GetPart(Lines[i], 'type='), 'dir') or AnsiSameText(GetPart(Lines[i], 'type='), 'cdir'); + flr.FFileSize := StrToInt64Def(GetPart(Lines[i], 'size='), 0); + flr.FPermission := GetPart(Lines[i], 'mode='); + s := flr.FPermission; + flr.FFileName := GetPart(Lines[i], '; '); + Flist.Add(flr); + end; +end; + end. diff -Nru cqrprop-0.0.7/src/synapse/ftptsend.pas cqrprop-0.0.8/src/synapse/ftptsend.pas --- cqrprop-0.0.7/src/synapse/ftptsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ftptsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,403 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/httpsend.pas cqrprop-0.0.8/src/synapse/httpsend.pas --- cqrprop-0.0.7/src/synapse/httpsend.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/httpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.012.009 | +| Project : Ararat Synapse | 003.013.000 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| Copyright (c)1999-2015, Lukas Gebauer | +| Copyright (c)1999-2021, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,8 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2015. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2021. | +| Portions created by Pepak are Copyright (c) 2020-2021. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -63,13 +64,20 @@ {$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$ENDIF} +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + unit httpsend; interface uses SysUtils, Classes, - blcksock, synautil, synaip, synacode, synsock; + blcksock, synautil, synaip, synacode, synsock + {$IFDEF NEXTGEN} + ,synafpc + {$ENDIF}; const cHttpProtocol = '80'; @@ -101,18 +109,21 @@ FResultString: string; FUserAgent: string; FCookies: TStringList; - FDownloadSize: integer; - FUploadSize: integer; - FRangeStart: integer; - FRangeEnd: integer; + FDownloadSize: int64; + FUploadSize: int64; + FRangeStart: int64; + FRangeEnd: int64; FAddPortNumberToHost: Boolean; + FInputStream, FOutputStream: TStream; function ReadUnknown: Boolean; virtual; - function ReadIdentity(Size: Integer): Boolean; virtual; + function ReadIdentity(Size: int64): Boolean; virtual; function ReadChunked: Boolean; virtual; procedure ParseCookies; function PrepareHeaders: AnsiString; function InternalDoConnect(needssl: Boolean): Boolean; function InternalConnect(needssl: Boolean): Boolean; + function InputDocument: TStream; + function OutputDocument: TStream; public constructor Create; destructor Destroy; override; @@ -158,13 +169,13 @@ {:If you need to download only part of a requested document, specify here the position of subpart begin. If 0, the full document is requested.} - property RangeStart: integer read FRangeStart Write FRangeStart; + property RangeStart: int64 read FRangeStart Write FRangeStart; {:If you need to download only part of a requested document, specify here the position of subpart end. If 0, the document from rangeStart to end of document is requested. (Useful for resuming broken downloads, for example.)} - property RangeEnd: integer read FRangeEnd Write FRangeEnd; + property RangeEnd: int64 read FRangeEnd Write FRangeEnd; {:Mime type of sending data. Default is: 'text/html'.} property MimeType: string read FMimeType Write FMimeType; @@ -209,12 +220,12 @@ {:if this value is not 0, then data download is pending. In this case you have here the total size of downloaded data. Useful for drawing download progressbar from OnStatus event.} - property DownloadSize: integer read FDownloadSize; + property DownloadSize: int64 read FDownloadSize; {:if this value is not 0, then data upload is pending. In this case you have here the total size of uploaded data. Useful for drawing upload progressbar from OnStatus event.} - property UploadSize: integer read FUploadSize; + property UploadSize: int64 read FUploadSize; {:Socket object used for TCP/IP operation. Good for setting OnStatus hook, etc.} @@ -223,6 +234,12 @@ {:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE. Some buggy servers do not like port informations in this header.} property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost; + public + {:for direct sending from any TStream. Defalut nil = use Document property instead.} + property InputStream: TStream read FInputStream write FInputStream; + + {:for direct dovnloading into any TStream. Defalut nil = use Document property instead.} + property OutputStream: TStream read FOutputStream write FOutputStream; end; {:A very useful function, and example of use can be found in the THTTPSend @@ -296,6 +313,8 @@ FUploadSize := 0; FAddPortNumberToHost := true; FKeepAliveTimeout := 300; + FInputStream := nil; + FOutputStream := nil; Clear; end; @@ -308,11 +327,29 @@ inherited Destroy; end; +function THTTPSend.InputDocument: TStream; +begin + if InputStream <> nil then + Result := InputStream + else + Result := Document; +end; + +function THTTPSend.OutputDocument: TStream; +begin + if OutputStream <> nil then + Result := OutputStream + else + Result := Document; +end; + procedure THTTPSend.Clear; begin FRangeStart := 0; FRangeEnd := 0; FDocument.Clear; + InputDocument.Size := 0; + OutputDocument.Size := 0; FHeaders.Clear; FMimeType := 'text/html'; end; @@ -383,7 +420,7 @@ status100: Boolean; status100error: string; ToClose: Boolean; - Size: Integer; + Size: int64; Prot, User, Pass, Host, Port, Path, Para, URI: string; s, su: AnsiString; HttpTunnel: Boolean; @@ -400,7 +437,7 @@ FDownloadSize := 0; FUploadSize := 0; - URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); + URI := ParseURL(trim(URL), Prot, User, Pass, Host, Port, Path, Para); User := DecodeURL(user); Pass := DecodeURL(pass); if User = '' then @@ -425,14 +462,14 @@ FSock.HTTPTunnelPass := ''; end; UsingProxy := (FProxyHost <> '') and not(HttpTunnel); - Sending := FDocument.Size > 0; + Sending := InputDocument.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)); + FHeaders.Insert(0, 'Content-Length: ' + IntToStr(InputDocument.Size)); if FMimeType <> '' then FHeaders.Insert(0, 'Content-Type: ' + FMimeType); end; @@ -514,7 +551,7 @@ end; { reading Status } - FDocument.Position := 0; + InputDocument.Position := 0; Status100Error := ''; if status100 then begin @@ -538,23 +575,23 @@ begin { we can upload content } Status100Error := ''; - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); + FUploadSize := InputDocument.Size; + FSock.SendStreamRaw(InputDocument); end; end else { upload content } if sending then begin - if FDocument.Size >= c64k then + if InputDocument.Size >= c64k then begin FSock.SendString(PrepareHeaders); - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); + FUploadSize := InputDocument.Size; + FSock.SendStreamRaw(InputDocument); end else begin - s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size); + s := PrepareHeaders + ReadStrFromStream(InputDocument, InputDocument.Size); FUploadSize := Length(s); FSock.SendString(s); end; @@ -590,7 +627,7 @@ begin { old HTTP 0.9 and some buggy servers not send result } s := s + CRLF; - WriteStrToStream(FDocument, s); + WriteStrToStream(OutputDocument, s); FResultCode := 0; end; until (FSock.LastError <> 0) or (FResultCode <> 100); @@ -618,7 +655,7 @@ su := UpperCase(s); if Pos('CONTENT-LENGTH:', su) = 1 then begin - Size := StrToIntDef(Trim(SeparateRight(s, ':')), -1); + Size := StrToInt64Def(Trim(SeparateRight(s, ':')), -1); if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then FTransferEncoding := TE_IDENTITY; end; @@ -671,7 +708,7 @@ Result := ReadChunked; end; - FDocument.Seek(0, soFromBeginning); + OutputDocument.Position := 0; if ToClose then begin FSock.CloseSocket; @@ -689,7 +726,7 @@ repeat s := FSock.RecvPacket(FTimeout); if FSock.LastError = 0 then - WriteStrToStream(FDocument, s); + WriteStrToStream(OutputDocument, s); until FSock.LastError <> 0; if FSock.LastError = WSAECONNRESET then begin @@ -698,13 +735,13 @@ end; end; -function THTTPSend.ReadIdentity(Size: Integer): Boolean; +function THTTPSend.ReadIdentity(Size: int64): Boolean; begin if Size > 0 then begin FDownloadSize := Size; - FSock.RecvStreamSize(FDocument, FTimeout, Size); - FDocument.Position := FDocument.Size; + FSock.RecvStreamSize(OutputDocument, FTimeout, Size); + OutputDocument.Position := OutputDocument.Size; Result := FSock.LastError = 0; end else @@ -714,7 +751,7 @@ function THTTPSend.ReadChunked: Boolean; var s: ansistring; - Size: Integer; + Size: int64; begin repeat repeat @@ -724,7 +761,7 @@ Break; s := Trim(SeparateLeft(s, ' ')); s := Trim(SeparateLeft(s, ';')); - Size := StrToIntDef('$' + s, 0); + Size := StrToInt64Def('$' + s, 0); if Size = 0 then Break; if not ReadIdentity(Size) then @@ -780,7 +817,7 @@ Result := HTTP.HTTPMethod('GET', URL); if Result then begin - Response.Seek(0, soFromBeginning); + Response.Position := 0; Response.CopyFrom(HTTP.Document, 0); end; finally @@ -800,7 +837,7 @@ Data.Size := 0; if Result then begin - Data.Seek(0, soFromBeginning); + Data.Position := 0; Data.CopyFrom(HTTP.Document, 0); end; finally diff -Nru cqrprop-0.0.7/src/synapse/imapsend.pas cqrprop-0.0.8/src/synapse/imapsend.pas --- cqrprop-0.0.7/src/synapse/imapsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/imapsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,871 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.005.004 | +|==============================================================================| +| Content: IMAP4rev1 client | +|==============================================================================| +| Copyright (c)1999-2015, 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-2015. | +| 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'; + if Result then + FAuthDone := True; +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 -Nru cqrprop-0.0.7/src/synapse/jedi.inc cqrprop-0.0.8/src/synapse/jedi.inc --- cqrprop-0.0.7/src/synapse/jedi.inc 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/jedi.inc 2023-04-10 12:51:00.000000000 +0000 @@ -1,1430 +1,2044 @@ -{$IFNDEF JEDI_INC} -{$DEFINE JEDI_INC} - -{**************************************************************************************************} -{ } -{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");} -{ you may not use this file except in compliance with the License. You may obtain a copy of the } -{ License at http://www.mozilla.org/MPL/ } -{ } -{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } -{ ANY KIND, either express or implied. See the License for the specific language governing rights } -{ and limitations under the License. } -{ } -{ The Original Code is: jedi.inc. } -{ The Initial Developer of the Original Code is Project JEDI http://www.delphi-jedi.org } -{ } -{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General } -{ Public License (the "LGPL License"), in which case the provisions of the LGPL License are } -{ applicable instead of those above. If you wish to allow use of your version of this file only } -{ under the terms of the LGPL License and not to allow others to use your version of this file } -{ under the MPL, indicate your decision by deleting the provisions above and replace them with } -{ the notice and other provisions required by the LGPL License. If you do not delete the } -{ provisions above, a recipient may use your version of this file under either the MPL or the } -{ LGPL License. } -{ } -{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } -{ } -{**************************************************************************************************} -{ } -{ This file defines various generic compiler directives used in different libraries, e.g. in the } -{ JEDI Code Library (JCL) and JEDI Visual Component Library Library (JVCL). The directives in } -{ this file are of generic nature and consist mostly of mappings from the VERXXX directives } -{ defined by Delphi, C++Builder and FPC to friendly names such as DELPHI5 and } -{ SUPPORTS_WIDESTRING. These friendly names are subsequently used in the libraries to test for } -{ compiler versions and/or whether the compiler supports certain features (such as widestrings or } -{ 64 bit integers. The libraries provide an additional, library specific, include file. For the } -{ JCL e.g. this is jcl.inc. These files should be included in source files instead of this file } -{ (which is pulled in automatically). } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: 2012-09-04 16:01:38 +0200 (út, 04 9 2012) $ } -{ Revision: $Rev:: 161 $ } -{ Author: $Author:: outchy $ } -{ } -{**************************************************************************************************} - -(* - -- Development environment directives - - This file defines two directives to indicate which development environment the - library is being compiled with. Currently this can either be Delphi, Kylix, - C++Builder or FPC. - - Directive Description - ------------------------------------------------------------------------------ - DELPHI Defined if compiled with Delphi - KYLIX Defined if compiled with Kylix - DELPHICOMPILER Defined if compiled with Delphi or Kylix/Delphi - BCB Defined if compiled with C++Builder - CPPBUILDER Defined if compiled with C++Builder (alias for BCB) - BCBCOMPILER Defined if compiled with C++Builder or Kylix/C++ - DELPHILANGUAGE Defined if compiled with Delphi, Kylix or C++Builder - BORLAND Defined if compiled with Delphi, Kylix or C++Builder - FPC Defined if compiled with FPC - -- Platform Directives - - Platform directives are not all explicitly defined in this file, some are - defined by the compiler itself. They are listed here only for completeness. - - Directive Description - ------------------------------------------------------------------------------ - WIN32 Defined when target platform is 32 bit Windows - WIN64 Defined when target platform is 64 bit Windows - MSWINDOWS Defined when target platform is 32 bit Windows - LINUX Defined when target platform is Linux - UNIX Defined when target platform is Unix-like (including Linux) - CLR Defined when target platform is .NET - -- Architecture directives. These are auto-defined by FPC - CPU32 and CPU64 are mostly for generic pointer size dependant differences rather - than for a specific architecture. - - CPU386 Defined when target platform is native x86 (win32) - CPUx86_64 Defined when target platform is native x86_64 (win64) - CPU32 Defined when target is 32-bit - CPU64 Defined when target is 64-bit - CPUASM Defined when target assembler is available - -- Visual library Directives - - The following directives indicate for a visual library. In a Delphi/BCB - (Win32) application you need to define the VisualCLX symbol in the project - options, if you want to use the VisualCLX library. Alternatively you can use - the IDE expert, which is distributed with the JCL to do this automatically. - - Directive Description - ------------------------------------------------------------------------------ - VCL Defined for Delphi/BCB (Win32) exactly if VisualCLX is not defined - VisualCLX Defined for Kylix; needs to be defined for Delphi/BCB to - use JCL with VisualCLX applications. - - -- Other cross-platform related defines - - These symbols are intended to help in writing portable code. - - Directive Description - ------------------------------------------------------------------------------ - PUREPASCAL Code is machine-independent (as opposed to assembler code) - Win32API Code is specific for the Win32 API; - use instead of "{$IFNDEF CLR} {$IFDEF MSWINDOWS}" constructs - - -- Delphi Versions - - The following directives are direct mappings from the VERXXX directives to a - friendly name of the associated compiler. These directives are only defined if - the compiler is Delphi (ie DELPHI is defined). - - Directive Description - ------------------------------------------------------------------------------ - DELPHI1 Defined when compiling with Delphi 1 (Codename WASABI/MANGO) - DELPHI2 Defined when compiling with Delphi 2 (Codename POLARIS) - DELPHI3 Defined when compiling with Delphi 3 (Codename IVORY) - DELPHI4 Defined when compiling with Delphi 4 (Codename ALLEGRO) - DELPHI5 Defined when compiling with Delphi 5 (Codename ARGUS) - DELPHI6 Defined when compiling with Delphi 6 (Codename ILLIAD) - DELPHI7 Defined when compiling with Delphi 7 (Codename AURORA) - DELPHI8 Defined when compiling with Delphi 8 (Codename OCTANE) - DELPHI2005 Defined when compiling with Delphi 2005 (Codename DIAMONDBACK) - DELPHI9 Alias for DELPHI2005 - DELPHI10 Defined when compiling with Delphi 2006 (Codename DEXTER) - DELPHI2006 Alias for DELPHI10 - DELPHI11 Defined when compiling with Delphi 2007 for Win32 (Codename SPACELY) - DELPHI2007 Alias for DELPHI11 - DELPHI12 Defined when compiling with Delphi 2009 for Win32 (Codename TIBURON) - DELPHI2009 Alias for DELPHI12 - DELPHI14 Defined when compiling with Delphi 2010 for Win32 (Codename WEAVER) - DELPHI2010 Alias for DELPHI14 - DELPHI15 Defined when compiling with Delphi XE for Win32 (Codename FULCRUM) - DELPHIXE Alias for DELPHI15 - DELPHI16 Defined when compiling with Delphi XE2 for Win32 (Codename PULSAR) - DELPHIXE2 Alias for DELPHI16 - DELPHI17 Defined when compiling with Delphi XE3 for Win32 (Codename WATERDRAGON) - DELPHIXE3 Alias for DELPHI17 - DELPHI1_UP Defined when compiling with Delphi 1 or higher - DELPHI2_UP Defined when compiling with Delphi 2 or higher - DELPHI3_UP Defined when compiling with Delphi 3 or higher - DELPHI4_UP Defined when compiling with Delphi 4 or higher - DELPHI5_UP Defined when compiling with Delphi 5 or higher - DELPHI6_UP Defined when compiling with Delphi 6 or higher - DELPHI7_UP Defined when compiling with Delphi 7 or higher - DELPHI8_UP Defined when compiling with Delphi 8 or higher - DELPHI2005_UP Defined when compiling with Delphi 2005 or higher - DELPHI9_UP Alias for DELPHI2005_UP - DELPHI10_UP Defined when compiling with Delphi 2006 or higher - DELPHI2006_UP Alias for DELPHI10_UP - DELPHI11_UP Defined when compiling with Delphi 2007 for Win32 or higher - DELPHI2007_UP Alias for DELPHI11_UP - DELPHI12_UP Defined when compiling with Delphi 2009 for Win32 or higher - DELPHI2009_UP Alias for DELPHI12_UP - DELPHI14_UP Defined when compiling with Delphi 2010 for Win32 or higher - DELPHI2010_UP Alias for DELPHI14_UP - DELPHI15_UP Defined when compiling with Delphi XE for Win32 or higher - DELPHIXE_UP Alias for DELPHI15_UP - DELPHI16_UP Defined when compiling with Delphi XE2 for Win32 or higher - DELPHIXE2_UP Alias for DELPHI16_UP - DELPHI17_UP Defined when compiling with Delphi XE3 for Win32 or higher - DELPHIXE3_UP Alias for DELPHI17_UP - - -- Kylix Versions - - The following directives are direct mappings from the VERXXX directives to a - friendly name of the associated compiler. These directives are only defined if - the compiler is Kylix (ie KYLIX is defined). - - Directive Description - ------------------------------------------------------------------------------ - KYLIX1 Defined when compiling with Kylix 1 - KYLIX2 Defined when compiling with Kylix 2 - KYLIX3 Defined when compiling with Kylix 3 (Codename CORTEZ) - KYLIX1_UP Defined when compiling with Kylix 1 or higher - KYLIX2_UP Defined when compiling with Kylix 2 or higher - KYLIX3_UP Defined when compiling with Kylix 3 or higher - - -- Delphi Compiler Versions (Delphi / Kylix, not in BCB mode) - - Directive Description - ------------------------------------------------------------------------------ - DELPHICOMPILER1 Defined when compiling with Delphi 1 - DELPHICOMPILER2 Defined when compiling with Delphi 2 - DELPHICOMPILER3 Defined when compiling with Delphi 3 - DELPHICOMPILER4 Defined when compiling with Delphi 4 - DELPHICOMPILER5 Defined when compiling with Delphi 5 - DELPHICOMPILER6 Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 - DELPHICOMPILER7 Defined when compiling with Delphi 7 - DELPHICOMPILER8 Defined when compiling with Delphi 8 - DELPHICOMPILER9 Defined when compiling with Delphi 2005 - DELPHICOMPILER10 Defined when compiling with Delphi Personality of BDS 4.0 - DELPHICOMPILER11 Defined when compiling with Delphi 2007 for Win32 - DELPHICOMPILER12 Defined when compiling with Delphi Personality of BDS 6.0 - DELPHICOMPILER14 Defined when compiling with Delphi Personality of BDS 7.0 - DELPHICOMPILER15 Defined when compiling with Delphi Personality of BDS 8.0 - DELPHICOMPILER16 Defined when compiling with Delphi Personality of BDS 9.0 - DELPHICOMPILER17 Defined when compiling with Delphi Personality of BDS 10.0 - DELPHICOMPILER1_UP Defined when compiling with Delphi 1 or higher - DELPHICOMPILER2_UP Defined when compiling with Delphi 2 or higher - DELPHICOMPILER3_UP Defined when compiling with Delphi 3 or higher - DELPHICOMPILER4_UP Defined when compiling with Delphi 4 or higher - DELPHICOMPILER5_UP Defined when compiling with Delphi 5 or higher - DELPHICOMPILER6_UP Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 or higher - DELPHICOMPILER7_UP Defined when compiling with Delphi 7 or higher - DELPHICOMPILER8_UP Defined when compiling with Delphi 8 or higher - DELPHICOMPILER9_UP Defined when compiling with Delphi 2005 - DELPHICOMPILER10_UP Defined when compiling with Delphi 2006 or higher - DELPHICOMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher - DELPHICOMPILER12_UP Defined when compiling with Delphi 2009 for Win32 or higher - DELPHICOMPILER14_UP Defined when compiling with Delphi 2010 for Win32 or higher - DELPHICOMPILER15_UP Defined when compiling with Delphi XE for Win32 or higher - DELPHICOMPILER16_UP Defined when compiling with Delphi XE2 for Win32 or higher - DELPHICOMPILER17_UP Defined when compiling with Delphi XE3 for Win32 or higher - - -- C++Builder Versions - - The following directives are direct mappings from the VERXXX directives to a - friendly name of the associated compiler. These directives are only defined if - the compiler is C++Builder (ie BCB is defined). - - Directive Description - ------------------------------------------------------------------------------ - BCB1 Defined when compiling with C++Builder 1 - BCB3 Defined when compiling with C++Builder 3 - BCB4 Defined when compiling with C++Builder 4 - BCB5 Defined when compiling with C++Builder 5 (Codename RAMPAGE) - BCB6 Defined when compiling with C++Builder 6 (Codename RIPTIDE) - BCB10 Defined when compiling with C++Builder Personality of BDS 4.0 (also known as C++Builder 2006) (Codename DEXTER) - BCB11 Defined when compiling with C++Builder Personality of RAD Studio 2007 (also known as C++Builder 2007) (Codename COGSWELL) - BCB12 Defined when compiling with C++Builder Personality of RAD Studio 2009 (also known as C++Builder 2009) (Codename TIBURON) - BCB14 Defined when compiling with C++Builder Personality of RAD Studio 2010 (also known as C++Builder 2010) (Codename WEAVER) - BCB15 Defined when compiling with C++Builder Personality of RAD Studio XE (also known as C++Builder XE) (Codename FULCRUM) - BCB16 Defined when compiling with C++Builder Personality of RAD Studio XE2 (also known as C++Builder XE2) (Codename PULSAR) - BCB17 Defined when compiling with C++Builder Personality of RAD Studio XE3 (also known as C++Builder XE3) (Codename WATERDRAGON) - BCB1_UP Defined when compiling with C++Builder 1 or higher - BCB3_UP Defined when compiling with C++Builder 3 or higher - BCB4_UP Defined when compiling with C++Builder 4 or higher - BCB5_UP Defined when compiling with C++Builder 5 or higher - BCB6_UP Defined when compiling with C++Builder 6 or higher - BCB10_UP Defined when compiling with C++Builder Personality of BDS 4.0 or higher - BCB11_UP Defined when compiling with C++Builder Personality of RAD Studio 2007 or higher - BCB12_UP Defined when compiling with C++Builder Personality of RAD Studio 2009 or higher - BCB14_UP Defined when compiling with C++Builder Personality of RAD Studio 2010 or higher - BCB15_UP Defined when compiling with C++Builder Personality of RAD Studio XE or higher - BCB16_UP Defined when compiling with C++Builder Personality of RAD Studio XE2 or higher - BCB17_UP Defined when compiling with C++Builder Personality of RAD Studio XE3 or higher - - -- RAD Studio / Borland Developer Studio Versions - - The following directives are direct mappings from the VERXXX directives to a - friendly name of the associated IDE. These directives are only defined if - the IDE is Borland Developer Studio Version 2 or above. - - Note: Borland Developer Studio 2006 is marketed as Delphi 2006 or C++Builder 2006, - but those provide only different labels for identical content. - - Directive Description - ------------------------------------------------------------------------------ - BDS Defined when compiling with BDS version of dcc32.exe (Codename SIDEWINDER) - BDS2 Defined when compiling with BDS 2.0 (Delphi 8) (Codename OCTANE) - BDS3 Defined when compiling with BDS 3.0 (Delphi 2005) (Codename DIAMONDBACK) - BDS4 Defined when compiling with BDS 4.0 (Borland Developer Studio 2006) (Codename DEXTER) - BDS5 Defined when compiling with BDS 5.0 (CodeGear RAD Studio 2007) (Codename HIGHLANDER) - BDS6 Defined when compiling with BDS 6.0 (CodeGear RAD Studio 2009) (Codename TIBURON) - BDS7 Defined when compiling with BDS 7.0 (Embarcadero RAD Studio 2010) (Codename WEAVER) - BDS8 Defined when compiling with BDS 8.0 (Embarcadero RAD Studio XE) (Codename FULCRUM) - BDS9 Defined when compiling with BDS 9.0 (Embarcadero RAD Studio XE2) (Codename PULSAR) - BDS10 Defined when compiling with BDS 10.0 (Embarcadero RAD Studio XE3) (Codename WATERDRAGON) - BDS2_UP Defined when compiling with BDS 2.0 or higher - BDS3_UP Defined when compiling with BDS 3.0 or higher - BDS4_UP Defined when compiling with BDS 4.0 or higher - BDS5_UP Defined when compiling with BDS 5.0 or higher - BDS6_UP Defined when compiling with BDS 6.0 or higher - BDS7_UP Defined when compiling with BDS 7.0 or higher - BDS8_UP Defined when compiling with BDS 8.0 or higher - BDS9_UP Defined when compiling with BDS 9.0 or higher - BDS10_UP Defined when compiling with BDS 10.0 or higher - -- Compiler Versions - - The following directives are direct mappings from the VERXXX directives to a - friendly name of the associated compiler. Unlike the DELPHI_X and BCB_X - directives, these directives are indepedent of the development environment. - That is, they are defined regardless of whether compilation takes place using - Delphi or C++Builder. - - Directive Description - ------------------------------------------------------------------------------ - COMPILER1 Defined when compiling with Delphi 1 - COMPILER2 Defined when compiling with Delphi 2 or C++Builder 1 - COMPILER3 Defined when compiling with Delphi 3 - COMPILER35 Defined when compiling with C++Builder 3 - COMPILER4 Defined when compiling with Delphi 4 or C++Builder 4 - COMPILER5 Defined when compiling with Delphi 5 or C++Builder 5 - COMPILER6 Defined when compiling with Delphi 6 or C++Builder 6 - COMPILER7 Defined when compiling with Delphi 7 - COMPILER8 Defined when compiling with Delphi 8 - COMPILER9 Defined when compiling with Delphi 9 - COMPILER10 Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 - COMPILER11 Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 - COMPILER12 Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 - COMPILER14 Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 - COMPILER15 Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 - COMPILER16 Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 - COMPILER17 Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 - COMPILER1_UP Defined when compiling with Delphi 1 or higher - COMPILER2_UP Defined when compiling with Delphi 2 or C++Builder 1 or higher - COMPILER3_UP Defined when compiling with Delphi 3 or higher - COMPILER35_UP Defined when compiling with C++Builder 3 or higher - COMPILER4_UP Defined when compiling with Delphi 4 or C++Builder 4 or higher - COMPILER5_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher - COMPILER6_UP Defined when compiling with Delphi 6 or C++Builder 6 or higher - COMPILER7_UP Defined when compiling with Delphi 7 - COMPILER8_UP Defined when compiling with Delphi 8 - COMPILER9_UP Defined when compiling with Delphi Personalities of BDS 3.0 - COMPILER10_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher - COMPILER11_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher - COMPILER12_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher - COMPILER14_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher - COMPILER15_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher - COMPILER16_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher - COMPILER17_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher - - -- RTL Versions - - Use e.g. following to determine the exact RTL version since version 14.0: - {$IFDEF CONDITIONALEXPRESSIONS} - {$IF Declared(RTLVersion) and (RTLVersion >= 14.2)} - // code for Delphi 6.02 or higher, Kylix 2 or higher, C++Builder 6 or higher - ... - {$IFEND} - {$ENDIF} - - Directive Description - ------------------------------------------------------------------------------ - RTL80_UP Defined when compiling with Delphi 1 or higher - RTL90_UP Defined when compiling with Delphi 2 or higher - RTL93_UP Defined when compiling with C++Builder 1 or higher - RTL100_UP Defined when compiling with Delphi 3 or higher - RTL110_UP Defined when compiling with C++Builder 3 or higher - RTL120_UP Defined when compiling with Delphi 4 or higher - RTL125_UP Defined when compiling with C++Builder 4 or higher - RTL130_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher - RTL140_UP Defined when compiling with Delphi 6, Kylix 1, 2 or 3 or C++Builder 6 or higher - RTL150_UP Defined when compiling with Delphi 7 or higher - RTL160_UP Defined when compiling with Delphi 8 or higher - RTL170_UP Defined when compiling with Delphi Personalities of BDS 3.0 or higher - RTL180_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher - RTL185_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher - RTL190_UP Defined when compiling with Delphi.NET of BDS 5.0 or higher - RTL200_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher - RTL210_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher - RTL220_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher - RTL230_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher - RTL240_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher - - -- CLR Versions - - Directive Description - ------------------------------------------------------------------------------ - CLR Defined when compiling for .NET - CLR10 Defined when compiling for .NET 1.0 (may be overriden by FORCE_CLR10) - CLR10_UP Defined when compiling for .NET 1.0 or higher - CLR11 Defined when compiling for .NET 1.1 (may be overriden by FORCE_CLR11) - CLR11_UP Defined when compiling for .NET 1.1 or higher - CLR20 Defined when compiling for .NET 2.0 (may be overriden by FORCE_CLR20) - CLR20_UP Defined when compiling for .NET 2.0 or higher - - -- Feature Directives - - The features directives are used to test if the compiler supports specific - features, such as method overloading, and adjust the sources accordingly. Use - of these directives is preferred over the use of the DELPHI and COMPILER - directives. - - Directive Description - ------------------------------------------------------------------------------ - SUPPORTS_CONSTPARAMS Compiler supports const parameters (D1+) - SUPPORTS_SINGLE Compiler supports the Single type (D1+) - SUPPORTS_DOUBLE Compiler supports the Double type (D1+) - SUPPORTS_EXTENDED Compiler supports the Extended type (D1+) - SUPPORTS_CURRENCY Compiler supports the Currency type (D2+) - SUPPORTS_THREADVAR Compiler supports threadvar declarations (D2+) - SUPPORTS_OUTPARAMS Compiler supports out parameters (D3+) - SUPPORTS_VARIANT Compiler supports variant (D2+) - SUPPORTS_WIDECHAR Compiler supports the WideChar type (D2+) - SUPPORTS_WIDESTRING Compiler supports the WideString type (D3+/BCB3+) - SUPPORTS_INTERFACE Compiler supports interfaces (D3+/BCB3+) - SUPPORTS_DISPINTERFACE Compiler supports dispatch interfaces (D3+/BCB3+) - SUPPORTS_DISPID Compiler supports dispatch ids (D3+/BCB3+/FPC) - SUPPORTS_EXTSYM Compiler supports the $EXTERNALSYM directive (D4+/BCB3+) - SUPPORTS_NODEFINE Compiler supports the $NODEFINE directive (D4+/BCB3+) - SUPPORTS_LONGWORD Compiler supports the LongWord type (unsigned 32 bit) (D4+/BCB4+) - SUPPORTS_INT64 Compiler supports the Int64 type (D4+/BCB4+) - SUPPORTS_UINT64 Compiler supports the UInt64 type (D XE+ ?) - SUPPORTS_DYNAMICARRAYS Compiler supports dynamic arrays (D4+/BCB4+) - SUPPORTS_DEFAULTPARAMS Compiler supports default parameters (D4+/BCB4+) - SUPPORTS_OVERLOAD Compiler supports overloading (D4+/BCB4+) - SUPPORTS_IMPLEMENTS Compiler supports implements (D4+/BCB4+) - SUPPORTS_DEPRECATED Compiler supports the deprecated directive (D6+/BCB6+) - SUPPORTS_PLATFORM Compiler supports the platform directive (D6+/BCB6+) - SUPPORTS_LIBRARY Compiler supports the library directive (D6+/BCB6+/FPC) - SUPPORTS_LOCAL Compiler supports the local directive (D6+/BCB6+) - SUPPORTS_SETPEFLAGS Compiler supports the SetPEFlags directive (D6+/BCB6+) - SUPPORTS_EXPERIMENTAL_WARNINGS Compiler supports the WARN SYMBOL_EXPERIMENTAL and WARN UNIT_EXPERIMENTAL directives (D6+/BCB6+) - SUPPORTS_INLINE Compiler supports the inline directive (D9+/FPC) - SUPPORTS_FOR_IN Compiler supports for in loops (D9+) - SUPPORTS_NESTED_CONSTANTS Compiler supports nested constants (D9+) - SUPPORTS_NESTED_TYPES Compiler supports nested types (D9+) - SUPPORTS_REGION Compiler supports the REGION and ENDREGION directives (D9+) - SUPPORTS_ENHANCED_RECORDS Compiler supports class [operator|function|procedure] for record types (D9.NET, D10+) - SUPPORTS_CLASS_FIELDS Compiler supports class fields (D9.NET, D10+) - SUPPORTS_CLASS_HELPERS Compiler supports class helpers (D9.NET, D10+) - SUPPORTS_CLASS_OPERATORS Compiler supports class operators (D9.NET, D10+) - SUPPORTS_CLASS_CTORDTORS Compiler supports class contructors/destructors (D14+) - SUPPORTS_STRICT Compiler supports strict keyword (D9.NET, D10+) - SUPPORTS_STATIC Compiler supports static keyword (D9.NET, D10+) - SUPPORTS_FINAL Compiler supports final keyword (D9.NET, D10+) - SUPPORTS_METHODINFO Compiler supports the METHODINFO directives (D10+) - SUPPORTS_GENERICS Compiler supports generic implementations (D11.NET, D12+) - SUPPORTS_DEPRECATED_DETAILS Compiler supports additional text for the deprecated directive (D11.NET, D12+) - ACCEPT_DEPRECATED Compiler supports or ignores the deprecated directive (D6+/BCB6+/FPC) - ACCEPT_PLATFORM Compiler supports or ignores the platform directive (D6+/BCB6+/FPC) - ACCEPT_LIBRARY Compiler supports or ignores the library directive (D6+/BCB6+) - SUPPORTS_CUSTOMVARIANTS Compiler supports custom variants (D6+/BCB6+) - SUPPORTS_VARARGS Compiler supports varargs (D6+/BCB6+) - SUPPORTS_ENUMVALUE Compiler supports assigning ordinalities to values of enums (D6+/BCB6+) - SUPPORTS_DEPRECATED_WARNINGS Compiler supports deprecated warnings (D6+/BCB6+) - SUPPORTS_LIBRARY_WARNINGS Compiler supports library warnings (D6+/BCB6+) - SUPPORTS_PLATFORM_WARNINGS Compiler supports platform warnings (D6+/BCB6+) - SUPPORTS_UNSAFE_WARNINGS Compiler supports unsafe warnings (D7) - SUPPORTS_WEAKPACKAGEUNIT Compiler supports the WEAKPACKAGEUNIT directive - SUPPORTS_COMPILETIME_MESSAGES Compiler supports the MESSAGE directive - SUPPORTS_PACKAGES Compiler supports Packages - HAS_UNIT_LIBC Unit Libc exists (Kylix, FPC on Linux/x86) - HAS_UNIT_RTLCONSTS Unit RTLConsts exists (D6+/BCB6+/FPC) - HAS_UNIT_TYPES Unit Types exists (D6+/BCB6+/FPC) - HAS_UNIT_VARIANTS Unit Variants exists (D6+/BCB6+/FPC) - HAS_UNIT_STRUTILS Unit StrUtils exists (D6+/BCB6+/FPC) - HAS_UNIT_DATEUTILS Unit DateUtils exists (D6+/BCB6+/FPC) - HAS_UNIT_CONTNRS Unit contnrs exists (D6+/BCB6+/FPC) - HAS_UNIT_HTTPPROD Unit HTTPProd exists (D9+) - HAS_UNIT_GIFIMG Unit GifImg exists (D11+) - HAS_UNIT_ANSISTRINGS Unit AnsiStrings exists (D12+) - HAS_UNIT_PNGIMAGE Unit PngImage exists (D12+) - HAS_UNIT_CHARACTER Unit Character exists (D12+) - XPLATFORM_RTL The RTL supports crossplatform function names (e.g. RaiseLastOSError) (D6+/BCB6+/FPC) - SUPPORTS_UNICODE string type is aliased to an unicode string (WideString or UnicodeString) (DX.NET, D12+) - SUPPORTS_UNICODE_STRING Compiler supports UnicodeString (D12+) - SUPPORTS_INT_ALIASES Types Int8, Int16, Int32, UInt8, UInt16 and UInt32 are defined in the unit System (D12+) - HAS_UNIT_RTTI Unit RTTI is available (D14+) - SUPPORTS_CAST_INTERFACE_TO_OBJ The compiler supports casts from interfaces to objects (D14+) - SUPPORTS_DELAYED_LOADING The compiler generates stubs for delaying imported function loads (D14+) - HAS_UNIT_REGULAREXPRESSIONSAPI Unit RegularExpressionsAPI is available (D15+) - HAS_UNIT_SYSTEM_UITYPES Unit System.UITypes is available (D16+) - HAS_UNIT_SYSTEM_ACTIONS Unit System.Actions is available (D17+) - - -- Compiler Settings - - The compiler settings directives indicate whether a specific compiler setting - is in effect. This facilitates changing compiler settings locally in a more - compact and readible manner. - - Directive Description - ------------------------------------------------------------------------------ - ALIGN_ON Compiling in the A+ state (no alignment) - BOOLEVAL_ON Compiling in the B+ state (complete boolean evaluation) - ASSERTIONS_ON Compiling in the C+ state (assertions on) - DEBUGINFO_ON Compiling in the D+ state (debug info generation on) - IMPORTEDDATA_ON Compiling in the G+ state (creation of imported data references) - LONGSTRINGS_ON Compiling in the H+ state (string defined as AnsiString) - IOCHECKS_ON Compiling in the I+ state (I/O checking enabled) - WRITEABLECONST_ON Compiling in the J+ state (typed constants can be modified) - LOCALSYMBOLS Compiling in the L+ state (local symbol generation) - LOCALSYMBOLS_ON Alias of LOCALSYMBOLS - TYPEINFO_ON Compiling in the M+ state (RTTI generation on) - OPTIMIZATION_ON Compiling in the O+ state (code optimization on) - OPENSTRINGS_ON Compiling in the P+ state (variable string parameters are openstrings) - OVERFLOWCHECKS_ON Compiling in the Q+ state (overflow checing on) - RANGECHECKS_ON Compiling in the R+ state (range checking on) - TYPEDADDRESS_ON Compiling in the T+ state (pointers obtained using the @ operator are typed) - SAFEDIVIDE_ON Compiling in the U+ state (save FDIV instruction through RTL emulation) - VARSTRINGCHECKS_ON Compiling in the V+ state (type checking of shortstrings) - STACKFRAMES_ON Compiling in the W+ state (generation of stack frames) - EXTENDEDSYNTAX_ON Compiling in the X+ state (Delphi extended syntax enabled) -*) - -{$DEFINE BORLAND} - -{ Set FreePascal to Delphi mode } -{$IFDEF FPC} - {$MODE DELPHI} -// {$ASMMODE Intel} //Not needed and raise error on non-intel platforms! - {$UNDEF BORLAND} - {$DEFINE CPUASM} - // FPC defines CPU32, CPU64 and Unix automatically -{$ENDIF} - -{$IFDEF BORLAND} - {$IFDEF LINUX} - {$DEFINE KYLIX} - {$ENDIF LINUX} - {$IFNDEF CLR} - {$IFNDEF CPUX86} - {$IFNDEF CPUX64} - {$DEFINE CPU386} // For Borland compilers select the x86 compat assembler by default - {$DEFINE CPU32} // Assume Borland compilers are 32-bit (rather than 64-bit) - {$DEFINE CPUASM} - {$ELSE ~CPUX64} - {$DEFINE CPU64} - {$DEFINE CPUASM} - {$DEFINE DELPHI64_TEMPORARY} - {$ENDIF ~CPUX64} - {$ELSE ~CPUX86} - {$DEFINE CPU386} - {$DEFINE CPU32} - {$DEFINE CPUASM} - {$ENDIF ~CPUX86} - {$ENDIF ~CLR} -{$ENDIF BORLAND} - -{------------------------------------------------------------------------------} -{ VERXXX to COMPILERX, DELPHIX and BCBX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF BORLAND} - {$IFDEF KYLIX} - {$I kylix.inc} // FPC incompatible stuff - {$ELSE ~KYLIX} - - {$DEFINE UNKNOWN_COMPILER_VERSION} - - {$IFDEF VER80} - {$DEFINE COMPILER1} - {$DEFINE DELPHI1} - {$DEFINE DELPHICOMPILER1} - {$DEFINE RTL80_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER90} - {$DEFINE COMPILER2} - {$DEFINE DELPHI2} - {$DEFINE DELPHICOMPILER2} - {$DEFINE RTL90_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER93} - {$DEFINE COMPILER2} - {$DEFINE BCB1} - {$DEFINE BCB} - {$DEFINE RTL93_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER100} - {$DEFINE COMPILER3} - {$DEFINE DELPHI3} - {$DEFINE DELPHICOMPILER3} - {$DEFINE RTL100_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER110} - {$DEFINE COMPILER35} - {$DEFINE BCB3} - {$DEFINE BCB} - {$DEFINE RTL110_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER120} - {$DEFINE COMPILER4} - {$DEFINE DELPHI4} - {$DEFINE DELPHICOMPILER4} - {$DEFINE RTL120_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER125} - {$DEFINE COMPILER4} - {$DEFINE BCB4} - {$DEFINE BCB} - {$DEFINE RTL125_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER130} - {$DEFINE COMPILER5} - {$IFDEF BCB} - {$DEFINE BCB5} - {$ELSE} - {$DEFINE DELPHI5} - {$DEFINE DELPHICOMPILER5} - {$ENDIF} - {$DEFINE RTL130_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER140} - {$DEFINE COMPILER6} - {$IFDEF BCB} - {$DEFINE BCB6} - {$ELSE} - {$DEFINE DELPHI6} - {$DEFINE DELPHICOMPILER6} - {$ENDIF} - {$DEFINE RTL140_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER150} - {$DEFINE COMPILER7} - {$DEFINE DELPHI7} - {$DEFINE DELPHICOMPILER7} - {$DEFINE RTL150_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER160} - {$DEFINE BDS2} - {$DEFINE BDS} - {$IFDEF CLR} - {$DEFINE CLR10} - {$ENDIF CLR} - {$DEFINE COMPILER8} - {$DEFINE DELPHI8} - {$DEFINE DELPHICOMPILER8} - {$DEFINE RTL160_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER170} - {$DEFINE BDS3} - {$DEFINE BDS} - {$IFDEF CLR} - {$DEFINE CLR11} - {$ENDIF CLR} - {$DEFINE COMPILER9} - {$DEFINE DELPHI9} - {$DEFINE DELPHI2005} // synonym to DELPHI9 - {$DEFINE DELPHICOMPILER9} - {$DEFINE RTL170_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER180} - {$DEFINE BDS} - {$IFDEF CLR} - {$DEFINE CLR11} - {$ENDIF CLR} - {$IFDEF VER185} - {$DEFINE BDS5} - {$DEFINE COMPILER11} - {$IFDEF BCB} - {$DEFINE BCB11} - {$ELSE} - {$DEFINE DELPHI11} - {$DEFINE DELPHI2007} // synonym to DELPHI11 - {$DEFINE DELPHICOMPILER11} - {$ENDIF} - {$DEFINE RTL185_UP} - {$ELSE ~~VER185} - {$DEFINE BDS4} - {$DEFINE COMPILER10} - {$IFDEF BCB} - {$DEFINE BCB10} - {$ELSE} - {$DEFINE DELPHI10} - {$DEFINE DELPHI2006} // synonym to DELPHI10 - {$DEFINE DELPHICOMPILER10} - {$ENDIF} - {$DEFINE RTL180_UP} - {$ENDIF ~VER185} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$IFDEF VER190} // Delphi 2007 for .NET - {$DEFINE BDS} - {$DEFINE BDS5} - {$IFDEF CLR} - {$DEFINE CLR20} - {$ENDIF CLR} - {$DEFINE COMPILER11} - {$DEFINE DELPHI11} - {$DEFINE DELPHI2007} // synonym to DELPHI11 - {$DEFINE DELPHICOMPILER11} - {$DEFINE RTL190_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER190} - - {$IFDEF VER200} // RAD Studio 2009 - {$DEFINE BDS} - {$DEFINE BDS6} - {$IFDEF CLR} - {$DEFINE CLR20} - {$ENDIF CLR} - {$DEFINE COMPILER12} - {$IFDEF BCB} - {$DEFINE BCB12} - {$ELSE} - {$DEFINE DELPHI12} - {$DEFINE DELPHI2009} // synonym to DELPHI12 - {$DEFINE DELPHICOMPILER12} - {$ENDIF BCB} - {$IFDEF CLR} - {$DEFINE RTL190_UP} - {$ELSE} - {$DEFINE RTL200_UP} - {$ENDIF} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER200} - - {$IFDEF VER210} // RAD Studio 2010 - {$DEFINE BDS} - {$DEFINE BDS7} - {$DEFINE COMPILER14} - {$IFDEF BCB} - {$DEFINE BCB14} - {$ELSE} - {$DEFINE DELPHI14} - {$DEFINE DELPHI2010} // synonym to DELPHI14 - {$DEFINE DELPHICOMPILER14} - {$ENDIF BCB} - {$DEFINE RTL210_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER210} - - {$IFDEF VER220} // RAD Studio XE - {$DEFINE BDS} - {$DEFINE BDS8} - {$DEFINE COMPILER15} - {$IFDEF BCB} - {$DEFINE BCB15} - {$ELSE} - {$DEFINE DELPHI15} - {$DEFINE DELPHIXE} // synonym to DELPHI15 - {$DEFINE DELPHICOMPILER15} - {$ENDIF BCB} - {$DEFINE RTL220_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER220} - - {$IFDEF VER230} // RAD Studio XE2 - {$DEFINE BDS} - {$DEFINE BDS9} - {$DEFINE COMPILER16} - {$IFDEF BCB} - {$DEFINE BCB16} - {$ELSE} - {$DEFINE DELPHI16} - {$DEFINE DELPHIXE2} // synonym to DELPHI16 - {$DEFINE DELPHICOMPILER16} - {$ENDIF BCB} - {$DEFINE RTL230_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER230} - - {$IFDEF VER240} // RAD Studio XE3 - {$DEFINE BDS} - {$DEFINE BDS10} - {$DEFINE COMPILER17} - {$IFDEF BCB} - {$DEFINE BCB17} - {$ELSE} - {$DEFINE DELPHI17} - {$DEFINE DELPHIXE3} // synonym to DELPHI17 - {$DEFINE DELPHICOMPILER17} - {$ENDIF BCB} - {$DEFINE RTL240_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF VER240} - - {$IFDEF UNKNOWN_COMPILER_VERSION} // adjust for newer version (always use latest version) - {$DEFINE BDS} - {$DEFINE BDS10} - {$DEFINE COMPILER17} - {$IFDEF BCB} - {$DEFINE BCB17} - {$ELSE} - {$DEFINE DELPHI17} - {$DEFINE DELPHIXE3} // synonym to DELPHI17 - {$DEFINE DELPHICOMPILER17} - {$ENDIF BCB} - {$DEFINE RTL240_UP} - {$UNDEF UNKNOWN_COMPILER_VERSION} - {$ENDIF} - - {$ENDIF ~KYLIX} - - {$IFDEF BCB} - {$DEFINE CPPBUILDER} - {$DEFINE BCBCOMPILER} - {$ELSE ~BCB} - {$DEFINE DELPHI} - {$DEFINE DELPHICOMPILER} - {$ENDIF ~BCB} - -{$ENDIF BORLAND} - -{------------------------------------------------------------------------------} -{ DELPHIX_UP from DELPHIX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF DELPHI17} {$DEFINE DELPHI17_UP} {$ENDIF} -{$IFDEF DELPHI16} {$DEFINE DELPHI16_UP} {$ENDIF} -{$IFDEF DELPHI15} {$DEFINE DELPHI15_UP} {$ENDIF} -{$IFDEF DELPHI14} {$DEFINE DELPHI14_UP} {$ENDIF} -{$IFDEF DELPHI12} {$DEFINE DELPHI12_UP} {$ENDIF} -{$IFDEF DELPHI11} {$DEFINE DELPHI11_UP} {$ENDIF} -{$IFDEF DELPHI10} {$DEFINE DELPHI10_UP} {$ENDIF} -{$IFDEF DELPHI9} {$DEFINE DELPHI9_UP} {$ENDIF} -{$IFDEF DELPHI8} {$DEFINE DELPHI8_UP} {$ENDIF} -{$IFDEF DELPHI7} {$DEFINE DELPHI7_UP} {$ENDIF} -{$IFDEF DELPHI6} {$DEFINE DELPHI6_UP} {$ENDIF} -{$IFDEF DELPHI5} {$DEFINE DELPHI5_UP} {$ENDIF} -{$IFDEF DELPHI4} {$DEFINE DELPHI4_UP} {$ENDIF} -{$IFDEF DELPHI3} {$DEFINE DELPHI3_UP} {$ENDIF} -{$IFDEF DELPHI2} {$DEFINE DELPHI2_UP} {$ENDIF} -{$IFDEF DELPHI1} {$DEFINE DELPHI1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ DELPHIX_UP from DELPHIX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF DELPHI17_UP} - {$DEFINE DELPHIXE3_UP} // synonym to DELPHI17_UP - {$DEFINE DELPHI16_UP} -{$ENDIF} - -{$IFDEF DELPHI16_UP} - {$DEFINE DELPHIXE2_UP} // synonym to DELPHI16_UP - {$DEFINE DELPHI15_UP} -{$ENDIF} - -{$IFDEF DELPHI15_UP} - {$DEFINE DELPHIXE_UP} // synonym to DELPHI15_UP - {$DEFINE DELPHI14_UP} -{$ENDIF} - -{$IFDEF DELPHI14_UP} - {$DEFINE DELPHI2010_UP} // synonym to DELPHI14_UP - {$DEFINE DELPHI12_UP} -{$ENDIF} - -{$IFDEF DELPHI12_UP} - {$DEFINE DELPHI2009_UP} // synonym to DELPHI12_UP - {$DEFINE DELPHI11_UP} -{$ENDIF} - -{$IFDEF DELPHI11_UP} - {$DEFINE DELPHI2007_UP} // synonym to DELPHI11_UP - {$DEFINE DELPHI10_UP} -{$ENDIF} - -{$IFDEF DELPHI10_UP} - {$DEFINE DELPHI2006_UP} // synonym to DELPHI10_UP - {$DEFINE DELPHI9_UP} -{$ENDIF} - -{$IFDEF DELPHI9_UP} - {$DEFINE DELPHI2005_UP} // synonym to DELPHI9_UP - {$DEFINE DELPHI8_UP} -{$ENDIF} - -{$IFDEF DELPHI8_UP} {$DEFINE DELPHI7_UP} {$ENDIF} -{$IFDEF DELPHI7_UP} {$DEFINE DELPHI6_UP} {$ENDIF} -{$IFDEF DELPHI6_UP} {$DEFINE DELPHI5_UP} {$ENDIF} -{$IFDEF DELPHI5_UP} {$DEFINE DELPHI4_UP} {$ENDIF} -{$IFDEF DELPHI4_UP} {$DEFINE DELPHI3_UP} {$ENDIF} -{$IFDEF DELPHI3_UP} {$DEFINE DELPHI2_UP} {$ENDIF} -{$IFDEF DELPHI2_UP} {$DEFINE DELPHI1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ BCBX_UP from BCBX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF BCB17} {$DEFINE BCB17_UP} {$ENDIF} -{$IFDEF BCB16} {$DEFINE BCB16_UP} {$ENDIF} -{$IFDEF BCB15} {$DEFINE BCB15_UP} {$ENDIF} -{$IFDEF BCB14} {$DEFINE BCB14_UP} {$ENDIF} -{$IFDEF BCB12} {$DEFINE BCB12_UP} {$ENDIF} -{$IFDEF BCB11} {$DEFINE BCB11_UP} {$ENDIF} -{$IFDEF BCB10} {$DEFINE BCB10_UP} {$ENDIF} -{$IFDEF BCB6} {$DEFINE BCB6_UP} {$ENDIF} -{$IFDEF BCB5} {$DEFINE BCB5_UP} {$ENDIF} -{$IFDEF BCB4} {$DEFINE BCB4_UP} {$ENDIF} -{$IFDEF BCB3} {$DEFINE BCB3_UP} {$ENDIF} -{$IFDEF BCB1} {$DEFINE BCB1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ BCBX_UP from BCBX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF BCB17_UP} {$DEFINE BCB16_UP} {$ENDIF} -{$IFDEF BCB16_UP} {$DEFINE BCB15_UP} {$ENDIF} -{$IFDEF BCB15_UP} {$DEFINE BCB14_UP} {$ENDIF} -{$IFDEF BCB14_UP} {$DEFINE BCB12_UP} {$ENDIF} -{$IFDEF BCB12_UP} {$DEFINE BCB11_UP} {$ENDIF} -{$IFDEF BCB11_UP} {$DEFINE BCB10_UP} {$ENDIF} -{$IFDEF BCB10_UP} {$DEFINE BCB6_UP} {$ENDIF} -{$IFDEF BCB6_UP} {$DEFINE BCB5_UP} {$ENDIF} -{$IFDEF BCB5_UP} {$DEFINE BCB4_UP} {$ENDIF} -{$IFDEF BCB4_UP} {$DEFINE BCB3_UP} {$ENDIF} -{$IFDEF BCB3_UP} {$DEFINE BCB1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ BDSX_UP from BDSX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF BDS10} {$DEFINE BDS10_UP} {$ENDIF} -{$IFDEF BDS9} {$DEFINE BDS9_UP} {$ENDIF} -{$IFDEF BDS8} {$DEFINE BDS8_UP} {$ENDIF} -{$IFDEF BDS7} {$DEFINE BDS7_UP} {$ENDIF} -{$IFDEF BDS6} {$DEFINE BDS6_UP} {$ENDIF} -{$IFDEF BDS5} {$DEFINE BDS5_UP} {$ENDIF} -{$IFDEF BDS4} {$DEFINE BDS4_UP} {$ENDIF} -{$IFDEF BDS3} {$DEFINE BDS3_UP} {$ENDIF} -{$IFDEF BDS2} {$DEFINE BDS2_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ BDSX_UP from BDSX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF BDS10_UP} {$DEFINE BDS9_UP} {$ENDIF} -{$IFDEF BDS9_UP} {$DEFINE BDS8_UP} {$ENDIF} -{$IFDEF BDS8_UP} {$DEFINE BDS7_UP} {$ENDIF} -{$IFDEF BDS7_UP} {$DEFINE BDS6_UP} {$ENDIF} -{$IFDEF BDS6_UP} {$DEFINE BDS5_UP} {$ENDIF} -{$IFDEF BDS5_UP} {$DEFINE BDS4_UP} {$ENDIF} -{$IFDEF BDS4_UP} {$DEFINE BDS3_UP} {$ENDIF} -{$IFDEF BDS3_UP} {$DEFINE BDS2_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ DELPHICOMPILERX_UP from DELPHICOMPILERX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF DELPHICOMPILER17} {$DEFINE DELPHICOMPILER17_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER16} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER15} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER14} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER12} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER11} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER10} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER9} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER8} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER7} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER6} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER5} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER4} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER3} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER2} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER1} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ DELPHICOMPILERX_UP from DELPHICOMPILERX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF DELPHICOMPILER17_UP} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER16_UP} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER15_UP} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER14_UP} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER12_UP} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER11_UP} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER10_UP} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER9_UP} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER7_UP} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER6_UP} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER5_UP} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER4_UP} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER3_UP} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF} -{$IFDEF DELPHICOMPILER2_UP} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ COMPILERX_UP from COMPILERX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF COMPILER17} {$DEFINE COMPILER17_UP} {$ENDIF} -{$IFDEF COMPILER16} {$DEFINE COMPILER16_UP} {$ENDIF} -{$IFDEF COMPILER15} {$DEFINE COMPILER15_UP} {$ENDIF} -{$IFDEF COMPILER14} {$DEFINE COMPILER14_UP} {$ENDIF} -{$IFDEF COMPILER12} {$DEFINE COMPILER12_UP} {$ENDIF} -{$IFDEF COMPILER11} {$DEFINE COMPILER11_UP} {$ENDIF} -{$IFDEF COMPILER10} {$DEFINE COMPILER10_UP} {$ENDIF} -{$IFDEF COMPILER9} {$DEFINE COMPILER9_UP} {$ENDIF} -{$IFDEF COMPILER8} {$DEFINE COMPILER8_UP} {$ENDIF} -{$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$ENDIF} -{$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF} -{$IFDEF COMPILER5} {$DEFINE COMPILER5_UP} {$ENDIF} -{$IFDEF COMPILER4} {$DEFINE COMPILER4_UP} {$ENDIF} -{$IFDEF COMPILER35} {$DEFINE COMPILER35_UP} {$ENDIF} -{$IFDEF COMPILER3} {$DEFINE COMPILER3_UP} {$ENDIF} -{$IFDEF COMPILER2} {$DEFINE COMPILER2_UP} {$ENDIF} -{$IFDEF COMPILER1} {$DEFINE COMPILER1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ COMPILERX_UP from COMPILERX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF COMPILER17_UP} {$DEFINE COMPILER16_UP} {$ENDIF} -{$IFDEF COMPILER16_UP} {$DEFINE COMPILER15_UP} {$ENDIF} -{$IFDEF COMPILER15_UP} {$DEFINE COMPILER14_UP} {$ENDIF} -{$IFDEF COMPILER14_UP} {$DEFINE COMPILER12_UP} {$ENDIF} -{$IFDEF COMPILER12_UP} {$DEFINE COMPILER11_UP} {$ENDIF} -{$IFDEF COMPILER11_UP} {$DEFINE COMPILER10_UP} {$ENDIF} -{$IFDEF COMPILER10_UP} {$DEFINE COMPILER9_UP} {$ENDIF} -{$IFDEF COMPILER9_UP} {$DEFINE COMPILER8_UP} {$ENDIF} -{$IFDEF COMPILER8_UP} {$DEFINE COMPILER7_UP} {$ENDIF} -{$IFDEF COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} -{$IFDEF COMPILER6_UP} {$DEFINE COMPILER5_UP} {$ENDIF} -{$IFDEF COMPILER5_UP} {$DEFINE COMPILER4_UP} {$ENDIF} -{$IFDEF COMPILER4_UP} {$DEFINE COMPILER35_UP} {$ENDIF} -{$IFDEF COMPILER35_UP} {$DEFINE COMPILER3_UP} {$ENDIF} -{$IFDEF COMPILER3_UP} {$DEFINE COMPILER2_UP} {$ENDIF} -{$IFDEF COMPILER2_UP} {$DEFINE COMPILER1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ RTLX_UP from RTLX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF RTL240_UP} {$DEFINE RTL230_UP} {$ENDIF} -{$IFDEF RTL230_UP} {$DEFINE RTL220_UP} {$ENDIF} -{$IFDEF RTL220_UP} {$DEFINE RTL210_UP} {$ENDIF} -{$IFDEF RTL210_UP} {$DEFINE RTL200_UP} {$ENDIF} -{$IFDEF RTL200_UP} {$DEFINE RTL190_UP} {$ENDIF} -{$IFDEF RTL190_UP} {$DEFINE RTL185_UP} {$ENDIF} -{$IFDEF RTL185_UP} {$DEFINE RTL180_UP} {$ENDIF} -{$IFDEF RTL180_UP} {$DEFINE RTL170_UP} {$ENDIF} -{$IFDEF RTL170_UP} {$DEFINE RTL160_UP} {$ENDIF} -{$IFDEF RTL160_UP} {$DEFINE RTL150_UP} {$ENDIF} -{$IFDEF RTL150_UP} {$DEFINE RTL145_UP} {$ENDIF} -{$IFDEF RTL145_UP} {$DEFINE RTL142_UP} {$ENDIF} -{$IFDEF RTL142_UP} {$DEFINE RTL140_UP} {$ENDIF} -{$IFDEF RTL140_UP} {$DEFINE RTL130_UP} {$ENDIF} -{$IFDEF RTL130_UP} {$DEFINE RTL125_UP} {$ENDIF} -{$IFDEF RTL125_UP} {$DEFINE RTL120_UP} {$ENDIF} -{$IFDEF RTL120_UP} {$DEFINE RTL110_UP} {$ENDIF} -{$IFDEF RTL110_UP} {$DEFINE RTL100_UP} {$ENDIF} -{$IFDEF RTL100_UP} {$DEFINE RTL93_UP} {$ENDIF} -{$IFDEF RTL93_UP} {$DEFINE RTL90_UP} {$ENDIF} -{$IFDEF RTL90_UP} {$DEFINE RTL80_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ Check for CLR overrides of default detection } -{------------------------------------------------------------------------------} - -{$IFDEF CLR} - {$IFDEF FORCE_CLR10} - {$DEFINE CLR10} - {$UNDEF CLR11} - {$UNDEF CLR20} - {$ENDIF FORCE_CLR10} - - {$IFDEF FORCE_CLR11} - {$UNDEF CLR10} - {$DEFINE CLR11} - {$UNDEF CLR20} - {$ENDIF FORCE_CLR11} - - {$IFDEF FORCE_CLR20} - {$UNDEF CLR10} - {$UNDEF CLR11} - {$DEFINE CLR20} - {$ENDIF FORCE_CLR20} -{$ENDIF CLR} - -{------------------------------------------------------------------------------} -{ CLRX from CLRX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF CLR10} {$DEFINE CLR10_UP} {$ENDIF} -{$IFDEF CLR11} {$DEFINE CLR11_UP} {$ENDIF} -{$IFDEF CLR20} {$DEFINE CLR20_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ CLRX_UP from CLRX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF CLR20_UP} {$DEFINE CLR11_UP} {$ENDIF} -{$IFDEF CLR11_UP} {$DEFINE CLR10_UP} {$ENDIF} - -{------------------------------------------------------------------------------} - -{$IFDEF DELPHICOMPILER} - {$DEFINE DELPHILANGUAGE} -{$ENDIF} - -{$IFDEF BCBCOMPILER} - {$DEFINE DELPHILANGUAGE} -{$ENDIF} - -{------------------------------------------------------------------------------} -{ KYLIXX_UP from KYLIXX mappings } -{------------------------------------------------------------------------------} - -{$IFDEF KYLIX3} {$DEFINE KYLIX3_UP} {$ENDIF} -{$IFDEF KYLIX2} {$DEFINE KYLIX2_UP} {$ENDIF} -{$IFDEF KYLIX1} {$DEFINE KYLIX1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ KYLIXX_UP from KYLIXX_UP mappings } -{------------------------------------------------------------------------------} - -{$IFDEF KYLIX3_UP} {$DEFINE KYLIX2_UP} {$ENDIF} -{$IFDEF KYLIX2_UP} {$DEFINE KYLIX1_UP} {$ENDIF} - -{------------------------------------------------------------------------------} -{ Map COMPILERX_UP to friendly feature names } -{------------------------------------------------------------------------------} - -{$IFDEF FPC} - {$IFDEF VER1_0} - Please use FPC 2.0 or higher to compile this. - {$ELSE} - {$DEFINE SUPPORTS_OUTPARAMS} - {$DEFINE SUPPORTS_WIDECHAR} - {$DEFINE SUPPORTS_WIDESTRING} - {$IFDEF HASINTF} - {$DEFINE SUPPORTS_INTERFACE} - {$ENDIF} - {$IFDEF HASVARIANT} - {$DEFINE SUPPORTS_VARIANT} - {$ENDIF} - {$IFDEF FPC_HAS_TYPE_SINGLE} - {$DEFINE SUPPORTS_SINGLE} - {$ENDIF} - {$IFDEF FPC_HAS_TYPE_DOUBLE} - {$DEFINE SUPPORTS_DOUBLE} - {$ENDIF} - {$IFDEF FPC_HAS_TYPE_EXTENDED} - {$DEFINE SUPPORTS_EXTENDED} - {$ENDIF} - {$IFDEF HASCURRENCY} - {$DEFINE SUPPORTS_CURRENCY} - {$ENDIF} - {$DEFINE SUPPORTS_THREADVAR} - {$DEFINE SUPPORTS_CONSTPARAMS} - {$DEFINE SUPPORTS_LONGWORD} - {$DEFINE SUPPORTS_INT64} - {$DEFINE SUPPORTS_DYNAMICARRAYS} - {$DEFINE SUPPORTS_DEFAULTPARAMS} - {$DEFINE SUPPORTS_OVERLOAD} - {$DEFINE ACCEPT_DEPRECATED} // 2.2 also gives warnings - {$DEFINE ACCEPT_PLATFORM} // 2.2 also gives warnings - {$DEFINE ACCEPT_LIBRARY} - {$DEFINE SUPPORTS_EXTSYM} - {$DEFINE SUPPORTS_NODEFINE} - - {$DEFINE SUPPORTS_CUSTOMVARIANTS} - {$DEFINE SUPPORTS_VARARGS} - {$DEFINE SUPPORTS_ENUMVALUE} - {$IFDEF LINUX} - {$DEFINE HAS_UNIT_LIBC} - {$ENDIF LINUX} - {$DEFINE HAS_UNIT_CONTNRS} - {$DEFINE HAS_UNIT_TYPES} - {$DEFINE HAS_UNIT_VARIANTS} - {$DEFINE HAS_UNIT_STRUTILS} - {$DEFINE HAS_UNIT_DATEUTILS} - {$DEFINE HAS_UNIT_RTLCONSTS} - - {$DEFINE XPLATFORM_RTL} - - {$IFDEF VER2_2} - {$DEFINE SUPPORTS_DISPINTERFACE} - {$DEFINE SUPPORTS_IMPLEMENTS} - {$DEFINE SUPPORTS_DISPID} - {$ELSE} - {$UNDEF SUPPORTS_DISPINTERFACE} - {$UNDEF SUPPORTS_IMPLEMENTS} - {$endif} - {$UNDEF SUPPORTS_UNSAFE_WARNINGS} - {$ENDIF} -{$ENDIF FPC} - -{$IFDEF CLR} - {$DEFINE SUPPORTS_UNICODE} -{$ENDIF CLR} - -{$IFDEF COMPILER1_UP} - {$DEFINE SUPPORTS_CONSTPARAMS} - {$DEFINE SUPPORTS_SINGLE} - {$DEFINE SUPPORTS_DOUBLE} - {$DEFINE SUPPORTS_EXTENDED} - {$DEFINE SUPPORTS_PACKAGES} -{$ENDIF COMPILER1_UP} - -{$IFDEF COMPILER2_UP} - {$DEFINE SUPPORTS_CURRENCY} - {$DEFINE SUPPORTS_THREADVAR} - {$DEFINE SUPPORTS_VARIANT} - {$DEFINE SUPPORTS_WIDECHAR} -{$ENDIF COMPILER2_UP} - -{$IFDEF COMPILER3_UP} - {$DEFINE SUPPORTS_OUTPARAMS} - {$DEFINE SUPPORTS_WIDESTRING} - {$DEFINE SUPPORTS_INTERFACE} - {$DEFINE SUPPORTS_DISPINTERFACE} - {$DEFINE SUPPORTS_DISPID} - {$DEFINE SUPPORTS_WEAKPACKAGEUNIT} -{$ENDIF COMPILER3_UP} - -{$IFDEF COMPILER35_UP} - {$DEFINE SUPPORTS_EXTSYM} - {$DEFINE SUPPORTS_NODEFINE} -{$ENDIF COMPILER35_UP} - -{$IFDEF COMPILER4_UP} - {$DEFINE SUPPORTS_LONGWORD} - {$DEFINE SUPPORTS_INT64} - {$DEFINE SUPPORTS_DYNAMICARRAYS} - {$DEFINE SUPPORTS_DEFAULTPARAMS} - {$DEFINE SUPPORTS_OVERLOAD} - {$DEFINE SUPPORTS_IMPLEMENTS} -{$ENDIF COMPILER4_UP} - -{$IFDEF COMPILER6_UP} - {$DEFINE SUPPORTS_DEPRECATED} - {$DEFINE SUPPORTS_LIBRARY} - {$DEFINE SUPPORTS_PLATFORM} - {$DEFINE SUPPORTS_LOCAL} - {$DEFINE SUPPORTS_SETPEFLAGS} - {$DEFINE SUPPORTS_EXPERIMENTAL_WARNINGS} - {$DEFINE ACCEPT_DEPRECATED} - {$DEFINE ACCEPT_PLATFORM} - {$DEFINE ACCEPT_LIBRARY} - {$DEFINE SUPPORTS_DEPRECATED_WARNINGS} - {$DEFINE SUPPORTS_LIBRARY_WARNINGS} - {$DEFINE SUPPORTS_PLATFORM_WARNINGS} - {$DEFINE SUPPORTS_CUSTOMVARIANTS} - {$DEFINE SUPPORTS_VARARGS} - {$DEFINE SUPPORTS_ENUMVALUE} - {$DEFINE SUPPORTS_COMPILETIME_MESSAGES} -{$ENDIF COMPILER6_UP} - -{$IFDEF COMPILER7_UP} - {$DEFINE SUPPORTS_UNSAFE_WARNINGS} -{$ENDIF COMPILER7_UP} - -{$IFDEF COMPILER9_UP} - {$DEFINE SUPPORTS_FOR_IN} - {$DEFINE SUPPORTS_INLINE} - {$DEFINE SUPPORTS_NESTED_CONSTANTS} - {$DEFINE SUPPORTS_NESTED_TYPES} - {$DEFINE SUPPORTS_REGION} - {$IFDEF CLR} - {$DEFINE SUPPORTS_ENHANCED_RECORDS} - {$DEFINE SUPPORTS_CLASS_FIELDS} - {$DEFINE SUPPORTS_CLASS_HELPERS} - {$DEFINE SUPPORTS_CLASS_OPERATORS} - {$DEFINE SUPPORTS_STRICT} - {$DEFINE SUPPORTS_STATIC} - {$DEFINE SUPPORTS_FINAL} - {$ENDIF CLR} -{$ENDIF COMPILER9_UP} - -{$IFDEF COMPILER10_UP} - {$DEFINE SUPPORTS_ENHANCED_RECORDS} - {$DEFINE SUPPORTS_CLASS_FIELDS} - {$DEFINE SUPPORTS_CLASS_HELPERS} - {$DEFINE SUPPORTS_CLASS_OPERATORS} - {$DEFINE SUPPORTS_STRICT} - {$DEFINE SUPPORTS_STATIC} - {$DEFINE SUPPORTS_FINAL} - {$DEFINE SUPPORTS_METHODINFO} -{$ENDIF COMPILER10_UP} - -{$IFDEF COMPILER11_UP} - {$IFDEF CLR} - {$DEFINE SUPPORTS_GENERICS} - {$DEFINE SUPPORTS_DEPRECATED_DETAILS} - {$ENDIF CLR} -{$ENDIF COMPILER11_UP} - -{$IFDEF COMPILER12_UP} - {$DEFINE SUPPORTS_GENERICS} - {$DEFINE SUPPORTS_DEPRECATED_DETAILS} - {$DEFINE SUPPORTS_INT_ALIASES} - {$IFNDEF CLR} - {$DEFINE SUPPORTS_UNICODE} - {$DEFINE SUPPORTS_UNICODE_STRING} - {$ENDIF CLR} -{$ENDIF COMPILER12_UP} - -{$IFDEF COMPILER14_UP} - {$DEFINE SUPPORTS_CLASS_CTORDTORS} - {$DEFINE HAS_UNIT_RTTI} - {$DEFINE SUPPORTS_CAST_INTERFACE_TO_OBJ} - {$DEFINE SUPPORTS_DELAYED_LOADING} -{$ENDIF COMPILER14_UP} - -{$IFDEF COMPILER16_UP} - {$DEFINE USE_64BIT_TYPES} -{$ENDIF COMPILER16_UP} - -{$IFDEF RTL130_UP} - {$DEFINE HAS_UNIT_CONTNRS} -{$ENDIF RTL130_UP} - -{$IFDEF RTL140_UP} - {$IFDEF LINUX} - {$DEFINE HAS_UNIT_LIBC} - {$ENDIF LINUX} - {$DEFINE HAS_UNIT_RTLCONSTS} - {$DEFINE HAS_UNIT_TYPES} - {$DEFINE HAS_UNIT_VARIANTS} - {$DEFINE HAS_UNIT_STRUTILS} - {$DEFINE HAS_UNIT_DATEUTILS} - {$DEFINE XPLATFORM_RTL} -{$ENDIF RTL140_UP} - -{$IFDEF RTL170_UP} - {$DEFINE HAS_UNIT_HTTPPROD} -{$ENDIF RTL170_UP} - -{$IFDEF RTL185_UP} - {$DEFINE HAS_UNIT_GIFIMG} -{$ENDIF RTL185_UP} - -{$IFDEF RTL200_UP} - {$DEFINE HAS_UNIT_ANSISTRINGS} - {$DEFINE HAS_UNIT_PNGIMAGE} - {$DEFINE HAS_UNIT_CHARACTER} -{$ENDIF RTL200_UP} - -{$IFDEF RTL220_UP} - {$DEFINE SUPPORTS_UINT64} - {$DEFINE HAS_UNIT_REGULAREXPRESSIONSAPI} -{$ENDIF RTL220_UP} - -{$IFDEF RTL230_UP} - {$DEFINE HAS_UNITSCOPE} - {$DEFINE HAS_UNIT_SYSTEM_UITYPES} -{$ENDIF RTL230_UP} - -{$IFDEF RTL240_UP} - {$DEFINE HAS_UNIT_SYSTEM_ACTIONS} -{$ENDIF RTL240_UP} - -{------------------------------------------------------------------------------} -{ Cross-platform related defines } -{------------------------------------------------------------------------------} - -{$IFNDEF CPUASM} - {$DEFINE PUREPASCAL} -{$ENDIF ~CPUASM} - -{$IFDEF WIN32} - {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+ - {$DEFINE Win32API} -{$ENDIF} - -{$IFDEF DELPHILANGUAGE} - {$IFDEF LINUX} - {$DEFINE UNIX} - {$ENDIF} - - {$IFNDEF CONSOLE} - {$IFDEF LINUX} - {$DEFINE VisualCLX} - {$ENDIF} - {$IFNDEF VisualCLX} - {$DEFINE VCL} - {$ENDIF} - {$ENDIF ~CONSOLE} -{$ENDIF DELPHILANGUAGE} - -{------------------------------------------------------------------------------} -{ Compiler settings } -{------------------------------------------------------------------------------} - -{$IFOPT A+} {$DEFINE ALIGN_ON} {$ENDIF} -{$IFOPT B+} {$DEFINE BOOLEVAL_ON} {$ENDIF} -{$IFDEF COMPILER2_UP} - {$IFOPT C+} {$DEFINE ASSERTIONS_ON} {$ENDIF} -{$ENDIF} -{$IFOPT D+} {$DEFINE DEBUGINFO_ON} {$ENDIF} -{$IFOPT G+} {$DEFINE IMPORTEDDATA_ON} {$ENDIF} -{$IFDEF COMPILER2_UP} - {$IFOPT H+} {$DEFINE LONGSTRINGS_ON} {$ENDIF} -{$ENDIF} - -// Hints -{$IFOPT I+} {$DEFINE IOCHECKS_ON} {$ENDIF} -{$IFDEF COMPILER2_UP} - {$IFOPT J+} {$DEFINE WRITEABLECONST_ON} {$ENDIF} -{$ENDIF} -{$IFOPT L+} {$DEFINE LOCALSYMBOLS} {$DEFINE LOCALSYMBOLS_ON} {$ENDIF} -{$IFOPT M+} {$DEFINE TYPEINFO_ON} {$ENDIF} -{$IFOPT O+} {$DEFINE OPTIMIZATION_ON} {$ENDIF} -{$IFOPT P+} {$DEFINE OPENSTRINGS_ON} {$ENDIF} -{$IFOPT Q+} {$DEFINE OVERFLOWCHECKS_ON} {$ENDIF} -{$IFOPT R+} {$DEFINE RANGECHECKS_ON} {$ENDIF} - -// Real compatibility -{$IFOPT T+} {$DEFINE TYPEDADDRESS_ON} {$ENDIF} -{$IFOPT U+} {$DEFINE SAFEDIVIDE_ON} {$ENDIF} -{$IFOPT V+} {$DEFINE VARSTRINGCHECKS_ON} {$ENDIF} -{$IFOPT W+} {$DEFINE STACKFRAMES_ON} {$ENDIF} - -// Warnings -{$IFOPT X+} {$DEFINE EXTENDEDSYNTAX_ON} {$ENDIF} - -// for Delphi/BCB trial versions remove the point from the line below -{.$UNDEF SUPPORTS_WEAKPACKAGEUNIT} - -{$ENDIF ~JEDI_INC} +{$IFNDEF JEDI_INC} +{$DEFINE JEDI_INC} + +{**************************************************************************************************} +{ } +{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");} +{ you may not use this file except in compliance with the License. You may obtain a copy of the } +{ License at http://www.mozilla.org/MPL/ } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } +{ ANY KIND, either express or implied. See the License for the specific language governing rights } +{ and limitations under the License. } +{ } +{ The Original Code is: jedi.inc. } +{ The Initial Developer of the Original Code is Project JEDI http://www.delphi-jedi.org } +{ } +{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General } +{ Public License (the "LGPL License"), in which case the provisions of the LGPL License are } +{ applicable instead of those above. If you wish to allow use of your version of this file only } +{ under the terms of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and replace them with } +{ the notice and other provisions required by the LGPL License. If you do not delete the } +{ provisions above, a recipient may use your version of this file under either the MPL or the } +{ LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{**************************************************************************************************} +{ } +{ This file defines various generic compiler directives used in different libraries, e.g. in the } +{ JEDI Code Library (JCL) and JEDI Visual Component Library Library (JVCL). The directives in } +{ this file are of generic nature and consist mostly of mappings from the VERXXX directives } +{ defined by Delphi, C++Builder and FPC to friendly names such as DELPHI5 and } +{ SUPPORTS_WIDESTRING. These friendly names are subsequently used in the libraries to test for } +{ compiler versions and/or whether the compiler supports certain features (such as widestrings or } +{ 64 bit integers. The libraries provide an additional, library specific, include file. For the } +{ JCL e.g. this is jcl.inc. These files should be included in source files instead of this file } +{ (which is pulled in automatically). } +{ } +{**************************************************************************************************} +{ } +{ Last modified: $Date:: $ } +{ Revision: $Rev:: $ } +{ Author: $Author:: $ } +{ } +{**************************************************************************************************} + +(* + +- Development environment directives + + This file defines two directives to indicate which development environment the + library is being compiled with. Currently this can either be Delphi, Kylix, + C++Builder or FPC. + + Directive Description + ------------------------------------------------------------------------------ + DELPHI Defined if compiled with Delphi + KYLIX Defined if compiled with Kylix + DELPHICOMPILER Defined if compiled with Delphi or Kylix/Delphi + BCB Defined if compiled with C++Builder + CPPBUILDER Defined if compiled with C++Builder (alias for BCB) + BCBCOMPILER Defined if compiled with C++Builder or Kylix/C++ + DELPHILANGUAGE Defined if compiled with Delphi, Kylix or C++Builder + BORLAND Defined if compiled with Delphi, Kylix or C++Builder + FPC Defined if compiled with FPC + +- Platform Directives + + Platform directives are not all explicitly defined in this file, some are + defined by the compiler itself. They are listed here only for completeness. + + Directive Description + ------------------------------------------------------------------------------ + WIN32 Defined when target platform is 32 bit Windows + WIN64 Defined when target platform is 64 bit Windows + MSWINDOWS Defined when target platform is 32 bit Windows + LINUX Defined when target platform is Linux + UNIX Defined when target platform is Unix-like (including Linux) + CLR Defined when target platform is .NET + +- Architecture directives. These are auto-defined by FPC + CPU32 and CPU64 are mostly for generic pointer size dependant differences rather + than for a specific architecture. + + CPU386 Defined when target platform is native x86 (win32) + CPUx86_64 Defined when target platform is native x86_64 (win64) + CPU32 Defined when target is 32-bit + CPU64 Defined when target is 64-bit + CPUASM Defined when target assembler is available + +- Visual library Directives + + The following directives indicate for a visual library. In a Delphi/BCB + (Win32) application you need to define the VisualCLX symbol in the project + options, if you want to use the VisualCLX library. Alternatively you can use + the IDE expert, which is distributed with the JCL to do this automatically. + + Directive Description + ------------------------------------------------------------------------------ + VCL Defined for Delphi/BCB (Win32) exactly if VisualCLX is not defined + VisualCLX Defined for Kylix; needs to be defined for Delphi/BCB to + use JCL with VisualCLX applications. + + +- Other cross-platform related defines + + These symbols are intended to help in writing portable code. + + Directive Description + ------------------------------------------------------------------------------ + PUREPASCAL Code is machine-independent (as opposed to assembler code) + Win32API Code is specific for the Win32 API; + use instead of "{$IFNDEF CLR} {$IFDEF MSWINDOWS}" constructs + + +- Delphi Versions + + The following directives are direct mappings from the VERXXX directives to a + friendly name of the associated compiler. These directives are only defined if + the compiler is Delphi (ie DELPHI is defined). + + Directive Description + ------------------------------------------------------------------------------ + DELPHI1 Defined when compiling with Delphi 1 (Codename WASABI/MANGO) + DELPHI2 Defined when compiling with Delphi 2 (Codename POLARIS) + DELPHI3 Defined when compiling with Delphi 3 (Codename IVORY) + DELPHI4 Defined when compiling with Delphi 4 (Codename ALLEGRO) + DELPHI5 Defined when compiling with Delphi 5 (Codename ARGUS) + DELPHI6 Defined when compiling with Delphi 6 (Codename ILLIAD) + DELPHI7 Defined when compiling with Delphi 7 (Codename AURORA) + DELPHI8 Defined when compiling with Delphi 8 (Codename OCTANE) + DELPHI2005 Defined when compiling with Delphi 2005 (Codename DIAMONDBACK) + DELPHI9 Alias for DELPHI2005 + DELPHI10 Defined when compiling with Delphi 2006 (Codename DEXTER) + DELPHI2006 Alias for DELPHI10 + DELPHI11 Defined when compiling with Delphi 2007 for Win32 (Codename SPACELY) + DELPHI2007 Alias for DELPHI11 + DELPHI12 Defined when compiling with Delphi 2009 for Win32 (Codename TIBURON) + DELPHI2009 Alias for DELPHI12 + DELPHI14 Defined when compiling with Delphi 2010 for Win32 (Codename WEAVER) + DELPHI2010 Alias for DELPHI14 + DELPHI15 Defined when compiling with Delphi XE for Win32 (Codename FULCRUM) + DELPHIXE Alias for DELPHI15 + DELPHI16 Defined when compiling with Delphi XE2 for Win32 (Codename PULSAR) + DELPHIXE2 Alias for DELPHI16 + DELPHI17 Defined when compiling with Delphi XE3 for Win32 (Codename WATERDRAGON) + DELPHIXE3 Alias for DELPHI17 + DELPHI18 Defined when compiling with Delphi XE4 for Win32 (Codename QUINTESSENCE) + DELPHIXE4 Alias for DELPHI18 + DELPHI19 Defined when compiling with Delphi XE5 for Win32 (Codename ZEPHYR) + DELPHIXE5 Alias for DELPHI19 + DELPHI20 Defined when compiling with Delphi XE6 for Win32 (Codename PROTEUS) + DELPHIXE6 Alias for DELPHI20 + DELPHI21 Defined when compiling with Delphi XE7 for Win32 (Codename CARPATHIA) + DELPHIXE7 Alias for DELPHI21 + DELPHI22 Defined when compiling with Delphi XE8 for Win32 (Codename ELBRUS) + DELPHIXE8 Alias for DELPHI22 + DELPHI23 Defined when compiling with Delphi 10 for Win32 (Codename AITANA) + DELPHIX_SEATTLE Alias for DELPHI23 + DELPHI24 Defined when compiling with Delphi 10.1 for Win32 (Codename BIGBEN) + DELPHIX_BERLIN Alias for DELPHI24 + DELPHI25 Defined when compiling with Delphi 10.2 for Win32 (Codename GODZILLA) + DELPHIX_TOKYO Alias for DELPHI25 + DELPHI26 Defined when compiling with Delphi 10.3 for Win32 (Codename CARNIVAL) + DELPHIX_RIO Alias for DELPHI26 + DELPHI27 Defined when compiling with Delphi 10.4 for Win32 (Codename DENALI) + DELPHIX_SYDNEY Alias for DELPHI27 + DELPHI28 Defined when compiling with Delphi 10.4 for Win32 (Codename OLYMPUS) + DELPHIX_ALEXANDRIA Alias for DELPHI28 + DELPHI1_UP Defined when compiling with Delphi 1 or higher + DELPHI2_UP Defined when compiling with Delphi 2 or higher + DELPHI3_UP Defined when compiling with Delphi 3 or higher + DELPHI4_UP Defined when compiling with Delphi 4 or higher + DELPHI5_UP Defined when compiling with Delphi 5 or higher + DELPHI6_UP Defined when compiling with Delphi 6 or higher + DELPHI7_UP Defined when compiling with Delphi 7 or higher + DELPHI8_UP Defined when compiling with Delphi 8 or higher + DELPHI2005_UP Defined when compiling with Delphi 2005 or higher + DELPHI9_UP Alias for DELPHI2005_UP + DELPHI10_UP Defined when compiling with Delphi 2006 or higher + DELPHI2006_UP Alias for DELPHI10_UP + DELPHI11_UP Defined when compiling with Delphi 2007 for Win32 or higher + DELPHI2007_UP Alias for DELPHI11_UP + DELPHI12_UP Defined when compiling with Delphi 2009 for Win32 or higher + DELPHI2009_UP Alias for DELPHI12_UP + DELPHI14_UP Defined when compiling with Delphi 2010 for Win32 or higher + DELPHI2010_UP Alias for DELPHI14_UP + DELPHI15_UP Defined when compiling with Delphi XE for Win32 or higher + DELPHIXE_UP Alias for DELPHI15_UP + DELPHI16_UP Defined when compiling with Delphi XE2 for Win32 or higher + DELPHIXE2_UP Alias for DELPHI16_UP + DELPHI17_UP Defined when compiling with Delphi XE3 for Win32 or higher + DELPHIXE3_UP Alias for DELPHI17_UP + DELPHI18_UP Defined when compiling with Delphi XE4 for Win32 or higher + DELPHIXE4_UP Alias for DELPHI18_UP + DELPHI19_UP Defined when compiling with Delphi XE5 for Win32 or higher + DELPHIXE5_UP Alias for DELPHI19_UP + DELPHI20_UP Defined when compiling with Delphi XE6 for Win32 or higher + DELPHIXE6_UP Alias for DELPHI20_UP + DELPHI21_UP Defined when compiling with Delphi XE7 for Win32 or higher + DELPHIXE7_UP Alias for DELPHI21_UP + DELPHI22_UP Defined when compiling with Delphi XE8 for Win32 or higher + DELPHIXE8_UP Alias for DELPHI22_UP + DELPHI23_UP Defined when compiling with Delphi 10 for Win32 or higher + DELPHIX_SEATTLE_UP Alias for DELPHI23_UP + DELPHI24_UP Defined when compiling with Delphi 10.1 for Win32 or higher + DELPHIX_BERLIN_UP Alias for DELPHI24_UP + DELPHI25_UP Defined when compiling with Delphi 10.2 for Win32 or higher + DELPHIX_TOKYO_UP Alias for DELPHI25_UP + DELPHI26_UP Defined when compiling with Delphi 10.3 for Win32 or higher + DELPHIX_RIO_UP Alias for DELPHI26_UP + DELPHI27_UP Defined when compiling with Delphi 10.4 for Win32 or higher + DELPHIX_SYDNEY_UP Alias for DELPHI27_UP + DELPHI28_UP Defined when compiling with Delphi 11 for Win32 or higher + DELPHIX_ALEXANDRIA_UP Alias for DELPHI28_UP + + +- Kylix Versions + + The following directives are direct mappings from the VERXXX directives to a + friendly name of the associated compiler. These directives are only defined if + the compiler is Kylix (ie KYLIX is defined). + + Directive Description + ------------------------------------------------------------------------------ + KYLIX1 Defined when compiling with Kylix 1 + KYLIX2 Defined when compiling with Kylix 2 + KYLIX3 Defined when compiling with Kylix 3 (Codename CORTEZ) + KYLIX1_UP Defined when compiling with Kylix 1 or higher + KYLIX2_UP Defined when compiling with Kylix 2 or higher + KYLIX3_UP Defined when compiling with Kylix 3 or higher + + +- Delphi Compiler Versions (Delphi / Kylix, not in BCB mode) + + Directive Description + ------------------------------------------------------------------------------ + DELPHICOMPILER1 Defined when compiling with Delphi 1 + DELPHICOMPILER2 Defined when compiling with Delphi 2 + DELPHICOMPILER3 Defined when compiling with Delphi 3 + DELPHICOMPILER4 Defined when compiling with Delphi 4 + DELPHICOMPILER5 Defined when compiling with Delphi 5 + DELPHICOMPILER6 Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 + DELPHICOMPILER7 Defined when compiling with Delphi 7 + DELPHICOMPILER8 Defined when compiling with Delphi 8 + DELPHICOMPILER9 Defined when compiling with Delphi 2005 + DELPHICOMPILER10 Defined when compiling with Delphi Personality of BDS 4.0 + DELPHICOMPILER11 Defined when compiling with Delphi 2007 for Win32 + DELPHICOMPILER12 Defined when compiling with Delphi Personality of BDS 6.0 + DELPHICOMPILER14 Defined when compiling with Delphi Personality of BDS 7.0 + DELPHICOMPILER15 Defined when compiling with Delphi Personality of BDS 8.0 + DELPHICOMPILER16 Defined when compiling with Delphi Personality of BDS 9.0 + DELPHICOMPILER17 Defined when compiling with Delphi Personality of BDS 10.0 + DELPHICOMPILER18 Defined when compiling with Delphi Personality of BDS 11.0 + DELPHICOMPILER19 Defined when compiling with Delphi Personality of BDS 12.0 + DELPHICOMPILER20 Defined when compiling with Delphi Personality of BDS 14.0 + DELPHICOMPILER21 Defined when compiling with Delphi Personality of BDS 15.0 + DELPHICOMPILER22 Defined when compiling with Delphi Personality of BDS 16.0 + DELPHICOMPILER23 Defined when compiling with Delphi Personality of BDS 17.0 + DELPHICOMPILER24 Defined when compiling with Delphi Personality of BDS 18.0 + DELPHICOMPILER25 Defined when compiling with Delphi Personality of BDS 19.0 + DELPHICOMPILER26 Defined when compiling with Delphi Personality of BDS 20.0 + DELPHICOMPILER27 Defined when compiling with Delphi Personality of BDS 21.0 + DELPHICOMPILER28 Defined when compiling with Delphi Personality of BDS 22.0 + DELPHICOMPILER1_UP Defined when compiling with Delphi 1 or higher + DELPHICOMPILER2_UP Defined when compiling with Delphi 2 or higher + DELPHICOMPILER3_UP Defined when compiling with Delphi 3 or higher + DELPHICOMPILER4_UP Defined when compiling with Delphi 4 or higher + DELPHICOMPILER5_UP Defined when compiling with Delphi 5 or higher + DELPHICOMPILER6_UP Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 or higher + DELPHICOMPILER7_UP Defined when compiling with Delphi 7 or higher + DELPHICOMPILER8_UP Defined when compiling with Delphi 8 or higher + DELPHICOMPILER9_UP Defined when compiling with Delphi 2005 + DELPHICOMPILER10_UP Defined when compiling with Delphi 2006 or higher + DELPHICOMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher + DELPHICOMPILER12_UP Defined when compiling with Delphi 2009 for Win32 or higher + DELPHICOMPILER14_UP Defined when compiling with Delphi 2010 for Win32 or higher + DELPHICOMPILER15_UP Defined when compiling with Delphi XE for Win32 or higher + DELPHICOMPILER16_UP Defined when compiling with Delphi XE2 for Win32 or higher + DELPHICOMPILER17_UP Defined when compiling with Delphi XE3 for Win32 or higher + DELPHICOMPILER18_UP Defined when compiling with Delphi XE4 for Win32 or higher + DELPHICOMPILER19_UP Defined when compiling with Delphi XE5 for Win32 or higher + DELPHICOMPILER20_UP Defined when compiling with Delphi XE6 for Win32 or higher + DELPHICOMPILER21_UP Defined when compiling with Delphi XE7 for Win32 or higher + DELPHICOMPILER22_UP Defined when compiling with Delphi XE8 for Win32 or higher + DELPHICOMPILER23_UP Defined when compiling with Delphi 10 for Win32 or higher + DELPHICOMPILER24_UP Defined when compiling with Delphi 10.1 for Win32 or higher + DELPHICOMPILER25_UP Defined when compiling with Delphi 10.2 for Win32 or higher + DELPHICOMPILER26_UP Defined when compiling with Delphi 10.3 for Win32 or higher + DELPHICOMPILER27_UP Defined when compiling with Delphi 10.4 for Win32 or higher + DELPHICOMPILER28_UP Defined when compiling with Delphi 11 for Win32 or higher + + +- C++Builder Versions + + The following directives are direct mappings from the VERXXX directives to a + friendly name of the associated compiler. These directives are only defined if + the compiler is C++Builder (ie BCB is defined). + + Directive Description + ------------------------------------------------------------------------------ + BCB1 Defined when compiling with C++Builder 1 + BCB3 Defined when compiling with C++Builder 3 + BCB4 Defined when compiling with C++Builder 4 + BCB5 Defined when compiling with C++Builder 5 (Codename RAMPAGE) + BCB6 Defined when compiling with C++Builder 6 (Codename RIPTIDE) + BCB10 Defined when compiling with C++Builder Personality of BDS 4.0 (also known as C++Builder 2006) (Codename DEXTER) + BCB11 Defined when compiling with C++Builder Personality of RAD Studio 2007 (also known as C++Builder 2007) (Codename COGSWELL) + BCB12 Defined when compiling with C++Builder Personality of RAD Studio 2009 (also known as C++Builder 2009) (Codename TIBURON) + BCB14 Defined when compiling with C++Builder Personality of RAD Studio 2010 (also known as C++Builder 2010) (Codename WEAVER) + BCB15 Defined when compiling with C++Builder Personality of RAD Studio XE (also known as C++Builder XE) (Codename FULCRUM) + BCB16 Defined when compiling with C++Builder Personality of RAD Studio XE2 (also known as C++Builder XE2) (Codename PULSAR) + BCB17 Defined when compiling with C++Builder Personality of RAD Studio XE3 (also known as C++Builder XE3) (Codename WATERDRAGON) + BCB18 Defined when compiling with C++Builder Personality of RAD Studio XE4 (also known as C++Builder XE4) (Codename QUINTESSENCE) + BCB19 Defined when compiling with C++Builder Personality of RAD Studio XE5 (also known as C++Builder XE5) (Codename ZEPHYR) + BCB20 Defined when compiling with C++Builder Personality of RAD Studio XE6 (also known as C++Builder XE6) (Codename PROTEUS) + BCB21 Defined when compiling with C++Builder Personality of RAD Studio XE7 (also known as C++Builder XE7) (Codename CARPATHIA) + BCB22 Defined when compiling with C++Builder Personality of RAD Studio XE8 (also known as C++Builder XE8) (Codename ELBRUS) + BCB23 Defined when compiling with C++Builder Personality of RAD Studio 10 Seattle (also known as C++Builder 10 Seattle) (Codename AITANA) + BCB24 Defined when compiling with C++Builder Personality of RAD Studio 10.1 Berlin (also known as C++Builder 10.1 Berlin) (Codename BIGBEN) + BCB25 Defined when compiling with C++Builder Personality of RAD Studio 10.2 Tokyo (also known as C++Builder 10.2 Tokyo) (Codename GODZILLA) + BCB26 Defined when compiling with C++Builder Personality of RAD Studio 10.3 Rio (also known as C++Builder 10.3) (Codename CARNIVAL) + BCB27 Defined when compiling with C++Builder Personality of RAD Studio 10.4 Rio (also known as C++Builder 10.4) (Codename DENALI) + BCB28 Defined when compiling with C++Builder Personality of RAD Studio 11 (also known as C++Builder 11) (Codename OLYMPUS) + BCB1_UP Defined when compiling with C++Builder 1 or higher + BCB3_UP Defined when compiling with C++Builder 3 or higher + BCB4_UP Defined when compiling with C++Builder 4 or higher + BCB5_UP Defined when compiling with C++Builder 5 or higher + BCB6_UP Defined when compiling with C++Builder 6 or higher + BCB10_UP Defined when compiling with C++Builder Personality of BDS 4.0 or higher + BCB11_UP Defined when compiling with C++Builder Personality of RAD Studio 2007 or higher + BCB12_UP Defined when compiling with C++Builder Personality of RAD Studio 2009 or higher + BCB14_UP Defined when compiling with C++Builder Personality of RAD Studio 2010 or higher + BCB15_UP Defined when compiling with C++Builder Personality of RAD Studio XE or higher + BCB16_UP Defined when compiling with C++Builder Personality of RAD Studio XE2 or higher + BCB17_UP Defined when compiling with C++Builder Personality of RAD Studio XE3 or higher + BCB18_UP Defined when compiling with C++Builder Personality of RAD Studio XE4 or higher + BCB19_UP Defined when compiling with C++Builder Personality of RAD Studio XE5 or higher + BCB20_UP Defined when compiling with C++Builder Personality of RAD Studio XE6 or higher + BCB21_UP Defined when compiling with C++Builder Personality of RAD Studio XE7 or higher + BCB22_UP Defined when compiling with C++Builder Personality of RAD Studio XE8 or higher + BCB23_UP Defined when compiling with C++Builder Personality of RAD Studio 10 or higher + BCB24_UP Defined when compiling with C++Builder Personality of RAD Studio 10.1 or higher + BCB25_UP Defined when compiling with C++Builder Personality of RAD Studio 10.2 or higher + BCB26_UP Defined when compiling with C++Builder Personality of RAD Studio 10.3 or higher + BCB27_UP Defined when compiling with C++Builder Personality of RAD Studio 10.4 or higher + BCB28_UP Defined when compiling with C++Builder Personality of RAD Studio 11 or higher + + +- RAD Studio / Borland Developer Studio Versions + + The following directives are direct mappings from the VERXXX directives to a + friendly name of the associated IDE. These directives are only defined if + the IDE is Borland Developer Studio Version 2 or above. + + Note: Borland Developer Studio 2006 is marketed as Delphi 2006 or C++Builder 2006, + but those provide only different labels for identical content. + + Directive Description + ------------------------------------------------------------------------------ + BDS Defined when compiling with BDS version of dcc32.exe (Codename SIDEWINDER) + BDS2 Defined when compiling with BDS 2.0 (Delphi 8) (Codename OCTANE) + BDS3 Defined when compiling with BDS 3.0 (Delphi 2005) (Codename DIAMONDBACK) + BDS4 Defined when compiling with BDS 4.0 (Borland Developer Studio 2006) (Codename DEXTER) + BDS5 Defined when compiling with BDS 5.0 (CodeGear RAD Studio 2007) (Codename HIGHLANDER) + BDS6 Defined when compiling with BDS 6.0 (CodeGear RAD Studio 2009) (Codename TIBURON) + BDS7 Defined when compiling with BDS 7.0 (Embarcadero RAD Studio 2010) (Codename WEAVER) + BDS8 Defined when compiling with BDS 8.0 (Embarcadero RAD Studio XE) (Codename FULCRUM) + BDS9 Defined when compiling with BDS 9.0 (Embarcadero RAD Studio XE2) (Codename PULSAR) + BDS10 Defined when compiling with BDS 10.0 (Embarcadero RAD Studio XE3) (Codename WATERDRAGON) + BDS11 Defined when compiling with BDS 11.0 (Embarcadero RAD Studio XE4) (Codename QUINTESSENCE) + BDS12 Defined when compiling with BDS 12.0 (Embarcadero RAD Studio XE5) (Codename ZEPHYR) + BDS14 Defined when compiling with BDS 14.0 (Embarcadero RAD Studio XE6) (Codename PROTEUS) + BDS15 Defined when compiling with BDS 15.0 (Embarcadero RAD Studio XE7) (Codename CARPATHIA) + BDS16 Defined when compiling with BDS 16.0 (Embarcadero RAD Studio XE8) (Codename ELBRUS) + BDS17 Defined when compiling with BDS 17.0 (Embarcadero RAD Studio 10) (Codename AITANA) + BDS18 Defined when compiling with BDS 18.0 (Embarcadero RAD Studio 10.1) (Codename BIGBEN) + BDS19 Defined when compiling with BDS 19.0 (Embarcadero RAD Studio 10.2) (Codename GODZILLA) + BDS20 Defined when compiling with BDS 20.0 (Embarcadero RAD Studio 10.3) (Codename CARNIVAL) + BDS21 Defined when compiling with BDS 21.0 (Embarcadero RAD Studio 10.4) (Codename DENALI) + BDS22 Defined when compiling with BDS 22.0 (Embarcadero RAD Studio 11) (Codename OLYMPUS) + BDS2_UP Defined when compiling with BDS 2.0 or higher + BDS3_UP Defined when compiling with BDS 3.0 or higher + BDS4_UP Defined when compiling with BDS 4.0 or higher + BDS5_UP Defined when compiling with BDS 5.0 or higher + BDS6_UP Defined when compiling with BDS 6.0 or higher + BDS7_UP Defined when compiling with BDS 7.0 or higher + BDS8_UP Defined when compiling with BDS 8.0 or higher + BDS9_UP Defined when compiling with BDS 9.0 or higher + BDS10_UP Defined when compiling with BDS 10.0 or higher + BDS11_UP Defined when compiling with BDS 11.0 or higher + BDS12_UP Defined when compiling with BDS 12.0 or higher + BDS14_UP Defined when compiling with BDS 14.0 or higher + BDS15_UP Defined when compiling with BDS 15.0 or higher + BDS16_UP Defined when compiling with BDS 16.0 or higher + BDS17_UP Defined when compiling with BDS 17.0 or higher + BDS18_UP Defined when compiling with BDS 18.0 or higher + BDS19_UP Defined when compiling with BDS 19.0 or higher + BDS20_UP Defined when compiling with BDS 20.0 or higher + BDS21_UP Defined when compiling with BDS 21.0 or higher + BDS22_UP Defined when compiling with BDS 22.0 or higher + +- Compiler Versions + + The following directives are direct mappings from the VERXXX directives to a + friendly name of the associated compiler. Unlike the DELPHI_X and BCB_X + directives, these directives are indepedent of the development environment. + That is, they are defined regardless of whether compilation takes place using + Delphi or C++Builder. + + Directive Description + ------------------------------------------------------------------------------ + COMPILER1 Defined when compiling with Delphi 1 + COMPILER2 Defined when compiling with Delphi 2 or C++Builder 1 + COMPILER3 Defined when compiling with Delphi 3 + COMPILER35 Defined when compiling with C++Builder 3 + COMPILER4 Defined when compiling with Delphi 4 or C++Builder 4 + COMPILER5 Defined when compiling with Delphi 5 or C++Builder 5 + COMPILER6 Defined when compiling with Delphi 6 or C++Builder 6 + COMPILER7 Defined when compiling with Delphi 7 + COMPILER8 Defined when compiling with Delphi 8 + COMPILER9 Defined when compiling with Delphi 9 + COMPILER10 Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 + COMPILER11 Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 + COMPILER12 Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 + COMPILER14 Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 + COMPILER15 Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 + COMPILER16 Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 + COMPILER17 Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 + COMPILER18 Defined when compiling with Delphi or C++Builder Personalities of BDS 11.0 + COMPILER19 Defined when compiling with Delphi or C++Builder Personalities of BDS 12.0 + COMPILER20 Defined when compiling with Delphi or C++Builder Personalities of BDS 14.0 + COMPILER21 Defined when compiling with Delphi or C++Builder Personalities of BDS 15.0 + COMPILER22 Defined when compiling with Delphi or C++Builder Personalities of BDS 16.0 + COMPILER23 Defined when compiling with Delphi or C++Builder Personalities of BDS 17.0 + COMPILER24 Defined when compiling with Delphi or C++Builder Personalities of BDS 18.0 + COMPILER25 Defined when compiling with Delphi or C++Builder Personalities of BDS 19.0 + COMPILER26 Defined when compiling with Delphi or C++Builder Personalities of BDS 20.0 + COMPILER27 Defined when compiling with Delphi or C++Builder Personalities of BDS 21.0 + COMPILER28 Defined when compiling with Delphi or C++Builder Personalities of BDS 22.0 + COMPILER1_UP Defined when compiling with Delphi 1 or higher + COMPILER2_UP Defined when compiling with Delphi 2 or C++Builder 1 or higher + COMPILER3_UP Defined when compiling with Delphi 3 or higher + COMPILER35_UP Defined when compiling with C++Builder 3 or higher + COMPILER4_UP Defined when compiling with Delphi 4 or C++Builder 4 or higher + COMPILER5_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher + COMPILER6_UP Defined when compiling with Delphi 6 or C++Builder 6 or higher + COMPILER7_UP Defined when compiling with Delphi 7 + COMPILER8_UP Defined when compiling with Delphi 8 + COMPILER9_UP Defined when compiling with Delphi Personalities of BDS 3.0 + COMPILER10_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher + COMPILER11_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher + COMPILER12_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher + COMPILER14_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher + COMPILER15_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher + COMPILER16_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher + COMPILER17_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher + COMPILER18_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 11.0 or higher + COMPILER19_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 12.0 or higher + COMPILER20_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 14.0 or higher + COMPILER21_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 15.0 or higher + COMPILER22_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 16.0 or higher + COMPILER23_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 17.0 or higher + COMPILER24_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 18.0 or higher + COMPILER25_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 19.0 or higher + COMPILER26_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 20.0 or higher + COMPILER27_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 21.0 or higher + COMPILER28_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 22.0 or higher + + +- RTL Versions + + Use e.g. following to determine the exact RTL version since version 14.0: + {$IFDEF CONDITIONALEXPRESSIONS} + {$IF Declared(RTLVersion) and (RTLVersion >= 14.2)} + // code for Delphi 6.02 or higher, Kylix 2 or higher, C++Builder 6 or higher + ... + {$IFEND} + {$ENDIF} + + Directive Description + ------------------------------------------------------------------------------ + RTL80_UP Defined when compiling with Delphi 1 or higher + RTL90_UP Defined when compiling with Delphi 2 or higher + RTL93_UP Defined when compiling with C++Builder 1 or higher + RTL100_UP Defined when compiling with Delphi 3 or higher + RTL110_UP Defined when compiling with C++Builder 3 or higher + RTL120_UP Defined when compiling with Delphi 4 or higher + RTL125_UP Defined when compiling with C++Builder 4 or higher + RTL130_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher + RTL140_UP Defined when compiling with Delphi 6, Kylix 1, 2 or 3 or C++Builder 6 or higher + RTL150_UP Defined when compiling with Delphi 7 or higher + RTL160_UP Defined when compiling with Delphi 8 or higher + RTL170_UP Defined when compiling with Delphi Personalities of BDS 3.0 or higher + RTL180_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher + RTL185_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher + RTL190_UP Defined when compiling with Delphi.NET of BDS 5.0 or higher + RTL200_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher + RTL210_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher + RTL220_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher + RTL230_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher + RTL240_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher + RTL250_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 11.0 or higher + RTL260_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 12.0 or higher + RTL270_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 14.0 or higher + RTL280_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 15.0 or higher + RTL290_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 16.0 or higher + RTL300_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 17.0 or higher + RTL310_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 18.0 or higher + RTL320_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 19.0 or higher + RTL330_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 20.0 or higher + RTL340_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 21.0 or higher + RTL350_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 22.0 or higher + + +- CLR Versions + + Directive Description + ------------------------------------------------------------------------------ + CLR Defined when compiling for .NET + CLR10 Defined when compiling for .NET 1.0 (may be overriden by FORCE_CLR10) + CLR10_UP Defined when compiling for .NET 1.0 or higher + CLR11 Defined when compiling for .NET 1.1 (may be overriden by FORCE_CLR11) + CLR11_UP Defined when compiling for .NET 1.1 or higher + CLR20 Defined when compiling for .NET 2.0 (may be overriden by FORCE_CLR20) + CLR20_UP Defined when compiling for .NET 2.0 or higher + + +- Feature Directives + + The features directives are used to test if the compiler supports specific + features, such as method overloading, and adjust the sources accordingly. Use + of these directives is preferred over the use of the DELPHI and COMPILER + directives. + + Directive Description + ------------------------------------------------------------------------------ + SUPPORTS_CONSTPARAMS Compiler supports const parameters (D1+) + SUPPORTS_SINGLE Compiler supports the Single type (D1+) + SUPPORTS_DOUBLE Compiler supports the Double type (D1+) + SUPPORTS_EXTENDED Compiler supports the Extended type (D1+) + SUPPORTS_CURRENCY Compiler supports the Currency type (D2+) + SUPPORTS_THREADVAR Compiler supports threadvar declarations (D2+) + SUPPORTS_OUTPARAMS Compiler supports out parameters (D3+) + SUPPORTS_VARIANT Compiler supports variant (D2+) + SUPPORTS_WIDECHAR Compiler supports the WideChar type (D2+) + SUPPORTS_WIDESTRING Compiler supports the WideString type (D3+/BCB3+) + SUPPORTS_INTERFACE Compiler supports interfaces (D3+/BCB3+) + SUPPORTS_DISPINTERFACE Compiler supports dispatch interfaces (D3+/BCB3+) + SUPPORTS_DISPID Compiler supports dispatch ids (D3+/BCB3+/FPC) + SUPPORTS_EXTSYM Compiler supports the $EXTERNALSYM directive (D4+/BCB3+) + SUPPORTS_NODEFINE Compiler supports the $NODEFINE directive (D4+/BCB3+) + SUPPORTS_LONGWORD Compiler supports the LongWord type (unsigned 32 bit) (D4+/BCB4+) + SUPPORTS_INT64 Compiler supports the Int64 type (D4+/BCB4+) + SUPPORTS_UINT64 Compiler supports the UInt64 type (D7+) + SUPPORTS_DYNAMICARRAYS Compiler supports dynamic arrays (D4+/BCB4+) + SUPPORTS_DEFAULTPARAMS Compiler supports default parameters (D4+/BCB4+) + SUPPORTS_OVERLOAD Compiler supports overloading (D4+/BCB4+) + SUPPORTS_IMPLEMENTS Compiler supports implements (D4+/BCB4+) + SUPPORTS_DEPRECATED Compiler supports the deprecated directive (D6+/BCB6+) + SUPPORTS_PLATFORM Compiler supports the platform directive (D6+/BCB6+) + SUPPORTS_LIBRARY Compiler supports the library directive (D6+/BCB6+/FPC) + SUPPORTS_LOCAL Compiler supports the local directive (D6+/BCB6+) + SUPPORTS_SETPEFLAGS Compiler supports the SetPEFlags directive (D6+/BCB6+) + SUPPORTS_EXPERIMENTAL_WARNINGS Compiler supports the WARN SYMBOL_EXPERIMENTAL and WARN UNIT_EXPERIMENTAL directives (D6+/BCB6+) + SUPPORTS_INLINE Compiler supports the inline directive (D9+/FPC) + SUPPORTS_FOR_IN Compiler supports for in loops (D9+) + SUPPORTS_NESTED_CONSTANTS Compiler supports nested constants (D9+) + SUPPORTS_NESTED_TYPES Compiler supports nested types (D9+) + SUPPORTS_REGION Compiler supports the REGION and ENDREGION directives (D9+) + SUPPORTS_ENHANCED_RECORDS Compiler supports class [operator|function|procedure] for record types (D9.NET, D10+) + SUPPORTS_CLASS_FIELDS Compiler supports class fields (D9.NET, D10+) + SUPPORTS_CLASS_HELPERS Compiler supports class helpers (D9.NET, D10+) + SUPPORTS_CLASS_OPERATORS Compiler supports class operators (D9.NET, D10+) + SUPPORTS_CLASS_CTORDTORS Compiler supports class contructors/destructors (D14+) + SUPPORTS_STRICT Compiler supports strict keyword (D9.NET, D10+) + SUPPORTS_STATIC Compiler supports static keyword (D9.NET, D10+) + SUPPORTS_FINAL Compiler supports final keyword (D9.NET, D10+) + SUPPORTS_METHODINFO Compiler supports the METHODINFO directives (D10+) + SUPPORTS_GENERICS Compiler supports generic implementations (D11.NET, D12+) + SUPPORTS_GENERIC_TYPES Compiler supports generic implementations of types (D11.NET, D12+, FPC) + SUPPORTS_GENERIC_METHODS Compiler supports generic implementations of methods (D11.NET, D12+, FPC) + SUPPORTS_GENERIC_ROUTINES Compiler supports generic implementations of global functions/procedures (FPC) + SUPPORTS_DEPRECATED_DETAILS Compiler supports additional text for the deprecated directive (D11.NET, D12+) + ACCEPT_DEPRECATED Compiler supports or ignores the deprecated directive (D6+/BCB6+/FPC) + ACCEPT_PLATFORM Compiler supports or ignores the platform directive (D6+/BCB6+/FPC) + ACCEPT_LIBRARY Compiler supports or ignores the library directive (D6+/BCB6+) + SUPPORTS_CUSTOMVARIANTS Compiler supports custom variants (D6+/BCB6+) + SUPPORTS_VARARGS Compiler supports varargs (D6+/BCB6+) + SUPPORTS_ENUMVALUE Compiler supports assigning ordinalities to values of enums (D6+/BCB6+) + SUPPORTS_DEPRECATED_WARNINGS Compiler supports deprecated warnings (D6+/BCB6+) + SUPPORTS_LIBRARY_WARNINGS Compiler supports library warnings (D6+/BCB6+) + SUPPORTS_PLATFORM_WARNINGS Compiler supports platform warnings (D6+/BCB6+) + SUPPORTS_UNSAFE_WARNINGS Compiler supports unsafe warnings (D7) + SUPPORTS_WEAKPACKAGEUNIT Compiler supports the WEAKPACKAGEUNIT directive + SUPPORTS_COMPILETIME_MESSAGES Compiler supports the MESSAGE directive + SUPPORTS_PACKAGES Compiler supports Packages + HAS_UNIT_LIBC Unit Libc exists (Kylix, FPC on Linux/x86) + HAS_UNIT_RTLCONSTS Unit RTLConsts exists (D6+/BCB6+/FPC) + HAS_UNIT_TYPES Unit Types exists (D6+/BCB6+/FPC) + HAS_UNIT_VARIANTS Unit Variants exists (D6+/BCB6+/FPC) + HAS_UNIT_STRUTILS Unit StrUtils exists (D6+/BCB6+/FPC) + HAS_UNIT_DATEUTILS Unit DateUtils exists (D6+/BCB6+/FPC) + HAS_UNIT_CONTNRS Unit contnrs exists (D6+/BCB6+/FPC) + HAS_UNIT_HTTPPROD Unit HTTPProd exists (D9+) + HAS_UNIT_GIFIMG Unit GifImg exists (D11+) + HAS_UNIT_ANSISTRINGS Unit AnsiStrings exists (D12+) + HAS_UNIT_PNGIMAGE Unit PngImage exists (D12+) + HAS_UNIT_CHARACTER Unit Character exists (D12+) + XPLATFORM_RTL The RTL supports crossplatform function names (e.g. RaiseLastOSError) (D6+/BCB6+/FPC) + SUPPORTS_UNICODE string type is aliased to an unicode string (WideString or UnicodeString) (DX.NET, D12+) + SUPPORTS_UNICODE_STRING Compiler supports UnicodeString (D12+) + SUPPORTS_INT_ALIASES Types Int8, Int16, Int32, UInt8, UInt16 and UInt32 are defined in the unit System (D12+) + HAS_UNIT_RTTI Unit RTTI is available (D14+) + SUPPORTS_CAST_INTERFACE_TO_OBJ The compiler supports casts from interfaces to objects (D14+) + SUPPORTS_DELAYED_LOADING The compiler generates stubs for delaying imported function loads (D14+) + HAS_UNIT_REGULAREXPRESSIONSAPI Unit RegularExpressionsAPI is available (D15+) + HAS_UNIT_SYSTEM_UITYPES Unit System.UITypes is available (D16+) + HAS_UNIT_SYSTEM_ACTIONS Unit System.Actions is available (D17+) + DEPRECATED_SYSUTILS_ANSISTRINGS AnsiString functions from SysUtils are deprecated and moved to System.AnsiStrings (D18+) + HAS_PROPERTY_STYLEELEMENTS TControl has a StyleElements property (D17+) + HAS_AUTOMATIC_DB_FIELDS Database fields are automatically created/refreshed (D20+) + HAS_EARGUMENTEXCEPTION Exception class EArgumentException is available (D14+) + HAS_ENOTIMPLEMENTED Exception class ENotImplemented is available (D15+) + HAS_UNIT_VCL_THEMES Unit Vcl.Themes is available (D16+) + HAS_UNIT_UXTHEME Unit (Vcl.)UxTheme is available (D7+) + HAS_EXCEPTION_STACKTRACE Exception class has the StackTrace propery (D12+) + SUPPORTS_LEGACYIFEND Compiler supports the LEGACYIFEND directive (D17+) + DEPRECATED_TCHARACTER TCharacter is deprecated and replaced by a record helper on Char (D18+) + HAS_PROPERTY_OLDCREATEORDER The OldCreateOrder property is available (D5 - D27) + + +- Compiler Settings + + The compiler settings directives indicate whether a specific compiler setting + is in effect. This facilitates changing compiler settings locally in a more + compact and readible manner. + + Directive Description + ------------------------------------------------------------------------------ + ALIGN_ON Compiling in the A+ state (no alignment) + BOOLEVAL_ON Compiling in the B+ state (complete boolean evaluation) + ASSERTIONS_ON Compiling in the C+ state (assertions on) + DEBUGINFO_ON Compiling in the D+ state (debug info generation on) + IMPORTEDDATA_ON Compiling in the G+ state (creation of imported data references) + LONGSTRINGS_ON Compiling in the H+ state (string defined as AnsiString) + IOCHECKS_ON Compiling in the I+ state (I/O checking enabled) + WRITEABLECONST_ON Compiling in the J+ state (typed constants can be modified) + LOCALSYMBOLS Compiling in the L+ state (local symbol generation) + LOCALSYMBOLS_ON Alias of LOCALSYMBOLS + TYPEINFO_ON Compiling in the M+ state (RTTI generation on) + OPTIMIZATION_ON Compiling in the O+ state (code optimization on) + OPENSTRINGS_ON Compiling in the P+ state (variable string parameters are openstrings) + OVERFLOWCHECKS_ON Compiling in the Q+ state (overflow checing on) + RANGECHECKS_ON Compiling in the R+ state (range checking on) + TYPEDADDRESS_ON Compiling in the T+ state (pointers obtained using the @ operator are typed) + SAFEDIVIDE_ON Compiling in the U+ state (save FDIV instruction through RTL emulation) + VARSTRINGCHECKS_ON Compiling in the V+ state (type checking of shortstrings) + STACKFRAMES_ON Compiling in the W+ state (generation of stack frames) + EXTENDEDSYNTAX_ON Compiling in the X+ state (Delphi extended syntax enabled) +*) + +{$DEFINE BORLAND} + +{ Set FreePascal to Delphi mode } +{$IFDEF FPC} + {$MODE DELPHI} +// {$ASMMODE Intel} //this break FPC on non-intel platforms. Why it is here? + {$UNDEF BORLAND} + {$DEFINE CPUASM} + // FPC defines CPU32, CPU64 and Unix automatically +{$ENDIF} + +{$IFDEF BORLAND} + {$IFDEF LINUX} + {$IFDEF VER140} // Only under Delphi 6, LINUX implies Kylix + {$DEFINE KYLIX} + {$ENDIF} + {$ENDIF LINUX} + {$IFNDEF CLR} + {$IFNDEF CPUX86} + // CPUX86 is not defined, which means it most likely is a 64 bits compiler. + // However, this is only the case if either of two other symbols are defined: + // http://docwiki.embarcadero.com/RADStudio/Seattle/en/Conditional_compilation_%28Delphi%29 + {$DEFINE CPU64} + {$DEFINE DELPHI64_TEMPORARY} + {$IFNDEF CPUX64} + {$IFNDEF CPU64BITS} + {$DEFINE CPU386} // None of the two 64-bits symbols are defined, assume this is 32-bit + {$DEFINE CPU32} + {$UNDEF CPU64} + {$UNDEF DELPHI64_TEMPORARY} + {$ENDIF ~CPU64BITS} + {$ENDIF ~CPUX64} + {$ELSE ~CPUX86} + {$DEFINE CPU386} + {$DEFINE CPU32} + {$ENDIF ~CPUX86} + {$ENDIF ~CLR} +{$ENDIF BORLAND} + +{------------------------------------------------------------------------------} +{ VERXXX to COMPILERX, DELPHIX and BCBX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF BORLAND} + {$IFDEF KYLIX} + {$I kylix.inc} // FPC incompatible stuff + {$ELSE ~KYLIX} + + {$DEFINE UNKNOWN_COMPILER_VERSION} + + {$IFDEF VER80} + {$DEFINE COMPILER1} + {$DEFINE DELPHI1} + {$DEFINE DELPHICOMPILER1} + {$DEFINE RTL80_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER90} + {$DEFINE COMPILER2} + {$DEFINE DELPHI2} + {$DEFINE DELPHICOMPILER2} + {$DEFINE RTL90_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER93} + {$DEFINE COMPILER2} + {$DEFINE BCB1} + {$DEFINE BCB} + {$DEFINE RTL93_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER100} + {$DEFINE COMPILER3} + {$DEFINE DELPHI3} + {$DEFINE DELPHICOMPILER3} + {$DEFINE RTL100_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER110} + {$DEFINE COMPILER35} + {$DEFINE BCB3} + {$DEFINE BCB} + {$DEFINE RTL110_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER120} + {$DEFINE COMPILER4} + {$DEFINE DELPHI4} + {$DEFINE DELPHICOMPILER4} + {$DEFINE RTL120_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER125} + {$DEFINE COMPILER4} + {$DEFINE BCB4} + {$DEFINE BCB} + {$DEFINE RTL125_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER130} + {$DEFINE COMPILER5} + {$IFDEF BCB} + {$DEFINE BCB5} + {$ELSE} + {$DEFINE DELPHI5} + {$DEFINE DELPHICOMPILER5} + {$ENDIF} + {$DEFINE RTL130_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER140} + {$DEFINE COMPILER6} + {$IFDEF BCB} + {$DEFINE BCB6} + {$ELSE} + {$DEFINE DELPHI6} + {$DEFINE DELPHICOMPILER6} + {$ENDIF} + {$DEFINE RTL140_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER150} + {$DEFINE COMPILER7} + {$DEFINE DELPHI7} + {$DEFINE DELPHICOMPILER7} + {$DEFINE RTL150_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER160} + {$DEFINE BDS2} + {$DEFINE BDS} + {$IFDEF CLR} + {$DEFINE CLR10} + {$ENDIF CLR} + {$DEFINE COMPILER8} + {$DEFINE DELPHI8} + {$DEFINE DELPHICOMPILER8} + {$DEFINE RTL160_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER170} + {$DEFINE BDS3} + {$DEFINE BDS} + {$IFDEF CLR} + {$DEFINE CLR11} + {$ENDIF CLR} + {$DEFINE COMPILER9} + {$DEFINE DELPHI9} + {$DEFINE DELPHI2005} // synonym to DELPHI9 + {$DEFINE DELPHICOMPILER9} + {$DEFINE RTL170_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER180} + {$DEFINE BDS} + {$IFDEF CLR} + {$DEFINE CLR11} + {$ENDIF CLR} + {$IFDEF VER185} + {$DEFINE BDS5} + {$DEFINE COMPILER11} + {$IFDEF BCB} + {$DEFINE BCB11} + {$ELSE} + {$DEFINE DELPHI11} + {$DEFINE DELPHI2007} // synonym to DELPHI11 + {$DEFINE DELPHICOMPILER11} + {$ENDIF} + {$DEFINE RTL185_UP} + {$ELSE ~~VER185} + {$DEFINE BDS4} + {$DEFINE COMPILER10} + {$IFDEF BCB} + {$DEFINE BCB10} + {$ELSE} + {$DEFINE DELPHI10} + {$DEFINE DELPHI2006} // synonym to DELPHI10 + {$DEFINE DELPHICOMPILER10} + {$ENDIF} + {$DEFINE RTL180_UP} + {$ENDIF ~VER185} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$IFDEF VER190} // Delphi 2007 for .NET + {$DEFINE BDS} + {$DEFINE BDS5} + {$IFDEF CLR} + {$DEFINE CLR20} + {$ENDIF CLR} + {$DEFINE COMPILER11} + {$DEFINE DELPHI11} + {$DEFINE DELPHI2007} // synonym to DELPHI11 + {$DEFINE DELPHICOMPILER11} + {$DEFINE RTL190_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER190} + + {$IFDEF VER200} // RAD Studio 2009 + {$DEFINE BDS} + {$DEFINE BDS6} + {$IFDEF CLR} + {$DEFINE CLR20} + {$ENDIF CLR} + {$DEFINE COMPILER12} + {$IFDEF BCB} + {$DEFINE BCB12} + {$ELSE} + {$DEFINE DELPHI12} + {$DEFINE DELPHI2009} // synonym to DELPHI12 + {$DEFINE DELPHICOMPILER12} + {$ENDIF BCB} + {$IFDEF CLR} + {$DEFINE RTL190_UP} + {$ELSE} + {$DEFINE RTL200_UP} + {$ENDIF} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER200} + + {$IFDEF VER210} // RAD Studio 2010 + {$DEFINE BDS} + {$DEFINE BDS7} + {$DEFINE COMPILER14} + {$IFDEF BCB} + {$DEFINE BCB14} + {$ELSE} + {$DEFINE DELPHI14} + {$DEFINE DELPHI2010} // synonym to DELPHI14 + {$DEFINE DELPHICOMPILER14} + {$ENDIF BCB} + {$DEFINE RTL210_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER210} + + {$IFDEF VER220} // RAD Studio XE + {$DEFINE BDS} + {$DEFINE BDS8} + {$DEFINE COMPILER15} + {$IFDEF BCB} + {$DEFINE BCB15} + {$ELSE} + {$DEFINE DELPHI15} + {$DEFINE DELPHIXE} // synonym to DELPHI15 + {$DEFINE DELPHICOMPILER15} + {$ENDIF BCB} + {$DEFINE RTL220_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER220} + + {$IFDEF VER230} // RAD Studio XE2 + {$DEFINE BDS} + {$DEFINE BDS9} + {$DEFINE COMPILER16} + {$IFDEF BCB} + {$DEFINE BCB16} + {$ELSE} + {$DEFINE DELPHI16} + {$DEFINE DELPHIXE2} // synonym to DELPHI16 + {$DEFINE DELPHICOMPILER16} + {$ENDIF BCB} + {$DEFINE RTL230_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER230} + + {$IFDEF VER240} // RAD Studio XE3 + {$DEFINE BDS} + {$DEFINE BDS10} + {$DEFINE COMPILER17} + {$IFDEF BCB} + {$DEFINE BCB17} + {$ELSE} + {$DEFINE DELPHI17} + {$DEFINE DELPHIXE3} // synonym to DELPHI17 + {$DEFINE DELPHICOMPILER17} + {$ENDIF BCB} + {$DEFINE RTL240_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER240} + + {$IFDEF VER250} // RAD Studio XE4 + {$DEFINE BDS} + {$DEFINE BDS11} + {$DEFINE COMPILER18} + {$IFDEF BCB} + {$DEFINE BCB18} + {$ELSE} + {$DEFINE DELPHI18} + {$DEFINE DELPHIXE4} // synonym to DELPHI18 + {$DEFINE DELPHICOMPILER18} + {$ENDIF BCB} + {$DEFINE RTL250_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER250} + + {$IFDEF VER260} // RAD Studio XE5 + {$DEFINE BDS} + {$DEFINE BDS12} + {$DEFINE COMPILER19} + {$IFDEF BCB} + {$DEFINE BCB19} + {$ELSE} + {$DEFINE DELPHI19} + {$DEFINE DELPHIXE5} // synonym to DELPHI19 + {$DEFINE DELPHICOMPILER19} + {$ENDIF BCB} + {$DEFINE RTL260_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER260} + + {$IFDEF VER270} // RAD Studio XE6 + {$DEFINE BDS} + {$DEFINE BDS14} + {$DEFINE COMPILER20} + {$IFDEF BCB} + {$DEFINE BCB20} + {$ELSE} + {$DEFINE DELPHI20} + {$DEFINE DELPHIXE6} // synonym to DELPHI20 + {$DEFINE DELPHICOMPILER20} + {$ENDIF BCB} + {$DEFINE RTL270_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER270} + + {$IFDEF VER280} // RAD Studio XE7 + {$DEFINE BDS} + {$DEFINE BDS15} + {$DEFINE COMPILER21} + {$IFDEF BCB} + {$DEFINE BCB21} + {$ELSE} + {$DEFINE DELPHI21} + {$DEFINE DELPHIXE7} // synonym to DELPHI21 + {$DEFINE DELPHICOMPILER21} + {$ENDIF BCB} + {$DEFINE RTL280_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER280} + + {$IFDEF VER290} // RAD Studio XE8 + {$DEFINE BDS} + {$DEFINE BDS16} + {$DEFINE COMPILER22} + {$IFDEF BCB} + {$DEFINE BCB22} + {$ELSE} + {$DEFINE DELPHI22} + {$DEFINE DELPHIXE8} // synonym to DELPHI22 + {$DEFINE DELPHICOMPILER22} + {$ENDIF BCB} + {$DEFINE RTL290_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER290} + + {$IFDEF VER300} // RAD Studio 10 + {$DEFINE BDS} + {$DEFINE BDS17} + {$DEFINE COMPILER23} + {$IFDEF BCB} + {$DEFINE BCB23} + {$ELSE} + {$DEFINE DELPHI23} + {$DEFINE DELPHIX_SEATTLE} // synonym to DELPHI23 + {$DEFINE DELPHICOMPILER23} + {$ENDIF BCB} + {$DEFINE RTL300_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER300} + + {$IFDEF VER310} // RAD Studio 10.1 + {$DEFINE BDS} + {$DEFINE BDS18} + {$DEFINE COMPILER24} + {$IFDEF BCB} + {$DEFINE BCB24} + {$ELSE} + {$DEFINE DELPHI24} + {$DEFINE DELPHIX_BERLIN} // synonym to DELPHI24 + {$DEFINE DELPHICOMPILER24} + {$ENDIF BCB} + {$DEFINE RTL310_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER310} + + {$IFDEF VER320} // RAD Studio 10.2 + {$DEFINE BDS} + {$DEFINE BDS19} + {$DEFINE COMPILER25} + {$IFDEF BCB} + {$DEFINE BCB25} + {$ELSE} + {$DEFINE DELPHI25} + {$DEFINE DELPHIX_TOKYO} // synonym to DELPHI25 + {$DEFINE DELPHICOMPILER25} + {$ENDIF BCB} + {$DEFINE RTL320_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER320} + + {$IFDEF VER330} // RAD Studio 10.3 + {$DEFINE BDS} + {$DEFINE BDS20} + {$DEFINE COMPILER26} + {$IFDEF BCB} + {$DEFINE BCB26} + {$ELSE} + {$DEFINE DELPHI26} + {$DEFINE DELPHIX_RIO} // synonym to DELPHI26 + {$DEFINE DELPHICOMPILER26} + {$ENDIF BCB} + {$DEFINE RTL330_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER330} + + {$IFDEF VER340} // RAD Studio 10.4 + {$DEFINE BDS} + {$DEFINE BDS21} + {$DEFINE COMPILER27} + {$IFDEF BCB} + {$DEFINE BCB27} + {$ELSE} + {$DEFINE DELPHI27} + {$DEFINE DELPHIX_SYDNEY} // synonym to DELPHI27 + {$DEFINE DELPHICOMPILER27} + {$ENDIF BCB} + {$DEFINE RTL340_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER340} + + {$IFDEF VER350} // RAD Studio 11 + {$DEFINE BDS} + {$DEFINE BDS22} + {$DEFINE COMPILER28} + {$IFDEF BCB} + {$DEFINE BCB28} + {$ELSE} + {$DEFINE DELPHI28} + {$DEFINE DELPHIX_ALEXANDRIA} // synonym to DELPHI28 + {$DEFINE DELPHICOMPILER28} + {$ENDIF BCB} + {$DEFINE RTL350_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF VER350} + + {$IFDEF UNKNOWN_COMPILER_VERSION} // adjust for newer version (always use latest version) + {$DEFINE BDS} + {$DEFINE BDS22} + {$DEFINE COMPILER28} + {$IFDEF BCB} + {$DEFINE BCB28} + {$ELSE} + {$DEFINE DELPHI28} + {$DEFINE DELPHICOMPILER28} + {$ENDIF BCB} + {$DEFINE RTL350_UP} + {$UNDEF UNKNOWN_COMPILER_VERSION} + {$ENDIF} + + {$ENDIF ~KYLIX} + + {$IFDEF BCB} + {$DEFINE CPPBUILDER} + {$DEFINE BCBCOMPILER} + {$ELSE ~BCB} + {$DEFINE DELPHI} + {$DEFINE DELPHICOMPILER} + {$ENDIF ~BCB} + +{$ENDIF BORLAND} + +{------------------------------------------------------------------------------} +{ DELPHIX_UP from DELPHIX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF DELPHI28} {$DEFINE DELPHI28_UP} {$ENDIF} +{$IFDEF DELPHI27} {$DEFINE DELPHI27_UP} {$ENDIF} +{$IFDEF DELPHI26} {$DEFINE DELPHI26_UP} {$ENDIF} +{$IFDEF DELPHI25} {$DEFINE DELPHI25_UP} {$ENDIF} +{$IFDEF DELPHI24} {$DEFINE DELPHI24_UP} {$ENDIF} +{$IFDEF DELPHI23} {$DEFINE DELPHI23_UP} {$ENDIF} +{$IFDEF DELPHI22} {$DEFINE DELPHI22_UP} {$ENDIF} +{$IFDEF DELPHI21} {$DEFINE DELPHI21_UP} {$ENDIF} +{$IFDEF DELPHI20} {$DEFINE DELPHI20_UP} {$ENDIF} +{$IFDEF DELPHI19} {$DEFINE DELPHI19_UP} {$ENDIF} +{$IFDEF DELPHI18} {$DEFINE DELPHI18_UP} {$ENDIF} +{$IFDEF DELPHI17} {$DEFINE DELPHI17_UP} {$ENDIF} +{$IFDEF DELPHI16} {$DEFINE DELPHI16_UP} {$ENDIF} +{$IFDEF DELPHI15} {$DEFINE DELPHI15_UP} {$ENDIF} +{$IFDEF DELPHI14} {$DEFINE DELPHI14_UP} {$ENDIF} +{$IFDEF DELPHI12} {$DEFINE DELPHI12_UP} {$ENDIF} +{$IFDEF DELPHI11} {$DEFINE DELPHI11_UP} {$ENDIF} +{$IFDEF DELPHI10} {$DEFINE DELPHI10_UP} {$ENDIF} +{$IFDEF DELPHI9} {$DEFINE DELPHI9_UP} {$ENDIF} +{$IFDEF DELPHI8} {$DEFINE DELPHI8_UP} {$ENDIF} +{$IFDEF DELPHI7} {$DEFINE DELPHI7_UP} {$ENDIF} +{$IFDEF DELPHI6} {$DEFINE DELPHI6_UP} {$ENDIF} +{$IFDEF DELPHI5} {$DEFINE DELPHI5_UP} {$ENDIF} +{$IFDEF DELPHI4} {$DEFINE DELPHI4_UP} {$ENDIF} +{$IFDEF DELPHI3} {$DEFINE DELPHI3_UP} {$ENDIF} +{$IFDEF DELPHI2} {$DEFINE DELPHI2_UP} {$ENDIF} +{$IFDEF DELPHI1} {$DEFINE DELPHI1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ DELPHIX_UP from DELPHIX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF DELPHI28_UP} + {$DEFINE DELPHIX_ALEXANDRIA_UP} // synonym to DELPHI28_UP + {$DEFINE DELPHI27_UP} +{$ENDIF} + +{$IFDEF DELPHI27_UP} + {$DEFINE DELPHIX_SYDNEY_UP} // synonym to DELPHI27_UP + {$DEFINE DELPHI26_UP} +{$ENDIF} + +{$IFDEF DELPHI26_UP} + {$DEFINE DELPHIX_RIO_UP} // synonym to DELPHI26_UP + {$DEFINE DELPHI25_UP} +{$ENDIF} + +{$IFDEF DELPHI25_UP} + {$DEFINE DELPHIX_TOKYO_UP} // synonym to DELPHI25_UP + {$DEFINE DELPHI24_UP} +{$ENDIF} + +{$IFDEF DELPHI24_UP} + {$DEFINE DELPHIX_BERLIN_UP} // synonym to DELPHI24_UP + {$DEFINE DELPHI23_UP} +{$ENDIF} + +{$IFDEF DELPHI23_UP} + {$DEFINE DELPHIX_SEATTLE_UP} // synonym to DELPHI23_UP + {$DEFINE DELPHI22_UP} +{$ENDIF} + +{$IFDEF DELPHI22_UP} + {$DEFINE DELPHIXE8_UP} // synonym to DELPHI22_UP + {$DEFINE DELPHI21_UP} +{$ENDIF} + +{$IFDEF DELPHI21_UP} + {$DEFINE DELPHIXE7_UP} // synonym to DELPHI21_UP + {$DEFINE DELPHI20_UP} +{$ENDIF} + +{$IFDEF DELPHI20_UP} + {$DEFINE DELPHIXE6_UP} // synonym to DELPHI20_UP + {$DEFINE DELPHI19_UP} +{$ENDIF} + +{$IFDEF DELPHI19_UP} + {$DEFINE DELPHIXE5_UP} // synonym to DELPHI19_UP + {$DEFINE DELPHI18_UP} +{$ENDIF} + +{$IFDEF DELPHI18_UP} + {$DEFINE DELPHIXE4_UP} // synonym to DELPHI18_UP + {$DEFINE DELPHI17_UP} +{$ENDIF} + +{$IFDEF DELPHI17_UP} + {$DEFINE DELPHIXE3_UP} // synonym to DELPHI17_UP + {$DEFINE DELPHI16_UP} +{$ENDIF} + +{$IFDEF DELPHI16_UP} + {$DEFINE DELPHIXE2_UP} // synonym to DELPHI16_UP + {$DEFINE DELPHI15_UP} +{$ENDIF} + +{$IFDEF DELPHI15_UP} + {$DEFINE DELPHIXE_UP} // synonym to DELPHI15_UP + {$DEFINE DELPHI14_UP} +{$ENDIF} + +{$IFDEF DELPHI14_UP} + {$DEFINE DELPHI2010_UP} // synonym to DELPHI14_UP + {$DEFINE DELPHI12_UP} +{$ENDIF} + +{$IFDEF DELPHI12_UP} + {$DEFINE DELPHI2009_UP} // synonym to DELPHI12_UP + {$DEFINE DELPHI11_UP} +{$ENDIF} + +{$IFDEF DELPHI11_UP} + {$DEFINE DELPHI2007_UP} // synonym to DELPHI11_UP + {$DEFINE DELPHI10_UP} +{$ENDIF} + +{$IFDEF DELPHI10_UP} + {$DEFINE DELPHI2006_UP} // synonym to DELPHI10_UP + {$DEFINE DELPHI9_UP} +{$ENDIF} + +{$IFDEF DELPHI9_UP} + {$DEFINE DELPHI2005_UP} // synonym to DELPHI9_UP + {$DEFINE DELPHI8_UP} +{$ENDIF} + +{$IFDEF DELPHI8_UP} {$DEFINE DELPHI7_UP} {$ENDIF} +{$IFDEF DELPHI7_UP} {$DEFINE DELPHI6_UP} {$ENDIF} +{$IFDEF DELPHI6_UP} {$DEFINE DELPHI5_UP} {$ENDIF} +{$IFDEF DELPHI5_UP} {$DEFINE DELPHI4_UP} {$ENDIF} +{$IFDEF DELPHI4_UP} {$DEFINE DELPHI3_UP} {$ENDIF} +{$IFDEF DELPHI3_UP} {$DEFINE DELPHI2_UP} {$ENDIF} +{$IFDEF DELPHI2_UP} {$DEFINE DELPHI1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ BCBX_UP from BCBX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF BCB28} {$DEFINE BCB28_UP} {$ENDIF} +{$IFDEF BCB27} {$DEFINE BCB27_UP} {$ENDIF} +{$IFDEF BCB26} {$DEFINE BCB26_UP} {$ENDIF} +{$IFDEF BCB25} {$DEFINE BCB25_UP} {$ENDIF} +{$IFDEF BCB24} {$DEFINE BCB24_UP} {$ENDIF} +{$IFDEF BCB23} {$DEFINE BCB23_UP} {$ENDIF} +{$IFDEF BCB22} {$DEFINE BCB22_UP} {$ENDIF} +{$IFDEF BCB21} {$DEFINE BCB21_UP} {$ENDIF} +{$IFDEF BCB20} {$DEFINE BCB20_UP} {$ENDIF} +{$IFDEF BCB19} {$DEFINE BCB19_UP} {$ENDIF} +{$IFDEF BCB18} {$DEFINE BCB18_UP} {$ENDIF} +{$IFDEF BCB17} {$DEFINE BCB17_UP} {$ENDIF} +{$IFDEF BCB16} {$DEFINE BCB16_UP} {$ENDIF} +{$IFDEF BCB15} {$DEFINE BCB15_UP} {$ENDIF} +{$IFDEF BCB14} {$DEFINE BCB14_UP} {$ENDIF} +{$IFDEF BCB12} {$DEFINE BCB12_UP} {$ENDIF} +{$IFDEF BCB11} {$DEFINE BCB11_UP} {$ENDIF} +{$IFDEF BCB10} {$DEFINE BCB10_UP} {$ENDIF} +{$IFDEF BCB6} {$DEFINE BCB6_UP} {$ENDIF} +{$IFDEF BCB5} {$DEFINE BCB5_UP} {$ENDIF} +{$IFDEF BCB4} {$DEFINE BCB4_UP} {$ENDIF} +{$IFDEF BCB3} {$DEFINE BCB3_UP} {$ENDIF} +{$IFDEF BCB1} {$DEFINE BCB1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ BCBX_UP from BCBX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF BCB28_UP} {$DEFINE BCB27_UP} {$ENDIF} +{$IFDEF BCB27_UP} {$DEFINE BCB26_UP} {$ENDIF} +{$IFDEF BCB26_UP} {$DEFINE BCB25_UP} {$ENDIF} +{$IFDEF BCB25_UP} {$DEFINE BCB24_UP} {$ENDIF} +{$IFDEF BCB24_UP} {$DEFINE BCB23_UP} {$ENDIF} +{$IFDEF BCB23_UP} {$DEFINE BCB22_UP} {$ENDIF} +{$IFDEF BCB22_UP} {$DEFINE BCB21_UP} {$ENDIF} +{$IFDEF BCB21_UP} {$DEFINE BCB20_UP} {$ENDIF} +{$IFDEF BCB20_UP} {$DEFINE BCB19_UP} {$ENDIF} +{$IFDEF BCB19_UP} {$DEFINE BCB18_UP} {$ENDIF} +{$IFDEF BCB18_UP} {$DEFINE BCB17_UP} {$ENDIF} +{$IFDEF BCB17_UP} {$DEFINE BCB16_UP} {$ENDIF} +{$IFDEF BCB16_UP} {$DEFINE BCB15_UP} {$ENDIF} +{$IFDEF BCB15_UP} {$DEFINE BCB14_UP} {$ENDIF} +{$IFDEF BCB14_UP} {$DEFINE BCB12_UP} {$ENDIF} +{$IFDEF BCB12_UP} {$DEFINE BCB11_UP} {$ENDIF} +{$IFDEF BCB11_UP} {$DEFINE BCB10_UP} {$ENDIF} +{$IFDEF BCB10_UP} {$DEFINE BCB6_UP} {$ENDIF} +{$IFDEF BCB6_UP} {$DEFINE BCB5_UP} {$ENDIF} +{$IFDEF BCB5_UP} {$DEFINE BCB4_UP} {$ENDIF} +{$IFDEF BCB4_UP} {$DEFINE BCB3_UP} {$ENDIF} +{$IFDEF BCB3_UP} {$DEFINE BCB1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ BDSX_UP from BDSX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF BDS22} {$DEFINE BDS22_UP} {$ENDIF} +{$IFDEF BDS21} {$DEFINE BDS21_UP} {$ENDIF} +{$IFDEF BDS20} {$DEFINE BDS20_UP} {$ENDIF} +{$IFDEF BDS19} {$DEFINE BDS19_UP} {$ENDIF} +{$IFDEF BDS18} {$DEFINE BDS18_UP} {$ENDIF} +{$IFDEF BDS17} {$DEFINE BDS17_UP} {$ENDIF} +{$IFDEF BDS16} {$DEFINE BDS16_UP} {$ENDIF} +{$IFDEF BDS15} {$DEFINE BDS15_UP} {$ENDIF} +{$IFDEF BDS14} {$DEFINE BDS14_UP} {$ENDIF} +{$IFDEF BDS12} {$DEFINE BDS12_UP} {$ENDIF} +{$IFDEF BDS11} {$DEFINE BDS11_UP} {$ENDIF} +{$IFDEF BDS10} {$DEFINE BDS10_UP} {$ENDIF} +{$IFDEF BDS9} {$DEFINE BDS9_UP} {$ENDIF} +{$IFDEF BDS8} {$DEFINE BDS8_UP} {$ENDIF} +{$IFDEF BDS7} {$DEFINE BDS7_UP} {$ENDIF} +{$IFDEF BDS6} {$DEFINE BDS6_UP} {$ENDIF} +{$IFDEF BDS5} {$DEFINE BDS5_UP} {$ENDIF} +{$IFDEF BDS4} {$DEFINE BDS4_UP} {$ENDIF} +{$IFDEF BDS3} {$DEFINE BDS3_UP} {$ENDIF} +{$IFDEF BDS2} {$DEFINE BDS2_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ BDSX_UP from BDSX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF BDS22_UP} {$DEFINE BDS21_UP} {$ENDIF} +{$IFDEF BDS21_UP} {$DEFINE BDS20_UP} {$ENDIF} +{$IFDEF BDS20_UP} {$DEFINE BDS19_UP} {$ENDIF} +{$IFDEF BDS19_UP} {$DEFINE BDS18_UP} {$ENDIF} +{$IFDEF BDS18_UP} {$DEFINE BDS17_UP} {$ENDIF} +{$IFDEF BDS17_UP} {$DEFINE BDS16_UP} {$ENDIF} +{$IFDEF BDS16_UP} {$DEFINE BDS15_UP} {$ENDIF} +{$IFDEF BDS15_UP} {$DEFINE BDS14_UP} {$ENDIF} +{$IFDEF BDS14_UP} {$DEFINE BDS12_UP} {$ENDIF} +{$IFDEF BDS12_UP} {$DEFINE BDS11_UP} {$ENDIF} +{$IFDEF BDS11_UP} {$DEFINE BDS10_UP} {$ENDIF} +{$IFDEF BDS10_UP} {$DEFINE BDS9_UP} {$ENDIF} +{$IFDEF BDS9_UP} {$DEFINE BDS8_UP} {$ENDIF} +{$IFDEF BDS8_UP} {$DEFINE BDS7_UP} {$ENDIF} +{$IFDEF BDS7_UP} {$DEFINE BDS6_UP} {$ENDIF} +{$IFDEF BDS6_UP} {$DEFINE BDS5_UP} {$ENDIF} +{$IFDEF BDS5_UP} {$DEFINE BDS4_UP} {$ENDIF} +{$IFDEF BDS4_UP} {$DEFINE BDS3_UP} {$ENDIF} +{$IFDEF BDS3_UP} {$DEFINE BDS2_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ DELPHICOMPILERX_UP from DELPHICOMPILERX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF DELPHICOMPILER28} {$DEFINE DELPHICOMPILER28_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER27} {$DEFINE DELPHICOMPILER27_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER26} {$DEFINE DELPHICOMPILER26_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER25} {$DEFINE DELPHICOMPILER25_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER24} {$DEFINE DELPHICOMPILER24_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER23} {$DEFINE DELPHICOMPILER23_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER22} {$DEFINE DELPHICOMPILER22_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER21} {$DEFINE DELPHICOMPILER21_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER20} {$DEFINE DELPHICOMPILER20_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER19} {$DEFINE DELPHICOMPILER19_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER18} {$DEFINE DELPHICOMPILER18_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER17} {$DEFINE DELPHICOMPILER17_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER16} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER15} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER14} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER12} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER11} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER10} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER9} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER8} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER7} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER6} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER5} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER4} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER3} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER2} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER1} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ DELPHICOMPILERX_UP from DELPHICOMPILERX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF DELPHICOMPILER28_UP} {$DEFINE DELPHICOMPILER27_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER27_UP} {$DEFINE DELPHICOMPILER26_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER26_UP} {$DEFINE DELPHICOMPILER25_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER25_UP} {$DEFINE DELPHICOMPILER24_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER24_UP} {$DEFINE DELPHICOMPILER23_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER23_UP} {$DEFINE DELPHICOMPILER22_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER22_UP} {$DEFINE DELPHICOMPILER21_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER21_UP} {$DEFINE DELPHICOMPILER20_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER20_UP} {$DEFINE DELPHICOMPILER19_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER19_UP} {$DEFINE DELPHICOMPILER18_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER18_UP} {$DEFINE DELPHICOMPILER17_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER17_UP} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER16_UP} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER15_UP} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER14_UP} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER12_UP} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER11_UP} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER10_UP} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER9_UP} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER7_UP} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER6_UP} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER5_UP} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER4_UP} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER3_UP} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF} +{$IFDEF DELPHICOMPILER2_UP} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ COMPILERX_UP from COMPILERX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF COMPILER28} {$DEFINE COMPILER28_UP} {$ENDIF} +{$IFDEF COMPILER27} {$DEFINE COMPILER27_UP} {$ENDIF} +{$IFDEF COMPILER26} {$DEFINE COMPILER26_UP} {$ENDIF} +{$IFDEF COMPILER25} {$DEFINE COMPILER25_UP} {$ENDIF} +{$IFDEF COMPILER24} {$DEFINE COMPILER24_UP} {$ENDIF} +{$IFDEF COMPILER23} {$DEFINE COMPILER23_UP} {$ENDIF} +{$IFDEF COMPILER22} {$DEFINE COMPILER22_UP} {$ENDIF} +{$IFDEF COMPILER21} {$DEFINE COMPILER21_UP} {$ENDIF} +{$IFDEF COMPILER20} {$DEFINE COMPILER20_UP} {$ENDIF} +{$IFDEF COMPILER19} {$DEFINE COMPILER19_UP} {$ENDIF} +{$IFDEF COMPILER18} {$DEFINE COMPILER18_UP} {$ENDIF} +{$IFDEF COMPILER17} {$DEFINE COMPILER17_UP} {$ENDIF} +{$IFDEF COMPILER16} {$DEFINE COMPILER16_UP} {$ENDIF} +{$IFDEF COMPILER15} {$DEFINE COMPILER15_UP} {$ENDIF} +{$IFDEF COMPILER14} {$DEFINE COMPILER14_UP} {$ENDIF} +{$IFDEF COMPILER12} {$DEFINE COMPILER12_UP} {$ENDIF} +{$IFDEF COMPILER11} {$DEFINE COMPILER11_UP} {$ENDIF} +{$IFDEF COMPILER10} {$DEFINE COMPILER10_UP} {$ENDIF} +{$IFDEF COMPILER9} {$DEFINE COMPILER9_UP} {$ENDIF} +{$IFDEF COMPILER8} {$DEFINE COMPILER8_UP} {$ENDIF} +{$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$ENDIF} +{$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF} +{$IFDEF COMPILER5} {$DEFINE COMPILER5_UP} {$ENDIF} +{$IFDEF COMPILER4} {$DEFINE COMPILER4_UP} {$ENDIF} +{$IFDEF COMPILER35} {$DEFINE COMPILER35_UP} {$ENDIF} +{$IFDEF COMPILER3} {$DEFINE COMPILER3_UP} {$ENDIF} +{$IFDEF COMPILER2} {$DEFINE COMPILER2_UP} {$ENDIF} +{$IFDEF COMPILER1} {$DEFINE COMPILER1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ COMPILERX_UP from COMPILERX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF COMPILER28_UP} {$DEFINE COMPILER27_UP} {$ENDIF} +{$IFDEF COMPILER27_UP} {$DEFINE COMPILER26_UP} {$ENDIF} +{$IFDEF COMPILER26_UP} {$DEFINE COMPILER25_UP} {$ENDIF} +{$IFDEF COMPILER25_UP} {$DEFINE COMPILER24_UP} {$ENDIF} +{$IFDEF COMPILER24_UP} {$DEFINE COMPILER23_UP} {$ENDIF} +{$IFDEF COMPILER23_UP} {$DEFINE COMPILER22_UP} {$ENDIF} +{$IFDEF COMPILER22_UP} {$DEFINE COMPILER21_UP} {$ENDIF} +{$IFDEF COMPILER21_UP} {$DEFINE COMPILER20_UP} {$ENDIF} +{$IFDEF COMPILER20_UP} {$DEFINE COMPILER19_UP} {$ENDIF} +{$IFDEF COMPILER19_UP} {$DEFINE COMPILER18_UP} {$ENDIF} +{$IFDEF COMPILER18_UP} {$DEFINE COMPILER17_UP} {$ENDIF} +{$IFDEF COMPILER17_UP} {$DEFINE COMPILER16_UP} {$ENDIF} +{$IFDEF COMPILER16_UP} {$DEFINE COMPILER15_UP} {$ENDIF} +{$IFDEF COMPILER15_UP} {$DEFINE COMPILER14_UP} {$ENDIF} +{$IFDEF COMPILER14_UP} {$DEFINE COMPILER12_UP} {$ENDIF} +{$IFDEF COMPILER12_UP} {$DEFINE COMPILER11_UP} {$ENDIF} +{$IFDEF COMPILER11_UP} {$DEFINE COMPILER10_UP} {$ENDIF} +{$IFDEF COMPILER10_UP} {$DEFINE COMPILER9_UP} {$ENDIF} +{$IFDEF COMPILER9_UP} {$DEFINE COMPILER8_UP} {$ENDIF} +{$IFDEF COMPILER8_UP} {$DEFINE COMPILER7_UP} {$ENDIF} +{$IFDEF COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF} +{$IFDEF COMPILER6_UP} {$DEFINE COMPILER5_UP} {$ENDIF} +{$IFDEF COMPILER5_UP} {$DEFINE COMPILER4_UP} {$ENDIF} +{$IFDEF COMPILER4_UP} {$DEFINE COMPILER35_UP} {$ENDIF} +{$IFDEF COMPILER35_UP} {$DEFINE COMPILER3_UP} {$ENDIF} +{$IFDEF COMPILER3_UP} {$DEFINE COMPILER2_UP} {$ENDIF} +{$IFDEF COMPILER2_UP} {$DEFINE COMPILER1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ RTLX_UP from RTLX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF RTL350_UP} {$DEFINE RTL340_UP} {$ENDIF} +{$IFDEF RTL340_UP} {$DEFINE RTL330_UP} {$ENDIF} +{$IFDEF RTL330_UP} {$DEFINE RTL320_UP} {$ENDIF} +{$IFDEF RTL320_UP} {$DEFINE RTL310_UP} {$ENDIF} +{$IFDEF RTL310_UP} {$DEFINE RTL300_UP} {$ENDIF} +{$IFDEF RTL300_UP} {$DEFINE RTL290_UP} {$ENDIF} +{$IFDEF RTL290_UP} {$DEFINE RTL280_UP} {$ENDIF} +{$IFDEF RTL280_UP} {$DEFINE RTL270_UP} {$ENDIF} +{$IFDEF RTL270_UP} {$DEFINE RTL260_UP} {$ENDIF} +{$IFDEF RTL260_UP} {$DEFINE RTL250_UP} {$ENDIF} +{$IFDEF RTL250_UP} {$DEFINE RTL240_UP} {$ENDIF} +{$IFDEF RTL240_UP} {$DEFINE RTL230_UP} {$ENDIF} +{$IFDEF RTL230_UP} {$DEFINE RTL220_UP} {$ENDIF} +{$IFDEF RTL220_UP} {$DEFINE RTL210_UP} {$ENDIF} +{$IFDEF RTL210_UP} {$DEFINE RTL200_UP} {$ENDIF} +{$IFDEF RTL200_UP} {$DEFINE RTL190_UP} {$ENDIF} +{$IFDEF RTL190_UP} {$DEFINE RTL185_UP} {$ENDIF} +{$IFDEF RTL185_UP} {$DEFINE RTL180_UP} {$ENDIF} +{$IFDEF RTL180_UP} {$DEFINE RTL170_UP} {$ENDIF} +{$IFDEF RTL170_UP} {$DEFINE RTL160_UP} {$ENDIF} +{$IFDEF RTL160_UP} {$DEFINE RTL150_UP} {$ENDIF} +{$IFDEF RTL150_UP} {$DEFINE RTL145_UP} {$ENDIF} +{$IFDEF RTL145_UP} {$DEFINE RTL142_UP} {$ENDIF} +{$IFDEF RTL142_UP} {$DEFINE RTL140_UP} {$ENDIF} +{$IFDEF RTL140_UP} {$DEFINE RTL130_UP} {$ENDIF} +{$IFDEF RTL130_UP} {$DEFINE RTL125_UP} {$ENDIF} +{$IFDEF RTL125_UP} {$DEFINE RTL120_UP} {$ENDIF} +{$IFDEF RTL120_UP} {$DEFINE RTL110_UP} {$ENDIF} +{$IFDEF RTL110_UP} {$DEFINE RTL100_UP} {$ENDIF} +{$IFDEF RTL100_UP} {$DEFINE RTL93_UP} {$ENDIF} +{$IFDEF RTL93_UP} {$DEFINE RTL90_UP} {$ENDIF} +{$IFDEF RTL90_UP} {$DEFINE RTL80_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ Check for CLR overrides of default detection } +{------------------------------------------------------------------------------} + +{$IFDEF CLR} + {$IFDEF FORCE_CLR10} + {$DEFINE CLR10} + {$UNDEF CLR11} + {$UNDEF CLR20} + {$ENDIF FORCE_CLR10} + + {$IFDEF FORCE_CLR11} + {$UNDEF CLR10} + {$DEFINE CLR11} + {$UNDEF CLR20} + {$ENDIF FORCE_CLR11} + + {$IFDEF FORCE_CLR20} + {$UNDEF CLR10} + {$UNDEF CLR11} + {$DEFINE CLR20} + {$ENDIF FORCE_CLR20} +{$ENDIF CLR} + +{------------------------------------------------------------------------------} +{ CLRX from CLRX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF CLR10} {$DEFINE CLR10_UP} {$ENDIF} +{$IFDEF CLR11} {$DEFINE CLR11_UP} {$ENDIF} +{$IFDEF CLR20} {$DEFINE CLR20_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ CLRX_UP from CLRX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF CLR20_UP} {$DEFINE CLR11_UP} {$ENDIF} +{$IFDEF CLR11_UP} {$DEFINE CLR10_UP} {$ENDIF} + +{------------------------------------------------------------------------------} + +{$IFDEF DELPHICOMPILER} + {$DEFINE DELPHILANGUAGE} +{$ENDIF} + +{$IFDEF BCBCOMPILER} + {$DEFINE DELPHILANGUAGE} +{$ENDIF} + +{------------------------------------------------------------------------------} +{ KYLIXX_UP from KYLIXX mappings } +{------------------------------------------------------------------------------} + +{$IFDEF KYLIX3} {$DEFINE KYLIX3_UP} {$ENDIF} +{$IFDEF KYLIX2} {$DEFINE KYLIX2_UP} {$ENDIF} +{$IFDEF KYLIX1} {$DEFINE KYLIX1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ KYLIXX_UP from KYLIXX_UP mappings } +{------------------------------------------------------------------------------} + +{$IFDEF KYLIX3_UP} {$DEFINE KYLIX2_UP} {$ENDIF} +{$IFDEF KYLIX2_UP} {$DEFINE KYLIX1_UP} {$ENDIF} + +{------------------------------------------------------------------------------} +{ Map COMPILERX_UP to friendly feature names } +{------------------------------------------------------------------------------} + +{$IFDEF FPC} + {$IFDEF VER1_0} + Please use FPC 2.0 or higher to compile this. + {$ELSE} + { FPC_FULLVERSION is available from 2.2.4 on } + + {$DEFINE SUPPORTS_OUTPARAMS} + {$DEFINE SUPPORTS_WIDECHAR} + {$DEFINE SUPPORTS_WIDESTRING} + {$IF DEFINED(VER2_0) OR DEFINED(VER2_1)} + {$IFDEF HASINTF} + {$DEFINE SUPPORTS_INTERFACE} + {$ENDIF} + {$IFDEF HASVARIANT} + {$DEFINE SUPPORTS_VARIANT} + {$ENDIF} + {$IFDEF HASCURRENCY} + {$DEFINE SUPPORTS_CURRENCY} + {$ENDIF} + {$ELSE} + {$DEFINE SUPPORTS_INTERFACE} + {$DEFINE SUPPORTS_VARIANT} + {$DEFINE SUPPORTS_CURRENCY} + {$IFEND} + {$IFDEF FPC_HAS_TYPE_SINGLE} + {$DEFINE SUPPORTS_SINGLE} + {$ENDIF} + {$IFDEF FPC_HAS_TYPE_DOUBLE} + {$DEFINE SUPPORTS_DOUBLE} + {$ENDIF} + {$IFDEF FPC_HAS_TYPE_EXTENDED} + {$DEFINE SUPPORTS_EXTENDED} + {$ENDIF} + {$DEFINE SUPPORTS_THREADVAR} + {$DEFINE SUPPORTS_CONSTPARAMS} + {$DEFINE SUPPORTS_LONGWORD} + {$DEFINE SUPPORTS_INT64} + {$DEFINE SUPPORTS_DYNAMICARRAYS} + {$DEFINE SUPPORTS_DEFAULTPARAMS} + {$DEFINE SUPPORTS_OVERLOAD} + {$DEFINE ACCEPT_DEPRECATED} // 2.2 also gives warnings + {$DEFINE ACCEPT_PLATFORM} // 2.2 also gives warnings + {$DEFINE ACCEPT_LIBRARY} + {$DEFINE SUPPORTS_DEPRECATED} + {$DEFINE SUPPORTS_PLATFORM} + {$DEFINE SUPPORTS_LIBRARY} + {$DEFINE SUPPORTS_DEPRECATED_WARNINGS} + {$DEFINE SUPPORTS_PLATFORM_WARNINGS} + {$DEFINE SUPPORTS_EXTSYM} + {$DEFINE SUPPORTS_NODEFINE} + {$DEFINE SUPPORTS_DISPINTERFACE} + {$DEFINE SUPPORTS_IMPLEMENTS} + {$DEFINE SUPPORTS_DISPID} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE SUPPORTS_STATIC} + {$DEFINE SUPPORTS_COMPILETIME_MESSAGES} + + {$DEFINE SUPPORTS_CUSTOMVARIANTS} + {$DEFINE SUPPORTS_VARARGS} + {$DEFINE SUPPORTS_ENUMVALUE} + {$IF DEFINED(LINUX) AND DEFINED(CPU386)} + {$DEFINE HAS_UNIT_LIBC} + {$IFEND} + {$DEFINE HAS_UNIT_CONTNRS} + {$DEFINE HAS_UNIT_TYPES} + {$DEFINE HAS_UNIT_VARIANTS} + {$DEFINE HAS_UNIT_STRUTILS} + {$DEFINE HAS_UNIT_DATEUTILS} + {$DEFINE HAS_UNIT_RTLCONSTS} + + {$DEFINE XPLATFORM_RTL} + + {$IF DEFINED(FPC_FULLVERSION)} + { 2.2.4 or newer } + + {$DEFINE SUPPORTS_SETPEFLAGS} + {$DEFINE SUPPORTS_STRICT} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 20400)} + {$DEFINE SUPPORTS_UINT64} + {$DEFINE SUPPORTS_EXPERIMENTAL_WARNINGS} + {$DEFINE SUPPORTS_REGION} + {$DEFINE SUPPORTS_UNICODE_STRING} + {$IFEND} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 20402)} + {$DEFINE SUPPORTS_FOR_IN} + {$IFEND} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 20600)} + {$DEFINE SUPPORTS_LIBRARY_WARNINGS} + {$DEFINE SUPPORTS_DEPRECATED_DETAILS} + {$DEFINE SUPPORTS_NESTED_TYPES} + {$DEFINE SUPPORTS_NESTED_CONSTANTS} + {$DEFINE SUPPORTS_ENHANCED_RECORDS} // called Advanced Records in FPC + {$DEFINE SUPPORTS_CLASS_FIELDS} + {$DEFINE SUPPORTS_CLASS_HELPERS} + {$DEFINE SUPPORTS_CLASS_OPERATORS} + {$DEFINE SUPPORTS_CLASS_CTORDTORS} + {$DEFINE SUPPORTS_FINAL} + {$DEFINE SUPPORTS_CAST_INTERFACE_TO_OBJ} + + {$DEFINE HAS_ENOTIMPLEMENTED} + {$IFEND} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 20602)} + {$DEFINE SUPPORTS_INT_ALIASES} + + {$DEFINE HAS_EARGUMENTEXCEPTION} + {$IFEND} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 30000)} + {$DEFINE SUPPORTS_GENERICS} + {$DEFINE SUPPORTS_GENERIC_TYPES} + + {$DEFINE HAS_UNIT_CHARACTER} + {$IFEND} + + {$IF defined(FPC_FULLVERSION) and (FPC_FULLVERSION >= 30200)} + {$DEFINE SUPPORTS_GENERIC_METHODS} + {$DEFINE SUPPORTS_GENERIC_ROUTINES} + {$DEFINE SUPPORTS_WEAKPACKAGEUNIT} + + {$DEFINE HAS_UNIT_RTTI} + {$DEFINE HAS_UNIT_SYSTEM_UITYPES} + {$IFEND} + {$ELSE} + { older than 2.2.4 } + + {$IFDEF VER2_2} + {$SUPPORTS_SETPEFLAGS} + {$SUPPORTS_STRICT} + {$ENDIF} + {$IFEND} + {$ENDIF} +{$ENDIF FPC} + +{$IFDEF CLR} + {$DEFINE SUPPORTS_UNICODE} +{$ENDIF CLR} + +{$IFDEF BORLAND} + {$IFNDEF CLR} + // The ASSEMBLER symbol appeared with Delphi 7 + {$IFNDEF COMPILER7_UP} + {$DEFINE CPUASM} + {$ELSE} + {$IFDEF ASSEMBLER} + {$DEFINE CPUASM} + {$ENDIF ASSEMBLER} + {$ENDIF ~COMPILER7_UP} + {$ENDIF ~CLR} +{$ENDIF BORLAND} + +{$IFDEF COMPILER1_UP} + {$DEFINE SUPPORTS_CONSTPARAMS} + {$DEFINE SUPPORTS_SINGLE} + {$DEFINE SUPPORTS_DOUBLE} + {$DEFINE SUPPORTS_EXTENDED} + {$DEFINE SUPPORTS_PACKAGES} +{$ENDIF COMPILER1_UP} + +{$IFDEF COMPILER2_UP} + {$DEFINE SUPPORTS_CURRENCY} + {$DEFINE SUPPORTS_THREADVAR} + {$DEFINE SUPPORTS_VARIANT} + {$DEFINE SUPPORTS_WIDECHAR} +{$ENDIF COMPILER2_UP} + +{$IFDEF COMPILER3_UP} + {$DEFINE SUPPORTS_OUTPARAMS} + {$DEFINE SUPPORTS_WIDESTRING} + {$DEFINE SUPPORTS_INTERFACE} + {$DEFINE SUPPORTS_DISPINTERFACE} + {$DEFINE SUPPORTS_DISPID} + {$DEFINE SUPPORTS_WEAKPACKAGEUNIT} +{$ENDIF COMPILER3_UP} + +{$IFDEF COMPILER35_UP} + {$DEFINE SUPPORTS_EXTSYM} + {$DEFINE SUPPORTS_NODEFINE} +{$ENDIF COMPILER35_UP} + +{$IFDEF COMPILER4_UP} + {$DEFINE SUPPORTS_LONGWORD} + {$DEFINE SUPPORTS_INT64} + {$DEFINE SUPPORTS_DYNAMICARRAYS} + {$DEFINE SUPPORTS_DEFAULTPARAMS} + {$DEFINE SUPPORTS_OVERLOAD} + {$DEFINE SUPPORTS_IMPLEMENTS} +{$ENDIF COMPILER4_UP} + +{$IFDEF COMPILER6_UP} + {$DEFINE SUPPORTS_DEPRECATED} + {$DEFINE SUPPORTS_LIBRARY} + {$DEFINE SUPPORTS_PLATFORM} + {$DEFINE SUPPORTS_LOCAL} + {$DEFINE SUPPORTS_SETPEFLAGS} + {$DEFINE SUPPORTS_EXPERIMENTAL_WARNINGS} + {$DEFINE ACCEPT_DEPRECATED} + {$DEFINE ACCEPT_PLATFORM} + {$DEFINE ACCEPT_LIBRARY} + {$DEFINE SUPPORTS_DEPRECATED_WARNINGS} + {$DEFINE SUPPORTS_LIBRARY_WARNINGS} + {$DEFINE SUPPORTS_PLATFORM_WARNINGS} + {$DEFINE SUPPORTS_CUSTOMVARIANTS} + {$DEFINE SUPPORTS_VARARGS} + {$DEFINE SUPPORTS_ENUMVALUE} + {$DEFINE SUPPORTS_COMPILETIME_MESSAGES} +{$ENDIF COMPILER6_UP} + +{$IFDEF COMPILER7_UP} + {$DEFINE SUPPORTS_UNSAFE_WARNINGS} + {$DEFINE SUPPORTS_UINT64} +{$ENDIF COMPILER7_UP} + +{$IFDEF COMPILER9_UP} + {$DEFINE SUPPORTS_FOR_IN} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE SUPPORTS_NESTED_CONSTANTS} + {$DEFINE SUPPORTS_NESTED_TYPES} + {$DEFINE SUPPORTS_REGION} + {$IFDEF CLR} + {$DEFINE SUPPORTS_ENHANCED_RECORDS} + {$DEFINE SUPPORTS_CLASS_FIELDS} + {$DEFINE SUPPORTS_CLASS_HELPERS} + {$DEFINE SUPPORTS_CLASS_OPERATORS} + {$DEFINE SUPPORTS_STRICT} + {$DEFINE SUPPORTS_STATIC} + {$DEFINE SUPPORTS_FINAL} + {$ENDIF CLR} +{$ENDIF COMPILER9_UP} + +{$IFDEF COMPILER10_UP} + {$DEFINE SUPPORTS_ENHANCED_RECORDS} + {$DEFINE SUPPORTS_CLASS_FIELDS} + {$DEFINE SUPPORTS_CLASS_HELPERS} + {$DEFINE SUPPORTS_CLASS_OPERATORS} + {$DEFINE SUPPORTS_STRICT} + {$DEFINE SUPPORTS_STATIC} + {$DEFINE SUPPORTS_FINAL} + {$DEFINE SUPPORTS_METHODINFO} +{$ENDIF COMPILER10_UP} + +{$IFDEF COMPILER11_UP} + {$IFDEF CLR} + {$DEFINE SUPPORTS_GENERICS} + {$DEFINE SUPPORTS_GENERIC_TYPES} + {$DEFINE SUPPORTS_GENERIC_METHODS} + {$DEFINE SUPPORTS_DEPRECATED_DETAILS} + {$ENDIF CLR} +{$ENDIF COMPILER11_UP} + +{$IFDEF COMPILER12_UP} + {$DEFINE SUPPORTS_GENERICS} + {$DEFINE SUPPORTS_GENERIC_TYPES} + {$DEFINE SUPPORTS_GENERIC_METHODS} + {$DEFINE SUPPORTS_DEPRECATED_DETAILS} + {$DEFINE SUPPORTS_INT_ALIASES} + {$IFNDEF CLR} + {$DEFINE SUPPORTS_UNICODE} + {$DEFINE SUPPORTS_UNICODE_STRING} + {$ENDIF CLR} +{$ENDIF COMPILER12_UP} + +{$IFDEF COMPILER14_UP} + {$DEFINE SUPPORTS_CLASS_CTORDTORS} + {$DEFINE HAS_UNIT_RTTI} + {$DEFINE SUPPORTS_CAST_INTERFACE_TO_OBJ} + {$DEFINE SUPPORTS_DELAYED_LOADING} +{$ENDIF COMPILER14_UP} + +{$IFDEF COMPILER16_UP} + {$DEFINE USE_64BIT_TYPES} +{$ENDIF COMPILER16_UP} + +{$IFDEF COMPILER17_UP} + {$DEFINE SUPPORTS_LEGACYIFEND} +{$ENDIF COMPILER17_UP} + +{$IFDEF RTL130_UP} + {$DEFINE HAS_UNIT_CONTNRS} + {$DEFINE HAS_PROPERTY_OLDCREATEORDER} +{$ENDIF RTL130_UP} + +{$IFDEF RTL140_UP} + {$IFDEF LINUX} + {$DEFINE HAS_UNIT_LIBC} + {$ENDIF LINUX} + {$DEFINE HAS_UNIT_RTLCONSTS} + {$DEFINE HAS_UNIT_TYPES} + {$DEFINE HAS_UNIT_VARIANTS} + {$DEFINE HAS_UNIT_STRUTILS} + {$DEFINE HAS_UNIT_DATEUTILS} + {$DEFINE XPLATFORM_RTL} +{$ENDIF RTL140_UP} + +{$IFDEF RTL150_UP} + {$DEFINE HAS_UNIT_UXTHEME} +{$ENDIF RTL150_UP} + +{$IFDEF RTL170_UP} + {$DEFINE HAS_UNIT_HTTPPROD} +{$ENDIF RTL170_UP} + +{$IFDEF RTL185_UP} + {$DEFINE HAS_UNIT_GIFIMG} +{$ENDIF RTL185_UP} + +{$IFDEF RTL200_UP} + {$DEFINE HAS_UNIT_ANSISTRINGS} + {$DEFINE HAS_UNIT_PNGIMAGE} + {$DEFINE HAS_UNIT_CHARACTER} + {$DEFINE HAS_EXCEPTION_STACKTRACE} +{$ENDIF RTL200_UP} + +{$IFDEF RTL210_UP} + {$DEFINE HAS_EARGUMENTEXCEPTION} +{$ENDIF RTL210_UP} + +{$IFDEF RTL220_UP} + {$DEFINE HAS_UNIT_REGULAREXPRESSIONSAPI} + {$DEFINE HAS_ENOTIMPLEMENTED} +{$ENDIF RTL220_UP} + +{$IFDEF RTL230_UP} + {$DEFINE HAS_UNITSCOPE} + {$DEFINE HAS_UNIT_SYSTEM_UITYPES} + {$DEFINE HAS_UNIT_VCL_THEMES} +{$ENDIF RTL230_UP} + +{$IFDEF RTL240_UP} + {$DEFINE HAS_UNIT_SYSTEM_ACTIONS} + {$DEFINE HAS_PROPERTY_STYLEELEMENTS} +{$ENDIF RTL240_UP} + +{$IFDEF RTL250_UP} + {$DEFINE DEPRECATED_SYSUTILS_ANSISTRINGS} + {$DEFINE DEPRECATED_TCHARACTER} +{$ENDIF RTL250_UP} + +{$IFDEF RTL270_UP} + {$DEFINE HAS_AUTOMATIC_DB_FIELDS} +{$ENDIF RTL270_UP} + +{$IFDEF RTL320_UP} + {$UNDEF HAS_UNIT_LIBC} +{$ENDIF RTL320_UP} + +{$IFDEF RTL350_UP} + {$UNDEF HAS_PROPERTY_OLDCREATEORDER} +{$ENDIF} + +{------------------------------------------------------------------------------} +{ Cross-platform related defines } +{------------------------------------------------------------------------------} + +{$IFNDEF CPUASM} + {$DEFINE PUREPASCAL} +{$ENDIF ~CPUASM} + +{$IFDEF WIN32} + {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+ + {$DEFINE Win32API} +{$ENDIF} + +{$IFDEF DELPHILANGUAGE} + {$IFDEF LINUX} + {$DEFINE UNIX} + {$ENDIF} + + {$IFNDEF CONSOLE} + {$IFDEF LINUX} + {$DEFINE VisualCLX} + {$ENDIF} + {$IFNDEF VisualCLX} + {$DEFINE VCL} + {$ENDIF} + {$ENDIF ~CONSOLE} +{$ENDIF DELPHILANGUAGE} + +{------------------------------------------------------------------------------} +{ Compiler settings } +{------------------------------------------------------------------------------} + +{$IFOPT A+} {$DEFINE ALIGN_ON} {$ENDIF} +{$IFOPT B+} {$DEFINE BOOLEVAL_ON} {$ENDIF} +{$IFDEF COMPILER2_UP} + {$IFOPT C+} {$DEFINE ASSERTIONS_ON} {$ENDIF} +{$ENDIF} +{$IFOPT D+} {$DEFINE DEBUGINFO_ON} {$ENDIF} +{$IFOPT G+} {$DEFINE IMPORTEDDATA_ON} {$ENDIF} +{$IFDEF COMPILER2_UP} + {$IFOPT H+} {$DEFINE LONGSTRINGS_ON} {$ENDIF} +{$ENDIF} + +// Hints +{$IFOPT I+} {$DEFINE IOCHECKS_ON} {$ENDIF} +{$IFDEF COMPILER2_UP} + {$IFOPT J+} {$DEFINE WRITEABLECONST_ON} {$ENDIF} +{$ENDIF} +{$IFOPT L+} {$DEFINE LOCALSYMBOLS} {$DEFINE LOCALSYMBOLS_ON} {$ENDIF} +{$IFOPT M+} {$DEFINE TYPEINFO_ON} {$ENDIF} +{$IFOPT O+} {$DEFINE OPTIMIZATION_ON} {$ENDIF} +{$IFOPT P+} {$DEFINE OPENSTRINGS_ON} {$ENDIF} +{$IFOPT Q+} {$DEFINE OVERFLOWCHECKS_ON} {$ENDIF} +{$IFOPT R+} {$DEFINE RANGECHECKS_ON} {$ENDIF} + +// Real compatibility +{$IFOPT T+} {$DEFINE TYPEDADDRESS_ON} {$ENDIF} +{$IFOPT U+} {$DEFINE SAFEDIVIDE_ON} {$ENDIF} +{$IFOPT V+} {$DEFINE VARSTRINGCHECKS_ON} {$ENDIF} +{$IFOPT W+} {$DEFINE STACKFRAMES_ON} {$ENDIF} + +// Warnings +{$IFOPT X+} {$DEFINE EXTENDEDSYNTAX_ON} {$ENDIF} + +// for Delphi/BCB trial versions remove the point from the line below +{.$UNDEF SUPPORTS_WEAKPACKAGEUNIT} + +{$ENDIF ~JEDI_INC} diff -Nru cqrprop-0.0.7/src/synapse/kylix.inc cqrprop-0.0.8/src/synapse/kylix.inc --- cqrprop-0.0.7/src/synapse/kylix.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/kylix.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,30 @@ +// +// This is FPC-incompatible code and was excluded from jedi.inc for this reason +// +// Kylix 3/C++ for some reason evaluates CompilerVersion comparisons to False, +// if the constant to compare with is a floating point value - weird. +// The "+" sign prevents Kylix/Delphi from issueing a warning about comparing +// signed and unsigned values. +// + {$IF not Declared(CompilerVersion)} + {$DEFINE KYLIX1} + {$DEFINE COMPILER6} + {$DEFINE DELPHICOMPILER6} + {$DEFINE RTL140_UP} + {$ELSEIF Declared(CompilerVersion) and (CompilerVersion > +14)} + {$DEFINE KYLIX2} + {$DEFINE COMPILER6} + {$DEFINE DELPHICOMPILER6} + {$DEFINE RTL142_UP} + {$ELSEIF Declared(CompilerVersion) and (CompilerVersion < +15)} + {$DEFINE KYLIX3} + {$DEFINE COMPILER6} + {$IFNDEF BCB} + {$DEFINE DELPHICOMPILER6} + {$ENDIF} + {$DEFINE RTL145_UP} + {$ELSE} + Add new Kylix version + {$IFEND} + + diff -Nru cqrprop-0.0.7/src/synapse/laz_synapse.lpk cqrprop-0.0.8/src/synapse/laz_synapse.lpk --- cqrprop-0.0.7/src/synapse/laz_synapse.lpk 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/laz_synapse.lpk 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,171 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff -Nru cqrprop-0.0.7/src/synapse/laz_synapse.pas cqrprop-0.0.8/src/synapse/laz_synapse.pas --- cqrprop-0.0.7/src/synapse/laz_synapse.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/laz_synapse.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,19 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit laz_synapse; + +{$warn 5023 off : no warning about unused units} +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, ssl_openssl, ssl_openssl_lib; + +implementation + +end. diff -Nru cqrprop-0.0.7/src/synapse/ldapsend.pas cqrprop-0.0.8/src/synapse/ldapsend.pas --- cqrprop-0.0.7/src/synapse/ldapsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ldapsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1261 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.007.001 | +|==============================================================================| +| Content: LDAP client | +|==============================================================================| +| Copyright (c)1999-2014, 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-2014. | +| 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-2696, 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; + LDAP_ASN1_CONTROLS = $A0; + + +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); + public + function Add(const S: string): Integer; override; + 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; + FSearchPageSize: integer; + FSearchCookie: AnsiString; + 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; + + {:Specify number of results to return per search request. Value 0 means + no paging.} + property SearchPageSize: integer read FSearchPageSize Write FSearchPageSize; + + {:Cookie returned by paged search results. Use an empty string for the first + search request.} + property SearchCookie: AnsiString read FSearchCookie Write FSearchCookie; + + {: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.Add(const S: string): Integer; +begin + Result := inherited Add(''); + Put(Result,S); +end; + +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; + FSearchPageSize := 0; + FSearchCookie := ''; + 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, c: 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); + if FSearchPageSize > 0 then + begin + c := ASNObject('1.2.840.113556.1.4.319', ASN1_OCTSTR); // controlType: pagedResultsControl + c := c + ASNObject(ASNEncInt(0), ASN1_BOOL); // criticality: FALSE + t := ASNObject(ASNEncInt(FSearchPageSize), ASN1_INT); // page size + t := t + ASNObject(FSearchCookie, ASN1_OCTSTR); // search cookie + t := ASNObject(t, ASN1_SEQ); // wrap with SEQUENCE + c := c + ASNObject(t, ASN1_OCTSTR); // add searchControlValue as OCTET STRING + c := ASNObject(c, ASN1_SEQ); // wrap with SEQUENCE + s := s + ASNObject(c, LDAP_ASN1_CONTROLS); // append Controls to SearchRequest + end; + 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; + n := 1; + ASNItem(n, t, x); + if x = LDAP_ASN1_CONTROLS then + begin + ASNItem(n, t, x); + if x = ASN1_SEQ then + begin + s := ASNItem(n, t, x); + if s = '1.2.840.113556.1.4.319' then + begin + s := ASNItem(n, t, x); // searchControlValue + n := 1; + ASNItem(n, s, x); + if x = ASN1_SEQ then + begin + ASNItem(n, s, x); // total number of result records, if known, otherwise 0 + FSearchCookie := ASNItem(n, s, x); // active search cookie, empty when done + end; + end; + end; + end; + 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 -Nru cqrprop-0.0.7/src/synapse/mimeinln.pas cqrprop-0.0.8/src/synapse/mimeinln.pas --- cqrprop-0.0.7/src/synapse/mimeinln.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/mimeinln.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,263 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/mimemess.pas cqrprop-0.0.8/src/synapse/mimemess.pas --- cqrprop-0.0.7/src/synapse/mimemess.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/mimemess.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,851 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.006.001 | +|==============================================================================| +| Content: MIME message object | +|==============================================================================| +| Copyright (c)1999-2021, 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-2021. | +| 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; virtual; + + {:Decode message from @link(Lines) to @link(MessagePart). Massage headers + are parsed into @link(Header) object.} + procedure DecodeMessage; virtual; + + {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 := CreateStringList; + FCCList := CreateStringList; + FCustomHeaders := CreateStringList; + 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 := CreateStringList; + 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(AnsiString(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 := CreateStringList; + 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 := CreateStringList; + 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 := CreateStringList; + 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 := CreateStringList; + 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 -Nru cqrprop-0.0.7/src/synapse/mimepart.pas cqrprop-0.0.8/src/synapse/mimepart.pas --- cqrprop-0.0.7/src/synapse/mimepart.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/mimepart.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1241 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.009.002 | +|==============================================================================| +| Content: MIME support procedures and functions | +|==============================================================================| +| Copyright (c)1999-2021 | +| | +| 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-2021. | +| 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; +{:Generates a stringlist that does not write a BOM character.} +Function CreateStringList : TStringList; + +implementation + +{==============================================================================} + +constructor TMIMEPart.Create; +begin + inherited Create; + FOnWalkPart := nil; + FLines := CreateStringList; + FPartBody := CreateStringList; + FHeaders := CreateStringList; + FPrePart := CreateStringList; + FPostPart := CreateStringList; + 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.Position := 0; +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; +{$IFDEF UNICODE} + s, t: RawByteString; +{$ELSE} + s, t: string; +{$ENDIF} + n, x: Integer; + d1, d2: integer; +begin + if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then + Encoding := 'base64'; + l := CreateStringList; + FPartBody.Clear; + FDecodedLines.Position := 0; + 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; + +function CreateStringList: TStringList; +begin + Result := TStringList.Create; +{$IFDEF UNICODE} + Result.WriteBOM := False; +{$ENDIF} +end; + +end. diff -Nru cqrprop-0.0.7/src/synapse/nntpsend.pas cqrprop-0.0.8/src/synapse/nntpsend.pas --- cqrprop-0.0.7/src/synapse/nntpsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/nntpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,483 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/pingsend.pas cqrprop-0.0.8/src/synapse/pingsend.pas --- cqrprop-0.0.7/src/synapse/pingsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/pingsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,720 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.004 | +|==============================================================================| +| Content: PING sender | +|==============================================================================| +| Copyright (c)1999-2023, 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-2023. | +| 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: THandle; stdcall; + TIcmpCloseHandle = function(handle: THandle): boolean; stdcall; + TIcmpSendEcho2 = function(handle: THandle; 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: THandle; stdcall; + TIcmp6SendEcho2 = function(handle: THandle; 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) > Cardinal(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 +{$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); +{$ELSE} + Result := 0; +{$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: THandle; + 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 + 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 -Nru cqrprop-0.0.7/src/synapse/pop3send.pas cqrprop-0.0.8/src/synapse/pop3send.pas --- cqrprop-0.0.7/src/synapse/pop3send.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/pop3send.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,483 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/slogsend.pas cqrprop-0.0.8/src/synapse/slogsend.pas --- cqrprop-0.0.7/src/synapse/slogsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/slogsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,320 @@ +{==============================================================================| +| 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( {$IFDEF UNICODE} AnsiString {$ENDIF} (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 -Nru cqrprop-0.0.7/src/synapse/smtpsend.pas cqrprop-0.0.8/src/synapse/smtpsend.pas --- cqrprop-0.0.7/src/synapse/smtpsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/smtpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,724 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/snmpsend.pas cqrprop-0.0.8/src/synapse/snmpsend.pas --- cqrprop-0.0.7/src/synapse/snmpsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/snmpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1278 @@ +{==============================================================================| +| 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} + {$TYPEINFO ON} +{$ENDIF} + +unit snmpsend; + +interface + +uses + Classes, SysUtils, + blcksock, synautil, asn1util, synaip, synacode, synacrypt + {$IfDef POSIX} + ,System.Generics.Collections, System.Generics.Defaults + {$EndIf} + {$IfDef NEXTGEN} + ,synafpc + {$EndIf}; + +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; + + {$IFDEF POSIX} + TSNMPMibList = TList; + {$ELSE} + TSNMPMibList = TList; + {$ENDIF} + + {:@abstract(Data object abstracts SNMP data packet)} + TSNMPRec = class(TObject) + protected + FVersion: Integer; + FPDUType: Integer; + FID: Integer; + FErrorStatus: Integer; + FErrorIndex: Integer; + FCommunity: AnsiString; + FSNMPMibList: TSNMPMibList; + 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: TSNMPMibList 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 := TSNMPMibList.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 + 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 -Nru cqrprop-0.0.7/src/synapse/sntpsend.pas cqrprop-0.0.8/src/synapse/sntpsend.pas --- cqrprop-0.0.7/src/synapse/sntpsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/sntpsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,381 @@ +{==============================================================================| +| 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+} + +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + +unit sntpsend; + +interface + +uses + SysUtils, + synsock, blcksock, synautil + {$IFDEF NEXTGEN} + ,synafpc + {$ENDIF}; + +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 -Nru cqrprop-0.0.7/src/synapse/ssdotnet.inc cqrprop-0.0.8/src/synapse/ssdotnet.inc --- cqrprop-0.0.7/src/synapse/ssdotnet.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssdotnet.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1099 @@ +{==============================================================================| +| 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 -Nru cqrprop-0.0.7/src/synapse/ssfpc.inc cqrprop-0.0.8/src/synapse/ssfpc.inc --- cqrprop-0.0.7/src/synapse/ssfpc.inc 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssfpc.inc 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.005 | +| Project : Ararat Synapse | 001.001.008 | |==============================================================================| | Content: Socket Independent Platform Layer - FreePascal definition include | |==============================================================================| -| Copyright (c)2006-2013, Lukas Gebauer | +| Copyright (c)2006-2021, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2006-2013. | +| Portions created by Lukas Gebauer are Copyright (c)2006-2021. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -255,9 +255,8 @@ 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 + MSG_NOSIGNAL = 0; // Signal is disabled by SO_NOSIGPIPE socket option instead + //was $20000 as undocumented option for Mac OS X {$else} MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. {$endif} @@ -365,7 +364,7 @@ case sin_family: sa_family_t of AF_INET: (sin_port: word; sin_addr: TInAddr; - sin_zero: array[0..7] of Char); + sin_zero: array[0..7] of byte); AF_INET6: (sin6_port: word; sin6_flowinfo: longword; sin6_addr: TInAddr6; @@ -514,9 +513,9 @@ begin case sin.sin_family of AF_INET: - Result := SizeOf(TSockAddrIn); + Result := SizeOf(TSockAddrIn); AF_INET6: - Result := SizeOf(TSockAddrIn6); + Result := SizeOf(TSockAddrIn6); else Result := 0; end; @@ -755,7 +754,7 @@ begin Result := 0; FillChar(Sin, Sizeof(Sin), 0); - Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); + Sin.sin_port := synsock.htons(Resolveport(port, family, SockProtocol, SockType)); TwoPass := False; if Family = AF_UNSPEC then begin @@ -850,7 +849,7 @@ end; if IPList.Count = 0 then - IPList.Add(cLocalHost); + IPList.Add(cAnyHost); end; function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; @@ -858,14 +857,16 @@ ProtoEnt: TProtocolEntry; ServEnt: TServiceEntry; begin - Result := synsock.htons(StrToIntDef(Port, 0)); + Result := StrToIntDef(Port, 0); if Result = 0 then begin ProtoEnt.Name := ''; - GetProtocolByNumber(SockProtocol, ProtoEnt); - ServEnt.port := 0; - GetServiceByName(Port, ProtoEnt.Name, ServEnt); - Result := ServEnt.port; + if GetProtocolByNumber(SockProtocol, ProtoEnt) then + begin + ServEnt.port := 0; + if GetServiceByName(Port, ProtoEnt.Name, ServEnt) then + Result := synsock.ntohs(ServEnt.port); + end; end; end; diff -Nru cqrprop-0.0.7/src/synapse/ssl_cryptlib.pas cqrprop-0.0.8/src/synapse/ssl_cryptlib.pas --- cqrprop-0.0.7/src/synapse/ssl_cryptlib.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_cryptlib.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.001 | +| Project : Ararat Synapse | 001.001.002 | |==============================================================================| | Content: SSL/SSH support by Peter Gutmann's CryptLib | |==============================================================================| @@ -79,6 +79,10 @@ {$ENDIF} {$H+} +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + unit ssl_cryptlib; interface @@ -142,7 +146,7 @@ {:See @inherited} function GetPeerName: string; override; {:See @inherited} - function GetPeerFingerprint: string; override; + function GetPeerFingerprint: ansistring; override; {:See @inherited} function GetVerifyCert: integer; override; published @@ -296,7 +300,7 @@ FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); if server then case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_TLSv1_2, LT_TLSv1_3: st := CRYPT_SESSION_SSL_SERVER; LT_SSHv2: st := CRYPT_SESSION_SSH_SERVER; @@ -305,7 +309,7 @@ end else case FSSLType of - LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: + LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_TLSv1_2, LT_TLSv1_3: st := CRYPT_SESSION_SSL; LT_SSHv2: st := CRYPT_SESSION_SSH; @@ -322,6 +326,10 @@ x := 1; LT_TLSv1_1: x := 2; + LT_TLSv1_2: + x := 3; + LT_TLSv1_3: + x := 4; end; if x >= 0 then if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then @@ -337,9 +345,9 @@ aUserName := fUserName; aPassword := fPassword; cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, - Pointer(FUsername), Length(FUsername)); + Pointer(aUsername), Length(aUsername)); cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, - Pointer(FPassword), Length(FPassword)); + Pointer(aPassword), Length(aPassword)); end; if FSSLType = LT_SSHv2 then if FSSHChannelType <> '' then @@ -507,7 +515,7 @@ 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 + if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_TLSv1_2, LT_TLSv1_3, LT_all] then case x of 0: Result := 'SSLv3'; @@ -515,6 +523,10 @@ Result := 'TLSv1'; 2: Result := 'TLSv1.1'; + 3: + Result := 'TLSv1.2'; + 4: + Result := 'TLSv1.3'; end; if FSSLType in [LT_SSHv2] then case x of @@ -564,7 +576,7 @@ cryptDestroyCert(cert); end; -function TSSLCryptLib.GetPeerFingerprint: string; +function TSSLCryptLib.GetPeerFingerprint: ansistring; var cert: CRYPT_CERTIFICATE; begin @@ -677,5 +689,3 @@ finalization cryptEnd; end. - - diff -Nru cqrprop-0.0.7/src/synapse/sslinux.inc cqrprop-0.0.8/src/synapse/sslinux.inc --- cqrprop-0.0.7/src/synapse/sslinux.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/sslinux.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1326 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.009 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Linux definition include | +|==============================================================================| +| 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)2003-2012. | +| 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, + {$IFDEF POSIX} //even POSIX should use new ssPosix module instead... + Posix.Errno, + Posix.Signal, + Posix.NetDB + {$ELSE} + Libc + {$ENDIF}; + +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; + {$IFDEF POSIX} + uint32_t = UInt32; + {$ENDIF} + 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 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 = 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 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: 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; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + {$IfDef POSIX} + Signal(SIGPIPE, TSignalHandler(SIG_IGN)); + {$Else} + Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + {$EndIf} + 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 -Nru cqrprop-0.0.7/src/synapse/ssl_libssh2.pas cqrprop-0.0.8/src/synapse/ssl_libssh2.pas --- cqrprop-0.0.7/src/synapse/ssl_libssh2.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_libssh2.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,251 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: SSH support by LibSSH2 | +|==============================================================================| +| Copyright (c)1999-2013, 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 Alexey Suhinin. | +| Portions created by Alexey Suhinin are Copyright (c)2012-2013. | +| Portions created by Lukas Gebauer are Copyright (c)2013-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +//requires LibSSH2 libraries! http://libssh2.org + +{:@abstract(SSH plugin for LibSSH2) + +Requires libssh2.dll or libssh2.so. +You can download binaries as part of the CURL project from +http://curl.haxx.se/download.html + +You need Pascal bindings for the library too! You can find one at: + http://www.lazarus.freepascal.org/index.php/topic,15935.msg86465.html#msg86465 + +This plugin implements the client part only. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_libssh2; + +interface + +uses + SysUtils, + blcksock, synsock, + libssh2; + +type + {:@abstract(class implementing LibSSH2 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!} + TSSLLibSSH2 = class(TCustomSSL) + protected + FSession: PLIBSSH2_SESSION; + FChannel: PLIBSSH2_CHANNEL; + function SSHCheck(Value: integer): Boolean; + function DeInit: Boolean; + 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} + function Connect: 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; + published + end; + +implementation + +{==============================================================================} +function TSSLLibSSH2.SSHCheck(Value: integer): Boolean; +var + PLastError: PAnsiChar; + ErrMsgLen: Integer; +begin + Result := true; + FLastError := 0; + FLastErrorDesc := ''; + if Value<0 then + begin + FLastError := libssh2_session_last_error(FSession, PLastError, ErrMsglen, 0); + FLastErrorDesc := PLastError; + Result := false; + end; +end; + + +function TSSLLibSSH2.DeInit: Boolean; +begin + if Assigned(FChannel) then + begin + libssh2_channel_free(FChannel); + FChannel := nil; + end; + if Assigned(FSession) then + begin + libssh2_session_disconnect(FSession,'Goodbye'); + libssh2_session_free(FSession); + FSession := nil; + end; + FSSLEnabled := False; + Result := true; +end; + +constructor TSSLLibSSH2.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FSession := nil; + FChannel := nil; +end; + +destructor TSSLLibSSH2.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLLibSSH2.Connect: boolean; +begin + Result := False; + if SSLEnabled then DeInit; + if (FSocket.Socket <> INVALID_SOCKET) and (FSocket.SSL.SSLType = LT_SSHv2) then + begin + FSession := libssh2_session_init(); + if not Assigned(FSession) then + begin + FLastError := -999; + FLastErrorDesc := 'Cannot initialize SSH session'; + exit; + end; + if not SSHCheck(libssh2_session_startup(FSession, FSocket.Socket)) then + exit; + // Attempt private key authentication, then fall back to username/password but + // do not forget original private key auth error. This avoids giving spurious errors like + // Authentication failed (username/password) + // instead of e.g. + // Unable to extract public key from private key file: Method unimplemented in libgcrypt backend + if FSocket.SSL.PrivateKeyFile<>'' then + if (not SSHCheck(libssh2_userauth_publickey_fromfile(FSession, PChar(FSocket.SSL.Username), nil, PChar(FSocket.SSL.PrivateKeyFile), PChar(FSocket.SSL.KeyPassword)))) + and (libssh2_userauth_password(FSession, PChar(FSocket.SSL.Username), PChar(FSocket.SSL.Password))<0) then + exit; + FChannel := libssh2_channel_open_session(FSession); + if not assigned(FChannel) then + begin +// SSHCheck(-1); + FLastError:=-999; + FLastErrorDesc := 'Cannot open session'; + exit; + end; + if not SSHCheck(libssh2_channel_request_pty(FChannel, 'vanilla')) then + exit; + if not SSHCheck(libssh2_channel_shell(FChannel)) then + exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLLibSSH2.LibName: String; +begin + Result := 'ssl_libssh2'; +end; + +function TSSLLibSSH2.Shutdown: boolean; +begin + Result := DeInit; +end; + + +function TSSLLibSSH2.BiShutdown: boolean; +begin + Result := DeInit; +end; + +function TSSLLibSSH2.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + Result:=libssh2_channel_write(FChannel, PAnsiChar(Buffer), Len); + SSHCheck(Result); +end; + +function TSSLLibSSH2.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +begin + result:=libssh2_channel_read(FChannel, PAnsiChar(Buffer), Len); + SSHCheck(Result); +end; + +function TSSLLibSSH2.WaitingData: Integer; +begin + if libssh2_poll_channel_read(FChannel, Result) <> 1 then + Result := 0; +end; + +function TSSLLibSSH2.GetSSLVersion: string; +begin + Result := 'SSH2'; +end; + +function TSSLLibSSH2.LibVersion: String; +begin + Result := libssh2_version(0); +end; + +initialization + if libssh2_init(0)=0 then + SSLImplementation := TSSLLibSSH2; + +finalization + libssh2_exit; + +end. diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl11_lib.pas cqrprop-0.0.8/src/synapse/ssl_openssl11_lib.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl11_lib.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl11_lib.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1545 @@ +{==============================================================================| +| Project : Ararat Synapse | 004.000.000 | +|==============================================================================| +| Content: SSL support by OpenSSL 1.1 | +|==============================================================================| +| Copyright (c)1999-2021, 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-2021. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| 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 1.1 is loaded dynamicly on-demand. If this library is not found in system, +requested OpenSSL function just return errorcode. +} +unit ssl_openssl11_lib; + +interface + +uses + Classes, + synafpc, +{$IFNDEF MSWINDOWS} + {$IFDEF FPC} + {$IFDEF UNIX} + BaseUnix, + {$ENDIF UNIX} + {$ELSE} + {$IFDEF POSIX} + {$ELSE} + Libc, + {$ENDIF} + + {$ENDIF} + SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +var + {$IFNDEF MSWINDOWS} + {$IFDEF DARWIN} + DLLSSLName: string = 'libssl.dylib'; + DLLUtilName: string = 'libcrypto.dylib'; + {$ELSE} + {$IFDEF OS2} + {$IFDEF OS2GCC} + DLLSSLName: string = 'kssl.dll'; + DLLUtilName: string = 'kcrypto.dll'; + {$ELSE OS2GCC} + DLLSSLName: string = 'ssl.dll'; + DLLUtilName: string = 'crypto.dll'; + {$ENDIF OS2GCC} + {$ELSE OS2} //linux + DLLSSLName: string = 'libssl.so.1.1'; + DLLUtilName: string = 'libcrypto.so.1.1'; + {$ENDIF OS2} + {$ENDIF} + {$ELSE} + {$IFDEF WIN64} + DLLSSLName: string = 'libssl-1_1-x64.dll'; + DLLUtilName: string = 'libcrypto-1_1-x64.dll'; + {$ELSE} + DLLSSLName: string = 'libssl-1_1.dll'; + DLLUtilName: string = 'libcrypto-1_1.dll'; + {$ENDIF} + {$ENDIF} + +type + SslPtr = Pointer; + PSslPtr = ^SslPtr; + PSSL_CTX = SslPtr; + PSSL = SslPtr; + PSSL_METHOD = SslPtr; + PX509 = SslPtr; + PX509_NAME = SslPtr; + PX509_STORE = Pointer; + 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; + + TLS1_VERSION = $0301; + TLS1_1_VERSION = $0302; + TLS1_2_VERSION = $0303; + TLS1_3_VERSION = $0304; +var + SSLLibHandle: TLibHandle = 0; + SSLUtilHandle: TLibHandle = 0; + SSLLibFile: string = ''; + SSLUtilFile: string = ''; + +// libssl.dll + function SslGetError(s: PSSL; ret_code: Integer):Integer; +// 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 SslMethodTLS: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 SslCtxSetMinProtoVersion(ctx: PSSL_CTX; version: integer): integer; + function SslCtxSetMaxProtoVersion(ctx: PSSL_CTX; version: integer): 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; +// function ErrErrorString(e: integer; buf: PChar): PChar; + function OpenSSLversion(t: integer): Ansistring; + procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); + function ErrGetError: integer; + procedure ErrClearError; + 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 OPENSSL_sk_num(Stack: PSTACK): Integer; + function OPENSSL_sk_value(Stack: PSTACK; Item: Integer): PAnsiChar; + function X509_STORE_add_cert(Store: PX509_STORE; Cert: PX509): Integer; + function SSL_CTX_get_cert_store(const Ctx: PSSL_CTX): PX509_STORE; + + 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); + +function IsSSLloaded: Boolean; +function InitSSLInterface: Boolean; +function DestroySSLInterface: Boolean; + +var + _X509Free: TX509Free = nil; {pf} + +implementation + +uses +{$IFDEF OS2} + Sockets, +{$ENDIF OS2} + SyncObjs; + +type +// libssl.dll + TSslGetError = function(s: PSSL; ret_code: Integer):Integer; 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; + TSslMethodTLS = 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; + TSslCtxSetMinProtoVersion = function(ctx: PSSL_CTX; version: integer): integer; cdecl; + TSslCtxSetMaxProtoVersion = function(ctx: PSSL_CTX; version: integer): 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 + + TOPENSSL_sk_new_null = function: PSTACK; cdecl; + TOPENSSL_sk_num = function(Stack: PSTACK): Integer; cdecl; + TOPENSSL_sk_value = function(Stack: PSTACK; Item: Integer): PAnsiChar; cdecl; + TOPENSSL_sk_free = procedure(Stack: PSTACK); cdecl; + TOPENSSL_sk_insert = function(Stack: PSTACK; Data: PAnsiChar; Index: Integer): Integer; cdecl; + TX509_dup = function(X: PX509): PX509; cdecl; + TSSL_CTX_get_cert_store = function(const Ctx: PSSL_CTX): PX509_STORE;cdecl; + TX509_STORE_add_cert = function(Store: PX509_STORE; Cert: PX509): Integer; cdecl; + + 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; + TOpenSSLversion = function(t: integer): PAnsiChar; cdecl; + TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl; + TErrGetError = function: integer; cdecl; + TErrClearError = 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; + +var +// libssl.dll + _SslGetError: TSslGetError = nil; + _SslCtxSetCipherList: TSslCtxSetCipherList = nil; + _SslCtxNew: TSslCtxNew = nil; + _SslCtxFree: TSslCtxFree = nil; + _SslSetFd: TSslSetFd = nil; + _SslMethodTLS: TSslMethodTLS = 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; + _SslCtxSetMinProtoVersion: TSslCtxSetMinProtoVersion = nil; + _SslCtxSetMaxProtoVersion: TSslCtxSetMaxProtoVersion = nil; + +// libeay.dll + + _OPENSSL_sk_new_null: TOPENSSL_sk_new_null = nil; + _OPENSSL_sk_num: TOPENSSL_sk_num = nil; + _OPENSSL_sk_value: TOPENSSL_sk_value = nil; + _OPENSSL_sk_free: TOPENSSL_sk_free = nil; + _OPENSSL_sk_insert: TOPENSSL_sk_insert = nil; + _SSL_CTX_get_cert_store : TSSL_CTX_get_cert_store = nil; + _X509_STORE_add_cert : TX509_STORE_add_cert = nil; + + _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; + _OpenSSLversion: TOpenSSLversion = nil; + _ErrErrorString: TErrErrorString = nil; + _ErrGetError: TErrGetError = nil; + _ErrClearError: TErrClearError = 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; + +var + SSLCS: TCriticalSection; + SSLloaded: boolean = false; + +// 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 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 SslMethodTLS:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLS) then + Result := _SslMethodTLS + 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 SslCtxSetMinProtoVersion(ctx: PSSL_CTX; version: integer): integer; +begin + if InitSSLInterface and Assigned(_SslCtxSetMinProtoVersion) then + Result := _SslCtxSetMinProtoVersion(ctx, version) + else + Result := 0; +end; + +function SslCtxSetMaxProtoVersion(ctx: PSSL_CTX; version: integer): integer; +begin + if InitSSLInterface and Assigned(_SslCtxSetMaxProtoVersion) then + Result := _SslCtxSetMaxProtoVersion(ctx, version) + 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 + Result := _SSLGetCurrentCipher(s) + 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 OpenSSLversion(t: integer): Ansistring; +begin + if InitSSLInterface and Assigned(_OpenSSLversion) then + Result := PAnsiChar(_OpenSSLversion(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; + +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(b, x) + 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; + +function OPENSSL_sk_num(Stack: PSTACK): Integer; +begin + if InitSSLInterface and Assigned(_OPENSSL_sk_num) then + Result := _OPENSSL_sk_num(Stack); +end; + +function SSL_CTX_get_cert_store(const Ctx: PSSL_CTX): PX509_STORE; +begin + if InitSSLInterface and Assigned(_SSL_CTX_get_cert_store) then + Result := _SSL_CTX_get_cert_store(Ctx); +end; + +function OPENSSL_sk_value(Stack: PSTACK; Item: Integer): PAnsiChar; +begin + if InitSSLInterface and Assigned(_OPENSSL_sk_value) then + Result := _OPENSSL_sk_value(Stack, Item); +end; + +function X509_STORE_add_cert(Store: PX509_STORE; Cert: PX509): Integer; +begin + if InitSSLInterface and Assigned(_X509_STORE_add_cert) then + Result := _X509_STORE_add_cert(Store, Cert); +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; + +function LoadLib(const Value: String): HModule; +begin + Result := LoadLibrary(PChar(Value)); +end; + +function GetProcAddr(module: HModule; const ProcName: string): SslPtr; +begin + Result := GetProcAddress(module, PChar(ProcName)); +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 + SSLUtilHandle := LoadLib(DLLUtilName); + SSLLibHandle := LoadLib(DLLSSLName); + if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then + begin + _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); + _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'); + _SslMethodTLS := GetProcAddr(SSLLibHandle, 'TLS_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'); + _SslCtxSetMinProtoVersion := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_min_proto_version'); + _SslCtxSetMaxProtoVersion := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_max_proto_version'); + _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'); + + _OPENSSL_sk_new_null:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_new_null'); + _OPENSSL_sk_num:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_num'); + _OPENSSL_sk_value:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_value'); + _OPENSSL_sk_free:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_free'); + _OPENSSL_sk_insert:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_insert'); + _SSL_CTX_get_cert_store:= GetProcAddr(SSLLibHandle, 'SSL_CTX_get_cert_store'); + _X509_STORE_add_cert := GetProcAddr(SSLUtilHandle, 'X509_STORE_add_cert'); + + _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_set1_notBefore'); + _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set1_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'); + _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _OpenSSLversion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); + _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); + _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); + _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'); + // + 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; + SSLloaded := True; +{$IFDEF OS2} + Result := InitEMXHandles; +{$ELSE OS2} + Result := True; +{$ENDIF OS2} + end + else + begin + //load failed! + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + SSLCS.Leave; + end; +end; + +function DestroySSLInterface: Boolean; +begin + SSLCS.Enter; + try + SSLloaded := false; + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + + _SslGetError := nil; + _SslCtxSetCipherList := nil; + _SslCtxNew := nil; + _SslCtxFree := nil; + _SslSetFd := nil; + _SslMethodTLS := 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; + _SslCtxSetMinProtoVersion := nil; + _SslCtxSetMaxProtoVersion := 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; + _EvpGetDigestByName := nil; + _OpenSSLversion := nil; + _ErrErrorString := nil; + _ErrGetError := nil; + _ErrClearError := 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; + finally + SSLCS.Leave; + end; + Result := True; +end; + +function IsSSLloaded: Boolean; +begin + Result := SSLLoaded; +end; + +initialization +begin + SSLCS:= TCriticalSection.Create; +end; + +finalization +begin + DestroySSLInterface; + SSLCS.Free; +end; + +end. diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl11.pas cqrprop-0.0.8/src/synapse/ssl_openssl11.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl11.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl11.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,846 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.000.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| Copyright (c)1999-2021, 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-2021. | +| 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) + +Compatibility with OpenSSL versions: +1.1.0 +1.1.1 + +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 does not have support for .NET! + +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! +} + +{$INCLUDE 'jedi.inc'} + +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ssl_openssl11{$IFDEF SUPPORTS_DEPRECATED} deprecated{$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use ssl_openssl3 with OpenSSL 3.0 instead'{$ENDIF}{$ENDIF}; + +interface + +uses + SysUtils, Classes, + {$IFDEF DELPHI23_UP} AnsiStrings, {$ENDIF} + blcksock, synsock, synautil, + ssl_openssl11_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: ansistring; 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 + +{==============================================================================} + +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); + {$IFDEF DELPHI23_UP}AnsiStrings.{$ENDIF}StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); +end; + +{==============================================================================} + +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 := OpenSSLversion(0); +end; + +function TSSLOpenSSL.LibName: String; +begin + Result := 'ssl_openssl11'; +end; + +function TSSLOpenSSL.SSLCheck: Boolean; +var + s : AnsiString; +begin + Result := true; + FLastErrorDesc := ''; + FLastError := ErrGetError; + ErrClearError; + if FLastError <> 0 then + begin + Result := False; + s := StringOfChar(#0, 256); + ErrErrorString(FLastError, s, Length(s)); + FLastErrorDesc := s; + 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; +begin + Result := True; + pk := EvpPkeynew; + x := X509New; + try + rsa := RsaGenerateKey(2048, $10001, nil, nil); + EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); + X509SetVersion(x, 2); +// Asn1IntegerSet(X509getSerialNumber(x), 0); + Asn1IntegerSet(X509getSerialNumber(x), GetTick); + 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('SHA256')); + b := BioNew(BioSMem); + try + i2dX509Bio(b, x); + xn := bioctrlpending(b); + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); + finally + BioFreeAll(b); + end; + FCertificate := s; + b := BioNew(BioSMem); + try + i2dPrivatekeyBio(b, pk); + xn := bioctrlpending(b); + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); + finally + BioFreeAll(b); + end; + FPrivatekey := s; + finally + X509free(x); + EvpPkeyFree(pk); + end; +end; + +function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean; +var + cert, pkey, ca: SslPtr; + certx: PAnsiChar; + b: PBIO; + p12: SslPtr; + i: Integer; + Store: PX509_STORE; + iTotal: Integer; +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} + + if Result and (ca <> nil) then + begin + iTotal := OPENSSL_sk_num(ca); + if iTotal > 0 then + begin + Store := SSL_CTX_get_cert_store(Fctx); + for I := 0 to iTotal - 1 do + begin + certx := OPENSSL_sk_value(ca, I); + if certx <> nil then + begin + if X509_STORE_add_cert(Store, certx) = 0 then + begin + // already exists + end; + //X509_free(Cert); + end; + end; + end; + end; + 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: ansistring; +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 := SslCtxNew(SslMethodTLS); // best common protocol + if Fctx = nil then + begin + SSLCheck; + Exit; + end + else + begin + case FSSLType of + LT_TLSv1: + begin + SslCtxSetMinProtoVersion(Fctx, TLS1_VERSION); + SslCtxSetMaxProtoVersion(Fctx, TLS1_VERSION); + end; + LT_TLSv1_1: + begin + SslCtxSetMinProtoVersion(Fctx, TLS1_1_VERSION); + SslCtxSetMaxProtoVersion(Fctx, TLS1_1_VERSION); + end; + LT_TLSv1_2: + begin + SslCtxSetMinProtoVersion(Fctx, TLS1_2_VERSION); + SslCtxSetMaxProtoVersion(Fctx, TLS1_2_VERSION); + end; + LT_TLSv1_3: + begin + SslCtxSetMinProtoVersion(Fctx, TLS1_3_VERSION); + SslCtxSetMaxProtoVersion(Fctx, TLS1_3_VERSION); + end; + end; + s := FCiphers; + SslCtxSetCipherList(Fctx, s); + if FVerifyCert then + SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) + else + SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); + + 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; + 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; + b: boolean; + err: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(False) then + begin + if sslsetfd(FSsl, FSocket.Socket) < 1 then + begin + SSLCheck; + Exit; + end; + if SNIHost<>'' then + SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(AnsiString(SNIHost))); + if FSocket.ConnectionTimeout <= 0 then //do blocking call of SSL_Connect + begin + x := sslconnect(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + end + else //do non-blocking call of SSL_Connect + begin + b := Fsocket.NonBlockMode; + Fsocket.NonBlockMode := true; + repeat + x := sslconnect(FSsl); + err := SslGetError(FSsl, x); + if err = SSL_ERROR_WANT_READ then + if not FSocket.CanRead(FSocket.ConnectionTimeout) then + break; + if err = SSL_ERROR_WANT_WRITE then + if not FSocket.CanWrite(FSocket.ConnectionTimeout) then + break; + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + Fsocket.NonBlockMode := b; + if err <> SSL_ERROR_NONE then + begin + SSLcheck; + Exit; + end; + 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 + if sslsetfd(FSsl, FSocket.Socket) < 1 then + 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; +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat + Result := SslWrite(FSsl, Buffer , Len); + 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; +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat + Result := SslRead(FSsl, Buffer , Len); + 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; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(s, 4096); + Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s)); + 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; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(s, 4096); + Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s)); + X509Free(cert); +end; + +function TSSLOpenSSL.GetPeerFingerprint: ansistring; +var + cert: PX509; + x: integer; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(Result, EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('SHA1'), Result, x); //was MD5 before + SetLength(Result, x); + X509Free(cert); +end; + +function TSSLOpenSSL.GetCertInfo: string; +var + cert: PX509; + x, y: integer; + b: PBIO; + s: AnsiString; +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); + setlength(s,x); + y := bioread(b,s,x); + if y > 0 then + setlength(s, y); + 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 -Nru cqrprop-0.0.7/src/synapse/ssl_openssl3_lib.pas cqrprop-0.0.8/src/synapse/ssl_openssl3_lib.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl3_lib.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl3_lib.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1522 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: SSL support by OpenSSL 3.0 | +|==============================================================================| +| Copyright (c)1999-2022, 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-2022. | +| Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| 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_openssl3_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 3.0 is loaded dynamicly on-demand. If this library is not found in system, +requested OpenSSL function just return errorcode. +} +unit ssl_openssl3_lib; + +interface + +uses + Classes, + synafpc, +{$IFNDEF MSWINDOWS} + {$IFDEF FPC} + {$IFDEF UNIX} + BaseUnix, + {$ENDIF UNIX} + {$ELSE} + {$IFDEF POSIX} + {$ELSE} + Libc, + {$ENDIF} + + {$ENDIF} + SysUtils; +{$ELSE} + Windows; +{$ENDIF} + + +var + {$IFNDEF MSWINDOWS} + {$IFDEF DARWIN} + DLLSSLName: string = 'libssl.3.dylib'; + DLLUtilName: string = 'libcrypto.3.dylib'; + {$ELSE} + {$IFDEF OS2} + {$IFDEF OS2GCC} + DLLSSLName: string = 'kssl.dll'; + DLLUtilName: string = 'kcrypto.dll'; + {$ELSE OS2GCC} + DLLSSLName: string = 'ssl.dll'; + DLLUtilName: string = 'crypto.dll'; + {$ENDIF OS2GCC} + {$ELSE OS2} //linux + DLLSSLName: string = 'libssl.so.3'; + DLLUtilName: string = 'libcrypto.so.3'; + {$ENDIF OS2} + {$ENDIF} + {$ELSE} + {$IFDEF WIN64} + DLLSSLName: string = 'libssl-3-x64.dll'; + DLLUtilName: string = 'libcrypto-3-x64.dll'; + {$ELSE} + DLLSSLName: string = 'libssl-3.dll'; + DLLUtilName: string = 'libcrypto-3.dll'; + {$ENDIF} + {$ENDIF} + +type + SslPtr = Pointer; + PSslPtr = ^SslPtr; + PSSL_CTX = SslPtr; + PSSL = SslPtr; + PSSL_METHOD = SslPtr; + PX509 = SslPtr; + PX509_NAME = SslPtr; + PX509_STORE = Pointer; + 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; + SSL_CTRL_SET_MIN_PROTO_VERSION = 123; + SSL_CTRL_SET_MAX_PROTO_VERSION = 124; + + TLSEXT_NAMETYPE_host_name = 0; + + TLS1_VERSION = $0301; + TLS1_1_VERSION = $0302; + TLS1_2_VERSION = $0303; + TLS1_3_VERSION = $0304; +var + SSLLibHandle: TLibHandle = 0; + SSLUtilHandle: TLibHandle = 0; + SSLLibFile: string = ''; + SSLUtilFile: string = ''; + +// libssl.dll + function SslGetError(s: PSSL; ret_code: Integer):Integer; +// 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 SslMethodTLS: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; +// function ErrErrorString(e: integer; buf: PChar): PChar; + function OpenSSLversion(t: integer): Ansistring; + procedure ErrErrorString(e: integer; var buf: Ansistring; len: integer); + function ErrGetError: integer; + procedure ErrClearError; + 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 OPENSSL_sk_num(Stack: PSTACK): Integer; + function OPENSSL_sk_value(Stack: PSTACK; Item: Integer): PAnsiChar; + function X509_STORE_add_cert(Store: PX509_STORE; Cert: PX509): Integer; + function SSL_CTX_get_cert_store(const Ctx: PSSL_CTX): PX509_STORE; + + 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); + +function IsSSLloaded: Boolean; +function InitSSLInterface: Boolean; +function DestroySSLInterface: Boolean; + +var + _X509Free: TX509Free = nil; {pf} + +implementation + +uses +{$IFDEF OS2} + Sockets, +{$ENDIF OS2} + SyncObjs; + +type +// libssl.dll + TSslGetError = function(s: PSSL; ret_code: Integer):Integer; 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; + TSslMethodTLS = 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 + + TOPENSSL_sk_new_null = function: PSTACK; cdecl; + TOPENSSL_sk_num = function(Stack: PSTACK): Integer; cdecl; + TOPENSSL_sk_value = function(Stack: PSTACK; Item: Integer): PAnsiChar; cdecl; + TOPENSSL_sk_free = procedure(Stack: PSTACK); cdecl; + TOPENSSL_sk_insert = function(Stack: PSTACK; Data: PAnsiChar; Index: Integer): Integer; cdecl; + TX509_dup = function(X: PX509): PX509; cdecl; + TSSL_CTX_get_cert_store = function(const Ctx: PSSL_CTX): PX509_STORE;cdecl; + TX509_STORE_add_cert = function(Store: PX509_STORE; Cert: PX509): Integer; cdecl; + + 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; + TOpenSSLversion = function(t: integer): PAnsiChar; cdecl; + TErrErrorString = procedure(e: integer; buf: PAnsiChar; len: integer); cdecl; + TErrGetError = function: integer; cdecl; + TErrClearError = 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; + +var +// libssl.dll + _SslGetError: TSslGetError = nil; + _SslCtxSetCipherList: TSslCtxSetCipherList = nil; + _SslCtxNew: TSslCtxNew = nil; + _SslCtxFree: TSslCtxFree = nil; + _SslSetFd: TSslSetFd = nil; + _SslMethodTLS: TSslMethodTLS = 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 + + _OPENSSL_sk_new_null: TOPENSSL_sk_new_null = nil; + _OPENSSL_sk_num: TOPENSSL_sk_num = nil; + _OPENSSL_sk_value: TOPENSSL_sk_value = nil; + _OPENSSL_sk_free: TOPENSSL_sk_free = nil; + _OPENSSL_sk_insert: TOPENSSL_sk_insert = nil; + _SSL_CTX_get_cert_store : TSSL_CTX_get_cert_store = nil; + _X509_STORE_add_cert : TX509_STORE_add_cert = nil; + + _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; + _OpenSSLversion: TOpenSSLversion = nil; + _ErrErrorString: TErrErrorString = nil; + _ErrGetError: TErrGetError = nil; + _ErrClearError: TErrClearError = 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; + +var + SSLCS: TCriticalSection; + SSLloaded: boolean = false; + +// 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 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 SslMethodTLS:PSSL_METHOD; +begin + if InitSSLInterface and Assigned(_SslMethodTLS) then + Result := _SslMethodTLS + 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 + Result := _SSLGetCurrentCipher(s) + 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 OpenSSLversion(t: integer): Ansistring; +begin + if InitSSLInterface and Assigned(_OpenSSLversion) then + Result := PAnsiChar(_OpenSSLversion(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; + +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(b, x) + 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; + +function OPENSSL_sk_num(Stack: PSTACK): Integer; +begin + if InitSSLInterface and Assigned(_OPENSSL_sk_num) then + Result := _OPENSSL_sk_num(Stack); +end; + +function SSL_CTX_get_cert_store(const Ctx: PSSL_CTX): PX509_STORE; +begin + if InitSSLInterface and Assigned(_SSL_CTX_get_cert_store) then + Result := _SSL_CTX_get_cert_store(Ctx); +end; + +function OPENSSL_sk_value(Stack: PSTACK; Item: Integer): PAnsiChar; +begin + if InitSSLInterface and Assigned(_OPENSSL_sk_value) then + Result := _OPENSSL_sk_value(Stack, Item); +end; + +function X509_STORE_add_cert(Store: PX509_STORE; Cert: PX509): Integer; +begin + if InitSSLInterface and Assigned(_X509_STORE_add_cert) then + Result := _X509_STORE_add_cert(Store, Cert); +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; + +function LoadLib(const Value: String): HModule; +begin + Result := LoadLibrary(PChar(Value)); +end; + +function GetProcAddr(module: HModule; const ProcName: string): SslPtr; +begin + Result := GetProcAddress(module, PChar(ProcName)); +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 + SSLUtilHandle := LoadLib(DLLUtilName); + SSLLibHandle := LoadLib(DLLSSLName); + if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then + begin + _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error'); + _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'); + _SslMethodTLS := GetProcAddr(SSLLibHandle, 'TLS_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_get1_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'); + + _OPENSSL_sk_new_null:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_new_null'); + _OPENSSL_sk_num:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_num'); + _OPENSSL_sk_value:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_value'); + _OPENSSL_sk_free:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_free'); + _OPENSSL_sk_insert:= GetProcAddr(SSLUtilHandle, 'OPENSSL_sk_insert'); + _SSL_CTX_get_cert_store:= GetProcAddr(SSLLibHandle, 'SSL_CTX_get_cert_store'); + _X509_STORE_add_cert := GetProcAddr(SSLUtilHandle, 'X509_STORE_add_cert'); + + _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_set1_notBefore'); + _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set1_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'); + _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname'); + _OpenSSLversion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version'); + _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n'); + _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error'); + _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error'); + _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'); + // + 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; + SSLloaded := True; +{$IFDEF OS2} + Result := InitEMXHandles; +{$ELSE OS2} + Result := True; +{$ENDIF OS2} + end + else + begin + //load failed! + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + Result := False; + end; + end + else + //loaded before... + Result := true; + finally + SSLCS.Leave; + end; +end; + +function DestroySSLInterface: Boolean; +begin + SSLCS.Enter; + try + SSLloaded := false; + if SSLLibHandle <> 0 then + begin + FreeLibrary(SSLLibHandle); + SSLLibHandle := 0; + end; + if SSLUtilHandle <> 0 then + begin + FreeLibrary(SSLUtilHandle); + SSLLibHandle := 0; + end; + + _SslGetError := nil; + _SslCtxSetCipherList := nil; + _SslCtxNew := nil; + _SslCtxFree := nil; + _SslSetFd := nil; + _SslMethodTLS := 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; + _EvpGetDigestByName := nil; + _OpenSSLversion := nil; + _ErrErrorString := nil; + _ErrGetError := nil; + _ErrClearError := 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; + finally + SSLCS.Leave; + end; + Result := True; +end; + +function IsSSLloaded: Boolean; +begin + Result := SSLLoaded; +end; + +initialization +begin + SSLCS:= TCriticalSection.Create; +end; + +finalization +begin + DestroySSLInterface; + SSLCS.Free; +end; + +end. diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl3.pas cqrprop-0.0.8/src/synapse/ssl_openssl3.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl3.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl3.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,846 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: SSL support by OpenSSL | +|==============================================================================| +| Copyright (c)1999-2022, 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-2022. | +| 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) + +Compatibility with OpenSSL versions: +3.0.0+ + +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 does not have support for .NET! + +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! +} + +{$INCLUDE 'jedi.inc'} + +{$H+} + +{$IFDEF UNICODE} + {$WARN IMPLICIT_STRING_CAST OFF} + {$WARN IMPLICIT_STRING_CAST_LOSS OFF} +{$ENDIF} + +unit ssl_openssl3; + +interface + +uses + SysUtils, Classes, + {$IFDEF DELPHI23_UP} AnsiStrings, {$ENDIF} + blcksock, synsock, synautil, + ssl_openssl3_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!} + TSSLOpenSSL3 = 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: AnsiString; 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 + +{==============================================================================} + +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); + {$IFDEF DELPHI23_UP}AnsiStrings.{$ENDIF}StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); +end; + +{==============================================================================} + +constructor TSSLOpenSSL3.Create(const Value: TTCPBlockSocket); +begin + inherited Create(Value); + FCiphers := 'DEFAULT'; + FSsl := nil; + Fctx := nil; +end; + +destructor TSSLOpenSSL3.Destroy; +begin + DeInit; + inherited Destroy; +end; + +function TSSLOpenSSL3.LibVersion: String; +begin + Result := OpenSSLversion(0); +end; + +function TSSLOpenSSL3.LibName: String; +begin + Result := 'ssl_openssl3'; +end; + +function TSSLOpenSSL3.SSLCheck: Boolean; +var + s : AnsiString; +begin + Result := true; + FLastErrorDesc := ''; + FLastError := ErrGetError; + ErrClearError; + if FLastError <> 0 then + begin + Result := False; + s := StringOfChar(#0, 256); + ErrErrorString(FLastError, s, Length(s)); + FLastErrorDesc := s; + end; +end; + +function TSSLOpenSSL3.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; +begin + Result := True; + pk := EvpPkeynew; + x := X509New; + try + rsa := RsaGenerateKey(2048, $10001, nil, nil); + EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); + X509SetVersion(x, 2); //it is version 3! +// Asn1IntegerSet(X509getSerialNumber(x), 0); + Asn1IntegerSet(X509getSerialNumber(x), GetTick); + 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('SHA256')); + b := BioNew(BioSMem); + try + i2dX509Bio(b, x); + xn := bioctrlpending(b); + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); + finally + BioFreeAll(b); + end; + FCertificate := s; + b := BioNew(BioSMem); + try + i2dPrivatekeyBio(b, pk); + xn := bioctrlpending(b); + setlength(s, xn); + y := bioread(b, s, xn); + if y > 0 then + setlength(s, y); + finally + BioFreeAll(b); + end; + FPrivatekey := s; + finally + X509free(x); + EvpPkeyFree(pk); + end; +end; + +function TSSLOpenSSL3.LoadPFX(pfxdata: Ansistring): Boolean; +var + cert, pkey, ca: SslPtr; + certx: PAnsiChar; + b: PBIO; + p12: SslPtr; + i: Integer; + Store: PX509_STORE; + iTotal: Integer; +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} + + if Result and (ca <> nil) then + begin + iTotal := OPENSSL_sk_num(ca); + if iTotal > 0 then + begin + Store := SSL_CTX_get_cert_store(Fctx); + for I := 0 to iTotal - 1 do + begin + certx := OPENSSL_sk_value(ca, I); + if certx <> nil then + begin + if X509_STORE_add_cert(Store, certx) = 0 then + begin + // already exists + end; + //X509_free(Cert); + end; + end; + end; + end; + 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 TSSLOpenSSL3.SetSslKeys: boolean; +var + st: TFileStream; + s: ansistring; +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 TSSLOpenSSL3.Init(server:Boolean): Boolean; +var + s: AnsiString; +begin + Result := False; + FLastErrorDesc := ''; + FLastError := 0; + Fctx := SslCtxNew(SslMethodTLS); // best common protocol + if Fctx = nil then + begin + SSLCheck; + Exit; + end + else + begin + //limit support to specific protocol only + case FSSLType of + LT_TLSv1: + begin + SslCtxCtrl(Fctx, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_VERSION, nil); + SslCtxCtrl(Fctx, SSL_CTRL_SET_MAX_PROTO_VERSION, TLS1_VERSION, nil); + end; + LT_TLSv1_1: + begin + SslCtxCtrl(Fctx, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_1_VERSION, nil); + SslCtxCtrl(Fctx, SSL_CTRL_SET_MAX_PROTO_VERSION, TLS1_1_VERSION, nil); + end; + LT_TLSv1_2: + begin + SslCtxCtrl(Fctx, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_2_VERSION, nil); + SslCtxCtrl(Fctx, SSL_CTRL_SET_MAX_PROTO_VERSION, TLS1_2_VERSION, nil); + end; + LT_TLSv1_3: + begin + SslCtxCtrl(Fctx, SSL_CTRL_SET_MIN_PROTO_VERSION, TLS1_3_VERSION, nil); + SslCtxCtrl(Fctx, SSL_CTRL_SET_MAX_PROTO_VERSION, TLS1_3_VERSION, nil); + end; + end; + s := FCiphers; + SslCtxSetCipherList(Fctx, s); + if FVerifyCert then + SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil) + else + SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil); + SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback); + SslCtxSetDefaultPasswdCbUserdata(FCtx, self); + + 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 TSSLOpenSSL3.DeInit: Boolean; +begin + Result := True; + if assigned (Fssl) then + sslfree(Fssl); + Fssl := nil; + if assigned (Fctx) then + begin + SslCtxFree(Fctx); + Fctx := nil; + end; + FSSLEnabled := False; +end; + +function TSSLOpenSSL3.Prepare(server:Boolean): Boolean; +begin + Result := false; + DeInit; + if Init(server) then + Result := true + else + DeInit; +end; + +function TSSLOpenSSL3.Connect: boolean; +var + x: integer; + b: boolean; + err: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(False) then + begin + if sslsetfd(FSsl, FSocket.Socket) < 1 then + begin + SSLCheck; + Exit; + end; + if SNIHost<>'' then + SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(AnsiString(SNIHost))); + if FSocket.ConnectionTimeout <= 0 then //do blocking call of SSL_Connect + begin + x := sslconnect(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + end + else //do non-blocking call of SSL_Connect + begin + b := Fsocket.NonBlockMode; + Fsocket.NonBlockMode := true; + repeat + x := sslconnect(FSsl); + err := SslGetError(FSsl, x); + if err = SSL_ERROR_WANT_READ then + if not FSocket.CanRead(FSocket.ConnectionTimeout) then + break; + if err = SSL_ERROR_WANT_WRITE then + if not FSocket.CanWrite(FSocket.ConnectionTimeout) then + break; + until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE); + Fsocket.NonBlockMode := b; + if err <> SSL_ERROR_NONE then + begin + SSLcheck; + Exit; + end; + end; + if FverifyCert then + if (GetVerifyCert <> 0) or (not DoVerifyCert) then + Exit; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL3.Accept: boolean; +var + x: integer; +begin + Result := False; + if FSocket.Socket = INVALID_SOCKET then + Exit; + if Prepare(True) then + begin + if sslsetfd(FSsl, FSocket.Socket) < 1 then + begin + SSLCheck; + Exit; + end; + x := sslAccept(FSsl); + if x < 1 then + begin + SSLcheck; + Exit; + end; + FSSLEnabled := True; + Result := True; + end; +end; + +function TSSLOpenSSL3.Shutdown: boolean; +begin + if assigned(FSsl) then + sslshutdown(FSsl); + DeInit; + Result := True; +end; + +function TSSLOpenSSL3.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 TSSLOpenSSL3.SendBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat + Result := SslWrite(FSsl, Buffer , Len); + 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 TSSLOpenSSL3.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; +var + err: integer; +begin + FLastError := 0; + FLastErrorDesc := ''; + repeat + Result := SslRead(FSsl, Buffer , Len); + 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 TSSLOpenSSL3.WaitingData: Integer; +begin + Result := sslpending(Fssl); +end; + +function TSSLOpenSSL3.GetSSLVersion: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SSlGetVersion(FSsl); +end; + +function TSSLOpenSSL3.GetPeerSubject: string; +var + cert: PX509; + s: ansistring; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(s, 4096); + Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s)); + X509Free(cert); +end; + + +function TSSLOpenSSL3.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 TSSLOpenSSL3.GetPeerName: string; +var + s: ansistring; +begin + s := GetPeerSubject; + s := SeparateRight(s, '/CN='); + Result := Trim(SeparateLeft(s, '/')); +end; + +function TSSLOpenSSL3.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 TSSLOpenSSL3.GetPeerIssuer: string; +var + cert: PX509; + s: ansistring; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(s, 4096); + Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s)); + X509Free(cert); +end; + +function TSSLOpenSSL3.GetPeerFingerprint: AnsiString; +var + cert: PX509; + x: integer; +begin + if not assigned(FSsl) then + begin + Result := ''; + Exit; + end; + cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; + setlength(Result, EVP_MAX_MD_SIZE); + X509Digest(cert, EvpGetDigestByName('SHA1'), Result, x); //was MD5 before + SetLength(Result, x); + X509Free(cert); +end; + +function TSSLOpenSSL3.GetCertInfo: string; +var + cert: PX509; + x, y: integer; + b: PBIO; + s: AnsiString; +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); + setlength(s,x); + y := bioread(b,s,x); + if y > 0 then + setlength(s, y); + Result := ReplaceString(s, LF, CRLF); + finally + BioFreeAll(b); + end; + {pf} + finally + X509Free(cert); + end; + {/pf} +end; + +function TSSLOpenSSL3.GetCipherName: string; +begin + if not assigned(FSsl) then + Result := '' + else + Result := SslCipherGetName(SslGetCurrentCipher(FSsl)); +end; + +function TSSLOpenSSL3.GetCipherBits: integer; +var + x: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x); +end; + +function TSSLOpenSSL3.GetCipherAlgBits: integer; +begin + if not assigned(FSsl) then + Result := 0 + else + SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result); +end; + +function TSSLOpenSSL3.GetVerifyCert: integer; +begin + if not assigned(FSsl) then + Result := 1 + else + Result := SslGetVerifyResult(FSsl); +end; + +{==============================================================================} + +initialization + if InitSSLInterface then + SSLImplementation := TSSLOpenSSL3; + +end. diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl_capi.pas cqrprop-0.0.8/src/synapse/ssl_openssl_capi.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl_capi.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl_capi.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,903 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.003.000 | +|==============================================================================| +| Content: SSL support by OpenSSL and the CAPI engine | +|==============================================================================| +| Copyright (c)2018, Pepak | +| 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 Pepak (Czech Republic). | +| Portions created by Pepak are Copyright (c)2018. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +//requires OpenSSL libraries, including the CAPI engine (capi.dll)! +//recommended source: Stunnel (https://www.stunnel.org) + +{:@abstract(SSL plugin for OpenSSL and the CAPI engine) + +Compatibility with OpenSSL versions: + +1.0.2 works fine. + +1.1.x does not work properly out of the box. I was never able to get CAPI +to work with pre-built binaries or binaries that I built myself, even in +third party applications such as STunnel. The only config which works for +me involves custom-building OpenSSL with engines statically compiled into +libcrypto: + + 1) Install PERL (e.g. C:\PERL). Make sure the BIN subdirectory is in + the PATH (SET PATH=%PATH%;C:\PERL\BIN). + + 2) Download DMAKE ( https://metacpan.org/release/dmake ) and unpack it + into the Perl directory (you will get C:\PERL\DMAKE\DMAKE.EXE and + other files). Add the DMAKE directory to PATH as well. + + 3) Start Visual Studio Development Prompt, either 32 or 64bit. All the + following commands should be run in this prompt. + + 4) Install the Text::Template module by running: + cpan -i Text::Template + + 5) Download and unpack the OpenSSL sources into e.g. C:\SOURCE\OPENSSL. + + 6) Download and unpack the Zlib sources into e.g. C:\SOURCE\ZLIB. + + 7) Go to the ZLIB directory and run: + nmake -f win32/Makefile.msc + + 8) Go to the OpenSSL directory and run: + 32bit: + perl Configure shared enable-static-engine enable-zlib --with-zlib-include=C:\SOURCE\ZLIB --with-zlib-lib=C:\SOURCE\ZLIB\zlib.lib VC-WIN32 + 64bit: + perl Configure shared enable-static-engine enable-zlib --with-zlib-include=C:\SOURCE\ZLIB --with-zlib-lib=C:\SOURCE\ZLIB\zlib.lib VC-WIN64A + Make sure to replace both instances of C:\SOURCE\ZLIB with the actual + path to the Zlib library. + + 9) If you want to build the OpenSSL DLLs without external dependencies + (e.g. on the Visual Studio Runtime), edit the generated makefile: + + - Change the "/MD" flag in CNF_FLAGS to "/MT". + - Add "/NODEFAULTLIB:MSVCRT" to CNF_LDFLAGS. + + 10) In the OpenSSL directory, run: + nmake + + 11) When all is done, copy LIBCRYPTO-1_1*.DLL and LIBSSH-1_1*.DLL to + your application's binary directory. + + +OpenSSL libraries are loaded dynamically - you do not need the librares even if +you compile your application with this unit. SSL just won't work if you don't +have the OpenSSL libraries. + +The plugin is built on the standard OpenSSL plugin, giving it all the features +of it. In fact, if you do not have the CAPI engine, the plugin will behave in +exactly the same way as the original plugin - the CAPI engine is completely +optional, the plugin will work without it - obviously without the support for +Windows Certificate Stores. + +The windows certificate stores are supported through the following properties: + +@link(TSSLOpenSSLCapi.SigningCertificate) - expects pointer to the certificate +context of the signing certificate (PCCERT_CONTENT). @br + +Note that due to the limitations of OpenSSL, it is not possible to switch +between different engines (e.g. CAPI and default) on the fly - the engine is +a global setting for the whole of OpenSSL. For that reason, once the engine +is enabled (either explicitly or by using a Windows certificate for a connection), +it will stay enabled and there is no method for disabling it. + +} + +{$INCLUDE 'jedi.inc'} +{$H+} + +{$DEFINE USE_ENGINE_POOL} + +unit ssl_openssl_capi; + +interface + +uses + Windows, Crypt32, SysUtils, Classes, SyncObjs, + blcksock, ssl_openssl, ssl_openssl_lib; + +type + PENGINE = Pointer; + +type + TWindowsCertStoreLocation = ( + wcslCurrentUser + , wcslCurrentUserGroupPolicy + , wcslUsers + , wcslCurrentService + , wcslServices + , wcslLocalMachine + , wcslLocalMachineGroupPolicy + , wcslLocalMachineEnterprise + ); + +type + {:@abstract(class extending the OpenSSL SSL plugin with CAPI support.) + 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!} + TSSLOpenSSLCapi = class(TSSLOpenSSL) + private + FEngine: PENGINE; + FEngineInitialized: boolean; + FSigningCertificateLocation: TWindowsCertStoreLocation; + FSigningCertificateStore: string; + FSigningCertificateID: string; + function GetEngine: PENGINE; + protected + {:Loads a certificate context into the CAPI engine for signing/decryption.} + function LoadSigningCertificate: boolean; + {:See @inherited} + function SetSslKeys: boolean; override; + {:See @inherited} + function NeedSigningCertificate: boolean; override; + {:Returns true if the signing certificate should be used.} + function SigningCertificateSpecified: boolean; + {:Provides a cryptographic engine for OpenSSL} + property Engine: PENGINE read GetEngine; + public + {:See @inherited} + constructor Create(const Value: TTCPBlockSocket); override; + {:See @inherited} + destructor Destroy; override; + {:See @inherited} + procedure Assign(const Value: TCustomSSL); override; + {:Use this function to load the CAPI engine and/or verify that the engine + is available. The plugin will load CAPI itself when it is needed, so you + may skip this function completely, but it may be useful to perform a manual + CAPI load early during the application startup to make sure all connection + use the same cryptographic engine (and, as a result, behave the same way).} + class function InitEngine: boolean; + {:Location of the certificate store used for the communication.} + property SigningCertificateLocation: TWindowsCertStoreLocation read FSigningCertificateLocation write FSigningCertificateLocation; + {:Certificate store used for the communication. The most common is "MY", + or the user's private certificates.} + property SigningCertificateStore: string read FSigningCertificateStore write FSigningCertificateStore; + {:ID of the certificate to use. For standard CAPI, this is the friendly name + of the certificate. For the client-side SSL it is not really necessary, as + long as it is non-empty (which signifies that the CAPI engine should be + used). For the server side, it must be a substring of the SubjectName of + the certificate. The first matching certificate will be used.} + property SigningCertificateID: string read FSigningCertificateID write FSigningCertificateID; + end; + +implementation + +{$IFDEF SUPPORTS_REGION}{$REGION 'Support and compatibility functions'}{$ENDIF} +{==============================================================================} +{Support and compatibility functions } +{------------------------------------------------------------------------------} + +function GetModuleFileNamePAS(Handle: THandle; out FileName: string): boolean; +var + FN: string; + n: integer; +begin + Result := False; + if Handle = 0 then + Exit; + SetLength(FN, MAX_PATH); + n := GetModuleFileName(Handle, @FN[1], Length(FN)); + if (n > 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then + begin + SetLength(FN, n); + n := GetModuleFileName(Handle, @FN[1], Length(FN)); + end; + if (n > 0) and (GetLastError = ERROR_SUCCESS) then + begin + SetLength(FN, n); + FileName := FN; + Result := True; + end; +end; + +{$IFNDEF UNICODE} +type + PPointer = ^Pointer; + +procedure RaiseLastOSError; +begin + RaiseLastWin32Error; +end; +{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$REGION 'Imported functions'}{$ENDIF} +{==============================================================================} +{Imported functions } +{------------------------------------------------------------------------------} + +const + CapiEngineID = 'capi'; + DLLCapiName = CapiEngineID + '.dll'; + +const + SSL_CTRL_OPTIONS = 32; + SSL_OP_NO_TLSv1_2 = $08000000; + +const + ENGINE_METHOD_ALL = $ffff; + +type + PPX509 = ^PX509; + +var + FEngineCS: TCriticalSection = nil; + FEngineNeedsSHA2Workaround: boolean = False; + +var + FEngineInterfaceInitialized: boolean = False; + FENGINE_cleanup: procedure; cdecl = nil; + FENGINE_load_builtin_engines: procedure; cdecl = nil; + FENGINE_by_id: function(id: PAnsiChar): PENGINE; cdecl = nil; + FENGINE_ctrl_cmd_string: function(e: PENGINE; cmd_name, arg: PAnsiChar; cmd_optional: integer): integer; cdecl = nil; + FENGINE_init: function(e: PENGINE): integer; cdecl = nil; + FENGINE_finish: function(e: PENGINE): integer; cdecl = nil; + FENGINE_free: function(e: PENGINE): integer; cdecl = nil; + FENGINE_set_default: function(e: PENGINE; flags: DWORD): integer; cdecl = nil; + FENGINE_load_private_key: function(e: PENGINE; key_id: PAnsiChar; ui_method: Pointer; callback_data: Pointer): EVP_PKEY; cdecl = nil; + FSSL_CTX_set_client_cert_engine: function(ctx: PSSL_CTX; e: PENGINE): integer; cdecl = nil; + Fd2i_X509: function(px: PPX509; data: PPointer; len: integer): PX509; cdecl = nil; + +function InitEngineInterface: boolean; +var + OpenSSLFileName: string; + VerInfoSize: DWORD; + VerInfo: Pointer; + VerHandle: DWORD; + SpecVerInfo: PVsFixedFileInfo; +begin + if FEngineInterfaceInitialized then + begin + Result := True; + Exit; + end; + FEngineCS.Enter; + try + if FEngineInterfaceInitialized then + begin + Result := True; + Exit; + end; + Result := False; + if not InitSSLInterface then + Exit; + if SSLUtilHandle = 0 then + Exit; + if SSLLibHandle = 0 then + Exit; + FENGINE_cleanup := GetProcAddress(SSLUtilHandle, 'ENGINE_cleanup'); + FENGINE_load_builtin_engines := GetProcAddress(SSLUtilHandle, 'ENGINE_load_builtin_engines'); + FENGINE_by_id := GetProcAddress(SSLUtilHandle, 'ENGINE_by_id'); + FENGINE_ctrl_cmd_string := GetProcAddress(SSLUtilHandle, 'ENGINE_ctrl_cmd_string'); + FENGINE_init := GetProcAddress(SSLUtilHandle, 'ENGINE_init'); + FENGINE_finish := GetProcAddress(SSLUtilHandle, 'ENGINE_finish'); + FENGINE_free := GetProcAddress(SSLUtilHandle, 'ENGINE_free'); + FENGINE_set_default := GetProcAddress(SSLUtilHandle, 'ENGINE_set_default'); + FENGINE_load_private_key := GetProcAddress(SSLUtilHandle, 'ENGINE_load_private_key'); + FSSL_CTX_set_client_cert_engine := GetProcAddress(SSLLibHandle, 'SSL_CTX_set_client_cert_engine'); + Fd2i_X509 := GetProcAddress(SSLUtilHandle, 'd2i_X509'); + FEngineInterfaceInitialized := True; + //---- Workaround for a CAPI engine bug ------------------------------------ + // https://www.stunnel.org/pipermail/stunnel-users/2017-February/005720.html + // + // The capi ENGINE in OpenSSL 1.0.2 and earlier uses the CSP attached + // to the key for cryptographic operations. Unfortunately this means that + // SHA2 algorithms are not supported for client authentication. + // + // OpenSSL 1.1.0 adds a workaround for this issue. If you disable TLS 1.2 + // in earlier versions of OpenSSL it will not use SHA2 for client auth so + // that will also work. + begin + FEngineNeedsSHA2Workaround := False; + if GetModuleFileNamePAS(SSLUtilHandle, OpenSSLFileName) then + begin + VerInfoSize := GetFileVersionInfoSize(PChar(OpenSSLFileName), VerHandle); + if VerInfoSize > 0 then + begin + GetMem(VerInfo, VerInfoSize); + try + if GetFileVersionInfo(PChar(OpenSSLFileName), VerHandle, VerInfoSize, VerInfo) then + if VerQueryValue(VerInfo, '\', Pointer(SpecVerInfo), VerInfoSize) then + begin + if SpecVerInfo^.dwFileVersionMS < (65536*1 + 1) then + FEngineNeedsSHA2Workaround := True; + end; + finally + FreeMem(VerInfo); + end; + end; + end; + end; + //---- Workaround end ------------------------------------------------------ + Result := True; + finally + FEngineCS.Leave; + end; +end; + +procedure DestroyEngineInterface; +begin + FEngineCS.Enter; + try + if Assigned(FENGINE_cleanup) then + FENGINE_cleanup; + FENGINE_cleanup := nil; + FENGINE_load_builtin_engines := nil; + FENGINE_by_id := nil; + FENGINE_ctrl_cmd_string := nil; + FENGINE_init := nil; + FENGINE_finish := nil; + FENGINE_free := nil; + FENGINE_set_default := nil; + FENGINE_load_private_key := nil; + FSSL_CTX_set_client_cert_engine := nil; + Fd2i_X509 := nil; + FEngineInterfaceInitialized := False; + finally + FEngineCS.Leave; + end; +end; + +procedure ENGINE_load_builtin_engines; +begin + if InitEngineInterface and Assigned(FENGINE_load_builtin_engines) then + FENGINE_load_builtin_engines; +end; + +function ENGINE_by_id(id: PAnsiChar): PENGINE; +begin + if InitEngineInterface and Assigned(FENGINE_by_id) then + Result := FENGINE_by_id(id) + else + Result := nil; +end; + +function ENGINE_ctrl_cmd_string(e: PENGINE; cmd_name, arg: PAnsiChar; cmd_optional: integer): integer; +begin + if InitEngineInterface and Assigned(FENGINE_ctrl_cmd_string) then + Result := FENGINE_ctrl_cmd_string(e, cmd_name, arg, cmd_optional) + else + Result := 0; +end; + +function ENGINE_init(e: PENGINE): integer; +begin + if InitEngineInterface and Assigned(FENGINE_init) then + Result := FENGINE_init(e) + else + Result := 0; +end; + +function ENGINE_finish(e: PENGINE): integer; +begin + if InitEngineInterface and Assigned(FENGINE_finish) then + Result := FENGINE_finish(e) + else + Result := 0; +end; + +function ENGINE_free(e: PENGINE): integer; +begin + if InitEngineInterface and Assigned(FENGINE_free) then + Result := FENGINE_free(e) + else + Result := 0; +end; + +function ENGINE_set_default(e: PENGINE; flags: DWORD): integer; +begin + if InitEngineInterface and Assigned(FENGINE_set_default) then + Result := FENGINE_set_default(e, flags) + else + Result := 0; +end; + +function ENGINE_load_private_key(e: PENGINE; key_id: PAnsiChar; ui_method: Pointer; callback_data: Pointer): EVP_PKEY; +begin + if InitEngineInterface and Assigned(FENGINE_load_private_key) then + Result := FENGINE_load_private_key(e, key_id, ui_method, callback_data) + else + Result := nil; +end; + +function SSL_CTX_set_client_cert_engine(ctx: PSSL_CTX; e: PENGINE): integer; +begin + if InitEngineInterface and Assigned(FSSL_CTX_set_client_cert_engine) then + Result := FSSL_CTX_set_client_cert_engine(ctx, e) + else + Result := 0; +end; + +function d2i_X509(px: PPX509; data: PPointer; len: integer): PX509; +begin + if InitEngineInterface and Assigned(Fd2i_X509) then + Result := Fd2i_X509(px, data, len) + else + Result := nil; +end; + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$REGION 'CAPI engine support'}{$ENDIF} +{==============================================================================} +{CAPI engine support } +{------------------------------------------------------------------------------} + +var + FGlobalEngineInitialized: boolean = False; + FGlobalEngine: PENGINE = nil; + +function PrepareCapiEngine(out Engine: PENGINE): boolean; + + function LoadCapiEngine(Engine: PENGINE; const FileName: string): boolean; + begin + Result := False; + if ENGINE_ctrl_cmd_string(Engine, 'SO_PATH', PAnsiChar(AnsiString(FileName)), 0) <> 0 then + if ENGINE_ctrl_cmd_string(Engine, 'LOAD', nil, 0) <> 0 then + Result := True; + end; + + function LoadCapiEngineDynamic(out Engine: PENGINE): boolean; + var + OpenSSLFileName: string; + TempEngine: PENGINE; + begin + Result := False; + if not GetModuleFileNamePAS(SSLUtilHandle, OpenSSLFileName) then + Exit; + TempEngine := ENGINE_by_id('dynamic'); + try + if TempEngine <> nil then + begin + if LoadCapiEngine(TempEngine, ExtractFilePath(OpenSSLFileName) + DLLCapiName) then // need a version match! Same dir suggests the versions could be the same + if ENGINE_init(TempEngine) <> 0 then + begin + Engine := TempEngine; + TempEngine := nil; + Result := True; + end; + end; + finally + if TempEngine <> nil then + begin + ENGINE_free(TempEngine); + //TempEngine := nil; // triggers a hint + end; + end; + end; + + function LoadCapiEngineStatic(out Engine: PENGINE): boolean; + var + TempEngine: PENGINE; + begin + Result := False; + TempEngine := ENGINE_by_id(CapiEngineID); + try + if TempEngine <> nil then + begin + if ENGINE_init(TempEngine) <> 0 then + begin + Engine := TempEngine; + TempEngine := nil; + Result := True; + end; + end; + finally + if TempEngine <> nil then + begin + ENGINE_free(TempEngine); + //TempEngine := nil; // triggers a hint + end; + end; + end; + +begin + Result := LoadCapiEngineStatic(Engine) or LoadCapiEngineDynamic(Engine); +end; + +function InitCapiEngine: boolean; +var + E: PENGINE; +begin + Result := FGlobalEngine <> nil; + if FGlobalEngineInitialized then + Exit; + FEngineCS.Enter; + try + if FGlobalEngineInitialized then + Exit; + ENGINE_load_builtin_engines(); + if PrepareCapiEngine(E) then + begin + if not Assigned(FSSL_CTX_set_client_cert_engine) then + begin + if ENGINE_set_default(E, ENGINE_METHOD_ALL) = 0 then + begin + ENGINE_finish(E); + ENGINE_free(E); + E := nil; + end; + end; + FGlobalEngine := E; + end; + FGlobalEngineInitialized := True; + Result := FGlobalEngine <> nil; + finally + FEngineCS.Leave; + end; +end; + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$REGION 'Pool of engines'}{$ENDIF} +{==============================================================================} +{Pool of engines, to reduce the time to get a working connection } +{------------------------------------------------------------------------------} + +{$IFDEF USE_ENGINE_POOL} + +type + TEnginePool = class + private + fLock: TCriticalSection; + fAvailableList: TList; + protected + procedure Lock; + procedure Unlock; + public + constructor Create; + destructor Destroy; override; + function Acquire(out Engine: PENGINE): boolean; + procedure Release(var Engine: PENGINE); + procedure Clear; + end; + +var + FEnginePool: TEnginePool = nil; + +{ TEnginePool } + +function TEnginePool.Acquire(out Engine: PENGINE): boolean; +var + n: integer; +begin + if fAvailableList.Count > 0 then + begin + Lock; + try + for n := Pred(fAvailableList.Count) downto 0 do + begin + Engine := fAvailableList[n]; + if Engine <> nil then + begin + fAvailableList.Delete(n); + Result := True; + Exit; + end; + end; + finally + Unlock; + end; + end; + Result := InitCapiEngine and PrepareCapiEngine(Engine); +end; + +procedure TEnginePool.Clear; +var + i: integer; + E: PENGINE; +begin + Lock; + try + for i := 0 to Pred(fAvailableList.Count) do + begin + E := fAvailableList[i]; + fAvailableList[i] := nil; + if E <> nil then + begin + ENGINE_finish(E); + ENGINE_free(E); + end; + end; + fAvailableList.Clear; + finally + Unlock; + end; +end; + +constructor TEnginePool.Create; +begin + inherited Create; + fLock := TCriticalSection.Create; + fAvailableList := TList.Create; +end; + +destructor TEnginePool.Destroy; +begin + Clear; + FreeAndNil(fAvailableList); + FreeAndNil(fLock); + inherited; +end; + +procedure TEnginePool.Lock; +begin + fLock.Enter; +end; + +procedure TEnginePool.Release(var Engine: PENGINE); +begin + if Engine = nil then + Exit; + Lock; + try + fAvailableList.Add(Engine); + Engine := nil; + finally + Unlock; + end; +end; + +procedure TEnginePool.Unlock; +begin + fLock.Leave; +end; + +{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$REGION 'The plugin'}{$ENDIF} +{==============================================================================} +{The plugin } +{------------------------------------------------------------------------------} + +{ TSSLOpenSSLCapi } + +class function TSSLOpenSSLCapi.InitEngine: boolean; +begin + Result := InitCapiEngine; +end; + +procedure TSSLOpenSSLCapi.Assign(const Value: TCustomSSL); +var + CAPIValue: TSSLOpenSSLCapi; +begin + inherited; + if (Value <> nil) and (Value is TSSLOpenSSLCapi) then + begin + CAPIValue := TSSLOpenSSLCapi(Value); + Self.FSigningCertificateLocation := CAPIValue.FSigningCertificateLocation; + Self.FSigningCertificateStore := CAPIValue.FSigningCertificateStore; + Self.FSigningCertificateID := CAPIValue.FSigningCertificateID; + end; +end; + +constructor TSSLOpenSSLCapi.Create(const Value: TTCPBlockSocket); +begin + inherited; + FEngine := nil; + FEngineInitialized := False; + FSigningCertificateLocation := wcslCurrentUser; + FSigningCertificateStore := 'MY'; + FSigningCertificateID := ''; +end; + +destructor TSSLOpenSSLCapi.Destroy; +begin + if FEngine <> nil then + begin + {$IFDEF USE_ENGINE_POOL} + FEnginePool.Release(FEngine); + {$ELSE} + ENGINE_finish(FEngine); + ENGINE_free(FEngine); + {$ENDIF} + FEngineInitialized := False; + end; + inherited; +end; + +function TSSLOpenSSLCapi.GetEngine: PENGINE; +begin + if not FEngineInitialized then + begin + {$IFDEF USE_ENGINE_POOL} + if not FEnginePool.Acquire(FEngine) then + FEngine := nil; + {$ELSE} + if (not InitEngine) or (not PrepareCapiEngine(FEngine)) then + FEngine := nil; + {$ENDIF} + FEngineInitialized := True; + end; + Result := FEngine; +end; + +function TSSLOpenSSLCapi.LoadSigningCertificate: boolean; +var + pkey: EVP_PKEY; + pdata: Pointer; + cert: PX509; + store: HCERTSTORE; + certctx: PCCERT_CONTEXT; + flags: DWORD; +begin + Result := False; + if not SigningCertificateSpecified then + Exit; + if not InitEngine then + Exit; + if Engine = nil then + Exit; + if not Assigned(FSSL_CTX_set_client_cert_engine) then + Exit; + if SSL_CTX_set_client_cert_engine(Fctx, Engine) = 0 then + Exit; + if ENGINE_ctrl_cmd_string(Engine, 'store_name', PAnsiChar( {$IFDEF UNICODE} AnsiString {$ENDIF} (SigningCertificateStore)), 0) = 0 then + Exit; + if ENGINE_ctrl_cmd_string(Engine, 'lookup_method', '1', 0) = 0 then + Exit; + case SigningCertificateLocation of + wcslCurrentUser: + if ENGINE_ctrl_cmd_string(Engine, 'store_flags', '0', 0) = 0 then + Exit; + wcslLocalMachine: + if ENGINE_ctrl_cmd_string(Engine, 'store_flags', '1', 0) = 0 then + Exit; + else + Exit; // other store flags are not supported by the CAPI engine + end; + if Server then + begin + cert := nil; + pkey := nil; + try + // Need to find the context and the store for the certificate. Unfortunately, + // due to the CAPI engine limitations (see capi_load_privkey), I can only use + // a very limited set of criteria for finding the certificate + flags := 0; + case SigningCertificateLocation of + wcslCurrentUser: + flags := flags or CERT_SYSTEM_STORE_CURRENT_USER; + wcslLocalMachine: + flags := flags or CERT_SYSTEM_STORE_LOCAL_MACHINE; + else + Exit; // other store flags are not supported by the CAPI engine + end; + store := CertOpenStore(CERT_STORE_PROV_SYSTEM_W, 0, 0, flags, PWideChar(WideString(SigningCertificateStore))); + if store <> 0 then + begin + try + certctx := CertFindCertificateInStore(store, X509_ASN_ENCODING, 0, CERT_FIND_SUBJECT_STR_A, PAnsiChar( {$IFDEF UNICODE} AnsiString {$ENDIF} (SigningCertificateID)), nil); + if certctx = nil then + Exit; + pkey := ENGINE_load_private_key(Engine, PAnsiChar( {$IFDEF UNICODE} AnsiString {$ENDIF} (SigningCertificateID)), nil, nil); + if pkey = nil then + Exit; + pdata := certctx.pbCertEncoded; + cert := d2i_X509(nil, @pdata, certctx.cbCertEncoded); + if cert = nil then + Exit; + if SSLCTXusecertificate(Fctx, cert) <= 0 then + Exit; + if SSLCTXusePrivateKey(Fctx, pkey) <= 0 then + Exit; + Result := True; + finally + CertCloseStore(store, 0); + end; + end; + finally + if pkey <> nil then + EvpPkeyFree(pkey); + if cert <> nil then + X509free(cert); + end; + end + else + begin + Result := True; + end; + if Result then + if FEngineNeedsSHA2Workaround then + SslCtxCtrl(Fctx, SSL_CTRL_OPTIONS, SslCtxCtrl(Fctx, SSL_CTRL_OPTIONS, 0, nil) or SSL_OP_NO_TLSv1_2, nil); +end; + +function TSSLOpenSSLCapi.NeedSigningCertificate: boolean; +begin + Result := SigningCertificateSpecified and inherited NeedSigningCertificate; +end; + +function TSSLOpenSSLCapi.SetSslKeys: boolean; +begin + Result := False; + if not assigned(FCtx) then + Exit; + try + if SigningCertificateSpecified and InitEngine then + begin + if not LoadSigningCertificate then + Exit; + Result := True; + end; + if inherited SetSslKeys then + Result := True; + finally + SSLCheck; + end; +end; + +function TSSLOpenSSLCapi.SigningCertificateSpecified: boolean; +begin + Result := (SigningCertificateID <> ''); +end; + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +{$IFDEF SUPPORTS_REGION}{$REGION 'Initialization and finalization'}{$ENDIF} +{==============================================================================} +{Initialization and finalization } +{------------------------------------------------------------------------------} + +initialization +begin + FEngineCS := TCriticalSection.Create; + if InitSSLInterface and ((SSLImplementation = TSSLNone) or (SSLImplementation = TSSLOpenSSL)) then + SSLImplementation := TSSLOpenSSLCapi; + {$IFDEF USE_ENGINE_POOL} + FEnginePool := TEnginePool.Create; + {$ENDIF} +end; + +finalization +begin + DestroyEngineInterface; + {$IFDEF USE_ENGINE_POOL} + FreeAndNil(FEnginePool); + {$ENDIF} + FreeAndNil(FEngineCS); +end; + +{$IFDEF SUPPORTS_REGION}{$ENDREGION}{$ENDIF} + +end. diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl_lib.pas cqrprop-0.0.8/src/synapse/ssl_openssl_lib.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl_lib.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl_lib.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 003.008.000 | +| Project : Ararat Synapse | 003.009.000 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| @@ -35,10 +35,12 @@ | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2002-2017. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| Portions created by Pepak are Copyright (c)2018. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | | Tomas Hajny (OS2 support) | +| Pepak (multiversion support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -90,13 +92,13 @@ {$IFDEF FPC} {$IFDEF UNIX} BaseUnix, - uMyFindFile, {$ENDIF UNIX} {$ELSE} Libc, {$ENDIF} SysUtils; {$ELSE} + SysUtils, Windows; {$ENDIF} @@ -135,6 +137,58 @@ DLLSSLName2: string = 'libssl32.dll'; DLLUtilName: string = 'libeay32.dll'; {$ENDIF} +{$IFDEF MSWINDOWS} +const + LibCount = 5; + SSLLibNames: array[0..LibCount-1] of string = ( + // OpenSSL v3.0 + {$IFDEF WIN64} + 'libssl-3-x64.dll', + {$ELSE} + 'libssl-3.dll', + {$ENDIF} + // OpenSSL v1.1.x + {$IFDEF WIN64} + 'libssl-1_1-x64.dll', + {$ELSE} + 'libssl-1_1.dll', + {$ENDIF} + // OpenSSL v1.0.2 distinct names for x64 and x86 + {$IFDEF WIN64} + 'ssleay32-x64.dll', + {$ELSE} + 'ssleay32-x86.dll', + {$ENDIF} + // OpenSSL v1.0.2 + 'ssleay32.dll', + // OpenSSL (ancient) + 'libssl32.dll' + ); + CryptoLibNames: array[0..LibCount-1] of string = ( + // OpenSSL v3.0 + {$IFDEF WIN64} + 'libcrypto-3-x64.dll', + {$ELSE} + 'libcrypto-3.dll', + {$ENDIF} + // OpenSSL v1.1.x + {$IFDEF WIN64} + 'libcrypto-1_1-x64.dll', + {$ELSE} + 'libcrypto-1_1.dll', + {$ENDIF} + // OpenSSL v1.0.2 distinct names for x64 and x86 + {$IFDEF WIN64} + 'libeay32-x64.dll', + {$ELSE} + 'libeay32-x86.dll', + {$ENDIF} + // OpenSSL v1.0.2 + 'libeay32.dll', + // OpenSSL (ancient) + 'libeay32.dll' + ); +{$ENDIF} {$ENDIF} type @@ -1729,7 +1783,7 @@ function d2iX509bio(b: PBIO; x: PX509): PX509; {pf} begin if InitSSLInterface and Assigned(_d2iX509bio) then - Result := _d2iX509bio(x,b) + Result := _d2iX509bio(b, x) else Result := nil; end; @@ -1859,11 +1913,20 @@ {$ENDIF} end; +function GetLibFileName(Handle: THandle): string; +var + n: integer; +begin + n := MAX_PATH + 1024; + SetLength(Result, n); + n := GetModuleFilename(Handle, PChar(Result), n); + SetLength(Result, n); +end; + function InitSSLInterface: Boolean; var s: string; - x: integer; - Paths : TStringList; + i: integer; begin {pf} if SSLLoaded then @@ -1872,29 +1935,6 @@ exit; end; {/pf} - - Paths := TStringList.Create; - try - Paths.Add('/usr/lib64/'); - Paths.Add('/lib64/'); - Paths.Add('/usr/lib/x86_64-linux-gnu/'); - Paths.Add('/lib/x86_64-linux-gnu/'); - Paths.Add('/usr/lib/i386-linux-gnu/'); - Paths.Add('/usr/lib/'); - Paths.Add('/lib/'); - - DLLSSLName := MyFindFile('libssl*1.0.*', Paths); - DLLUtilName := MyFindFile('libcrypto*1.0.*', Paths); - - if (DLLSSLName = '') then - begin - DLLSSLName := MyFindFile('libssl*1.1*', Paths); - DLLUtilName := MyFindFile('libcrypto*1.1*', Paths) - end - finally - FreeAndNil(Paths) - end; - SSLCS.Enter; try if not IsSSLloaded then @@ -1903,12 +1943,24 @@ SSLLibHandle := 1; SSLUtilHandle := 1; {$ELSE} + // Note: It's important to ensure that the libraries both come from the + // same directory, preferably the one of the executable. Otherwise a + // version mismatch could easily occur. + {$IFDEF MSWINDOWS} + for i := 0 to Pred(LibCount) do + begin + SSLUtilHandle := LoadLib(CryptoLibNames[i]); + if SSLUtilHandle <> 0 then + begin + s := ExtractFilePath(GetLibFileName(SSLUtilHandle)); + SSLLibHandle := LoadLib(s + SSLLibNames[i]); + Break; + end; + end; + {$ELSE} SSLUtilHandle := LoadLib(DLLUtilName); SSLLibHandle := LoadLib(DLLSSLName); - {$IFDEF MSWINDOWS} - if (SSLLibHandle = 0) then - SSLLibHandle := LoadLib(DLLSSLName2); - {$ENDIF} + {$ENDIF} {$ENDIF} if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then begin @@ -2024,14 +2076,8 @@ 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; + SSLLibFile := GetLibFileName(SSLLibHandle); + SSLUtilFile := GetLibFileName(SSLUtilHandle); //init library if assigned(_SslLibraryInit) then _SslLibraryInit; diff -Nru cqrprop-0.0.7/src/synapse/ssl_openssl.pas cqrprop-0.0.8/src/synapse/ssl_openssl.pas --- cqrprop-0.0.7/src/synapse/ssl_openssl.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_openssl.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.003.000 | +| Project : Ararat Synapse | 001.004.000 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| @@ -35,6 +35,7 @@ | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | Portions created by Lukas Gebauer are Copyright (c)2005-2017. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. | +| Portions created by Pepak are Copyright (c)2018. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -76,9 +77,8 @@ accepting of new connections! } -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} +{$INCLUDE 'jedi.inc'} + {$H+} {$IFDEF UNICODE} @@ -86,7 +86,7 @@ {$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$ENDIF} -unit ssl_openssl; +unit ssl_openssl{$IFDEF SUPPORTS_DEPRECATED} deprecated{$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use ssl_openssl3 with OpenSSL 3.0 instead'{$ENDIF}{$ENDIF}; interface @@ -96,6 +96,9 @@ {$IFDEF CIL} System.Text, {$ENDIF} +{$IFDEF DELPHI23_UP} + AnsiStrings, +{$ENDIF} ssl_openssl_lib; type @@ -103,16 +106,20 @@ 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) + private + FServer: boolean; protected FSsl: PSSL; Fctx: PSSL_CTX; + function NeedSigningCertificate: boolean; virtual; function SSLCheck: Boolean; - function SetSslKeys: boolean; - function Init(server:Boolean): Boolean; + function SetSslKeys: boolean; virtual; + function Init: Boolean; function DeInit: Boolean; - function Prepare(server:Boolean): Boolean; + function Prepare: Boolean; function LoadPFX(pfxdata: ansistring): Boolean; function CreateSelfSignedCert(Host: string): Boolean; override; + property Server: boolean read FServer; public {:See @inherited} constructor Create(const Value: TTCPBlockSocket); override; @@ -148,7 +155,7 @@ {:See @inherited} function GetPeerNameHash: cardinal; override; {pf} {:See @inherited} - function GetPeerFingerprint: string; override; + function GetPeerFingerprint: ansistring; override; {:See @inherited} function GetCertInfo: string; override; {:See @inherited} @@ -176,7 +183,7 @@ if Length(Password) > (Size - 1) then SetLength(Password, Size - 1); Result := Length(Password); - StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); + {$IFDEF DELPHI23_UP}AnsiStrings.{$ENDIF}StrLCopy(buf, PAnsiChar(Password + #0), Result + 1); end; {$ENDIF} @@ -250,7 +257,7 @@ pk := EvpPkeynew; x := X509New; try - rsa := RsaGenerateKey(1024, $10001, nil, nil); + rsa := RsaGenerateKey(2048, $10001, nil, nil); EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa); X509SetVersion(x, 2); Asn1IntegerSet(X509getSerialNumber(x), 0); @@ -411,7 +418,12 @@ end; end; -function TSSLOpenSSL.Init(server:Boolean): Boolean; +function TSSLOpenSSL.NeedSigningCertificate: boolean; +begin + Result := (FCertificateFile = '') and (FCertificate = '') and (FPFXfile = '') and (FPFX = ''); +end; + +function TSSLOpenSSL.Init: Boolean; var s: AnsiString; begin @@ -433,10 +445,10 @@ LT_all: begin //try new call for OpenSSL 1.1.0 first - Fctx := SslCtxNew(SslMethodTLS); - if Fctx=nil then - //callback to previous versions - Fctx := SslCtxNew(SslMethodV23); + Fctx := SslCtxNew(SslMethodTLS); + if Fctx=nil then + //callback to previous versions + Fctx := SslCtxNew(SslMethodV23); end; else Exit; @@ -459,8 +471,7 @@ SslCtxSetDefaultPasswdCbUserdata(FCtx, self); {$ENDIF} - if server and (FCertificateFile = '') and (FCertificate = '') - and (FPFXfile = '') and (FPFX = '') then + if server and NeedSigningCertificate then begin CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); end; @@ -496,11 +507,11 @@ FSSLEnabled := False; end; -function TSSLOpenSSL.Prepare(server:Boolean): Boolean; +function TSSLOpenSSL.Prepare: Boolean; begin Result := false; DeInit; - if Init(server) then + if Init then Result := true else DeInit; @@ -515,7 +526,8 @@ Result := False; if FSocket.Socket = INVALID_SOCKET then Exit; - if Prepare(False) then + FServer := False; + if Prepare then begin {$IFDEF CIL} if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then @@ -573,7 +585,8 @@ Result := False; if FSocket.Socket = INVALID_SOCKET then Exit; - if Prepare(True) then + FServer := True; + if Prepare then begin {$IFDEF CIL} if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then @@ -806,7 +819,7 @@ X509Free(cert); end; -function TSSLOpenSSL.GetPeerFingerprint: string; +function TSSLOpenSSL.GetPeerFingerprint: ansistring; var cert: PX509; x: integer; diff -Nru cqrprop-0.0.7/src/synapse/ssl_sbb.pas cqrprop-0.0.8/src/synapse/ssl_sbb.pas --- cqrprop-0.0.7/src/synapse/ssl_sbb.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_sbb.pas 2023-04-10 12:51:00.000000000 +0000 @@ -131,7 +131,7 @@ {:See @inherited} function GetPeerName: string; override; {:See @inherited} - function GetPeerFingerprint: string; override; + function GetPeerFingerprint: ansistring; override; {:See @inherited} function GetCertInfo: string; override; published @@ -325,7 +325,7 @@ Result := FElSecureClient.CipherSuite; end; -function TSSLSBB.GetPeerFingerprint: string; +function TSSLSBB.GetPeerFingerprint: ansistring; begin Result := ''; // if FServer then diff -Nru cqrprop-0.0.7/src/synapse/ssl_streamsec.pas cqrprop-0.0.8/src/synapse/ssl_streamsec.pas --- cqrprop-0.0.7/src/synapse/ssl_streamsec.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssl_streamsec.pas 2023-04-10 12:51:00.000000000 +0000 @@ -137,7 +137,7 @@ {:See @inherited} function GetPeerName: string; override; {:See @inherited} - function GetPeerFingerprint: string; override; + function GetPeerFingerprint: ansistring; override; {:See @inherited} function GetCertInfo: string; override; published @@ -470,7 +470,7 @@ end; end; -function TSSLStreamSec.GetPeerFingerprint: string; +function TSSLStreamSec.GetPeerFingerprint: ansistring; var Cert: PASN1Struct; begin diff -Nru cqrprop-0.0.7/src/synapse/ssos2ws1.inc cqrprop-0.0.8/src/synapse/ssos2ws1.inc --- cqrprop-0.0.7/src/synapse/ssos2ws1.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssos2ws1.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1843 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: Socket Independent Platform Layer - OS/2 winsock1 | +|==============================================================================| +| Copyright (c)1999-2013, 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-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$MACRO ON} + +{$IFNDEF ODIN} + {$DEFINE WINSOCK1} + {$DEFINE PMWSOCK} +{$ENDIF ODIN} + +{$IFDEF PMWSOCK} + {$DEFINE extdecl := cdecl} +{$ELSE PMWSOCK} + {$DEFINE extdecl := stdcall} +{$ENDIF PMWSOCK} + +//{$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} +{$ELSE} + {$IFDEF WIN64} + {$ALIGN ON} + {$MINENUMSIZE 4} + {$ELSE} + {$MINENUMSIZE 4} + {$ALIGN OFF} + {$ENDIF} +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, Classes, +{$IFDEF OS2} + Sockets, Dynlibs +{$ELSE OS2} + Windows +{$ENDIF OS2} +; + +function InitSocketInterface(stack: String): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type +{$IFDEF OS2} + Bool = longint; +{$ENDIF OS2} + 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} + {$IFDEF OS2} + {$IFDEF DAPWSOCK} + DLLStackName = 'dapwsock.dll'; + {$ELSE DAPWSOCK} + DLLStackName = 'pmwsock.dll'; + {$ENDIF DAPWSOCK} + {$ELSE OS2} + DLLStackName = 'wsock32.dll'; + {$ENDIF OS2} + {$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; +{$IFDEF PMWSOCK} + h_addrtype: longint; + h_length: longint; +{$ELSE PMWSOCK} + h_addrtype: Smallint; + h_length: Smallint; +{$ENDIF PMWSOCK} + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; +{$IFDEF PMWSOCK} + n_addrtype: longint; +{$ELSE PMWSOCK} + n_addrtype: Smallint; +{$ENDIF PMWSOCK} + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; +{$ifdef WIN64} + s_proto: PAnsiChar; + s_port: Smallint; +{$else} +{$IFDEF PMWSOCK} + s_port: longint; +{$ELSE PMWSOCK} + s_port: Smallint; +{$ENDIF PMWSOCK} + s_proto: PAnsiChar; +{$endif} + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PAnsiChar; + p_aliases: ^PAnsichar; +{$IFDEF PMWSOCK} + p_proto: longint; +{$ELSE PMWSOCK} + p_proto: Smallint; +{$ENDIF PMWSOCK} + 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 +{$IFDEF PMWSOCK} + l_onoff: longint; + l_linger: longint; +{$ELSE PMWSOCK} + l_onoff: u_short; + l_linger: u_short; +{$ENDIF PMWSOCK} + 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; + extdecl; + TWSACleanup = function: Integer; + extdecl; + TWSAGetLastError = function: Integer; + extdecl; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; + extdecl; + TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; + extdecl; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; + extdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + extdecl; + TGetHostByName = function(name: PAnsiChar): PHostEnt; + extdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + extdecl; + TGetHostName = function(name: PAnsiChar; len: Integer): Integer; + extdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + extdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; + extdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; + extdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + extdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + extdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + extdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + extdecl; + Tntohs = function(netshort: u_short): u_short; + extdecl; + Tntohl = function(netlong: u_long): u_long; + extdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + extdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; + extdecl; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; + extdecl; + TInet_addr = function(cp: PAnsiChar): u_long; + extdecl; + Thtons = function(hostshort: u_short): u_short; + extdecl; + Thtonl = function(hostlong: u_long): u_long; + extdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + extdecl; + TCloseSocket = function(s: TSocket): Integer; + extdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + extdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + extdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + extdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + extdecl; + + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + extdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + extdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; + extdecl; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + extdecl; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + extdecl; + +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; +{$IFDEF OS2} + ssShutdown: TShutdown = nil; + ssSetSockOpt: TSetSockOpt = nil; + ssGetSockOpt: TGetSockOpt = nil; +{$ELSE OS2} + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; +{$ENDIF OS2} + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; +{$IFDEF OS2} + ssListen: TListen = nil; + ssIoctlSocket: TIoctlSocket = nil; +{$ELSE OS2} + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; +{$ENDIF OS2} + 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; +{$IFDEF OS2} + ssCloseSocket: TCloseSocket = nil; +{$ELSE OS2} + CloseSocket: TCloseSocket = nil; +{$ENDIF OS2} + ssBind: TBind = nil; + ssAccept: TAccept = nil; +{$IFDEF OS2} + ssSocket: TTSocket = nil; +{$ELSE OS2} + Socket: TTSocket = nil; +{$ENDIF OS2} + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +{$IFDEF OS2} + ss__WSAFDIsSet: T__WSAFDIsSet = nil; + + ssWSAIoctl: TWSAIoctl = nil; +{$ELSE OS2} + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; +{$ENDIF OS2} + +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; +{$IFDEF OS2} +function Socket (af, Struc, Protocol: Integer): TSocket; +function Shutdown (s: TSocket; how: Integer): Integer; +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +function Listen (s: TSocket; backlog: Integer): Integer; +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +function CloseSocket (s: TSocket): Integer; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +{$ENDIF OS2} + +{==============================================================================} +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 +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + 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 +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + Result := __WSAFDIsSet(Socket, FDSet) +{$IFDEF OS2} + <> 0 +{$ENDIF OS2} ; +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + 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 +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + 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 +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + 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 +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + 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 +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(addr); +{$IFDEF OS2} + Result := TSocket (EMXSocket (cInt (ssAccept (S, @Addr, X)))); +{$ELSE OS2} + Result := ssAccept(s, @addr, x); +{$ENDIF OS2} +end; + +{$IFDEF OS2} +function Shutdown (s: TSocket; how: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Shutdown := ssShutdown (s, how); +end; + +function Socket (af, Struc, Protocol: Integer): TSocket; +begin + Socket := TSocket (EMXSocket (cInt (ssSocket (af, Struc, Protocol)))); +end; + +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + SetSockOpt := ssSetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + GetSockOpt := ssGetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function Listen (s: TSocket; backlog: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Listen := ssListen (S, BackLog); +end; + +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + IOCtlSocket := ssIOCtlSocket (S, Cmd, Arg); +end; + +function CloseSocket (s: TSocket): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + CloseSocket := ssCloseSocket (S); +end; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; +begin + S := TSocket (NativeSocket (cInt (S))); + __WSAFDIsSet := ss__WSAFDIsSet (S, FDSet); +end; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +begin + S := TSocket (NativeSocket (cInt (S))); + WSAIOCtl := ssWSAIOCtl (S, dwIoControlCode, lpvInBuffer, cbInBuffer, + lpvOutBuffer, cbOutBuffer, lpcbBytesReturned, lpOverlapped, + lpCompletionRoutine); +end; +{$ENDIF OS2} + +{=============================================================================} +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; + 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 +{$IFDEF OS2} + ssWSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + ss__WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + ssCloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + ssIoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ELSE OS2} + WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ENDIF OS2} + 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'))); +{$IFDEF OS2} + ssGetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ELSE OS2} + GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ENDIF OS2} + 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'))); +{$IFDEF OS2} + ssListen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ELSE OS2} + Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ENDIF OS2} + 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'))); +{$IFDEF OS2} + ssSetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ssShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + ssSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ELSE OS2} + SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ENDIF OS2} + 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 -Nru cqrprop-0.0.7/src/synapse/ssposix.inc cqrprop-0.0.8/src/synapse/ssposix.inc --- cqrprop-0.0.7/src/synapse/ssposix.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/ssposix.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1153 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.005 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Delphi Posix definition include | +|==============================================================================| +| Copyright (c)2006-2013, 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-2012. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Radek Cervinka | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$WARN UNIT_PLATFORM OFF} +{$WARN SYMBOL_PLATFORM OFF} + +{$IFDEF POSIX} +{for delphi XE2+} + +//{$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! +} + +{ +note RC: +partially compatible with NextGen Delphi compiler - iOS + + +} + +interface + +uses + SyncObjs, SysUtils, Classes, synafpc, + Posix.SysSocket, Posix.SysSelect, Posix.SysTime, Posix.NetinetIn, + Posix.StrOpts, Posix.Errno; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cBroadcast = '255.255.255.255'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; + +type + TSocket = longint; + TAddrFamily = integer; + TMemory = pointer; + +type + TFDSet = fd_set; + PFDSet = Pfd_set; + Ptimeval = Posix.SysTime.ptimeval; + Ttimeval = Posix.SysTime.timeval; + +const + //not declared in all Delphi versions... + {$IF DECLARED(Posix.StrOpts.FIONREAD)} + FIONREAD = Posix.StrOpts.FIONREAD; + {$Else} + FIONREAD = {$IFDEF ANDROID}$541B{$ELSE}$4004667F{$ENDIF}; + {$IfEnd} + + {$IF DECLARED(Posix.StrOpts.FIONBIO)} + FIONBIO = Posix.StrOpts.FIONBIO; + {$Else} + FIONBIO = {$IFDEF ANDROID}$5421{$ELSE}$8004667E{$ENDIF}; + {$IfEnd} + + {$IF DECLARED(Posix.StrOpts.FIOASYNC)} + FIOASYNC = Posix.StrOpts.FIOASYNC; + {$Else} + FIOASYNC = {$IFDEF ANDROID}$5452{$ELSE}$8004667D{$ENDIF}; + {$IfEnd} + +const + IPPROTO_IP = Posix.NetinetIn.IPPROTO_IP; { Dummy } + IPPROTO_ICMP = Posix.NetinetIn.IPPROTO_ICMP; { Internet Control Message Protocol } + IPPROTO_IGMP = Posix.NetinetIn.IPPROTO_IGMP; { Internet Group Management Protocol} + IPPROTO_TCP = Posix.NetinetIn.IPPROTO_TCP; { TCP } + IPPROTO_UDP = Posix.NetinetIn.IPPROTO_UDP; { User Datagram Protocol } + IPPROTO_IPV6 = Posix.NetinetIn.IPPROTO_IPV6; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = Posix.NetinetIn.IPPROTO_RAW; + IPPROTO_MAX = Posix.NetinetIn.IPPROTO_MAX; + +type + PInAddr = ^TInAddr; + TInAddr = Posix.NetinetIn.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = Posix.NetinetIn.sockaddr_in; + + + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + + PInAddr6 = ^TInAddr6; + TInAddr6 = Posix.NetinetIn.in6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = Posix.NetinetIn.sockaddr_in6; + + + 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 = Posix.NetinetIn.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = Posix.NetinetIn.IP_TTL; { int; IP time to live. } + IP_HDRINCL = Posix.NetinetIn.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = Posix.NetinetIn.IP_OPTIONS; { ip_opts; IP per-packet options. } +// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } + IP_RECVOPTS = Posix.NetinetIn.IP_RECVOPTS; { bool } + IP_RETOPTS = Posix.NetinetIn.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 = Posix.NetinetIn.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = Posix.NetinetIn.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = Posix.NetinetIn.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = Posix.NetinetIn.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = Posix.NetinetIn.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = Posix.SysSocket.SOL_SOCKET; + + SO_DEBUG = Posix.SysSocket.SO_DEBUG; + SO_REUSEADDR = Posix.SysSocket.SO_REUSEADDR; + SO_TYPE = Posix.SysSocket.SO_TYPE; + SO_ERROR = Posix.SysSocket.SO_ERROR; + SO_DONTROUTE = Posix.SysSocket.SO_DONTROUTE; + SO_BROADCAST = Posix.SysSocket.SO_BROADCAST; + SO_SNDBUF = Posix.SysSocket.SO_SNDBUF; + SO_RCVBUF = Posix.SysSocket.SO_RCVBUF; + SO_KEEPALIVE = Posix.SysSocket.SO_KEEPALIVE; + SO_OOBINLINE = Posix.SysSocket.SO_OOBINLINE; +// SO_NO_CHECK = SysSocket.SO_NO_CHECK; +// SO_PRIORITY = SysSocket.SO_PRIORITY; + SO_LINGER = Posix.SysSocket.SO_LINGER; +// SO_BSDCOMPAT = SysSocket.SO_BSDCOMPAT; +// SO_REUSEPORT = SysSocket.SO_REUSEPORT; +// SO_PASSCRED = SysSocket.SO_PASSCRED; +// SO_PEERCRED = SysSocket.SO_PEERCRED; + SO_RCVLOWAT = Posix.SysSocket.SO_RCVLOWAT; + SO_SNDLOWAT = Posix.SysSocket.SO_SNDLOWAT; + SO_RCVTIMEO = Posix.SysSocket.SO_RCVTIMEO; + SO_SNDTIMEO = Posix.SysSocket.SO_SNDTIMEO; +{ Security levels - as per NRL IPv6 - don't actually do anything } +// SO_SECURITY_AUTHENTICATION = SysSocket.SO_SECURITY_AUTHENTICATION; +// SO_SECURITY_ENCRYPTION_TRANSPORT = SysSocket.SO_SECURITY_ENCRYPTION_TRANSPORT; +// SO_SECURITY_ENCRYPTION_NETWORK = SysSocket.SO_SECURITY_ENCRYPTION_NETWORK; +// SO_BINDTODEVICE = SysSocket.SO_BINDTODEVICE; +{ Socket filtering } +// SO_ATTACH_FILTER = SysSocket.SO_ATTACH_FILTER; +// SO_DETACH_FILTER = SysSocket.SO_DETACH_FILTER; + + SOMAXCONN = 1024; + + IPV6_UNICAST_HOPS = Posix.NetinetIn.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = Posix.NetinetIn.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = Posix.NetinetIn.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = Posix.NetinetIn.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = Posix.NetinetIn.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = Posix.NetinetIn.IPV6_LEAVE_GROUP; + +const + SOCK_STREAM = Posix.SysSocket.SOCK_STREAM;// 1; { stream socket } + SOCK_DGRAM = Posix.SysSocket.SOCK_DGRAM;// 2; { datagram socket } + SOCK_RAW = Posix.SysSocket.SOCK_RAW;// 3; { raw-protocol interface } + SOCK_RDM = Posix.SysSocket.SOCK_RDM;// 4; { reliably-delivered message } + SOCK_SEQPACKET = Posix.SysSocket.SOCK_SEQPACKET;// 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; //netinettcp.pas + +{ Address families. } + + AF_UNSPEC = Posix.SysSocket.AF_UNSPEC;// 0; { unspecified } + AF_INET = Posix.SysSocket.AF_INET; // 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = Posix.SysSocket.AF_INET6; // !! 30 { Internetwork Version 6 } + {$IF DECLARED(Posix.SysSocket.AF_MAX)} + AF_MAX = Posix.SysSocket.AF_MAX; // !! - variable by OS + {$Else} + AF_MAX = 43; //not declared for Android + {$IfEnd} + +{ 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 = Posix.SysSocket.linger; + +const + + MSG_OOB = Posix.SysSocket.MSG_OOB; // Process out-of-band data. + MSG_PEEK = Posix.SysSocket.MSG_PEEK; // Peek at incoming messages. + {$IFDEF MACOS} + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + // Works under MAC OS X, but is undocumented, + // So FPC doesn't include it + {$ELSE} + MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE. + {$ENDIF} + +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 = 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; + +{$IFDEF MACOS} + {$DEFINE SOCK_HAS_SINLEN} // OSX +{$ENDIF} + +type + TVarSin = packed record + {$ifdef SOCK_HAS_SINLEN} + sin_len : UInt8; + {$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 byte); + 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: Integer; 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 +uses + Posix.Base, Posix.Unistd, Posix.ArpaInet, Posix.NetDB; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_UNSPECIFIED(a^); +{ 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 := Posix.NetinetIn.IN6_IS_ADDR_LOOPBACK(a^); +{ 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 := Posix.NetinetIn.IN6_IS_ADDR_LINKLOCAL(a^); +{ Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));} +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_SITELOCAL(a^); +// Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := Posix.NetinetIn.IN6_IS_ADDR_MULTICAST(a^); +// 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^.s6_addr[15] := 1; +end; + +{$IFDEF NEXTGEN} +function GetHostByName(const name: string):Phostent; +begin + Result := Posix.NetDB.gethostbyname(MarshaledAString(TMarshal.AsAnsi(name))); +end; +{$ENDIF} + +{=============================================================================} + +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 Posix by Delphi'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := Posix.Errno.errno; +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := __FD_ISSET(socket, fdset); +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + __FD_SET(Socket, fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + __FD_CLR(Socket, fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + __FD_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; +var + sa: sockaddr absolute addr; +begin + Result := Posix.SysSocket.Bind(s, sa, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +var + sa: sockaddr absolute name; +begin + Result := Posix.SysSocket.Connect(s, sa, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: socklen_t; + address : sockaddr absolute name; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := Posix.SysSocket.GetSockName(s, address, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: socklen_t; + address : sockaddr absolute name; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := Posix.SysSocket.GetPeerName(s, address, Len); +end; + +function GetHostName: string; +{$IFDEF NEXTGEN} +var + name: TArray; +const + cMaxHostLength = 255; +begin + Result := ''; + SetLength(name, cMaxHostLength); + if Posix.Unistd.GetHostName(MarshaledAString(name), cMaxHostLength) = 0 then + Result := TEncoding.UTF8.GetString(name).ToUpper +{$ELSE} +var + s: AnsiString; +begin + Result := ''; + setlength(s, cMaxHostLength); + Posix.Unistd.GetHostName(PAnsiChar(s), Length(s) - 1); + Result := PChar(string(s)); +{$ENDIF} + if Result = '' then + Result := cLocalHostStr; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := Posix.SysSocket.Send(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := Posix.SysSocket.Recv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +var + sa: sockaddr absolute addrto; +begin + Result := Posix.SysSocket.SendTo(s, Buf^, len, flags, sa, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: socklen_t; + address : sockaddr absolute from; +begin + x := SizeOf(from); + Result := Posix.SysSocket.RecvFrom(s, Buf^, len, flags, address, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: socklen_t; + address : sockaddr absolute addr; +begin + x := SizeOf(addr); + Result := Posix.SysSocket.Accept(s, address, x); +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := Posix.SysSocket.Shutdown(s, how); +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := Posix.SysSocket.setsockopt(s, level, optname, pointer(optval), optlen); +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +var + x: socklen_t; +begin + x := optlen; + Result := Posix.SysSocket.getsockopt(s, level, optname, pointer(optval), x); + optlen := x; +end; + +function ntohs(netshort: word): word; +begin + Result := Posix.ArpaInet.ntohs(NetShort); +end; + +function ntohl(netlong: longword): longword; +begin + Result := Posix.ArpaInet.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if Posix.SysSocket.Listen(s, backlog) = 0 then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: Integer; var arg: integer): Integer; +begin + Result := Posix.StrOpts.Ioctl(s, cmd, @arg); +end; + +function htons(hostshort: word): word; +begin + Result := Posix.ArpaInet.htons(Hostshort); +end; + +function htonl(hostlong: longword): longword; +begin + Result := Posix.ArpaInet.htonl(HostLong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := Posix.Unistd.__close(s); +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + Result := Posix.SysSocket.Socket(af, struc, protocol); +end; + +function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + Result := Posix.SysSelect.Select(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 + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: AddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: string; Hints: AddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + aIP,aPort : AnsiString; + begin + aIP:=Utf8Encode(IP); + aPort:=Utf8Encode(Port); + 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 := GetAddrInfo(PAnsiChar(aIP), nil, Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := GetAddrInfo(nil, PAnsiChar(aPort), Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := GetAddrInfo(nil, PAnsiChar(aPort), Hints, Addr); + end + else + begin + //for Android see code in System.Net.Socket TIPAddress.LookupName + // Result := getaddrinfo(M.AsUTF8(TURI.UnicodeToIDNA(aIP)).ToPointer, nil, Hints, Addr); + Result := GetAddrInfo(PAnsiChar(aIP), PAnsiChar(aPort), 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 + 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 := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + {$IFDEF NEXTGEN} + ServEnt := GetServByName(MarshaledAString(TMarshal.AsAnsi(Port)), ProtoEnt^.p_name); + {$ELSE} + ServEnt := GetServByName(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name); + {$ENDIF} + if ServEnt = nil then + Sin.sin_port := htons(StrToIntDef(Port, 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := UInt32(INADDR_BROADCAST) + else + begin + {$IFDEF NEXTGEN} + Sin.sin_addr.s_addr := inet_addr(MarshaledAString(TMarshal.AsAnsi(IP))); + {$ELSE} + Sin.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(IP))); + {$ENDIF} + if Sin.sin_addr.s_addr = UInt32(INADDR_NONE) then + begin + {$IFDEF NEXTGEN} + HostEnt := GetHostByName(MarshaledAString(TMarshal.AsAnsi(IP))); + {$ELSE} + HostEnt := GetHostByName(PAnsiChar(AnsiString(IP))); + {$ENDIF} + Result := WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := UInt32(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: PAnsiChar; + hostlen, servlen: integer; + r: integer; + sa:sockaddr absolute Sin; + byHost, byServ: TBytes; + HostWrapper, ServWrapper: TPtrWrapper; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := string(p); + end + else + begin + // NEXTGEN compatible + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + Setlength(byHost, hostLen); + Setlength(byServ, hostLen); + HostWrapper := TPtrWrapper.Create(@byHost[0]); + ServWrapper := TPtrWrapper.Create(@byServ[0]); + r := getnameinfo(sa, SizeOfVarSin(sin), HostWrapper.ToPointer, hostlen, + ServWrapper.ToPointer, servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := TMarshal.ReadStringAsAnsi(HostWrapper{, NI_MAXHOST}); + 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: AddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: UINT32; + PAdrPtr: PaPInAddr; + i: Integer; + s: string; + InAddr: TInAddr; + aby:TArray; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + {$IFDEF NEXTGEN} + IP := inet_addr(MarshaledAString(TMarshal.AsAnsi(Name))); + {$ELSE} + IP := inet_addr(PAnsiChar(AnsiString(Name))); + {$ENDIF} + if IP = UINT32(INADDR_NONE) then + begin + SynSockCS.Enter; + try + {$IFDEF NEXTGEN} + RemoteHost := GetHostByName(MarshaledAString(TMarshal.AsAnsi(Name))); + {$ELSE} + RemoteHost := GetHostByName(PAnsiChar(AnsiString(Name))); + {$ENDIF} + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + aby := TArray(@InAddr); + s := Format('%d.%d.%d.%d', [aby[0], aby[1], + aby[2], aby[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 := GetAddrInfo(PAnsiChar(AnsiString(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); +{$IFDEF NEXTGEN} + r := getnameinfo(AddrNext^.ai_addr^, AddrNext^.ai_addrlen, + MarshaledAString(TMarshal.AsAnsi(host)), hostlen, MarshaledAString(TMarshal.AsAnsi(serv)), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); +{$ELSE} + r := getnameinfo(AddrNext^.ai_addr^, AddrNext^.ai_addrlen, + PAnsiChar(AnsiString(host)), hostlen, PAnsiChar(AnsiString(serv)), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); +{$ENDIF} + if r = 0 then + begin + host := PChar(host); + IPList.Add(host); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + 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: AddrInfo; + Addr: PAddrInfo; + _Addr: AddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := GetServByName(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(Port, 0) + else + Result := ntohs(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 := GetAddrInfo(nil, PAnsiChar(AnsiString(Port)), Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := ntohs(Addr^.ai_addr^.sa_data[0]); // port + if Addr^.ai_family = AF_INET6 then + Result := ntohs(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + begin + _Addr := Addr^; + FreeAddrInfo(_Addr); + end; + end; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + Hints: AddrInfo; + Addr: PAddrInfo; + _Addr: AddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: UINT32; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := inet_addr(PAnsiChar(AnsiString(IP))); + if IPn <> UINT32(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := string(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 := GetAddrInfo(PAnsiChar(AnsiString(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(AnsiString(host)), hostlen, PAnsiChar(AnsiString(serv)), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; + finally + if Assigned(Addr) then + begin + _Addr := Addr^; + FreeAddrInfo(_Addr); + end; + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + SockEnhancedApi := True; + 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 -Nru cqrprop-0.0.7/src/synapse/sswin32.inc cqrprop-0.0.8/src/synapse/sswin32.inc --- cqrprop-0.0.7/src/synapse/sswin32.inc 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/sswin32.inc 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,1657 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.003.001 | +|==============================================================================| +| Content: Socket Independent Platform Layer - Win32/64 definition include | +|==============================================================================| +| 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)2003-2012. | +| 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' *) + (*$HPPEMIT '#undef NI_MAXHOST' *) + (*$HPPEMIT '#undef NI_MAXSERV' *) + (*$HPPEMIT '#undef NI_NOFQDN' *) + (*$HPPEMIT '#undef NI_NUMERICHOST' *) + (*$HPPEMIT '#undef NI_NAMEREQD' *) + (*$HPPEMIT '#undef NI_NUMERICSERV' *) + (*$HPPEMIT '#undef NI_DGRAM' *) + (*$HPPEMIT '#undef AI_PASSIVE' *) + (*$HPPEMIT '#undef AI_CANONNAME' *) + (*$HPPEMIT '#undef AI_NUMERICHOST' *) + (*$HPPEMIT '#undef EWOULDBLOCK' *) + (*$HPPEMIT '#undef EINPROGRESS' *) + (*$HPPEMIT '#undef EALREADY' *) + (*$HPPEMIT '#undef ENOTSOCK' *) + (*$HPPEMIT '#undef EDESTADDRREQ' *) + (*$HPPEMIT '#undef EMSGSIZE' *) + (*$HPPEMIT '#undef EPROTOTYPE' *) + (*$HPPEMIT '#undef ENOPROTOOPT' *) + (*$HPPEMIT '#undef EPROTONOSUPPORT' *) + (*$HPPEMIT '#undef EOPNOTSUPP' *) + (*$HPPEMIT '#undef EAFNOSUPPORT' *) + (*$HPPEMIT '#undef EADDRINUSE' *) + (*$HPPEMIT '#undef EADDRNOTAVAIL' *) + (*$HPPEMIT '#undef ENETDOWN' *) + (*$HPPEMIT '#undef ENETUNREACH' *) + (*$HPPEMIT '#undef ENETRESET' *) + (*$HPPEMIT '#undef ECONNABORTED' *) + (*$HPPEMIT '#undef ECONNRESET' *) + (*$HPPEMIT '#undef ENOBUFS' *) + (*$HPPEMIT '#undef EISCONN' *) + (*$HPPEMIT '#undef ENOTCONN' *) + (*$HPPEMIT '#undef ETIMEDOUT' *) + (*$HPPEMIT '#undef ECONNREFUSED' *) + (*$HPPEMIT '#undef ELOOP' *) + (*$HPPEMIT '#undef EHOSTUNREACH' *) +{$ENDIF} + +{$IFDEF FPC} + {$IFDEF WIN32} + {$ALIGN OFF} + {$ELSE} + {$PACKRECORDS C} + {$ENDIF} +{$ELSE} + {$IFDEF WIN64} + {$ALIGN ON} + {$MINENUMSIZE 4} + {$ELSE} + {$MINENUMSIZE 4} + {$ALIGN OFF} + {$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.ntohs(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.ntohs(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.ntohs(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; + 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 -Nru cqrprop-0.0.7/src/synapse/synachar.pas cqrprop-0.0.8/src/synapse/synachar.pas --- cqrprop-0.0.7/src/synapse/synachar.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synachar.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 005.002.004 | +| Project : Ararat Synapse | 005.002.005 | |==============================================================================| | Content: Charset conversion support | |==============================================================================| @@ -72,6 +72,11 @@ {$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$ENDIF} +{$IFDEF NEXTGEN} + {$LEGACYIFEND ON} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + unit synachar; interface @@ -79,13 +84,17 @@ uses {$IFNDEF MSWINDOWS} {$IFNDEF FPC} - Libc, + {$IFNDEF POSIX} + Libc, + {$ELSE} + Posix.Langinfo, + {$ENDIF} {$ENDIF} {$ELSE} Windows, {$ENDIF} SysUtils, - synautil, synacode, synaicnv; + synautil, synacode, synaicnv, synafpc; type {:Type with all supported charsets.} @@ -1376,6 +1385,9 @@ NotNeedTransform: Boolean; FromID, ToID: string; begin + if not synaicnv.InitIconvInterface then + DisableIconv := True; + NotNeedTransform := (High(TransformTable) = 0); if (CharFrom = CharTo) and NotNeedTransform then begin @@ -1501,7 +1513,15 @@ function GetCurCP: TMimeChar; begin {$IFNDEF FPC} + {$IFNDEF POSIX} Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME)); + {$ELSE} + {$IFNDEF ANDROID} + Result := GetCPFromID(nl_langinfo(CODESET)); + {$ELSE} + Result := UTF_8; + {$ENDIF} + {$ENDIF} {$ELSE} //How to get system codepage without LIBC? Result := UTF_8; @@ -1736,15 +1756,40 @@ Result := ''; case Value of UCS_2: - Result := #$fe + #$ff; + begin + SetLength(Result, 2); + Result[1] := #$fe; + Result[2] := #$ff; + end; UCS_4: - Result := #$00 + #$00 + #$fe + #$ff; + begin + SetLength(Result, 4); + Result[1] := #$00; + Result[2] := #$00; + Result[3] := #$fe; + Result[4] := #$ff; + end; UCS_2LE: - Result := #$ff + #$fe; + begin + SetLength(Result, 2); + Result[1] := #$ff; + Result[2] := #$fe; + end; UCS_4LE: - Result := #$ff + #$fe + #$00 + #$00; + begin + SetLength(Result, 4); + Result[1] := #$ff; + Result[2] := #$fe; + Result[3] := #$00; + Result[4] := #$00; + end; UTF_8: - Result := #$ef + #$bb + #$bf; + begin + SetLength(Result, 3); + Result[1] := #$ef; + Result[2] := #$bb; + Result[3] := #$bf; + end; end; end; diff -Nru cqrprop-0.0.7/src/synapse/synacode.pas cqrprop-0.0.8/src/synapse/synacode.pas --- cqrprop-0.0.7/src/synapse/synacode.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synacode.pas 2023-04-10 12:51:00.000000000 +0000 @@ -64,12 +64,19 @@ {$WARN SUSPICIOUS_TYPECAST OFF} {$ENDIF} +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + unit synacode; interface uses - SysUtils; + SysUtils + {$IFDEF NEXTGEN} + ,synafpc + {$ENDIF}; type TSpecials = set of AnsiChar; @@ -194,10 +201,10 @@ function DecodeYEnc(const Value: AnsiString): AnsiString; {:Returns a new CRC32 value after adding a new byte of data.} -function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; +function UpdateCrc32(Value: Byte; Crc32: Cardinal): Cardinal; {:return CRC32 from a value string.} -function Crc32(const Value: AnsiString): Integer; +function Crc32(const Value: AnsiString): Cardinal; {:Returns a new CRC16 value after adding a new byte of data.} function UpdateCrc16(Value: Byte; Crc16: Word): Word; @@ -389,7 +396,7 @@ HashByte: array[0..19] of byte; end; - TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); + TMDTransform = procedure(var Buf: array of Integer; const Data: array of Integer); {==============================================================================} @@ -820,7 +827,7 @@ {==============================================================================} -function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; +function UpdateCrc32(Value: Byte; Crc32: Cardinal): Cardinal; begin Result := (Crc32 shr 8) xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; @@ -828,11 +835,11 @@ {==============================================================================} -function Crc32(const Value: AnsiString): Integer; +function Crc32(const Value: AnsiString): Cardinal; var n: Integer; begin - Result := Integer($FFFFFFFF); + Result := $FFFFFFFF; for n := 1 to Length(Value) do Result := UpdateCrc32(Ord(Value[n]), Result); Result := not Result; @@ -875,7 +882,7 @@ MDContext.State[3] := Integer($10325476); end; -procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); +procedure MD5Transform(var Buf: array of Integer; const Data: array of Integer); var A, B, C, D: LongInt; @@ -1380,7 +1387,7 @@ {==============================================================================} -procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); +procedure MD4Transform(var Buf: array of Integer; const Data: array of Integer); var A, B, C, D: LongInt; function LRot32(a, b: longint): longint; diff -Nru cqrprop-0.0.7/src/synapse/synacrypt.pas cqrprop-0.0.8/src/synapse/synacrypt.pas --- cqrprop-0.0.7/src/synapse/synacrypt.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synacrypt.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,2411 @@ +{==============================================================================| +| 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; +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 -Nru cqrprop-0.0.7/src/synapse/synadbg.pas cqrprop-0.0.8/src/synapse/synadbg.pas --- cqrprop-0.0.7/src/synapse/synadbg.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synadbg.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,156 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.001.003 | +|==============================================================================| +| Content: Socket debug tools | +|==============================================================================| +| Copyright (c)2008-2021, 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-2021. | +| 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), 2 * SizeOf(PtrInt)) + 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), 2 * SizeOf(PtrInt)) + d + s + CRLF; + AppendToLog(s); +end; + +initialization +begin + Logfile := changefileext(paramstr(0), '.slog'); +end; + +end. diff -Nru cqrprop-0.0.7/src/synapse/synafpc.pas cqrprop-0.0.8/src/synapse/synafpc.pas --- cqrprop-0.0.7/src/synapse/synafpc.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synafpc.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.003.001 | +| Project : Ararat Synapse | 001.004.000 | |==============================================================================| | Content: Utils for FreePascal compatibility | |==============================================================================| -| Copyright (c)1999-2013, Lukas Gebauer | +| Copyright (c)1999-2022, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -38,6 +38,7 @@ |==============================================================================| | Contributor(s): | | Tomas Hajny (OS2 support) | +| Projeto ACBr | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -45,9 +46,8 @@ {:@exclude} -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} +{$INCLUDE 'jedi.inc'} + {$H+} //old Delphi does not have MSWINDOWS define. {$IFDEF WIN32} @@ -56,25 +56,41 @@ {$ENDIF} {$ENDIF} +{$IFDEF NEXTGEN} + {$LEGACYIFEND ON} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + +{$IfDef DELPHI2009_UP} + {$DEFINE HAS_CHARINSET} +{$EndIf} +{$IfDef FPC} + {$DEFINE HAS_CHARINSET} +{$EndIf} + unit synafpc; interface uses -{$IFDEF FPC} - dynlibs, sysutils; -{$ELSE} - {$IFDEF MSWINDOWS} - Windows; + {$IFDEF FPC} + dynlibs, {$ELSE} - SysUtils; + {$IFDEF DELPHIXE4_UP} + {$IFNDEF NEXTGEN} + System.AnsiStrings, + {$ENDIF} + {$ENDIF} + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF} {$ENDIF} -{$ENDIF} + SysUtils; {$IFDEF FPC} type TLibHandle = dynlibs.TLibHandle; - + function LoadLibrary(ModuleName: PChar): TLibHandle; function FreeLibrary(Module: TLibHandle): LongBool; function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; @@ -82,23 +98,37 @@ {$ELSE} //not FPC type {$IFDEF CIL} - TLibHandle = Integer; - PtrInt = Integer; + TLibHandle = Integer; + PtrInt = Integer; {$ELSE} - TLibHandle = HModule; - {$IFDEF WIN64} - PtrInt = NativeInt; - {$ELSE} - PtrInt = Integer; - {$ENDIF} + TLibHandle = HModule; + {$IFDEF WIN64} + PtrInt = NativeInt; + {$ELSE} + PtrInt = Integer; + {$ENDIF} + {$ENDIF} + + {$IFDEF DELPHI3} + LongWord = DWord; {$ENDIF} - {$IFDEF VER100} - LongWord = DWord; + + {$IFDEF NEXTGEN} // Android FMX + AnsiString = RawByteString; + AnsiChar = UTF8Char; + PAnsiChar = PUTF8Char; + WideString = String; {$ENDIF} {$ENDIF} +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +function StrLComp(const Str1, Str2: PANSIChar; MaxLen: Cardinal): Integer; procedure Sleep(milliseconds: Cardinal); +{$IfNDef HAS_CHARINSET} +function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; +{$EndIf} + implementation @@ -127,10 +157,43 @@ begin Result := 0; end; - {$ELSE} {$ENDIF} +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +begin + {$IfDef FPC} + Result := SysUtils.StrLCopy(Dest, Source, MaxLen); + {$Else} + {$IFDEF DELPHIXE4_UP} + {$IfDef NEXTGEN} + Result := PAnsiChar( System.SysUtils.StrLCopy(PWideChar(Dest^), PWideChar(Source^), MaxLen)^ ); + {$Else} + Result := System.AnsiStrings.StrLCopy(Dest, Source, MaxLen); + {$EndIf} + {$Else} + Result := SysUtils.StrLCopy(Dest, Source, MaxLen); + {$ENDIF} + {$EndIf} +end; + +function StrLComp(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; +begin + {$IfDef FPC} + Result := SysUtils.strlcomp(Str1, Str2, MaxLen); + {$Else} + {$IFDEF DELPHIXE4_UP} + {$IfDef NEXTGEN} + Result := System.SysUtils.StrLComp(PWideChar(Str1^), PWideChar(Str2^), MaxLen); + {$Else} + Result := System.AnsiStrings.StrLComp(Str1, Str2, MaxLen); + {$EndIf} + {$Else} + Result := SysUtils.StrLComp(Str1, Str2, MaxLen); + {$ENDIF} + {$EndIf} +end; + procedure Sleep(milliseconds: Cardinal); begin {$IFDEF MSWINDOWS} @@ -142,7 +205,13 @@ {$ELSE} sysutils.sleep(milliseconds); {$ENDIF} +end; +{$IfNDef HAS_CHARINSET} +function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; +begin + result := C in CharSet; end; +{$EndIf} end. diff -Nru cqrprop-0.0.7/src/synapse/synaicnv.pas cqrprop-0.0.8/src/synapse/synaicnv.pas --- cqrprop-0.0.7/src/synapse/synaicnv.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synaicnv.pas 2023-04-10 12:51:00.000000000 +0000 @@ -72,7 +72,9 @@ synafpc, {$IFNDEF MSWINDOWS} {$IFNDEF FPC} - Libc, + {$IFNDEF POSIX} + Libc, + {$ENDIF} {$ENDIF} SysUtils; {$ELSE} @@ -103,9 +105,9 @@ 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 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; @@ -150,7 +152,7 @@ {$ELSE} type - Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; + 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; @@ -167,7 +169,7 @@ IconvCS: TCriticalSection; Iconvloaded: boolean = false; -function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpen (const tocode, fromcode: AnsiString): iconv_t; begin {$IFDEF CIL} try @@ -184,12 +186,12 @@ {$ENDIF} end; -function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenTranslit (const tocode, fromcode: AnsiString): iconv_t; begin Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); end; -function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; +function SynaIconvOpenIgnore (const tocode, fromcode: AnsiString): iconv_t; begin Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); end; @@ -294,10 +296,10 @@ 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'))); + _iconv_open := GetProcAddress(IconvLibHandle, PChar('libiconv_open')); + _iconv := GetProcAddress(IconvLibHandle, PChar('libiconv')); + _iconv_close := GetProcAddress(IconvLibHandle, PChar('libiconv_close')); + _iconvctl := GetProcAddress(IconvLibHandle, PChar('libiconvctl')); {$ENDIF} Result := True; Iconvloaded := True; diff -Nru cqrprop-0.0.7/src/synapse/synamisc.pas cqrprop-0.0.8/src/synapse/synamisc.pas --- cqrprop-0.0.7/src/synapse/synamisc.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synamisc.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,644 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.004.000 | +|==============================================================================| +| Content: misc. procedures and functions | +|==============================================================================| +| Copyright (c)1999-2022, 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-2022. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Miscellaneous 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} + +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS 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 POSIX} + ,Types,Posix.Stdlib +{$ELSE} + {$IFDEF UNIX} + {$IFNDEF FPC} + , Libc + {$ENDIF} + {$ELSE} + , Windows + {$ENDIF} +{$ENDIF} +; + +Type + {:@abstract(This record contains information about proxy settings.)} + TProxySetting = record + Host: string; + Port: string; + Bypass: string; + ResultCode: integer; + Autodetected: boolean; + end; + +{:With this function you can turn on a computer on the network, if this computer + supports Wake-on-LAN feature. You need the MAC address + (network card identifier) of the computer. You can also assign a target IP + addres. If you do not specify it, then broadcast is used to deliver magic + wake-on-LAN packet. + However broadcasts work only on your local network. When you need to wake-up a + 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 the system. If more than one DNS server + is defined, then the result is comma-delimited.} +function GetDNS: string; + +{:Read InternetExplorer 5.0+ proxy setting for given protocol. This function +works only on windows!} +function GetIEProxy(protocol: string): TProxySetting; + +{:Return all known IP addresses of required type on the local system. Addresses are divided by +comma/comma-delimited.} +function GetLocalIPsFamily(value: TSocketFamily): string; + +{:Return all known IP addresses on the local system. Addresses are divided by +comma/comma-delimited.} +function GetLocalIPs: string; + +{$IFDEF MSWINDOWS} +{:Autodetect system proxy setting for specified URL. This function +works only on windows!} +function GetProxyForURL(const AURL: WideString): TProxySetting; +{$ENDIF} + +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 + AnsiChar(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; +{$IFNDEF MSWINDOWS} +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; + Result.ResultCode := -1; + Result.Autodetected := false; +end; +{$ELSE} +type + PInternetPerConnOption = ^INTERNET_PER_CONN_OPTION; + INTERNET_PER_CONN_OPTION = record + dwOption: DWORD; + case Integer of + 0: (dwValue: DWORD); +// 1: (pszValue:LPTSTR); + 1: (pszValue:PAnsiChar); + 2: (ftValue: FILETIME); + end; + + PInternetPerConnOptionList = ^INTERNET_PER_CONN_OPTION_LIST; + INTERNET_PER_CONN_OPTION_LIST = record + dwSize :DWORD; +// pszConnection :LPTSTR; + pszConnection :PAnsiChar; + dwOptionCount :DWORD; + dwOptionError :DWORD; + pOptions :PInternetPerConnOption; + end; +const + INTERNET_PER_CONN_FLAGS = 1; + INTERNET_PER_CONN_PROXY_SERVER = 2; + INTERNET_PER_CONN_PROXY_BYPASS = 3; + INTERNET_PER_CONN_AUTOCONFIG_URL = 4; + INTERNET_PER_CONN_AUTODISCOVERY_FLAGS = 5; + PROXY_TYPE_DIRECT = $00000001; // direct to net + PROXY_TYPE_PROXY = $00000002; // via named proxy + PROXY_TYPE_AUTO_PROXY_URL = $00000004; // autoproxy URL + PROXY_TYPE_AUTO_DETECT = $00000008; // use autoproxy detection + AUTO_PROXY_FLAG_USER_SET = $00000001; // user changed this setting + AUTO_PROXY_FLAG_ALWAYS_DETECT = $00000002; // force detection even when its not needed + AUTO_PROXY_FLAG_DETECTION_RUN = $00000004; // detection has been run + AUTO_PROXY_FLAG_MIGRATED = $00000008; // migration has just been done + AUTO_PROXY_FLAG_DONT_CACHE_PROXY_RESULT = $00000010; // don't cache result of host=proxy name + AUTO_PROXY_FLAG_CACHE_INIT_RUN = $00000020; // don't initalize and run unless URL expired + AUTO_PROXY_FLAG_DETECTION_SUSPECT = $00000040; // if we're on a LAN & Modem, with only one IP, bad?!? + INTERNET_OPTION_PER_CONNECTION_OPTION = 75; + WininetDLL = 'WININET.DLL'; +var + WininetModule: THandle; + Option : array[0..4] of INTERNET_PER_CONN_OPTION; + List : INTERNET_PER_CONN_OPTION_LIST; + 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 := ''; + Result.ResultCode := 0; + Result.Autodetected := false; + 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'; + ProxyList := TStringList.Create; + try + Option[0].dwOption := INTERNET_PER_CONN_AUTOCONFIG_URL; + Option[1].dwOption := INTERNET_PER_CONN_AUTODISCOVERY_FLAGS; + Option[2].dwOption := INTERNET_PER_CONN_FLAGS; + Option[3].dwOption := INTERNET_PER_CONN_PROXY_BYPASS; + Option[4].dwOption := INTERNET_PER_CONN_PROXY_SERVER; + + List.dwSize := SizeOf(INTERNET_PER_CONN_OPTION_LIST); + List.pszConnection := nil; // LAN + List.dwOptionCount := 5; + List.dwOptionError := 0; + List.pOptions := @Option; + + + Err := InternetQueryOption(nil, INTERNET_OPTION_PER_CONNECTION_OPTION, @List, List.dwSize); + if Err then + begin + ProxyList.CommaText := ReplaceString(Option[4].pszValue, ' ', ','); + 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(Option[3].pszValue, ' ', ','); + end; + finally + ProxyList.Free; + end; + finally + FreeLibrary(WininetModule); + end; +end; +{$ENDIF} + +{==============================================================================} + +function GetLocalIPsFamily(value: TSocketFamily): string; +var + TcpSock: TTCPBlockSocket; + ipList: TStringList; +begin + Result := ''; + ipList := TStringList.Create; + try + TcpSock := TTCPBlockSocket.create; + try + if value <> SF_Any then + TcpSock.family := value; + TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); + Result := ipList.CommaText; + finally + TcpSock.Free; + end; + finally + ipList.Free; + end; +end; + +function GetLocalIPs: string; +begin + Result := GetLocalIPsFamily(SF_Any); +end; + +{==============================================================================} + +{$IFDEF MSWINDOWS} +function GetProxyForURL(const AURL: WideString): TProxySetting; +type + HINTERNET = Pointer; + INTERNET_PORT = Word; + PWinHTTPProxyInfo = ^TWinHTTPProxyInfo; + WINHTTP_PROXY_INFO = record + dwAccessType: DWORD; + lpszProxy: LPWSTR; + lpszProxyBypass: LPWSTR; + end; + TWinHTTPProxyInfo = WINHTTP_PROXY_INFO; + LPWINHTTP_PROXY_INFO = PWinHTTPProxyInfo; + PWinHTTPAutoProxyOptions = ^TWinHTTPAutoProxyOptions; + WINHTTP_AUTOPROXY_OPTIONS = record + dwFlags: DWORD; + dwAutoDetectFlags: DWORD; + lpszAutoConfigUrl: LPCWSTR; + lpvReserved: Pointer; + dwReserved: DWORD; + fAutoLogonIfChallenged: BOOL; + end; + TWinHTTPAutoProxyOptions = WINHTTP_AUTOPROXY_OPTIONS; + LPWINHTTP_AUTOPROXY_OPTIONS = PWinHTTPAutoProxyOptions; + PWinHTTPCurrentUserIEProxyConfig = ^TWinHTTPCurrentUserIEProxyConfig; + WINHTTP_CURRENT_USER_IE_PROXY_CONFIG = record + fAutoDetect: BOOL; + lpszAutoConfigUrl: LPWSTR; + lpszProxy: LPWSTR; + lpszProxyBypass: LPWSTR; + end; + TWinHTTPCurrentUserIEProxyConfig = WINHTTP_CURRENT_USER_IE_PROXY_CONFIG; + LPWINHTTP_CURRENT_USER_IE_PROXY_CONFIG = PWinHTTPCurrentUserIEProxyConfig; +const + WINHTTP_NO_REFERER = nil; + WINHTTP_NO_PROXY_NAME = nil; + WINHTTP_NO_PROXY_BYPASS = nil; + WINHTTP_DEFAULT_ACCEPT_TYPES = nil; + WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0; + WINHTTP_ACCESS_TYPE_NO_PROXY = 1; + WINHTTP_OPTION_PROXY = 38; + WINHTTP_OPTION_PROXY_USERNAME = $1002; + WINHTTP_OPTION_PROXY_PASSWORD = $1003; + WINHTTP_AUTOPROXY_AUTO_DETECT = $00000001; + WINHTTP_AUTOPROXY_CONFIG_URL = $00000002; + WINHTTP_AUTO_DETECT_TYPE_DHCP = $00000001; + WINHTTP_AUTO_DETECT_TYPE_DNS_A = $00000002; + WINHTTP_FLAG_BYPASS_PROXY_CACHE = $00000100; + WINHTTP_FLAG_REFRESH = WINHTTP_FLAG_BYPASS_PROXY_CACHE; +var + WinHttpModule: THandle; + Session: HINTERNET; + AutoDetectProxy: Boolean; + WinHttpProxyInfo: TWinHTTPProxyInfo; + AutoProxyOptions: TWinHTTPAutoProxyOptions; + IEProxyConfig: TWinHTTPCurrentUserIEProxyConfig; + WinHttpOpen: function (pwszUserAgent: LPCWSTR; dwAccessType: DWORD; + pwszProxyName, pwszProxyBypass: LPCWSTR; dwFlags: DWORD): HINTERNET; stdcall; + WinHttpConnect: function(hSession: HINTERNET; pswzServerName: LPCWSTR; + nServerPort: INTERNET_PORT; dwReserved: DWORD): HINTERNET; stdcall; + WinHttpOpenRequest: function(hConnect: HINTERNET; pwszVerb: LPCWSTR; + pwszObjectName: LPCWSTR; pwszVersion: LPCWSTR; pwszReferer: LPCWSTR; + ppwszAcceptTypes: PLPWSTR; dwFlags: DWORD): HINTERNET; stdcall; + WinHttpQueryOption: function(hInet: HINTERNET; dwOption: DWORD; + lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; + WinHttpGetProxyForUrl: function(hSession: HINTERNET; lpcwszUrl: LPCWSTR; + pAutoProxyOptions: LPWINHTTP_AUTOPROXY_OPTIONS; + var pProxyInfo: WINHTTP_PROXY_INFO): BOOL; stdcall; + WinHttpGetIEProxyConfigForCurrentUser: function( + var pProxyInfo: WINHTTP_CURRENT_USER_IE_PROXY_CONFIG): BOOL; stdcall; + WinHttpCloseHandle: function(hInternet: HINTERNET): BOOL; stdcall; +begin + Result.Host := ''; + Result.Port := ''; + Result.Bypass := ''; + Result.ResultCode := 0; + Result.Autodetected := false; + WinHttpModule := LoadLibrary('winhttp.dll'); + if WinHttpModule = 0 then + exit; + try + WinHttpOpen := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpOpen'))); + if @WinHttpOpen = nil then + Exit; + WinHttpConnect := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpConnect'))); + if @WinHttpConnect = nil then + Exit; + WinHttpOpenRequest := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpOpenRequest'))); + if @WinHttpOpenRequest = nil then + Exit; + WinHttpQueryOption := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpQueryOption'))); + if @WinHttpQueryOption = nil then + Exit; + WinHttpGetProxyForUrl := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpGetProxyForUrl'))); + if @WinHttpGetProxyForUrl = nil then + Exit; + WinHttpGetIEProxyConfigForCurrentUser := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpGetIEProxyConfigForCurrentUser'))); + if @WinHttpGetIEProxyConfigForCurrentUser = nil then + Exit; + WinHttpCloseHandle := GetProcAddress(WinHttpModule,PAnsiChar(AnsiString('WinHttpCloseHandle'))); + if @WinHttpCloseHandle = nil then + Exit; + + AutoDetectProxy := False; + FillChar(AutoProxyOptions, SizeOf(AutoProxyOptions), 0); + if WinHttpGetIEProxyConfigForCurrentUser(IEProxyConfig) then + begin + if IEProxyConfig.fAutoDetect then + begin + AutoProxyOptions.dwFlags := WINHTTP_AUTOPROXY_AUTO_DETECT; + AutoProxyOptions.dwAutoDetectFlags := WINHTTP_AUTO_DETECT_TYPE_DHCP or + WINHTTP_AUTO_DETECT_TYPE_DNS_A; + AutoDetectProxy := True; + end; + if IEProxyConfig.lpszAutoConfigURL <> '' then + begin + AutoProxyOptions.dwFlags := AutoProxyOptions.dwFlags or + WINHTTP_AUTOPROXY_CONFIG_URL; + AutoProxyOptions.lpszAutoConfigUrl := IEProxyConfig.lpszAutoConfigUrl; + AutoDetectProxy := True; + end; + if not AutoDetectProxy then + begin + Result.Host := IEProxyConfig.lpszProxy; + Result.Bypass := IEProxyConfig.lpszProxyBypass; + Result.Autodetected := false; + end; + end + else + begin + AutoProxyOptions.dwFlags := WINHTTP_AUTOPROXY_AUTO_DETECT; + AutoProxyOptions.dwAutoDetectFlags := WINHTTP_AUTO_DETECT_TYPE_DHCP or + WINHTTP_AUTO_DETECT_TYPE_DNS_A; + AutoDetectProxy := True; + end; + if AutoDetectProxy then + begin + Session := WinHttpOpen(nil, WINHTTP_ACCESS_TYPE_DEFAULT_PROXY, + WINHTTP_NO_PROXY_NAME, WINHTTP_NO_PROXY_BYPASS, 0); + if Assigned(Session) then + try + if WinHttpGetProxyForUrl(Session, LPCWSTR(AURL), + @AutoProxyOptions, WinHttpProxyInfo) then + begin + Result.Host := WinHttpProxyInfo.lpszProxy; + Result.Bypass := WinHttpProxyInfo.lpszProxyBypass; + Result.Autodetected := True; + end + else + Result.ResultCode := GetLastError; + finally + WinHttpCloseHandle(Session); + end + else + Result.ResultCode := GetLastError; + end; + if Result.Host <> '' then + begin + Result.Port := Trim(SeparateRight(Result.Host, ':')); + Result.Host := Trim(SeparateLeft(Result.Host, ':')); + end; + finally + FreeLibrary(WinHttpModule); + end; +end; +{$ENDIF} + + +end. diff -Nru cqrprop-0.0.7/src/synapse/synaser.pas cqrprop-0.0.8/src/synapse/synaser.pas --- cqrprop-0.0.7/src/synapse/synaser.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synaser.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 007.006.001 | +| Project : Ararat Synapse | 007.007.001 | |==============================================================================| | Content: Serial port support | |==============================================================================| -| Copyright (c)2001-2017, Lukas Gebauer | +| Copyright (c)2001-2023, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2017. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2023. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -83,14 +83,39 @@ {$ENDIF} {$ENDIF} +{$IFDEF UNIX} + {$DEFINE USE_LINUX_LOCK} +{$ENDIF} + +{$IFDEF ANDROID} + {$DEFINE UNIX} + {$UNDEF USE_LINUX_LOCK} +{$ENDIF} + {$IFDEF FPC} {$MODE DELPHI} {$IFDEF MSWINDOWS} - {$ASMMODE intel} + {$IFDEF CPUI386} + {$ASMMODE INTEL} + {$ENDIF} + {$IFDEF CPUX86_64} + {$ASMMODE INTEL} + {$ENDIF} {$ENDIF} {define working mode w/o LIBC for fpc} {$DEFINE NO_LIBC} {$ENDIF} + +{$IFDEF POSIX} + {$WARN UNIT_PLATFORM OFF} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} + +{$IFDEF NEXTGEN} + {$LEGACYIFEND ON} + {$ZEROBASEDSTRINGS OFF} +{$ENDIF} + {$Q-} {$H+} {$M+} @@ -101,11 +126,18 @@ uses {$IFNDEF MSWINDOWS} - {$IFNDEF NO_LIBC} - Libc, - KernelIoctl, + {$IFDEF POSIX} + Posix.Termios, Posix.Fcntl, Posix.Unistd, Posix.Stropts, Posix.SysSelect, Posix.SysTime, + {$IFDEF LINUX} + Linuxapi.KernelIoctl, + {$ENDIF} {$ELSE} - termio, baseunix, unix, + {$IFNDEF NO_LIBC} + Libc, + KernelIoctl, + {$ELSE} + termio, baseunix, unix, + {$ENDIF} {$ENDIF} {$IFNDEF FPC} Types, @@ -127,6 +159,7 @@ LockfileDirectory = '/var/lock'; {HGJ} PortIsClosed = -1; {HGJ} + ErrAccessDenied = 9990; {DSA} ErrAlreadyOwned = 9991; {HGJ} ErrAlreadyInUse = 9992; {HGJ} ErrWrongParameter = 9993; {HGJ} @@ -198,9 +231,13 @@ const {$IFDEF UNIX} {$IFDEF BSD} - MaxRates = 18; //MAC + MaxRates = 18; //MAC {$ELSE} - MaxRates = 30; //UNIX + {$IFDEF CPUARM} + MaxRates = 19; //CPUARM + {$ELSE} + MaxRates = 30; //UNIX + {$ENDIF} {$ENDIF} {$ELSE} MaxRates = 19; //WIN @@ -229,6 +266,7 @@ {$IFNDEF BSD} ,(460800, B460800) {$IFDEF UNIX} + {$IFNDEF CPUARM} ,(500000, B500000), (576000, B576000), (921600, B921600), @@ -240,6 +278,7 @@ (3000000, B3000000), (3500000, B3500000), (4000000, B4000000) + {$ENDIF} {$ENDIF} {$ENDIF} ); @@ -250,10 +289,27 @@ O_SYNC = $0080; { synchronous writes } {$ENDIF} +{$IFDEF ANDROID} +const + TIOCMSET = $5418; + TIOCMGET = $5415; + TCSBRK = $5409; +{$ENDIF} + const sOK = 0; sErr = integer(-1); +{$IFDEF POSIX} +const + TIOCM_DTR = $002; + TIOCM_RTS = $004; + TIOCM_CTS = $020; + TIOCM_CAR = $040; + TIOCM_RNG = $080; + TIOCM_DSR = $100; +{$ENDIF} + type {:Possible status event types for @link(THookSerialStatus)} @@ -330,9 +386,11 @@ procedure GetComNr(Value: string); virtual; function PreTestFailing: boolean; virtual;{HGJ} function TestCtrlLine: Boolean; virtual; -{$IFDEF UNIX} +{$IFNDEF MSWINDOWS} procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; +{$ENDIF} +{$IFDEF USE_LINUX_LOCK} function ReadLockfile: integer; virtual; function LockfileName: String; virtual; procedure CreateLockfile(PidNr: integer); virtual; @@ -343,7 +401,7 @@ {: data Control Block with communication parameters. Usable only when you need to call API directly.} DCB: Tdcb; -{$IFDEF UNIX} +{$IFNDEF MSWINDOWS} TermiosStruc: termios; {$ENDIF} {:Object constructor.} @@ -621,7 +679,7 @@ {:Raise Synaser error with ErrNumber code. Usually used by internal routines.} procedure RaiseSynaError(ErrNumber: integer); virtual; -{$IFDEF UNIX} +{$IFDEF USE_LINUX_LOCK} function cpomComportAccessible: boolean; virtual;{HGJ} procedure cpomReleaseComport; virtual; {HGJ} {$ENDIF} @@ -796,7 +854,7 @@ end; if InstanceActive then begin - {$IFDEF UNIX} + {$IFDEF USE_LINUX_LOCK} if FLinuxLock then cpomReleaseComport; {$ENDIF} @@ -871,7 +929,7 @@ sleep(x); end; end; - Next := GetTick + Trunc((Length / MaxB) * 1000); + Next := GetTick + LongWord(Trunc((Length / MaxB) * 1000)); end; end; @@ -935,23 +993,34 @@ {$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} + {$IFDEF USE_LINUX_LOCK} + // Comport already owned by another process? {HGJ} + if FLinuxLock then + if not cpomComportAccessible then + begin + if FileExists(LockfileName) then + RaiseSynaError(ErrAlreadyOwned) + else + RaiseSynaError(ErrAccessDenied); + + Exit; + end; + {$ENDIF} + + {$IFNDEF FPC} + {$IFDEF POSIX} + FHandle := open(MarshaledAString(AnsiString(FDevice)), O_RDWR or O_SYNC); + {$ELSE} + FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); + {$ENDIF} + {$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} + {$IFDEF USE_LINUX_LOCK} if FLastError <> sOK then if FLinuxLock then cpomReleaseComport; @@ -988,7 +1057,7 @@ begin SetSynaError(ErrNoDeviceAnswer); FileClose(FHandle); {HGJ} - {$IFDEF UNIX} + {$IFDEF USE_LINUX_LOCK} if FLinuxLock then cpomReleaseComport; {HGJ} {$ENDIF} {HGJ} @@ -1637,7 +1706,11 @@ procedure TBlockSerial.SetCommState; begin DcbToTermios(dcb, termiosstruc); - SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); + {$IfDef POSIX} + ioctl(Fhandle, TCSANOW, PInteger(@TermiosStruc)); + {$Else} + SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); + {$EndIf} ExceptCheck; end; {$ELSE} @@ -1800,7 +1873,7 @@ {$IFNDEF MSWINDOWS} function TBlockSerial.CanRead(Timeout: integer): boolean; var - FDSet: TFDSet; + FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF}; TimeVal: PTimeVal; TimeV: TTimeVal; x: Integer; @@ -1812,7 +1885,7 @@ TimeVal := nil; {$IFNDEF FPC} FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); + {$IFDEF POSIX}_FD_SET{$ELSE}FD_SET{$ENDIF}(FHandle, FDSet); x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); {$ELSE} fpFD_ZERO(FDSet); @@ -1842,7 +1915,7 @@ {$IFNDEF MSWINDOWS} function TBlockSerial.CanWrite(Timeout: integer): boolean; var - FDSet: TFDSet; + FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF}; TimeVal: PTimeVal; TimeV: TTimeVal; x: Integer; @@ -1854,7 +1927,7 @@ TimeVal := nil; {$IFNDEF FPC} FD_ZERO(FDSet); - FD_SET(FHandle, FDSet); + {$IFDEF POSIX}_FD_SET{$ELSE}FD_SET{$ENDIF}(FHandle, FDSet); x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); {$ELSE} fpFD_ZERO(FDSet); @@ -1871,8 +1944,10 @@ end; {$ELSE} function TBlockSerial.CanWrite(Timeout: integer): boolean; +{$IFDEF WIN32} var t: LongWord; +{$ENDIF} begin Result := SendingData = 0; if not Result then @@ -1929,9 +2004,20 @@ end; procedure TBlockSerial.Flush; +var + Data : Integer; begin {$IFNDEF MSWINDOWS} - SerialCheck(tcdrain(FHandle)); + {$IFDEF ANDROID} + Data := 1; + {$IFNDEF FPC} + ioctl(FHandle, TCSBRK, 1); + {$ELSE} + FpIOCtl(FHandle, TCSBRK, @Data); + {$ENDIF} + {$ELSE} + SerialCheck(tcdrain(FHandle)); + {$ENDIF} {$ELSE} SetSynaError(sOK); if not Flushfilebuffers(FHandle) then @@ -2087,7 +2173,7 @@ break; if s = 'NO DIALTONE' then break; - if Pos('CONNECT', s) = 1 then + if Pos('CONNECT', {$IFDEF UNICODE} string {$ENDIF} (s)) = 1 then begin FAtResult := True; break; @@ -2186,7 +2272,7 @@ Ownership Manager. } -{$IFDEF UNIX} +{$IFDEF USE_LINUX_LOCK} function TBlockSerial.LockfileName: String; var @@ -2198,8 +2284,13 @@ procedure TBlockSerial.CreateLockfile(PidNr: integer); var - f: TextFile; s: string; +{$IFDEF FPC} + m: Word; + FS: TFileStream; +{$ELSE} + f: TextFile; +{$ENDIF} begin // Create content for file s := IntToStr(PidNr); @@ -2207,6 +2298,7 @@ s := ' ' + s; // Create file try +{$IFNDEF FPC} AssignFile(f, LockfileName); try Rewrite(f); @@ -2214,6 +2306,21 @@ finally CloseFile(f); end; +{$ELSE} + s := s + sLineBreak; + if FileExists(LockfileName) then + m := fmOpenReadWrite + else + m := fmCreate; + FS := TFileStream.Create(LockfileName, m or fmShareDenyWrite); + try + FS.Seek(0, soEnd); + FS.Write(Pointer(s)^, Length(s)); + finally + FS.Free ; + end; +{$ENDIF} + // Allow all users to enjoy the benefits of cpom s := 'chmod a+rw ' + LockfileName; {$IFNDEF FPC} @@ -2252,7 +2359,7 @@ begin Filename := LockfileName; {$IFNDEF FPC} - MyPid := Libc.getpid; + MyPid := {$IFNDEF POSIX}Libc.{$ENDIF}getpid; {$ELSE} MyPid := fpGetPid; {$ENDIF} @@ -2260,20 +2367,20 @@ if not DirectoryExists(LockfileDirectory) then CreateDir(LockfileDirectory); // Check the Lockfile - if not FileExists (Filename) then + if not FileExists(Filename) then begin // comport is not locked. Lock it for us. CreateLockfile(MyPid); - result := true; + result := FileExists(Filename); 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 + if {$IFNDEF POSIX}Libc.{$ENDIF}getsid(ReadLockfile) = -1 then begin // Lockfile was left from former desaster DeleteFile(Filename); // error recovery CreateLockfile(MyPid); - result := true; + result := FileExists(Filename); exit; end; {$ENDIF} @@ -2319,13 +2426,15 @@ {$ENDIF} {$IFNDEF MSWINDOWS} function GetSerialPortNames: string; +const + ATTR = {$IFDEF POSIX}$7FFFFFFF{$ELSE}$FFFFFFFF{$ENDIF}; var sr : TSearchRec; begin Result := ''; - if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then + if FindFirst('/dev/ttyS*', ATTR, sr) = 0 then repeat - if (sr.Attr and $FFFFFFFF) = Sr.Attr then + if (sr.Attr and ATTR) = Sr.Attr then begin if Result <> '' then Result := Result + ','; @@ -2333,18 +2442,18 @@ end; until FindNext(sr) <> 0; FindClose(sr); - if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin + if FindFirst('/dev/ttyUSB*', ATTR, sr) = 0 then begin repeat - if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin + if (sr.Attr and ATTR) = Sr.Attr then begin if Result <> '' then Result := Result + ','; Result := Result + '/dev/' + sr.Name; end; until FindNext(sr) <> 0; end; FindClose(sr); - if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin + if FindFirst('/dev/ttyAM*', ATTR, sr) = 0 then begin repeat - if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin + if (sr.Attr and ATTR) = Sr.Attr then begin if Result <> '' then Result := Result + ','; Result := Result + '/dev/' + sr.Name; end; @@ -2354,4 +2463,4 @@ end; {$ENDIF} -end. \ No newline at end of file +end. diff -Nru cqrprop-0.0.7/src/synapse/synautil.pas cqrprop-0.0.8/src/synapse/synautil.pas --- cqrprop-0.0.7/src/synapse/synautil.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synautil.pas 2023-04-10 12:51:00.000000000 +0000 @@ -59,6 +59,11 @@ {$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN SUSPICIOUS_TYPECAST OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + +{$IFDEF NEXTGEN} + {$ZEROBASEDSTRINGS OFF} {$ENDIF} unit synautil; @@ -77,7 +82,7 @@ {$ENDIF OS2} {$ELSE FPC} {$IFDEF POSIX} - Posix.Base, Posix.Time, Posix.SysTypes, Posix.SysTime, Posix.Stdio, + Posix.Base, Posix.Time, Posix.SysTypes, Posix.SysTime, Posix.Stdio, Posix.Unistd, {$ELSE} Libc, {$ENDIF} @@ -86,6 +91,9 @@ {$IFDEF CIL} System.IO, {$ENDIF} +{$IFDEF DELPHIX_SEATTLE_UP} + AnsiStrings, +{$ENDIF} SysUtils, Classes, SynaFpc; {$IFDEF VER100} @@ -1843,7 +1851,7 @@ if Dir = '' then begin Path := StringOfChar(#0, MAX_PATH); - x := GetTempPath(Length(Path), PChar(Path)); + {x :=} GetTempPath(Length(Path), PChar(Path)); Path := PChar(Path); end else @@ -1917,7 +1925,7 @@ procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer); begin ABol := APtr; - while (APtrAETX then exit; - if strlcomp(MatchPos,#13#10,2)=0 then + if SynaFpc.strlcomp(MatchPos,#13#10,2)=0 then inc(MatchPos,2); if (MatchPos+2+Lng)>AETX then exit; - if strlcomp(MatchPos,'--',2)<>0 then + if SynaFpc.strlcomp(MatchPos,'--',2)<>0 then exit; inc(MatchPos,2); - if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then + if SynaFpc.strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then exit; inc(MatchPos,Lng); - if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + if ((MatchPos+2)<=AEtx) and (SynaFpc.strlcomp(MatchPos,#13#10,2)=0) then inc(MatchPos,2); Result := MatchPos; end; @@ -2084,10 +2092,10 @@ MatchPos := MatchBoundary(ABOL,AETX,ABoundary); if not Assigned(MatchPos) then exit; - if strlcomp(MatchPos,'--',2)<>0 then + if SynaFpc.strlcomp(MatchPos,'--',2)<>0 then exit; inc(MatchPos,2); - if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then + if (MatchPos+2<=AEtx) and (SynaFpc.strlcomp(MatchPos,#13#10,2)=0) then inc(MatchPos,2); Result := MatchPos; end; diff -Nru cqrprop-0.0.7/src/synapse/synsock.pas cqrprop-0.0.8/src/synapse/synsock.pas --- cqrprop-0.0.7/src/synapse/synsock.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/synsock.pas 2023-04-10 12:51:00.000000000 +0000 @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 005.002.003 | +| Project : Ararat Synapse | 005.002.004 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| -| Copyright (c)1999-2013, Lukas Gebauer | +| Copyright (c)1999-2022, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2013. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2022. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -72,15 +72,15 @@ {$I ssfpc.inc} {$ENDIF OS2} {$ELSE} - {$I sslinux.inc} + {$IFDEF POSIX} + {$I ssposix.inc} //experimental! + {$ELSE} + {$I sslinux.inc} + {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF} -{$IFDEF POSIX} -//Posix.SysSocket - {$I ssposix.inc} //experimental! -{$ENDIF} end. diff -Nru cqrprop-0.0.7/src/synapse/tlntsend.pas cqrprop-0.0.8/src/synapse/tlntsend.pas --- cqrprop-0.0.7/src/synapse/tlntsend.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/tlntsend.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,364 @@ +{==============================================================================| +| 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. diff -Nru cqrprop-0.0.7/src/synapse/tzutil.pas cqrprop-0.0.8/src/synapse/tzutil.pas --- cqrprop-0.0.7/src/synapse/tzutil.pas 1970-01-01 00:00:00.000000000 +0000 +++ cqrprop-0.0.8/src/synapse/tzutil.pas 2023-04-10 12:51:00.000000000 +0000 @@ -0,0 +1,702 @@ +//Unit with timezone support for some Freepascal platforms. +//Tomas Hajny + +unit tzutil; + + +interface + +type + DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX); + +(* Initialized to default values *) +const + TZName: string = ''; + TZDSTName: string = ''; + TZOffset: longint = 0; + DSTOffset: longint = 0; + DSTStartMonth: byte = 4; + DSTStartWeek: shortint = 1; + DSTStartDay: word = 0; + DSTStartSec: cardinal = 7200; + DSTEndMonth: byte = 10; + DSTEndWeek: shortint = -1; + DSTEndDay: word = 0; + DSTEndSec: cardinal = 10800; + DSTStartSpecType: DSTSpecType = DSTMonthWeekDay; + DSTEndSpecType: DSTSpecType = DSTMonthWeekDay; + +function TZSeconds: longint; +(* Return current offset from UTC in seconds while respecting DST *) + +implementation + +uses + Dos; + +function TZSeconds: longint; +const + MonthDays: array [1..12] of byte = + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + MonthEnds: array [1..12] of word = + (31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365); +var + Y, Mo, D, WD, H, Mi, S, S100: word; + MS, DS, ME, DE: byte; + L: longint; + Second: cardinal; + AfterDSTStart, BeforeDSTEnd: boolean; + +function LeapDay: byte; +begin + if (Y mod 400 = 0) or (Y mod 100 <> 0) and (Y mod 4 = 0) then + LeapDay := 1 + else + LeapDay := 0; +end; + +function FirstDay (MM: byte): byte; +(* What day of week (0-6) is the first day of month MM? *) +var + DD: longint; +begin + if MM < Mo then + begin + DD := D + MonthEnds [Pred (Mo)]; + if MM > 1 then + Dec (DD, MonthEnds [Pred (MM)]); + if (MM <= 2) and (Mo > 2) then + Inc (DD, LeapDay); + end + else + if MM > Mo then + begin + DD := - MonthDays [Mo] + D - MonthEnds [Pred (MM)] + MonthEnds [Mo]; + if (Mo <= 2) and (MM > 2) then + Dec (DD, LeapDay); + end + else +(* M = MM *) + DD := D; + DD := WD - DD mod 7 + 1; + if DD < 0 then + FirstDay := DD + 7 + else + FirstDay := DD mod 7; +end; + +begin + TZSeconds := TZOffset; + if DSTOffset <> TZOffset then + begin + GetDate (Y, Mo, D, WD); + GetTime (H, Mi, S, S100); + Second := cardinal (H) * 3600 + Mi * 60 + S; + + if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay) + then + begin + MS := DSTStartMonth; + if DSTStartSpecType = DSTMonthDay then + DS := DSTStartDay + else + begin + DS := FirstDay (DSTStartMonth); + if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then + if DSTStartDay < DS then + DS := DSTStartWeek * 7 + DSTStartDay - DS + 1 + else + DS := Pred (DSTStartWeek) * 7 + DSTStartDay - DS + 1 + else +(* Last week in month *) + begin + DS := DS + MonthDays [MS] - 1; + if MS = 2 then + Inc (DS, LeapDay); + DS := DS mod 7; + if DS < DSTStartDay then + DS := DS + 7 - DSTStartDay + else + DS := DS - DSTStartDay; + DS := MonthDays [MS] - DS; + end; + end; + end + else + begin +(* Julian day *) + L := DSTStartDay; + if (DSTStartSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + MS := 1; + DS := L; + end + else + if (L <= 59) or + (DSTStartSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + MS := 2; + DS := DSTStartDay - 31; + end + else + begin + MS := 3; + while (MS < 12) and (MonthEnds [MS] > L) do + Inc (MS); + DS := L - MonthEnds [Pred (MS)]; + end; + end; + + if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then + begin + ME := DSTEndMonth; + if DSTEndSpecType = DSTMonthDay then + DE := DSTEndDay + else + begin + DE := FirstDay (DSTEndMonth); + if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then + if DSTEndDay < DE then + DE := DSTEndWeek * 7 + DSTEndDay - DE + 1 + else + DE := Pred (DSTEndWeek) * 7 + DSTEndDay - DE + 1 + else +(* Last week in month *) + begin + DE := DE + MonthDays [ME] - 1; + if ME = 2 then + Inc (DE, LeapDay); + DE := DE mod 7; + if DE < DSTEndDay then + DE := DE + 7 - DSTEndDay + else + DE := DE - DSTEndDay; + DE := MonthDays [ME] - DE; + end; + end; + end + else + begin +(* Julian day *) + L := DSTEndDay; + if (DSTEndSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + ME := 1; + DE := L; + end + else + if (L <= 59) or + (DSTEndSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + ME := 2; + DE := DSTEndDay - 31; + end + else + begin + ME := 3; + while (ME < 12) and (MonthEnds [ME] > L) do + Inc (ME); + DE := L - MonthEnds [Pred (ME)]; + end; + end; + + if Mo < MS then + AfterDSTStart := false + else + if Mo > MS then + AfterDSTStart := true + else + if D < DS then + AfterDSTStart := false + else + if D > DS then + AfterDSTStart := true + else + AfterDSTStart := Second > DSTStartSec; + if Mo > ME then + BeforeDSTEnd := false + else + if Mo < ME then + BeforeDSTEnd := true + else + if D > DE then + BeforeDSTEnd := false + else + if D < DE then + BeforeDSTEnd := true + else + BeforeDSTEnd := Second < DSTEndSec; + if AfterDSTStart and BeforeDSTEnd then + TZSeconds := DSTOffset; + end; +end; + +procedure InitTZ; +const + TZEnvName = 'TZ'; + EMXTZEnvName = 'EMXTZ'; +var + TZ, S: string; + I, J: byte; + Err: longint; + GnuFmt: boolean; + ADSTStartMonth: byte; + ADSTStartWeek: shortint; + ADSTStartDay: word; + ADSTStartSec: cardinal; + ADSTEndMonth: byte; + ADSTEndWeek: shortint; + ADSTEndDay: word; + ADSTEndSec: cardinal; + ADSTStartSpecType: DSTSpecType; + ADSTEndSpecType: DSTSpecType; + ADSTChangeSec: cardinal; + + function ParseOffset (OffStr: string): longint; + (* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *) + var + TZShiftHH, TZShiftDir: shortint; + TZShiftMI, TZShiftSS: byte; + N1, N2: byte; + begin + TZShiftHH := 0; + TZShiftMI := 0; + TZShiftSS := 0; + TZShiftDir := 1; + N1 := 1; + while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do + Inc (N1); + Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err); + if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then + begin +(* Normalize the hour offset to -12..11 if necessary *) + if TZShiftHH > 11 then + Dec (TZShiftHH, 24) else + if TZShiftHH < -12 then + Inc (TZShiftHH, 24); + if TZShiftHH < 0 then + TZShiftDir := -1; + if (N1 <= Length (OffStr)) then + begin + N2 := Succ (N1); + while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do + Inc (N2); + Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err); + if (Err = 0) and (TZShiftMI <= 59) then + begin + if (N2 <= Length (OffStr)) then + begin + Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err); + if (Err <> 0) or (TZShiftSS > 59) then + TZShiftSS := 0; + end + end + else + TZShiftMI := 0; + end; + end + else + TZShiftHH := 0; + ParseOffset := longint (TZShiftHH) * 3600 + + TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS); + end; + +begin + TZ := GetEnv (TZEnvName); + if TZ = '' then + TZ := GetEnv (EMXTZEnvName); + if TZ <> '' then + begin + TZ := Upcase (TZ); +(* Timezone name *) + I := 1; + while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do + Inc (I); + TZName := Copy (TZ, 1, Pred (I)); + if I <= Length (TZ) then + begin +(* Timezone shift *) + J := Succ (I); + while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do + Inc (J); + TZOffset := ParseOffset (Copy (TZ, I, J - I)); +(* DST timezone name *) + I := J; + while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do + Inc (J); + if J > I then + begin + TZDSTName := Copy (TZ, I, J - I); +(* DST timezone name provided; if equal to the standard timezone *) +(* name then DSTOffset is set to be equal to TZOffset by default, *) +(* otherwise it is set to TZOffset - 3600 seconds. *) + if TZDSTName <> TZName then + DSTOffset := -3600 + TZOffset + else + DSTOffset := TZOffset; + end + else + begin + TZDSTName := TZName; +(* No DST timezone name provided => DSTOffset is equal to TZOffset *) + DSTOffset := TZOffset; + end; + if J <= Length (TZ) then + begin +(* Check if DST offset is specified here; *) +(* if not, default value set above is used. *) + if TZ [J] <> ',' then + begin + I := J; + Inc (J); + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + DSTOffset := ParseOffset (Copy (TZ, I, J - I)); + end; + if J < Length (TZ) then + begin + Inc (J); +(* DST switching details *) + case TZ [J] of + 'M': + begin +(* Mmonth.week.dayofweek[/StartHour] *) + ADSTStartSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end; + 'J': + begin +(* Jjulianday[/StartHour] *) + ADSTStartSpecType := DSTJulianX; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end + else + begin +(* Check the used format first - GNU libc / GCC / EMX expect *) +(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]"; *) +(* if more than one comma (',') is found, the following format is assumed: *) +(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond, *) +(* EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *) + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + S := Copy (TZ, I, J - I); + if J < Length (TZ) then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + GnuFmt := J > Length (TZ); + end + else + Exit; + if GnuFmt then + begin + ADSTStartSpecType := DSTJulian; + J := Pos ('/', S); + if J = 0 then + begin + Val (S, ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + end + else + begin + if J = Length (S) then + Exit; + Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end; + J := I; + end + else + begin + Val (S, ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or + (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (DSTStartWeek = 0) then + begin + if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31) + or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11]) + or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then + Exit; + ADSTStartSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) then + Exit; + ADSTStartSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5) + or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (DSTEndWeek = 0) then + begin + if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31) + or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11]) + or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then + Exit; + ADSTEndSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + ADSTEndSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) or (J >= Length (TZ)) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err); + if (Err = 0) and (ADSTChangeSec < 86400) then + begin +(* Format complete, all checks successful => accept the parsed values. *) + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + DSTOffset := TZOffset - ADSTChangeSec; + end; +(* Parsing finished *) + Exit; + end; + end; + end; +(* GnuFmt - DST end specification *) + if TZ [J] = 'M' then + begin +(* Mmonth.week.dayofweek *) + ADSTEndSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + end + else + begin + if TZ [J] = 'J' then + begin +(* Jjulianday *) + if J = Length (TZ) then + Exit; + Inc (J); + ADSTEndSpecType := DSTJulianX + end + else + ADSTEndSpecType := DSTJulian; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX) + or (ADSTEndDay > 365) then + Exit; + end; + if (J <= Length (TZ)) and (TZ [J] = '/') then + begin + if J = Length (TZ) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) then + Exit + else + ADSTEndSec := ADSTEndSec * 3600; + end + else + (* Use the preset default *) + ADSTEndSec := DSTEndSec; + +(* Format complete, all checks successful => accept the parsed values. *) + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + end; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + end; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + end; + end + else + DSTOffset := -3600 + TZOffset; + end; + end; +end; + + +begin + InitTZ; +end. diff -Nru cqrprop-0.0.7/src/uVersion.pas cqrprop-0.0.8/src/uVersion.pas --- cqrprop-0.0.7/src/uVersion.pas 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/src/uVersion.pas 2023-04-10 12:51:00.000000000 +0000 @@ -4,12 +4,12 @@ interface const - cVERSION = '0.0.7 (001)'; + cVERSION = '0.0.8 (001)'; cMAJOR = 0; cMINOR = 0; - cRELEAS = 7; + cRELEAS = 8; cBUILD = 1; - cBUILD_DATE = '2021-10-07'; + cBUILD_DATE = '2023-04-10'; implementation diff -Nru cqrprop-0.0.7/tools/new_version_local cqrprop-0.0.8/tools/new_version_local --- cqrprop-0.0.7/tools/new_version_local 2021-10-07 19:01:39.000000000 +0000 +++ cqrprop-0.0.8/tools/new_version_local 2023-04-10 12:51:00.000000000 +0000 @@ -1,6 +1,6 @@ #!/bin/bash -VERSION=0.0.5 +VERSION=0.0.8 # cqrprop version FINAL=$HOME/projects/final_cqrprop/