소스 검색

update Synapse to the last sources

DmBel 2 년 전
부모
커밋
784482856a
28개의 변경된 파일1011개의 추가작업 그리고 361개의 파일을 삭제
  1. 8 7
      asn1util.pas
  2. 14 20
      blcksock.pas
  3. 160 23
      ftpsend.pas
  4. 66 33
      httpsend.pas
  5. 2 1
      laz_synapse.pas
  6. 11 11
      mimemess.pas
  7. 27 13
      mimepart.pas
  8. 9 10
      pingsend.pas
  9. 1 1
      smtpsend.pas
  10. 17 5
      snmpsend.pas
  11. 4 0
      sntpsend.pas
  12. 15 14
      ssfpc.inc
  13. 19 9
      ssl_cryptlib.pas
  14. 25 14
      ssl_openssl.pas
  15. 86 31
      ssl_openssl_lib.pas
  16. 18 9
      sslinux.inc
  17. 58 33
      ssposix.inc
  18. 3 3
      sswin32.inc
  19. 53 7
      synachar.pas
  20. 8 8
      synacode.pas
  21. 0 1
      synacrypt.pas
  22. 5 5
      synadbg.pas
  23. 3 4
      synafpc.pas
  24. 3 3
      synaip.pas
  25. 255 44
      synamisc.pas
  26. 133 46
      synaser.pas
  27. 5 0
      synautil.pas
  28. 3 6
      synsock.pas

+ 8 - 7
asn1util.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.001.000 |
+| Project : Ararat Synapse                                       | 002.001.001 |
 |==============================================================================|
 |==============================================================================|
 | Content: support for ASN.1 BER coding and decoding                           |
 | Content: support for ASN.1 BER coding and decoding                           |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| Copyright (c)1999-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 1999-2014                |
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2021                |
 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
 | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
@@ -379,9 +379,9 @@ end;
 {==============================================================================}
 {==============================================================================}
 function MibToId(Mib: String): AnsiString;
 function MibToId(Mib: String): AnsiString;
 var
 var
-  x: Integer;
+  x: int64;
 
 
-  function WalkInt(var s: String): Integer;
+  function WalkInt(var s: String): int64;
   var
   var
     x: Integer;
     x: Integer;
     t: AnsiString;
     t: AnsiString;
@@ -397,7 +397,7 @@ var
       t := Copy(s, 1, x - 1);
       t := Copy(s, 1, x - 1);
       s := Copy(s, x + 1, Length(s) - x);
       s := Copy(s, x + 1, Length(s) - x);
     end;
     end;
-    Result := StrToIntDef(t, 0);
+    Result := StrToInt64Def(t, 0);
   end;
   end;
 
 
 begin
 begin
@@ -415,7 +415,8 @@ end;
 {==============================================================================}
 {==============================================================================}
 function IdToMib(const Id: AnsiString): String;
 function IdToMib(const Id: AnsiString): String;
 var
 var
-  x, y, n: Integer;
+  x, y: int64;
+  n: Integer;
 begin
 begin
   Result := '';
   Result := '';
   n := 1;
   n := 1;

+ 14 - 20
blcksock.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 009.010.000 |
+| Project : Ararat Synapse                                       | 009.010.002 |
 |==============================================================================|
 |==============================================================================|
 | Content: Library base                                                        |
 | Content: Library base                                                        |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2017, Lukas Gebauer                                        |
+| Copyright (c)1999-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -265,6 +265,7 @@ type
     LT_TLSv1,
     LT_TLSv1,
     LT_TLSv1_1,
     LT_TLSv1_1,
     LT_TLSv1_2,
     LT_TLSv1_2,
+    LT_TLSv1_3,
     LT_SSHv2
     LT_SSHv2
     );
     );
 
 
@@ -2621,12 +2622,13 @@ end;
 procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: int64);
 procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: int64);
 var
 var
   s: TSynaBytes;
   s: TSynaBytes;
-  n: integer;
+  n: int64;
 {$IFDEF CIL}
 {$IFDEF CIL}
   buf: TMemory;
   buf: TMemory;
 {$ENDIF}
 {$ENDIF}
 begin
 begin
-  for n := 1 to (Size div FSendMaxChunk) do
+  n := Size div int64(FSendMaxChunk);
+  while n > 0 do
   begin
   begin
     {$IFDEF CIL}
     {$IFDEF CIL}
     SetLength(buf, FSendMaxChunk);
     SetLength(buf, FSendMaxChunk);
@@ -2640,8 +2642,9 @@ begin
       Exit;
       Exit;
     WriteStrToStream(Stream, s);
     WriteStrToStream(Stream, s);
     {$ENDIF}
     {$ENDIF}
+    dec(n);
   end;
   end;
-  n := Size mod FSendMaxChunk;
+  n := Size mod int64(FSendMaxChunk);
   if n > 0 then
   if n > 0 then
   begin
   begin
     {$IFDEF CIL}
     {$IFDEF CIL}
@@ -3665,7 +3668,7 @@ begin
   end;
   end;
 end;
 end;
 
 
-  function TSocksBlockSocket.SocksDecode(const Value: string): integer;
+function TSocksBlockSocket.SocksDecode(const Value: string): integer;
 var
 var
   Atyp: Byte;
   Atyp: Byte;
   y, n: integer;
   y, n: integer;
@@ -3859,7 +3862,7 @@ begin
 end;
 end;
 
 
 {$IFNDEF CIL}
 {$IFNDEF CIL}
-procedure TUDPBlockSocket.AddMulticast(const MCastIP:string);
+procedure TUDPBlockSocket.AddMulticast(const MCastIP: string);
 var
 var
   Multicast: TIP_mreq;
   Multicast: TIP_mreq;
   Multicast6: TIPv6_mreq;
   Multicast6: TIPv6_mreq;
@@ -3870,11 +3873,7 @@ begin
   begin
   begin
     ip6 := StrToIp6(MCastIP);
     ip6 := StrToIp6(MCastIP);
     for n := 0 to 15 do
     for n := 0 to 15 do
-{$IFNDEF POSIX}
-      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
-{$ELSE}
-      Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n];
-{$ENDIF}
+      Multicast6.ipv6mr_multiaddr.{$IFDEF POSIX}s6_addr{$ELSE}u6_addr8{$ENDIF}[n] := Ip6[n];
     Multicast6.ipv6mr_interface := 0;
     Multicast6.ipv6mr_interface := 0;
     SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
     SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
       Pointer(@Multicast6), SizeOf(Multicast6)));
       Pointer(@Multicast6), SizeOf(Multicast6)));
@@ -3890,7 +3889,7 @@ begin
   ExceptCheck;
   ExceptCheck;
 end;
 end;
 
 
-procedure TUDPBlockSocket.DropMulticast(const MCastIP:string);
+procedure TUDPBlockSocket.DropMulticast(const MCastIP: string);
 var
 var
   Multicast: TIP_mreq;
   Multicast: TIP_mreq;
   Multicast6: TIPv6_mreq;
   Multicast6: TIPv6_mreq;
@@ -3901,12 +3900,7 @@ begin
   begin
   begin
     ip6 := StrToIp6(MCastIP);
     ip6 := StrToIp6(MCastIP);
     for n := 0 to 15 do
     for n := 0 to 15 do
-{$IFNDEF POSIX}
-      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
-{$ELSE}
-      Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n];
-{$ENDIF}
-
+      Multicast6.ipv6mr_multiaddr.{$IFDEF POSIX}s6_addr{$ELSE}u6_addr8{$ENDIF}[n] := Ip6[n];
     Multicast6.ipv6mr_interface := 0;
     Multicast6.ipv6mr_interface := 0;
     SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
     SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
       Pointer(@Multicast6), SizeOf(Multicast6)));
       Pointer(@Multicast6), SizeOf(Multicast6)));

+ 160 - 23
ftpsend.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 004.000.000 |
+| Project : Ararat Synapse                                       | 004.001.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: FTP client                                                          |
 | Content: FTP client                                                          |
 |==============================================================================|
 |==============================================================================|
@@ -34,10 +34,12 @@
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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 Lukas Gebauer are Copyright (c) 1999-2010.               |
+| Portions created by Jan Fiala are Copyright (c) 2019.                        |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
 |   Petr Esner <[email protected]>                                           |
 |   Petr Esner <[email protected]>                                           |
+|   Jan Fiala                                                                  |
 |==============================================================================|
 |==============================================================================|
 | History: see HISTORY.HTM from distribution package                           |
 | History: see HISTORY.HTM from distribution package                           |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
@@ -67,6 +69,9 @@ interface
 
 
 uses
 uses
   SysUtils, Classes,
   SysUtils, Classes,
+  {$IfDef POSIX}
+   ,System.Generics.Collections, System.Generics.Defaults
+  {$EndIf}
   blcksock, synautil, synaip, synsock;
   blcksock, synautil, synaip, synsock;
 
 
 const
 const
@@ -122,12 +127,18 @@ type
     property Permission: string read FPermission write FPermission;
     property Permission: string read FPermission write FPermission;
   end;
   end;
 
 
+  {$IFDEF POSIX}
+    TFTPRecList = TList<TFTPListRec>;
+  {$ELSE}
+    TFTPRecList = TList;
+  {$ENDIF}
+
   {:@abstract(This is TList of TFTPListRec objects.)
   {:@abstract(This is TList of TFTPListRec objects.)
    This object is used for holding lististing of all files information in listed
    This object is used for holding lististing of all files information in listed
    directory on FTP server.}
    directory on FTP server.}
   TFTPList = class(TObject)
   TFTPList = class(TObject)
   protected
   protected
-    FList: TList;
+    FList: TFTPRecList;
     FLines: TStringList;
     FLines: TStringList;
     FMasks: TStringList;
     FMasks: TStringList;
     FUnparsedLines: TStringList;
     FUnparsedLines: TStringList;
@@ -173,9 +184,13 @@ type
      @link(TFTPListRec).}
      @link(TFTPListRec).}
     procedure ParseLines; virtual;
     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).
     {:By this property you have access to list of @link(TFTPListRec).
      This is for compatibility only. Please, use @link(Items) instead.}
      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).}
     {:By this property you have access to list of @link(TFTPListRec).}
     property Items[Index: Integer]: TFTPListRec read GetListItem; default;
     property Items[Index: Integer]: TFTPListRec read GetListItem; default;
@@ -229,6 +244,7 @@ type
     FIsDataTLS: Boolean;
     FIsDataTLS: Boolean;
     FTLSonData: Boolean;
     FTLSonData: Boolean;
     FFullSSL: Boolean;
     FFullSSL: Boolean;
+    FUseMLSDList: Boolean;
     function Auth(Mode: integer): Boolean; virtual;
     function Auth(Mode: integer): Boolean; virtual;
     function Connect: Boolean; virtual;
     function Connect: Boolean; virtual;
     function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual;
     function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual;
@@ -446,6 +462,9 @@ type
     {:If @true (default), then try to use SSL/TLS on data transfers too.
     {:If @true (default), then try to use SSL/TLS on data transfers too.
      If @false, then SSL/TLS is used only for control connection.}
      If @false, then SSL/TLS is used only for control connection.}
     property TLSonData: Boolean read FTLSonData write FTLSonData;
     property TLSonData: Boolean read FTLSonData write FTLSonData;
+
+    {:Enable MLSD support for directory list.}
+    property UseMLSDList: Boolean read FUseMLSDList write FUseMLSDList;
   end;
   end;
 
 
 {:A very useful function, and example of use can be found in the TFtpSend object.
 {:A very useful function, and example of use can be found in the TFtpSend object.
@@ -497,6 +516,7 @@ begin
   FIsTLS := False;
   FIsTLS := False;
   FIsDataTLS := False;
   FIsDataTLS := False;
   FTLSonData := True;
   FTLSonData := True;
+  UseMLSDList := false;
 end;
 end;
 
 
 destructor TFTPSend.Destroy;
 destructor TFTPSend.Destroy;
@@ -986,7 +1006,10 @@ begin
   if NameList then
   if NameList then
     x := FTPCommand('NLST' + Directory)
     x := FTPCommand('NLST' + Directory)
   else
   else
-    x := FTPCommand('LIST' + Directory);
+    if FUseMLSDList then
+      x := FTPCommand('MLSD' + Directory)
+    else
+      x := FTPCommand('LIST' + Directory);
   if (x div 100) <> 1 then
   if (x div 100) <> 1 then
     Exit;
     Exit;
   Result := DataRead(FDataStream);
   Result := DataRead(FDataStream);
@@ -994,7 +1017,10 @@ begin
   begin
   begin
     FDataStream.Position := 0;
     FDataStream.Position := 0;
     FFTPList.Lines.LoadFromStream(FDataStream);
     FFTPList.Lines.LoadFromStream(FDataStream);
-    FFTPList.ParseLines;
+    if FUseMLSDList then
+      FFTPList.ParseMLSDLines
+    else
+      FFTPList.ParseLines;
   end;
   end;
   FDataStream.Position := 0;
   FDataStream.Position := 0;
 end;
 end;
@@ -1217,13 +1243,13 @@ end;
 constructor TFTPList.Create;
 constructor TFTPList.Create;
 begin
 begin
   inherited Create;
   inherited Create;
-  FList := TList.Create;
+  FList := TFTPRecList.Create;
   FLines := TStringList.Create;
   FLines := TStringList.Create;
   FMasks := TStringList.Create;
   FMasks := TStringList.Create;
   FUnparsedLines := TStringList.Create;
   FUnparsedLines := TStringList.Create;
   //various UNIX
   //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*$TTT$DD$UUUUU$n*');  //mostly used UNIX format
   FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
   FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
   //MacOS
   //MacOS
@@ -1240,8 +1266,20 @@ begin
   FMasks.add('DD MM YYYY  hh mmH $ d!n*');
   FMasks.add('DD MM YYYY  hh mmH $ d!n*');
   //VMS
   //VMS
   FMasks.add('v*$  DD TTT YYYY hh mm');
   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('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
   //AS400
   FMasks.add('!S*$MM DD YY hh mm ss !n*');
   FMasks.add('!S*$MM DD YY hh mm ss !n*');
   FMasks.add('!S*$DD MM YY hh mm ss !n*');
   FMasks.add('!S*$DD MM YY hh mm ss !n*');
@@ -1272,9 +1310,35 @@ begin
   //BullGCOS8
   //BullGCOS8
   FMasks.add('             $S* MM DD YY hh mm ss  !n*');
   FMasks.add('             $S* MM DD YY hh mm ss  !n*');
   FMasks.add('d            $S* MM DD YY           !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
   //BullGCOS7
-  FMasks.add('                                         TTT DD  YYYY n*');
-  FMasks.add('  d                                                   n*');
+//  FMasks.add('                                         TTT DD  YYYY n*');
+//  FMasks.add('  d                                                   n*');
 end;
 end;
 
 
 destructor TFTPList.Destroy;
 destructor TFTPList.Destroy;
@@ -1366,16 +1430,17 @@ begin
   IMask := 1;
   IMask := 1;
   Result := 1;
   Result := 1;
   LastMaskC := ' ';
   LastMaskC := ' ';
+  Value := TrimRight(Value);                                                    //Fiala
   while Imask <= Length(mask) do
   while Imask <= Length(mask) do
   begin
   begin
-    if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then
+    if not (Mask[Imask] in ['*', '\', '§']) and (Ivalue > Length(Value)) then   //Fiala
     begin
     begin
       Result := 0;
       Result := 0;
       Exit;
       Exit;
     end;
     end;
     MaskC := Mask[Imask];
     MaskC := Mask[Imask];
-    if Ivalue > Length(Value) then
-      Exit;
+//    if Ivalue > Length(Value) then
+//      Exit;
     c := Value[Ivalue];
     c := Value[Ivalue];
     case MaskC of
     case MaskC of
       'n':
       'n':
@@ -1422,6 +1487,8 @@ begin
             Result := 0;
             Result := 0;
             Exit;
             Exit;
           end;
           end;
+      'y':                                                                        //Fiala
+        if c <> ' ' then Result := 0;
       '*':
       '*':
         begin
         begin
           s := '';
           s := '';
@@ -1474,6 +1541,12 @@ begin
           end;
           end;
           Dec(IValue);
           Dec(IValue);
         end;
         end;
+      '§':                                                                      //Fiala
+        if IValue < Length(Value) then
+        begin
+          Result := 0;
+          Break;
+        end;
       '$':
       '$':
         begin
         begin
           while IValue <= Length(Value) do
           while IValue <= Length(Value) do
@@ -1512,6 +1585,12 @@ begin
               end;
               end;
           end;
           end;
         end;
         end;
+      ':':                                                                      //Fiala
+        if c <> ':' then
+        begin
+          Result := 0;
+          Exit;
+        end;
       '\':
       '\':
         begin
         begin
           Value := NextValue;
           Value := NextValue;
@@ -1530,6 +1609,7 @@ var
   x, n: integer;
   x, n: integer;
 begin
 begin
   Result := false;
   Result := false;
+  if (Trim(FileName) = '') and (Trim(VMSFileName) = '') then Exit;              //Fiala
   if FileName <> '' then
   if FileName <> '' then
   begin
   begin
     if pos('?', VMSFilename) > 0 then
     if pos('?', VMSFilename) > 0 then
@@ -1540,15 +1620,15 @@ begin
   if VMSFileName <> '' then
   if VMSFileName <> '' then
     if pos(';', VMSFilename) <= 0 then
     if pos(';', VMSFilename) <= 0 then
       Exit;
       Exit;
-  if (FileName = '') and (VMSFileName = '') then
-    Exit;
+//  if (FileName = '') and (VMSFileName = '') then
+//    Exit;
   if Permissions <> '' then
   if Permissions <> '' then
   begin
   begin
-    if length(Permissions) <> 10 then
+    if (length(Permissions) <> 10) and (length(Permissions) <> 7) then          //Fiala
       Exit;
       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;
         Exit;
   end;
   end;
   if Day <> '' then
   if Day <> '' then
@@ -1690,6 +1770,9 @@ begin
   {$ENDIF}
   {$ENDIF}
 
 
   DecodeDate(Date,myear,mmonth,mday);
   DecodeDate(Date,myear,mmonth,mday);
+  myear := YearOf(Date);                                                        //Fiala
+  mMonth := 1;                                                                  //Fiala
+  mDay := 1;                                                                    //Fiala
   mhours := 0;
   mhours := 0;
   mminutes := 0;
   mminutes := 0;
   mseconds := 0;
   mseconds := 0;
@@ -1718,9 +1801,13 @@ begin
       YearTime := TrimSP(YearTime);
       YearTime := TrimSP(YearTime);
       mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
       mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
       mminutes := StrToIntDef(SeparateRight(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
     end
     else
     else
       myear := StrToIntDef(YearTime, 0);
       myear := StrToIntDef(YearTime, 0);
@@ -1737,6 +1824,10 @@ begin
         if mHours <> 12 then
         if mHours <> 12 then
           mHours := MHours + 12;
           mHours := MHours + 12;
   end;
   end;
+  { osetrime prechodne roky }                                                   //Fiala
+  if (mday = 29) and (mmonth = 2) and not IsLeapYear(myear) then
+    Dec(Mday);
+
   Value.FileTime := Encodedate(myear, mmonth, mday)
   Value.FileTime := Encodedate(myear, mmonth, mday)
     + EncodeTime(mHours, mminutes, mseconds, 0);
     + EncodeTime(mHours, mminutes, mseconds, 0);
   if Permissions <> '' then
   if Permissions <> '' then
@@ -1961,4 +2052,50 @@ begin
   end;
   end;
 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.
 end.

+ 66 - 33
httpsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.012.009 |
+| Project : Ararat Synapse                                       | 003.013.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: HTTP client                                                         |
 | Content: HTTP client                                                         |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2015, Lukas Gebauer                                        |
+| Copyright (c)1999-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,8 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -63,6 +64,10 @@ Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
 {$ENDIF}
 {$ENDIF}
 
 
+{$IFDEF NEXTGEN}
+  {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
 unit httpsend;
 unit httpsend;
 
 
 interface
 interface
@@ -104,18 +109,21 @@ type
     FResultString: string;
     FResultString: string;
     FUserAgent: string;
     FUserAgent: string;
     FCookies: TStringList;
     FCookies: TStringList;
-    FDownloadSize: integer;
-    FUploadSize: integer;
-    FRangeStart: integer;
-    FRangeEnd: integer;
+    FDownloadSize: int64;
+    FUploadSize: int64;
+    FRangeStart: int64;
+    FRangeEnd: int64;
     FAddPortNumberToHost: Boolean;
     FAddPortNumberToHost: Boolean;
+    FInputStream, FOutputStream: TStream;
     function ReadUnknown: Boolean; virtual;
     function ReadUnknown: Boolean; virtual;
-    function ReadIdentity(Size: Integer): Boolean; virtual;
+    function ReadIdentity(Size: int64): Boolean; virtual;
     function ReadChunked: Boolean; virtual;
     function ReadChunked: Boolean; virtual;
     procedure ParseCookies;
     procedure ParseCookies;
     function PrepareHeaders: String;
     function PrepareHeaders: String;
     function InternalDoConnect(needssl: Boolean): Boolean;
     function InternalDoConnect(needssl: Boolean): Boolean;
     function InternalConnect(needssl: Boolean): Boolean;
     function InternalConnect(needssl: Boolean): Boolean;
+    function InputDocument: TStream;
+    function OutputDocument: TStream;
   public
   public
     constructor Create;
     constructor Create;
     destructor Destroy; override;
     destructor Destroy; override;
@@ -161,13 +169,13 @@ type
 
 
     {:If you need to download only part of a requested document, specify here
     {: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.}
      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
     {: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
      the position of subpart end. If 0, the document from rangeStart to end of
      document is requested.
      document is requested.
      (Useful for resuming broken downloads, for example.)}
      (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'.}
     {:Mime type of sending data. Default is: 'text/html'.}
     property MimeType: string read FMimeType Write FMimeType;
     property MimeType: string read FMimeType Write FMimeType;
@@ -212,12 +220,12 @@ type
     {:if this value is not 0, then data download is pending. In this case you
     {: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
      have here the total size of downloaded data. Useful for drawing download
      progressbar from OnStatus event.}
      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
     {: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
      here the total size of uploaded data. Useful for drawing upload progressbar
      from OnStatus event.}
      from OnStatus event.}
-    property UploadSize: integer read FUploadSize;
+    property UploadSize: int64 read FUploadSize;
 
 
     {:Socket object used for TCP/IP operation.
     {:Socket object used for TCP/IP operation.
      Good for setting OnStatus hook, etc.}
      Good for setting OnStatus hook, etc.}
@@ -226,6 +234,12 @@ type
     {:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE.
     {:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE.
      Some buggy servers do not like port informations in this header.}
      Some buggy servers do not like port informations in this header.}
     property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
     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;
 
 
     property ConnectionTimeOut: Integer read FConnectionTimeOut
     property ConnectionTimeOut: Integer read FConnectionTimeOut
       write FConnectionTimeOut;
       write FConnectionTimeOut;
@@ -304,7 +318,8 @@ begin
   FUploadSize := 0;
   FUploadSize := 0;
   FAddPortNumberToHost := true;
   FAddPortNumberToHost := true;
   FKeepAliveTimeout := 300;
   FKeepAliveTimeout := 300;
-
+  FInputStream := nil;
+  FOutputStream := nil;
   FConnectionTimeOut := 0;
   FConnectionTimeOut := 0;
   Clear;
   Clear;
 end;
 end;
@@ -318,11 +333,29 @@ begin
   inherited Destroy;
   inherited Destroy;
 end;
 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;
 procedure THTTPSend.Clear;
 begin
 begin
   FRangeStart := 0;
   FRangeStart := 0;
   FRangeEnd := 0;
   FRangeEnd := 0;
   FDocument.Clear;
   FDocument.Clear;
+  InputDocument.Size := 0;
+  OutputDocument.Size := 0;
   FHeaders.Clear;
   FHeaders.Clear;
   FMimeType := 'text/html';
   FMimeType := 'text/html';
 end;
 end;
@@ -395,7 +428,7 @@ var
   status100: Boolean;
   status100: Boolean;
   status100error: string;
   status100error: string;
   ToClose: Boolean;
   ToClose: Boolean;
-  Size: Integer;
+  Size: int64;
   Prot, User, Pass, Host, Port, Path, Para, URI: string;
   Prot, User, Pass, Host, Port, Path, Para, URI: string;
   s, su: String;
   s, su: String;
   HttpTunnel: Boolean;
   HttpTunnel: Boolean;
@@ -412,7 +445,7 @@ begin
   FDownloadSize := 0;
   FDownloadSize := 0;
   FUploadSize := 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);
   User := DecodeURL(user);
   Pass := DecodeURL(pass);
   Pass := DecodeURL(pass);
   if User = '' then
   if User = '' then
@@ -437,14 +470,14 @@ begin
     FSock.HTTPTunnelPass := '';
     FSock.HTTPTunnelPass := '';
   end;
   end;
   UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
   UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
-  Sending := FDocument.Size > 0;
+  Sending := InputDocument.Size > 0;
   {Headers for Sending data}
   {Headers for Sending data}
   status100 := FStatus100 and Sending and (FProtocol = '1.1');
   status100 := FStatus100 and Sending and (FProtocol = '1.1');
   if status100 then
   if status100 then
     FHeaders.Insert(0, 'Expect: 100-continue');
     FHeaders.Insert(0, 'Expect: 100-continue');
   if Sending then
   if Sending then
   begin
   begin
-    FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
+    FHeaders.Insert(0, 'Content-Length: ' + IntToStr(InputDocument.Size));
     if FMimeType <> '' then
     if FMimeType <> '' then
       FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
       FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
   end;
   end;
@@ -526,7 +559,7 @@ begin
   end;
   end;
 
 
   { reading Status }
   { reading Status }
-  FDocument.Position := 0;
+  InputDocument.Position := 0;
   Status100Error := '';
   Status100Error := '';
   if status100 then
   if status100 then
   begin
   begin
@@ -550,23 +583,23 @@ begin
     begin
     begin
       { we can upload content }
       { we can upload content }
       Status100Error := '';
       Status100Error := '';
-      FUploadSize := FDocument.Size;
-      FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+      FUploadSize := InputDocument.Size;
+      FSock.SendStreamRaw(InputDocument);
     end;
     end;
   end
   end
   else
   else
     { upload content }
     { upload content }
     if sending then
     if sending then
     begin
     begin
-      if FDocument.Size >= c64k then
+      if InputDocument.Size >= c64k then
       begin
       begin
         FSock.SendString(PrepareHeaders);
         FSock.SendString(PrepareHeaders);
-        FUploadSize := FDocument.Size;
-        FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+        FUploadSize := InputDocument.Size;
+        FSock.SendStreamRaw(InputDocument);
       end
       end
       else
       else
       begin
       begin
-        s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
+        s := PrepareHeaders + ReadStrFromStream(InputDocument, InputDocument.Size);
         FUploadSize := Length(s);
         FUploadSize := Length(s);
         FSock.SendString(s);
         FSock.SendString(s);
       end;
       end;
@@ -602,7 +635,7 @@ begin
       begin
       begin
         { old HTTP 0.9 and some buggy servers not send result }
         { old HTTP 0.9 and some buggy servers not send result }
         s := s + CRLF;
         s := s + CRLF;
-        WriteStrToStream(FDocument, s);
+        WriteStrToStream(OutputDocument, s);
         FResultCode := 0;
         FResultCode := 0;
       end;
       end;
     until (FSock.LastError <> 0) or (FResultCode <> 100);
     until (FSock.LastError <> 0) or (FResultCode <> 100);
@@ -630,7 +663,7 @@ begin
         su := UpperCase(s);
         su := UpperCase(s);
         if Pos('CONTENT-LENGTH:', su) = 1 then
         if Pos('CONTENT-LENGTH:', su) = 1 then
         begin
         begin
-          Size := StrToIntDef(Trim(SeparateRight(s, ':')), -1);
+          Size := StrToInt64Def(Trim(SeparateRight(s, ':')), -1);
           if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
           if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
             FTransferEncoding := TE_IDENTITY;
             FTransferEncoding := TE_IDENTITY;
         end;
         end;
@@ -683,7 +716,7 @@ begin
         Result := ReadChunked;
         Result := ReadChunked;
     end;
     end;
 
 
-  FDocument.Position := 0;
+  OutputDocument.Position := 0;
   if ToClose then
   if ToClose then
   begin
   begin
     FSock.CloseSocket;
     FSock.CloseSocket;
@@ -701,7 +734,7 @@ begin
   repeat
   repeat
     s := FSock.RecvPacket(FTimeout);
     s := FSock.RecvPacket(FTimeout);
     if FSock.LastError = 0 then
     if FSock.LastError = 0 then
-      WriteStrToStream(FDocument, s);
+      WriteStrToStream(OutputDocument, s);
   until FSock.LastError <> 0;
   until FSock.LastError <> 0;
   if FSock.LastError = WSAECONNRESET then
   if FSock.LastError = WSAECONNRESET then
   begin
   begin
@@ -710,13 +743,13 @@ begin
   end;
   end;
 end;
 end;
 
 
-function THTTPSend.ReadIdentity(Size: Integer): Boolean;
+function THTTPSend.ReadIdentity(Size: int64): Boolean;
 begin
 begin
   if Size > 0 then
   if Size > 0 then
   begin
   begin
     FDownloadSize := Size;
     FDownloadSize := Size;
-    FSock.RecvStreamSize(FDocument, FTimeout, Size);
-    FDocument.Position := FDocument.Size;
+    FSock.RecvStreamSize(OutputDocument, FTimeout, Size);
+    OutputDocument.Position := OutputDocument.Size;
     Result := FSock.LastError = 0;
     Result := FSock.LastError = 0;
   end
   end
   else
   else
@@ -726,7 +759,7 @@ end;
 function THTTPSend.ReadChunked: Boolean;
 function THTTPSend.ReadChunked: Boolean;
 var
 var
   s: string;
   s: string;
-  Size: Integer;
+  Size: int64;
 begin
 begin
   repeat
   repeat
     repeat
     repeat
@@ -736,7 +769,7 @@ begin
       Break;
       Break;
     s := Trim(SeparateLeft(s, ' '));
     s := Trim(SeparateLeft(s, ' '));
     s := Trim(SeparateLeft(s, ';'));
     s := Trim(SeparateLeft(s, ';'));
-    Size := StrToIntDef('$' + s, 0);
+    Size := StrToInt64Def('$' + s, 0);
     if Size = 0 then
     if Size = 0 then
       Break;
       Break;
     if not ReadIdentity(Size) then
     if not ReadIdentity(Size) then

+ 2 - 1
laz_synapse.pas

@@ -4,6 +4,7 @@
 
 
 unit laz_synapse;
 unit laz_synapse;
 
 
+{$warn 5023 off : no warning about unused units}
 interface
 interface
 
 
 uses
 uses
@@ -11,7 +12,7 @@ uses
   imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, 
   imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, 
   pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, 
   pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, 
   synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, 
   synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, 
-  synsock, tlntsend;
+  synsock, tlntsend, ssl_openssl, ssl_openssl_lib;
 
 
 implementation
 implementation
 
 

+ 11 - 11
mimemess.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.006.000 |
+| Project : Ararat Synapse                                       | 002.006.001 |
 |==============================================================================|
 |==============================================================================|
 | Content: MIME message object                                                 |
 | Content: MIME message object                                                 |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2012, Lukas Gebauer                                        |
+| Copyright (c)1999-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2012.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2021.                |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
@@ -306,9 +306,9 @@ implementation
 constructor TMessHeader.Create;
 constructor TMessHeader.Create;
 begin
 begin
   inherited Create;
   inherited Create;
-  FToList := TStringList.Create;
-  FCCList := TStringList.Create;
-  FCustomHeaders := TStringList.Create;
+  FToList := CreateStringList;
+  FCCList := CreateStringList;
+  FCustomHeaders := CreateStringList;
   FCharsetCode := GetCurCP;
   FCharsetCode := GetCurCP;
 end;
 end;
 
 
@@ -583,7 +583,7 @@ constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
 begin
 begin
   inherited Create;
   inherited Create;
   FMessagePart := TMimePart.Create;
   FMessagePart := TMimePart.Create;
-  FLines := TStringList.Create;
+  FLines := CreateStringList;
   FHeader := HeadClass.Create;
   FHeader := HeadClass.Create;
 end;
 end;
 
 
@@ -687,7 +687,7 @@ function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent:
 var
 var
   tmp: TStrings;
   tmp: TStrings;
 begin
 begin
-  tmp := TStringList.Create;
+  tmp := CreateStringList;
   try
   try
     tmp.LoadFromFile(FileName);
     tmp.LoadFromFile(FileName);
     Result := AddPartText(tmp, PartParent);
     Result := AddPartText(tmp, PartParent);
@@ -700,7 +700,7 @@ function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent:
 var
 var
   tmp: TStrings;
   tmp: TStrings;
 begin
 begin
-  tmp := TStringList.Create;
+  tmp := CreateStringList;
   try
   try
     tmp.LoadFromFile(FileName);
     tmp.LoadFromFile(FileName);
     Result := AddPartHTML(tmp, PartParent);
     Result := AddPartHTML(tmp, PartParent);
@@ -784,7 +784,7 @@ function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent:
 var
 var
   tmp: TStrings;
   tmp: TStrings;
 begin
 begin
-  tmp := TStringList.Create;
+  tmp := CreateStringList;
   try
   try
     tmp.LoadFromFile(FileName);
     tmp.LoadFromFile(FileName);
     Result := AddPartMess(tmp, PartParent);
     Result := AddPartMess(tmp, PartParent);
@@ -801,7 +801,7 @@ var
   x: integer;
   x: integer;
 begin
 begin
   //merge headers from THeaders and header field from MessagePart
   //merge headers from THeaders and header field from MessagePart
-  l := TStringList.Create;
+  l := CreateStringList;
   try
   try
     FHeader.EncodeHeaders(l);
     FHeader.EncodeHeaders(l);
     x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
     x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);

+ 27 - 13
mimepart.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 002.009.000 |
+| Project : Ararat Synapse                                       | 002.009.002 |
 |==============================================================================|
 |==============================================================================|
 | Content: MIME support procedures and functions                               |
 | Content: MIME support procedures and functions                               |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-200812                                                         |
+| Copyright (c)1999-2021                                                       |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
 | modification, are permitted provided that the following conditions are met:  |
 | modification, are permitted provided that the following conditions are met:  |
@@ -32,7 +32,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2012.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2021.                |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
@@ -370,6 +370,8 @@ const
 
 
 {:Generates a unique boundary string.}
 {:Generates a unique boundary string.}
 function GenerateBoundary: string;
 function GenerateBoundary: string;
+{:Generates a stringlist that does not write a BOM character.}
+Function CreateStringList : TStringList;
 
 
 implementation
 implementation
 
 
@@ -379,11 +381,11 @@ constructor TMIMEPart.Create;
 begin
 begin
   inherited Create;
   inherited Create;
   FOnWalkPart := nil;
   FOnWalkPart := nil;
-  FLines := TStringList.Create;
-  FPartBody := TStringList.Create;
-  FHeaders := TStringList.Create;
-  FPrePart := TStringList.Create;
-  FPostPart := TStringList.Create;
+  FLines := CreateStringList;
+  FPartBody := CreateStringList;
+  FHeaders := CreateStringList;
+  FPrePart := CreateStringList;
+  FPostPart := CreateStringList;
   FDecodedLines := TMemoryStream.Create;
   FDecodedLines := TMemoryStream.Create;
   FSubParts := TList.Create;
   FSubParts := TList.Create;
   FTargetCharset := GetCurCP;
   FTargetCharset := GetCurCP;
@@ -891,7 +893,7 @@ begin
     else
     else
       s := CharsetConversion(s, FCharsetCode, FTargetCharset);
       s := CharsetConversion(s, FCharsetCode, FTargetCharset);
   WriteStrToStream(FDecodedLines, s);
   WriteStrToStream(FDecodedLines, s);
-  FDecodedLines.Seek(0, soFromBeginning);
+  FDecodedLines.Position := 0;
 end;
 end;
 
 
 {==============================================================================}
 {==============================================================================}
@@ -964,15 +966,19 @@ end;
 procedure TMIMEPart.EncodePart;
 procedure TMIMEPart.EncodePart;
 var
 var
   l: TStringList;
   l: TStringList;
-  s, t: string;
+{$IFDEF UNICODE}
+  s, t: RawByteString;
+{$ELSE}
+   s, t: string;
+{$ENDIF}
   n, x: Integer;
   n, x: Integer;
   d1, d2: integer;
   d1, d2: integer;
 begin
 begin
   if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
   if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
     Encoding := 'base64';
     Encoding := 'base64';
-  l := TStringList.Create;
+  l := CreateStringList;
   FPartBody.Clear;
   FPartBody.Clear;
-  FDecodedLines.Seek(0, soFromBeginning);
+  FDecodedLines.Position := 0;
   try
   try
     case FPrimaryCode of
     case FPrimaryCode of
       MP_MULTIPART, MP_MESSAGE:
       MP_MULTIPART, MP_MESSAGE:
@@ -1074,7 +1080,7 @@ begin
     FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
     FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
   end;
   end;
   if FContentID <> '' then
   if FContentID <> '' then
-    FHeaders.Insert(0, 'Content-ID: ' + FContentID);
+    FHeaders.Insert(0, 'Content-ID: <' + FContentID + '>');
 
 
   case FEncodingCode of
   case FEncodingCode of
     ME_7BIT:
     ME_7BIT:
@@ -1224,4 +1230,12 @@ begin
   Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
   Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
 end;
 end;
 
 
+function CreateStringList: TStringList;
+begin
+  Result := TStringList.Create;
+{$IFDEF UNICODE}
+  Result.WriteBOM := False;
+{$ENDIF}
+end;
+
 end.
 end.

+ 9 - 10
pingsend.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 004.000.002 |
+| Project : Ararat Synapse                                       | 004.000.004 |
 |==============================================================================|
 |==============================================================================|
 | Content: PING sender                                                         |
 | Content: PING sender                                                         |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| Copyright (c)1999-2023, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2000-2010.                |
+| Portions created by Lukas Gebauer are Copyright (c)2000-2023.                |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -247,14 +247,14 @@ type
   end;
   end;
   PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
   PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
 
 
-  TIcmpCreateFile = function: integer; stdcall;
-  TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
-  TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+  TIcmpCreateFile = function: THandle; stdcall;
+  TIcmpCloseHandle = function(handle: THandle): boolean; stdcall;
+  TIcmpSendEcho2 = function(handle: THandle; Event: pointer; ApcRoutine: pointer;
     ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
     ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
     RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
     RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
     ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
     ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
-  TIcmp6CreateFile = function: integer; stdcall;
-  TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+  TIcmp6CreateFile = function: THandle; stdcall;
+  TIcmp6SendEcho2 = function(handle: THandle; Event: pointer; ApcRoutine: pointer;
     ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
     ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
     RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
     RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
     ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
     ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
@@ -588,7 +588,7 @@ function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
 {$IFDEF MSWINDOWS}
 {$IFDEF MSWINDOWS}
 var
 var
   PingIp6: boolean;
   PingIp6: boolean;
-  PingHandle: integer;
+  PingHandle: THandle;
   r: integer;
   r: integer;
   ipo: TIP_OPTION_INFORMATION;
   ipo: TIP_OPTION_INFORMATION;
   RBuff: Ansistring;
   RBuff: Ansistring;
@@ -618,7 +618,6 @@ begin
           PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
           PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
         if r > 0 then
         if r > 0 then
         begin
         begin
-          RBuff := #0 + #0 + RBuff;
           ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
           ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
           FPingTime := ip6reply^.RoundTripTime;
           FPingTime := ip6reply^.RoundTripTime;
           ip6reply^.Address.sin6_family := AF_INET6;
           ip6reply^.Address.sin6_family := AF_INET6;

+ 1 - 1
smtpsend.pas

@@ -589,7 +589,7 @@ end;
 function TSMTPSend.MailTo(const Value: string): Boolean;
 function TSMTPSend.MailTo(const Value: string): Boolean;
 begin
 begin
   FSock.SendString('RCPT TO: <' + Value + '>' + CRLF);
   FSock.SendString('RCPT TO: <' + Value + '>' + CRLF);
-  Result := ReadResult = 250;
+  Result := ReadResult div 100 = 2;
 end;
 end;
 
 
 function TSMTPSend.MailData(const Value: TStrings): Boolean;
 function TSMTPSend.MailData(const Value: TStrings): Boolean;

+ 17 - 5
snmpsend.pas

@@ -62,6 +62,7 @@ Supported Privacy encryptions: DES, 3DES, AES
 {$IFDEF UNICODE}
 {$IFDEF UNICODE}
   {$WARN IMPLICIT_STRING_CAST OFF}
   {$WARN IMPLICIT_STRING_CAST OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+  {$TYPEINFO ON}
 {$ENDIF}
 {$ENDIF}
 
 
 unit snmpsend;
 unit snmpsend;
@@ -70,7 +71,13 @@ interface
 
 
 uses
 uses
   Classes, SysUtils,
   Classes, SysUtils,
-  blcksock, synautil, asn1util, synaip, synacode, synacrypt;
+  blcksock, synautil, asn1util, synaip, synacode, synacrypt
+  {$IfDef POSIX}
+   ,System.Generics.Collections, System.Generics.Defaults
+  {$EndIf}
+  {$IfDef NEXTGEN}
+   ,synafpc
+  {$EndIf};
 
 
 const
 const
   cSnmpProtocol = '161';
   cSnmpProtocol = '161';
@@ -161,6 +168,12 @@ type
     EngineStamp: Cardinal;
     EngineStamp: Cardinal;
   end;
   end;
 
 
+  {$IFDEF POSIX}
+    TSNMPMibList = TList<TSNMPMib>;
+  {$ELSE}
+    TSNMPMibList = TList;
+  {$ENDIF}
+
   {:@abstract(Data object abstracts SNMP data packet)}
   {:@abstract(Data object abstracts SNMP data packet)}
   TSNMPRec = class(TObject)
   TSNMPRec = class(TObject)
   protected
   protected
@@ -170,7 +183,7 @@ type
     FErrorStatus: Integer;
     FErrorStatus: Integer;
     FErrorIndex: Integer;
     FErrorIndex: Integer;
     FCommunity: AnsiString;
     FCommunity: AnsiString;
-    FSNMPMibList: TList;
+    FSNMPMibList: TSNMPMibList;
     FMaxSize: Integer;
     FMaxSize: Integer;
     FFlags: TV3Flags;
     FFlags: TV3Flags;
     FFlagReportable: Boolean;
     FFlagReportable: Boolean;
@@ -227,7 +240,7 @@ type
     function MIBByIndex(Index: Integer): TSNMPMib;
     function MIBByIndex(Index: Integer): TSNMPMib;
 
 
     {:List of @link(TSNMPMib) objects.}
     {:List of @link(TSNMPMib) objects.}
-    property SNMPMibList: TList read FSNMPMibList;
+    property SNMPMibList: TSNMPMibList read FSNMPMibList;
   published
   published
     {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use
     {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use
      value 1 for SNMPv2c or value 3 for SNMPv3.}
      value 1 for SNMPv2c or value 3 for SNMPv3.}
@@ -435,7 +448,7 @@ implementation
 constructor TSNMPRec.Create;
 constructor TSNMPRec.Create;
 begin
 begin
   inherited Create;
   inherited Create;
-  FSNMPMibList := TList.Create;
+  FSNMPMibList := TSNMPMibList.Create;
   Clear;
   Clear;
   FAuthMode := AuthMD5;
   FAuthMode := AuthMD5;
   FPassword := '';
   FPassword := '';
@@ -1003,7 +1016,6 @@ function TSNMPSend.SendRequest: Boolean;
 var
 var
   sync: TV3Sync;
   sync: TV3Sync;
 begin
 begin
-  Result := False;
   if FQuery.FVersion = 3 then
   if FQuery.FVersion = 3 then
   begin
   begin
     sync := GetV3Sync;
     sync := GetV3Sync;

+ 4 - 0
sntpsend.pas

@@ -54,6 +54,10 @@ Used RFC: RFC-1305, RFC-2030
 {$Q-}
 {$Q-}
 {$H+}
 {$H+}
 
 
+{$IFDEF NEXTGEN}
+  {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
 unit sntpsend;
 unit sntpsend;
 
 
 interface
 interface

+ 15 - 14
ssfpc.inc

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.001.005 |
+| Project : Ararat Synapse                                       | 001.001.008 |
 |==============================================================================|
 |==============================================================================|
 | Content: Socket Independent Platform Layer - FreePascal definition include   |
 | Content: Socket Independent Platform Layer - FreePascal definition include   |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)2006-2013, Lukas Gebauer                                        |
+| Copyright (c)2006-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -255,9 +255,8 @@ const
   MSG_OOB       = sockets.MSG_OOB;      // Process out-of-band data.
   MSG_OOB       = sockets.MSG_OOB;      // Process out-of-band data.
   MSG_PEEK      = sockets.MSG_PEEK;     // Peek at incoming messages.
   MSG_PEEK      = sockets.MSG_PEEK;     // Peek at incoming messages.
   {$ifdef DARWIN}
   {$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}
   {$else}
    MSG_NOSIGNAL  = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
    MSG_NOSIGNAL  = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
   {$endif}
   {$endif}
@@ -366,7 +365,7 @@ type
         case sin_family: sa_family_t of
         case sin_family: sa_family_t of
           AF_INET: (sin_port: word;
           AF_INET: (sin_port: word;
                     sin_addr: TInAddr;
                     sin_addr: TInAddr;
-                    sin_zero: array[0..7] of Char);
+                    sin_zero: array[0..7] of byte);
           AF_INET6: (sin6_port:     word;
           AF_INET6: (sin6_port:     word;
                 		sin6_flowinfo: FixedUInt;
                 		sin6_flowinfo: FixedUInt;
       	    	      sin6_addr:     TInAddr6;
       	    	      sin6_addr:     TInAddr6;
@@ -756,7 +755,7 @@ var
 begin
 begin
   Result := 0;
   Result := 0;
   FillChar(Sin, Sizeof(Sin), 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;
   TwoPass := False;
   if Family = AF_UNSPEC then
   if Family = AF_UNSPEC then
   begin
   begin
@@ -851,7 +850,7 @@ begin
   end;
   end;
 
 
   if IPList.Count = 0 then
   if IPList.Count = 0 then
-    IPList.Add(cLocalHost);
+    IPList.Add(cAnyHost);
 end;
 end;
 
 
 function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
 function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
@@ -859,14 +858,16 @@ var
   ProtoEnt: TProtocolEntry;
   ProtoEnt: TProtocolEntry;
   ServEnt: TServiceEntry;
   ServEnt: TServiceEntry;
 begin
 begin
-  Result := synsock.htons(StrToIntDef(Port, 0));
+  Result := StrToIntDef(Port, 0);
   if Result = 0 then
   if Result = 0 then
   begin
   begin
     ProtoEnt.Name := '';
     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;
 end;
 end;
 
 

+ 19 - 9
ssl_cryptlib.pas

@@ -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                         |
 | Content: SSL/SSH support by Peter Gutmann's CryptLib                         |
 |==============================================================================|
 |==============================================================================|
@@ -79,6 +79,10 @@ and @link(TCustomSSL.password). You can use special SSH channels too, see
 {$ENDIF}
 {$ENDIF}
 {$H+}
 {$H+}
 
 
+{$IFDEF NEXTGEN}
+  {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
 unit ssl_cryptlib;
 unit ssl_cryptlib;
 
 
 interface
 interface
@@ -296,7 +300,7 @@ begin
   FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
   FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
   if server then
   if server then
     case FSSLType of
     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;
         st := CRYPT_SESSION_SSL_SERVER;
       LT_SSHv2:
       LT_SSHv2:
         st := CRYPT_SESSION_SSH_SERVER;
         st := CRYPT_SESSION_SSH_SERVER;
@@ -305,7 +309,7 @@ begin
     end
     end
   else
   else
     case FSSLType of
     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;
         st := CRYPT_SESSION_SSL;
       LT_SSHv2:
       LT_SSHv2:
         st := CRYPT_SESSION_SSH;
         st := CRYPT_SESSION_SSH;
@@ -322,6 +326,10 @@ begin
       x := 1;
       x := 1;
     LT_TLSv1_1:
     LT_TLSv1_1:
       x := 2;
       x := 2;
+    LT_TLSv1_2:
+      x := 3;
+    LT_TLSv1_3:
+      x := 4;
   end;
   end;
   if x >= 0 then
   if x >= 0 then
     if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
     if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
@@ -337,9 +345,9 @@ begin
     aUserName := fUserName;
     aUserName := fUserName;
     aPassword := fPassword;
     aPassword := fPassword;
     cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
     cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
-      Pointer(FUsername), Length(FUsername));
+      Pointer(aUsername), Length(aUsername));
     cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
     cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
-      Pointer(FPassword), Length(FPassword));
+      Pointer(aPassword), Length(aPassword));
   end;
   end;
   if FSSLType = LT_SSHv2 then
   if FSSLType = LT_SSHv2 then
     if FSSHChannelType <> '' then
     if FSSHChannelType <> '' then
@@ -507,7 +515,7 @@ begin
   if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
   if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
     Exit;
     Exit;
   cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
   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
     case x of
       0:
       0:
         Result := 'SSLv3';
         Result := 'SSLv3';
@@ -515,6 +523,10 @@ begin
         Result := 'TLSv1';
         Result := 'TLSv1';
       2:
       2:
         Result := 'TLSv1.1';
         Result := 'TLSv1.1';
+      3:
+        Result := 'TLSv1.2';
+      4:
+        Result := 'TLSv1.3';
     end;
     end;
   if FSSLType in [LT_SSHv2] then
   if FSSLType in [LT_SSHv2] then
     case x of
     case x of
@@ -676,6 +688,4 @@ initialization
   end;
   end;
 finalization
 finalization
   cryptEnd;
   cryptEnd;
-end.
-
-
+end.

+ 25 - 14
ssl_openssl.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.003.000 |
+| Project : Ararat Synapse                                       | 001.004.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: SSL support by OpenSSL                                              |
 | Content: SSL support by OpenSSL                                              |
 |==============================================================================|
 |==============================================================================|
@@ -35,6 +35,7 @@
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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 Lukas Gebauer are Copyright (c)2005-2017.                |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| Portions created by Pepak are Copyright (c)2018.                             |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -86,7 +87,7 @@ accepting of new connections!
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
 {$ENDIF}
 {$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
 interface
 
 
@@ -104,16 +105,20 @@ type
    Instance of this class will be created for each @link(TTCPBlockSocket).
    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!}
    You not need to create instance of this class, all is done by Synapse itself!}
   TSSLOpenSSL = class(TCustomSSL)
   TSSLOpenSSL = class(TCustomSSL)
+  private
+    FServer: boolean;
   protected
   protected
     FSsl: PSSL;
     FSsl: PSSL;
     Fctx: PSSL_CTX;
     Fctx: PSSL_CTX;
+    function NeedSigningCertificate: boolean; virtual;
     function SSLCheck: Boolean;
     function SSLCheck: Boolean;
-    function SetSslKeys: boolean;
-    function Init(server:Boolean): Boolean;
+    function SetSslKeys: boolean; virtual;
+    function Init: Boolean;
     function DeInit: Boolean;
     function DeInit: Boolean;
-    function Prepare(server:Boolean): Boolean;
+    function Prepare: Boolean;
     function LoadPFX(pfxdata: TSynaBytes): Boolean;
     function LoadPFX(pfxdata: TSynaBytes): Boolean;
     function CreateSelfSignedCert(Host: string): Boolean; override;
     function CreateSelfSignedCert(Host: string): Boolean; override;
+    property Server: boolean read FServer;
   public
   public
     {:See @inherited}
     {:See @inherited}
     constructor Create(const Value: TTCPBlockSocket); override;
     constructor Create(const Value: TTCPBlockSocket); override;
@@ -278,7 +283,7 @@ begin
   pk := EvpPkeynew;
   pk := EvpPkeynew;
   x := X509New;
   x := X509New;
   try
   try
-    rsa := RsaGenerateKey(1024, $10001, nil, nil);
+    rsa := RsaGenerateKey(2048, $10001, nil, nil);
     EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
     EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
     X509SetVersion(x, 2);
     X509SetVersion(x, 2);
     Asn1IntegerSet(X509getSerialNumber(x), 0);
     Asn1IntegerSet(X509getSerialNumber(x), 0);
@@ -448,7 +453,12 @@ begin
   end;
   end;
 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
 var
   s: TSynabytes;
   s: TSynabytes;
   buf: PByte;
   buf: PByte;
@@ -502,8 +512,7 @@ begin
     SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
     SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
 {$ENDIF}
 {$ENDIF}
 
 
-    if server and (FCertificateFile = '') and (FCertificate = '')
-      and (FPFXfile = '') and (FPFX = '') then
+    if server and NeedSigningCertificate then
     begin
     begin
       CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
       CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
     end;
     end;
@@ -539,11 +548,11 @@ begin
   FSSLEnabled := False;
   FSSLEnabled := False;
 end;
 end;
 
 
-function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
+function TSSLOpenSSL.Prepare: Boolean;
 begin
 begin
   Result := false;
   Result := false;
   DeInit;
   DeInit;
-  if Init(server) then
+  if Init then
     Result := true
     Result := true
   else
   else
     DeInit;
     DeInit;
@@ -560,7 +569,8 @@ begin
   Result := False;
   Result := False;
   if FSocket.Socket = INVALID_SOCKET then
   if FSocket.Socket = INVALID_SOCKET then
     Exit;
     Exit;
-  if Prepare(False) then
+  FServer := False;
+  if Prepare then
   begin
   begin
 {$IFDEF CIL}
 {$IFDEF CIL}
     if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
     if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
@@ -626,7 +636,8 @@ begin
   Result := False;
   Result := False;
   if FSocket.Socket = INVALID_SOCKET then
   if FSocket.Socket = INVALID_SOCKET then
     Exit;
     Exit;
-  if Prepare(True) then
+  FServer := True;
+  if Prepare then
   begin
   begin
 {$IFDEF CIL}
 {$IFDEF CIL}
     if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
     if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
@@ -1001,7 +1012,7 @@ end;
 {==============================================================================}
 {==============================================================================}
 
 
 initialization
 initialization
-  if InitSSLInterface then
+//  if InitSSLInterface then
     SSLImplementation := TSSLOpenSSL;
     SSLImplementation := TSSLOpenSSL;
 
 
 end.
 end.

+ 86 - 31
ssl_openssl_lib.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 003.008.000 |
+| Project : Ararat Synapse                                       | 003.009.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: SSL support by OpenSSL                                              |
 | Content: SSL support by OpenSSL                                              |
 |==============================================================================|
 |==============================================================================|
@@ -35,10 +35,12 @@
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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 Lukas Gebauer are Copyright (c)2002-2017.                |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
 | Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| Portions created by Pepak are Copyright (c)2018.                             |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
 |   Tomas Hajny (OS2 support)                                                  |
 |   Tomas Hajny (OS2 support)                                                  |
+|   Pepak (multiversion support)                                               |
 |==============================================================================|
 |==============================================================================|
 | History: see HISTORY.HTM from distribution package                           |
 | History: see HISTORY.HTM from distribution package                           |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
@@ -100,6 +102,7 @@ uses
   {$ENDIF}
   {$ENDIF}
   SysUtils;
   SysUtils;
 {$ELSE}
 {$ELSE}
+  SysUtils,
   Windows;
   Windows;
 {$ENDIF}
 {$ENDIF}
 
 
@@ -137,11 +140,59 @@ var
   DLLSSLName: string = 'ssleay32.dll';
   DLLSSLName: string = 'ssleay32.dll';
   DLLSSLName2: string = 'libssl32.dll';
   DLLSSLName2: string = 'libssl32.dll';
   DLLUtilName: string = 'libeay32.dll';
   DLLUtilName: string = 'libeay32.dll';
-
-  DLL_LIBCRYPTO_1_1: string = 'libcrypto-1_1.dll';
-  DLL_LIBSSL_1_1: string = 'libssl-1_1.dll';
-
   {$ENDIF}
   {$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}
 {$ENDIF}
 
 
 type
 type
@@ -1171,7 +1222,6 @@ var
 {$ENDIF}
 {$ENDIF}
 {$ENDIF}
 {$ENDIF}
 
 
-
 var
 var
   SSLCS: TCriticalSection;
   SSLCS: TCriticalSection;
   SSLloaded: boolean = false;
   SSLloaded: boolean = false;
@@ -1938,7 +1988,7 @@ end;
 function d2iX509bio(b: PBIO; x: PX509): PX509; {pf}
 function d2iX509bio(b: PBIO; x: PX509): PX509; {pf}
 begin
 begin
   if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iX509bio){$ENDIF} then
   if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iX509bio){$ENDIF} then
-    Result := _d2iX509bio(x,b)
+    Result := _d2iX509bio(b, x)
   else
   else
     Result := nil;
     Result := nil;
 end;
 end;
@@ -2080,10 +2130,22 @@ begin
 end;
 end;
 {$ENDIF}
 {$ENDIF}
 
 
+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;
 function InitSSLInterface: Boolean;
+{$IFDEF MSWINDOWS}
 var
 var
   s: string;
   s: string;
-  x: integer;
+  i: integer;
+{$ENDIF}
 begin
 begin
   {pf}
   {pf}
   if SSLLoaded then
   if SSLLoaded then
@@ -2103,25 +2165,24 @@ begin
       SSLLibHandle := 1;
       SSLLibHandle := 1;
       SSLUtilHandle := 1;
       SSLUtilHandle := 1;
 {$ELSE}
 {$ELSE}
-
-    {$IFDEF MSWINDOWS}
-      SSLUtilHandle := LoadLib(DLL_LIBCRYPTO_1_1);
-      SSLLibHandle := LoadLib(DLL_LIBSSL_1_1);
-
-      if (SSLUtilHandle = 0) or (SSLLibHandle = 0) then
+      // 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
       begin
-        FreeLibrary(SSLLibHandle);
-        FreeLibrary(SSLUtilHandle);
-        
-        SSLUtilHandle := LoadLib(DLLUtilName);
-        SSLLibHandle := LoadLib(DLLSSLName);
-        if (SSLLibHandle = 0) then
-          SSLLibHandle := LoadLib(DLLSSLName2);
+        SSLUtilHandle := LoadLib(CryptoLibNames[i]);
+        if SSLUtilHandle <> 0 then
+        begin
+          s := ExtractFilePath(GetLibFileName(SSLUtilHandle));
+          SSLLibHandle := LoadLib(s + SSLLibNames[i]);
+          Break;
+        end;
       end;
       end;
-    {$ELSE}
+      {$ELSE}
       SSLUtilHandle := LoadLib(DLLUtilName);
       SSLUtilHandle := LoadLib(DLLUtilName);
       SSLLibHandle := LoadLib(DLLSSLName);
       SSLLibHandle := LoadLib(DLLSSLName);
-    {$ENDIF}
+      {$ENDIF}
 {$ENDIF}
 {$ENDIF}
       if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
       if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
       begin
       begin
@@ -2240,14 +2301,8 @@ begin
         OPENSSLaddallalgorithms;
         OPENSSLaddallalgorithms;
         RandScreen;
         RandScreen;
 {$ELSE}
 {$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
         //init library
         {$IFNDEF STATIC}if assigned(_SslLibraryInit) then{$ENDIF}
         {$IFNDEF STATIC}if assigned(_SslLibraryInit) then{$ENDIF}
           _SslLibraryInit;
           _SslLibraryInit;

+ 18 - 9
sslinux.inc

@@ -64,11 +64,13 @@ interface
 uses
 uses
   SyncObjs, SysUtils, Classes,
   SyncObjs, SysUtils, Classes,
   synafpc,
   synafpc,
-  {$IFNDEF FPC}
-  Libc;
-  {$ELSE FPC}
-  libclite;
-  {$ENDIF ~FPC}
+  {$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 InitSocketInterface(stack: string): Boolean;
 function DestroySocketInterface: Boolean;
 function DestroySocketInterface: Boolean;
@@ -83,6 +85,9 @@ type
   u_long = Longint;
   u_long = Longint;
   pu_long = ^u_long;
   pu_long = ^u_long;
   pu_short = ^u_short;
   pu_short = ^u_short;
+  {$IFDEF POSIX}
+    uint32_t = UInt32;
+  {$ENDIF}
   TSocket = u_int;
   TSocket = u_int;
   TAddrFamily = integer;
   TAddrFamily = integer;
 
 
@@ -152,9 +157,9 @@ type
       0: (sin_family: u_short;
       0: (sin_family: u_short;
           sin_port: u_short;
           sin_port: u_short;
           sin_addr: TInAddr;
           sin_addr: TInAddr;
-          sin_zero: array[0..7] of Char);
+          sin_zero: array[0..7] of byte);
       1: (sa_family: u_short;
       1: (sa_family: u_short;
-          sa_data: array[0..13] of Char)
+          sa_data: array[0..13] of byte)
   end;
   end;
 
 
   TIP_mreq =  record
   TIP_mreq =  record
@@ -607,7 +612,7 @@ type
         case sin_family: u_short of
         case sin_family: u_short of
           AF_INET: (sin_port: u_short;
           AF_INET: (sin_port: u_short;
                     sin_addr: TInAddr;
                     sin_addr: TInAddr;
-                    sin_zero: array[0..7] of Char);
+                    sin_zero: array[0..7] of byte);
           AF_INET6: (sin6_port:     u_short;
           AF_INET6: (sin6_port:     u_short;
                 		sin6_flowinfo: u_long;
                 		sin6_flowinfo: u_long;
       	    	      sin6_addr:     TInAddr6;
       	    	      sin6_addr:     TInAddr6;
@@ -1219,7 +1224,11 @@ begin
     begin
     begin
       SockEnhancedApi := False;
       SockEnhancedApi := False;
       SockWship6Api := False;
       SockWship6Api := False;
-      Signal(SIGPIPE, TSignalHandler(SIG_IGN));
+      {$IfDef POSIX}
+        Signal(SIGPIPE, TSignalHandler(SIG_IGN));
+      {$Else}
+        Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
+      {$EndIf}
       LibHandle := LoadLibrary(PChar(Stack));
       LibHandle := LoadLibrary(PChar(Stack));
       if LibHandle <> 0 then
       if LibHandle <> 0 then
       begin
       begin

+ 58 - 33
ssposix.inc

@@ -1,5 +1,5 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.001.004 |
+| Project : Ararat Synapse                                       | 001.001.005 |
 |==============================================================================|
 |==============================================================================|
 | Content: Socket Independent Platform Layer - Delphi Posix definition include |
 | Content: Socket Independent Platform Layer - Delphi Posix definition include |
 |==============================================================================|
 |==============================================================================|
@@ -45,11 +45,12 @@
 
 
 {:@exclude}
 {:@exclude}
 
 
+{$WARN UNIT_PLATFORM OFF}
+{$WARN SYMBOL_PLATFORM OFF}
+
 {$IFDEF POSIX}
 {$IFDEF POSIX}
 {for delphi XE2+}
 {for delphi XE2+}
 
 
-{$WARN SYMBOL_PLATFORM OFF}
-
 //{$DEFINE FORCEOLDAPI}
 //{$DEFINE FORCEOLDAPI}
 {Note about define FORCEOLDAPI:
 {Note about define FORCEOLDAPI:
 If you activate this compiler directive, then is allways used old socket API
 If you activate this compiler directive, then is allways used old socket API
@@ -66,7 +67,6 @@ partially compatible with NextGen Delphi compiler - iOS
 
 
 }
 }
 
 
-
 interface
 interface
 
 
 uses
 uses
@@ -92,10 +92,8 @@ const
 type
 type
   TSocket = longint;
   TSocket = longint;
   TAddrFamily = integer;
   TAddrFamily = integer;
-
   TMemory = pointer;
   TMemory = pointer;
 
 
-
 type
 type
   TFDSet = fd_set;
   TFDSet = fd_set;
   PFDSet = Pfd_set;
   PFDSet = Pfd_set;
@@ -242,7 +240,11 @@ const
   AF_UNSPEC       = Posix.SysSocket.AF_UNSPEC;// 0;               { unspecified }
   AF_UNSPEC       = Posix.SysSocket.AF_UNSPEC;// 0;               { unspecified }
   AF_INET         = Posix.SysSocket.AF_INET;  // 2;               { internetwork: UDP, TCP, etc. }
   AF_INET         = Posix.SysSocket.AF_INET;  // 2;               { internetwork: UDP, TCP, etc. }
   AF_INET6        = Posix.SysSocket.AF_INET6; // !! 30            { Internetwork Version 6 }
   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
   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. }
 { Protocol families, same as address families for now. }
   PF_UNSPEC       = AF_UNSPEC;
   PF_UNSPEC       = AF_UNSPEC;
@@ -359,9 +361,13 @@ var
   SockEnhancedApi: Boolean;
   SockEnhancedApi: Boolean;
   SockWship6Api: Boolean;
   SockWship6Api: Boolean;
 
 
+{$IFDEF MACOS}
+   {$DEFINE SOCK_HAS_SINLEN} // OSX
+{$ENDIF}
+
 type
 type
   TVarSin = packed record
   TVarSin = packed record
-  {$IF defined(MACOS32) OR defined(IOS))}
+  {$ifdef SOCK_HAS_SINLEN}
      sin_len     : UInt8;
      sin_len     : UInt8;
   {$endif}
   {$endif}
 
 
@@ -371,7 +377,7 @@ type
         case sin_family: sa_family_t of
         case sin_family: sa_family_t of
           AF_INET: (sin_port: word;
           AF_INET: (sin_port: word;
                     sin_addr: TInAddr;
                     sin_addr: TInAddr;
-                    sin_zero: array[0..7] of Byte);
+                    sin_zero: array[0..7] of byte);
           AF_INET6: (sin6_port:     word;
           AF_INET6: (sin6_port:     word;
                 		sin6_flowinfo: FixedUInt;
                 		sin6_flowinfo: FixedUInt;
       	    	      sin6_addr:     TInAddr6;
       	    	      sin6_addr:     TInAddr6;
@@ -474,6 +480,13 @@ begin
   a^.s6_addr[15] := 1;
   a^.s6_addr[15] := 1;
 end;
 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;
 function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
@@ -571,14 +584,27 @@ begin
 end;
 end;
 
 
 function GetHostName: string;
 function GetHostName: string;
+const
+  cMaxHostLength = 255;
+{$IFDEF NEXTGEN}
 var
 var
-  name: TBytes;
+  name: TArray<Byte>;
 begin
 begin
-  SetLength(name, 256);
-  fillchar(name[0],sizeof(name),0);
-  if Posix.Unistd.GetHostName(@name[0], length(name))=0 then
-   result := Uppercase(StringOf(name)) else
-   result := 'LOCALHOST';
+  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;
 end;
 
 
 function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
 function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
@@ -694,12 +720,6 @@ begin
     Result := (Family = AF_INET6) and SockWship6Api;
     Result := (Family = AF_INET6) and SockWship6Api;
 end;
 end;
 
 
-function gethostbyname(name: pointer): PHostEnt; cdecl;
-  external libc name _PU + 'gethostbyname';
-
-function gethostbyaddr(var addr; len: socklen_t; atype: integer): PHostEnt; cdecl;
-  external libc name _PU + 'gethostbyaddr';
-
 function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
 function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
 var
 var
   ProtoEnt: PProtoEnt;
   ProtoEnt: PProtoEnt;
@@ -713,7 +733,10 @@ var
   function GetAddr(const IP, port: string; Hints: AddrInfo; var Sin: TVarSin): integer;
   function GetAddr(const IP, port: string; Hints: AddrInfo; var Sin: TVarSin): integer;
   var
   var
     Addr: PAddrInfo;
     Addr: PAddrInfo;
+    aIP,aPort : AnsiString;
   begin
   begin
+    aIP:=Utf8Encode(IP);
+    aPort:=Utf8Encode(Port);
     Addr := nil;
     Addr := nil;
     try
     try
       FillChar(Sin, Sizeof(Sin), 0);
       FillChar(Sin, Sizeof(Sin), 0);
@@ -721,23 +744,25 @@ var
       begin
       begin
         Hints.ai_socktype := 0;
         Hints.ai_socktype := 0;
         Hints.ai_protocol := 0;
         Hints.ai_protocol := 0;
-        Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), nil, Hints, Addr);
+        Result := GetAddrInfo(PAnsiChar(aIP), nil, Hints, Addr);
       end
       end
       else
       else
       begin
       begin
         if (IP = cAnyHost) or (IP = c6AnyHost) then
         if (IP = cAnyHost) or (IP = c6AnyHost) then
         begin
         begin
           Hints.ai_flags := AI_PASSIVE;
           Hints.ai_flags := AI_PASSIVE;
-          Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+          Result := GetAddrInfo(nil, PAnsiChar(aPort), Hints, Addr);
         end
         end
         else
         else
           if (IP = cLocalhost) or (IP = c6Localhost) then
           if (IP = cLocalhost) or (IP = c6Localhost) then
           begin
           begin
-            Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+            Result := GetAddrInfo(nil, PAnsiChar(aPort), Hints, Addr);
           end
           end
           else
           else
           begin
           begin
-            Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+            //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;
       end;
       end;
       if Result = 0 then
       if Result = 0 then
@@ -838,12 +863,12 @@ end;
 
 
 function GetSinIP(Sin: TVarSin): string;
 function GetSinIP(Sin: TVarSin): string;
 var
 var
-  p: pointer;
+  p: PAnsiChar;
   hostlen, servlen: integer;
   hostlen, servlen: integer;
   r: integer;
   r: integer;
   sa:sockaddr absolute Sin;
   sa:sockaddr absolute Sin;
   byHost, byServ: TBytes;
   byHost, byServ: TBytes;
-  HostWrapper, ServWrapper: Pointer;
+  HostWrapper, ServWrapper: TPtrWrapper;
 begin
 begin
   Result := '';
   Result := '';
   if not IsNewApi(Sin.AddressFamily) then
   if not IsNewApi(Sin.AddressFamily) then
@@ -859,12 +884,12 @@ begin
     servlen := NI_MAXSERV;
     servlen := NI_MAXSERV;
     Setlength(byHost, hostLen);
     Setlength(byHost, hostLen);
     Setlength(byServ, hostLen);
     Setlength(byServ, hostLen);
-    HostWrapper := @byHost[0];
-    ServWrapper := @byServ[0];
-    r := getnameinfo(sa, SizeOfVarSin(sin), HostWrapper, hostlen,
-      ServWrapper, servlen, NI_NUMERICHOST + NI_NUMERICSERV);
+    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
     if r = 0 then
-      Result := MarshaledAString(HostWrapper);
+      Result := TMarshal.ReadStringAsAnsi(HostWrapper{, NI_MAXHOST});
   end;
   end;
 end;
 end;
 
 
@@ -981,7 +1006,7 @@ var
   ServEnt: PServEnt;
   ServEnt: PServEnt;
   Hints: AddrInfo;
   Hints: AddrInfo;
   Addr: PAddrInfo;
   Addr: PAddrInfo;
-  _Addr: AddrInfo;
+  //_Addr: AddrInfo;
   r: integer;
   r: integer;
 begin
 begin
   Result := 0;
   Result := 0;
@@ -1029,7 +1054,7 @@ function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): s
 var
 var
   Hints: AddrInfo;
   Hints: AddrInfo;
   Addr: PAddrInfo;
   Addr: PAddrInfo;
-  _Addr: AddrInfo;
+  //_Addr: AddrInfo;
   r: integer;
   r: integer;
   host, serv: TBytes;
   host, serv: TBytes;
   hostlen, servlen: integer;
   hostlen, servlen: integer;

+ 3 - 3
sswin32.inc

@@ -1455,7 +1455,7 @@ begin
       if ServEnt = nil then
       if ServEnt = nil then
         Result := StrToIntDef(string(Port), 0)
         Result := StrToIntDef(string(Port), 0)
       else
       else
-        Result := synsock.htons(ServEnt^.s_port);
+        Result := synsock.ntohs(ServEnt^.s_port);
     finally
     finally
       SynSockCS.Leave;
       SynSockCS.Leave;
     end;
     end;
@@ -1473,9 +1473,9 @@ begin
       if (r = 0) and Assigned(Addr) then
       if (r = 0) and Assigned(Addr) then
       begin
       begin
         if Addr^.ai_family = AF_INET then
         if Addr^.ai_family = AF_INET then
-          Result := synsock.htons(Addr^.ai_addr^.sin_port);
+          Result := synsock.ntohs(Addr^.ai_addr^.sin_port);
         if Addr^.ai_family = AF_INET6 then
         if Addr^.ai_family = AF_INET6 then
-          Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
+          Result := synsock.ntohs(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
       end;
       end;
     finally
     finally
       if Assigned(Addr) then
       if Assigned(Addr) then

+ 53 - 7
synachar.pas

@@ -1,5 +1,5 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 005.002.004 |
+| Project : Ararat Synapse                                       | 005.002.005 |
 |==============================================================================|
 |==============================================================================|
 | Content: Charset conversion support                                          |
 | Content: Charset conversion support                                          |
 |==============================================================================|
 |==============================================================================|
@@ -72,6 +72,11 @@ Internal routines knows all major charsets for Europe or America. For East-Asian
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
 {$ENDIF}
 {$ENDIF}
 
 
+{$IFDEF NEXTGEN}
+  {$LEGACYIFEND ON}
+  {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
 unit synachar;
 unit synachar;
 
 
 interface
 interface
@@ -79,6 +84,11 @@ interface
 uses
 uses
 {$IFNDEF MSWINDOWS}
 {$IFNDEF MSWINDOWS}
   {$IFNDEF FPC}
   {$IFNDEF FPC}
+    {$IFNDEF POSIX}
+      Libc,
+    {$ELSE}
+      Posix.Langinfo,
+    {$ENDIF}
   {$ENDIF}
   {$ENDIF}
 {$ELSE}
 {$ELSE}
   Windows,
   Windows,
@@ -1378,6 +1388,9 @@ var
   NotNeedTransform: Boolean;
   NotNeedTransform: Boolean;
   FromID, ToID: string;
   FromID, ToID: string;
 begin
 begin
+  if not synaicnv.InitIconvInterface then
+    DisableIconv := True;
+
   NotNeedTransform := (High(TransformTable) = 0);
   NotNeedTransform := (High(TransformTable) = 0);
   if (CharFrom = CharTo) and NotNeedTransform then
   if (CharFrom = CharTo) and NotNeedTransform then
   begin
   begin
@@ -1502,8 +1515,16 @@ end;
 
 
 function GetCurCP: TMimeChar;
 function GetCurCP: TMimeChar;
 begin
 begin
-  {$IFNDEF LINUX}
+  {$IFNDEF FPC}
+    {$IFNDEF POSIX}
   Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
   Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
+    {$ELSE}
+      {$IFNDEF ANDROID}
+  Result := GetCPFromID(nl_langinfo(CODESET));
+      {$ELSE}
+  Result := UTF_8;
+      {$ENDIF}
+    {$ENDIF}
   {$ELSE}
   {$ELSE}
   //How to get system codepage without LIBC?
   //How to get system codepage without LIBC?
   Result := UTF_8;
   Result := UTF_8;
@@ -1738,15 +1759,40 @@ begin
   Result := '';
   Result := '';
   case Value of
   case Value of
     UCS_2:
     UCS_2:
-      Result := #$fe + #$ff;
+    begin
+      SetLength(Result, 2);
+      Result[1] := #$fe;
+      Result[2] := #$ff;
+    end;
     UCS_4:
     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:
     UCS_2LE:
-      Result := #$ff + #$fe;
+    begin
+      SetLength(Result, 2);
+      Result[1] := #$ff;
+      Result[2] := #$fe;
+    end;
     UCS_4LE:
     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:
     UTF_8:
-      Result := #$ef + #$bb + #$bf;
+    begin
+      SetLength(Result, 3);
+      Result[1] := #$ef;
+      Result[2] := #$bb;
+      Result[3] := #$bf;
+    end;
   end;
   end;
 end;
 end;
 
 

+ 8 - 8
synacode.pas

@@ -201,10 +201,10 @@ function DecodeXX(const Value: String): String;
 function DecodeYEnc(const Value: String): String;
 function DecodeYEnc(const Value: String): String;
 
 
 {:Returns a new CRC32 value after adding a new byte of data.}
 {: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.}
 {:return CRC32 from a value string.}
-function Crc32(const Value: String): Integer;
+function Crc32(const Value: String): Cardinal;
 
 
 {:Returns a new CRC16 value after adding a new byte of data.}
 {:Returns a new CRC16 value after adding a new byte of data.}
 function UpdateCrc16(Value: Byte; Crc16: Word): Word;
 function UpdateCrc16(Value: Byte; Crc16: Word): Word;
@@ -827,19 +827,19 @@ end;
 
 
 {==============================================================================}
 {==============================================================================}
 
 
-function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
+function UpdateCrc32(Value: Byte; Crc32: Cardinal): Cardinal;
 begin
 begin
   Result := (Crc32 shr 8)
   Result := (Crc32 shr 8)
-    xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))];
+    xor Cardinal(crc32tab[Byte(Value xor (Crc32 and Cardinal($000000FF)))]);
 end;
 end;
 
 
 {==============================================================================}
 {==============================================================================}
 
 
-function Crc32(const Value: String): Integer;
+function Crc32(const Value: String): Cardinal;
 var
 var
   n: Integer;
   n: Integer;
 begin
 begin
-  Result := Integer($FFFFFFFF);
+  Result := $FFFFFFFF;
   for n := 1 to Length(Value) do
   for n := 1 to Length(Value) do
     Result := UpdateCrc32(Ord(Value[n]), Result);
     Result := UpdateCrc32(Ord(Value[n]), Result);
   Result := not Result;
   Result := not Result;
@@ -882,7 +882,7 @@ begin
   MDContext.State[3] := Integer($10325476);
   MDContext.State[3] := Integer($10325476);
 end;
 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
 var
   A, B, C, D: LongInt;
   A, B, C, D: LongInt;
 
 
@@ -1387,7 +1387,7 @@ end;
 
 
 {==============================================================================}
 {==============================================================================}
 
 
-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
 var
   A, B, C, D: LongInt;
   A, B, C, D: LongInt;
   function LRot32(a, b: longint): longint;
   function LRot32(a, b: longint): longint;

+ 0 - 1
synacrypt.pas

@@ -1989,7 +1989,6 @@ var
   Size: integer;
   Size: integer;
   KC, ROUNDS, j, r, t, rconpointer: FixedUInt;
   KC, ROUNDS, j, r, t, rconpointer: FixedUInt;
   tk: array[0..MAXKC-1,0..3] of byte;
   tk: array[0..MAXKC-1,0..3] of byte;
-  //n: integer;
 begin
 begin
   FillChar(tk,Sizeof(tk),0);
   FillChar(tk,Sizeof(tk),0);
   //key must have at least 128 bits and max 256 bits
   //key must have at least 128 bits and max 256 bits

+ 5 - 5
synadbg.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.001.002 |
+| Project : Ararat Synapse                                       | 001.001.003 |
 |==============================================================================|
 |==============================================================================|
 | Content: Socket debug tools                                                  |
 | Content: Socket debug tools                                                  |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)2008-2011, Lukas Gebauer                                        |
+| Copyright (c)2008-2021, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2008-2011.                |
+| Portions created by Lukas Gebauer are Copyright (c)2008-2021.                |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -130,7 +130,7 @@ begin
   else
   else
     s := '-unknown-';
     s := '-unknown-';
   end;
   end;
-  s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF;
+  s := inttohex(PtrInt(Sender), 2 * SizeOf(PtrInt)) + s + ': ' + value + CRLF;
   AppendToLog(s);
   AppendToLog(s);
 end;
 end;
 
 
@@ -144,7 +144,7 @@ begin
     d := '-> '
     d := '-> '
   else
   else
     d := '<- ';
     d := '<- ';
-  s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF;
+  s :=inttohex(PtrInt(Sender), 2 * SizeOf(PtrInt)) + d + s + CRLF;
   AppendToLog(s);
   AppendToLog(s);
 end;
 end;
 
 

+ 3 - 4
synafpc.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.003.001 |
+| Project : Ararat Synapse                                       | 001.004.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: Utils for FreePascal compatibility                                  |
 | Content: Utils for FreePascal compatibility                                  |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| Copyright (c)1999-2022, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -38,6 +38,7 @@
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
 |   Tomas Hajny (OS2 support)                                                  |
 |   Tomas Hajny (OS2 support)                                                  |
+|   Projeto ACBr                                                               |
 |==============================================================================|
 |==============================================================================|
 | History: see HISTORY.HTM from distribution package                           |
 | History: see HISTORY.HTM from distribution package                           |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
@@ -131,7 +132,6 @@ function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer):
 begin
 begin
   Result := 0;
   Result := 0;
 end;
 end;
-
 {$ELSE}
 {$ELSE}
 {$ENDIF}
 {$ENDIF}
 
 
@@ -146,7 +146,6 @@ begin
 {$ELSE}
 {$ELSE}
   sysutils.sleep(milliseconds);
   sysutils.sleep(milliseconds);
 {$ENDIF}
 {$ENDIF}
-
 end;
 end;
 
 
 end.
 end.

+ 3 - 3
synaip.pas

@@ -42,7 +42,7 @@
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
 |==============================================================================}
 |==============================================================================}
 
 
-{:@abstract(IP address support procedures and functions)}
+{:@abstract(IP adress support procedures and functions)}
 
 
 {$IFDEF FPC}
 {$IFDEF FPC}
   {$MODE DELPHI}
   {$MODE DELPHI}
@@ -65,9 +65,9 @@ uses
   SysUtils, SynaUtil;
   SysUtils, SynaUtil;
 
 
 type
 type
-{:binary form of IPv6 address (for string conversion routines)}
+{:binary form of IPv6 adress (for string conversion routines)}
   TIp6Bytes = array [0..15] of Byte;
   TIp6Bytes = array [0..15] of Byte;
-{:binary form of IPv6 address (for string conversion routines)}
+{:binary form of IPv6 adress (for string conversion routines)}
   TIp6Words = array [0..7] of Word;
   TIp6Words = array [0..7] of Word;
 
 
 {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
 {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}

+ 255 - 44
synamisc.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 001.003.001 |
+| Project : Ararat Synapse                                       | 001.004.000 |
 |==============================================================================|
 |==============================================================================|
 | Content: misc. procedures and functions                                      |
 | Content: misc. procedures and functions                                      |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| Copyright (c)1999-2022, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c) 2002-2010.               |
+| Portions created by Lukas Gebauer are Copyright (c) 2002-2022.               |
 | All Rights Reserved.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -111,13 +111,15 @@ Type
     Host: string;
     Host: string;
     Port: string;
     Port: string;
     Bypass: string;
     Bypass: string;
+    ResultCode: integer;
+    Autodetected: boolean;
   end;
   end;
 
 
 {:With this function you can turn on a computer on the network, if this computer
 {: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. 
+ 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
  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
  computer on another network, you must specify any existing IP addres on same
  network segment as targeting computer.}
  network segment as targeting computer.}
@@ -127,14 +129,23 @@ procedure WakeOnLan(MAC, IP: string);
  is defined, then the result is comma-delimited.}
  is defined, then the result is comma-delimited.}
 function GetDNS: string;
 function GetDNS: string;
 
 
-{:Autodetect InternetExplorer proxy setting for given protocol. This function
+{:Read InternetExplorer 5.0+ proxy setting for given protocol. This function
 works only on windows!}
 works only on windows!}
 function GetIEProxy(protocol: string): TProxySetting;
 function GetIEProxy(protocol: string): TProxySetting;
 
 
-{:Return all known IP addresses on the local system. Addresses are divided by 
+{:Return all known IP addresses of required type on the local system. Addresses are divided by
 comma/comma-delimited.}
 comma/comma-delimited.}
-procedure GetLocalIPs(iplist: TStrings; ipfamily: Integer); overload;
-function GetLocalIPs: string; overload
+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
 implementation
 
 
@@ -359,22 +370,53 @@ begin
   Result.Host := '';
   Result.Host := '';
   Result.Port := '';
   Result.Port := '';
   Result.Bypass := '';
   Result.Bypass := '';
+  Result.ResultCode := -1;
+  Result.Autodetected := false;
 end;
 end;
 {$ELSE}
 {$ELSE}
 type
 type
-  PInternetProxyInfo = ^TInternetProxyInfo;
-  TInternetProxyInfo = packed record
-    dwAccessType: DWORD;
-    lpszProxy: LPCSTR;
-    lpszProxyBypass: LPCSTR;
+  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;
   end;
 const
 const
-  INTERNET_OPTION_PROXY = 38;
-  INTERNET_OPEN_TYPE_PROXY = 3;
+  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';
   WininetDLL = 'WININET.DLL';
 var
 var
   WininetModule: THandle;
   WininetModule: THandle;
-  ProxyInfo: PInternetProxyInfo;
+  Option : array[0..4] of INTERNET_PER_CONN_OPTION;
+  List   : INTERNET_PER_CONN_OPTION_LIST;
   Err: Boolean;
   Err: Boolean;
   Len: DWORD;
   Len: DWORD;
   Proxy: string;
   Proxy: string;
@@ -387,6 +429,8 @@ begin
   Result.Host := '';
   Result.Host := '';
   Result.Port := '';
   Result.Port := '';
   Result.Bypass := '';
   Result.Bypass := '';
+  Result.ResultCode := 0;
+  Result.Autodetected := false;
   WininetModule := LoadLibrary(WininetDLL);
   WininetModule := LoadLibrary(WininetDLL);
   if WininetModule = 0 then
   if WininetModule = 0 then
     exit;
     exit;
@@ -397,15 +441,25 @@ begin
 
 
     if protocol = '' then
     if protocol = '' then
       protocol := 'http';
       protocol := 'http';
-    Len := 4096;
-    GetMem(ProxyInfo, Len);
     ProxyList := TStringList.Create;
     ProxyList := TStringList.Create;
     try
     try
-      Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
+      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
       if Err then
-        if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
         begin
         begin
-          ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
+          ProxyList.CommaText := ReplaceString(Option[4].pszValue, ' ', ',');
           Proxy := '';
           Proxy := '';
           DefProxy := '';
           DefProxy := '';
           for n := 0 to ProxyList.Count -1 do
           for n := 0 to ProxyList.Count -1 do
@@ -425,11 +479,10 @@ begin
             Result.Host := Trim(SeparateLeft(Proxy, ':'));
             Result.Host := Trim(SeparateLeft(Proxy, ':'));
             Result.Port := Trim(SeparateRight(Proxy, ':'));
             Result.Port := Trim(SeparateRight(Proxy, ':'));
           end;
           end;
-          Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
+          Result.Bypass := ReplaceString(Option[3].pszValue, ' ', ',');
         end;
         end;
     finally
     finally
       ProxyList.Free;
       ProxyList.Free;
-      FreeMem(ProxyInfo);
     end;
     end;
   finally
   finally
     FreeLibrary(WininetModule);
     FreeLibrary(WininetModule);
@@ -440,23 +493,7 @@ end;
 
 
 {==============================================================================}
 {==============================================================================}
 
 
-procedure GetLocalIPs(iplist: TStrings; ipfamily: Integer);
-var
-  TcpSock: TTCPBlockSocket;
-begin
-    TcpSock := TTCPBlockSocket.create;
-    case ipfamily of
-      1 : TcpSock.family:=SF_IP4;
-      2 : TcpSock.family:=SF_IP6;
-    end;
-    try
-      TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
-    finally
-      TcpSock.Free;
-    end;
-end;
-
-function GetLocalIPs: string;
+function GetLocalIPsFamily(value: TSocketFamily): string;
 var
 var
   TcpSock: TTCPBlockSocket;
   TcpSock: TTCPBlockSocket;
   ipList: TStringList;
   ipList: TStringList;
@@ -465,8 +502,9 @@ begin
   ipList := TStringList.Create;
   ipList := TStringList.Create;
   try
   try
     TcpSock := TTCPBlockSocket.create;
     TcpSock := TTCPBlockSocket.create;
-    TcpSock.family:=SF_IP4;
     try
     try
+      if value <> SF_Any then
+        TcpSock.family := value;
       TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
       TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
       Result := ipList.CommaText;
       Result := ipList.CommaText;
     finally
     finally
@@ -477,6 +515,179 @@ begin
   end;
   end;
 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.
 end.

+ 133 - 46
synaser.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 007.006.001 |
+| Project : Ararat Synapse                                       | 007.007.001 |
 |==============================================================================|
 |==============================================================================|
 | Content: Serial port support                                                 |
 | Content: Serial port support                                                 |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)2001-2017, Lukas Gebauer                                        |
+| Copyright (c)2001-2023, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -83,6 +83,15 @@ case with my USB modem):
   {$ENDIF}
   {$ENDIF}
 {$ENDIF}
 {$ENDIF}
 
 
+{$IFDEF UNIX}
+  {$DEFINE USE_LINUX_LOCK}
+{$ENDIF}
+
+{$IFDEF ANDROID}
+  {$DEFINE UNIX}
+  {$UNDEF USE_LINUX_LOCK}
+{$ENDIF}
+
 {$IFDEF FPC}
 {$IFDEF FPC}
   {$MODE DELPHI}
   {$MODE DELPHI}
   {$IFDEF MSWINDOWS}
   {$IFDEF MSWINDOWS}
@@ -91,6 +100,17 @@ case with my USB modem):
   {define working mode w/o LIBC for fpc}
   {define working mode w/o LIBC for fpc}
   {$DEFINE NO_LIBC}
   {$DEFINE NO_LIBC}
 {$ENDIF}
 {$ENDIF}
+
+{$IFDEF POSIX}
+  {$WARN UNIT_PLATFORM OFF}
+  {$WARN SYMBOL_PLATFORM OFF}
+{$ENDIF}
+
+{$IFDEF NEXTGEN}
+  {$LEGACYIFEND ON}
+  {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
 {$Q-}
 {$Q-}
 {$H+}
 {$H+}
 {$M+}
 {$M+}
@@ -134,6 +154,7 @@ const
 
 
   LockfileDirectory = '/var/lock'; {HGJ}
   LockfileDirectory = '/var/lock'; {HGJ}
   PortIsClosed = -1;               {HGJ}
   PortIsClosed = -1;               {HGJ}
+  ErrAccessDenied = 9990;          {DSA}
   ErrAlreadyOwned = 9991;          {HGJ}
   ErrAlreadyOwned = 9991;          {HGJ}
   ErrAlreadyInUse = 9992;          {HGJ}
   ErrAlreadyInUse = 9992;          {HGJ}
   ErrWrongParameter = 9993;        {HGJ}
   ErrWrongParameter = 9993;        {HGJ}
@@ -208,9 +229,13 @@ type
 const
 const
 {$IFDEF UNIX}
 {$IFDEF UNIX}
   {$IFDEF BSD}
   {$IFDEF BSD}
-  MaxRates = 18;  //MAC
+    MaxRates = 18;  //MAC
   {$ELSE}
   {$ELSE}
-   MaxRates = 30; //UNIX
+    {$IFDEF CPUARM}
+    MaxRates = 19; //CPUARM
+    {$ELSE}
+    MaxRates = 30; //UNIX
+    {$ENDIF}
   {$ENDIF}
   {$ENDIF}
 {$ELSE}
 {$ELSE}
   MaxRates = 19;  //WIN
   MaxRates = 19;  //WIN
@@ -239,6 +264,7 @@ const
 {$IFNDEF BSD}
 {$IFNDEF BSD}
     ,(460800, B460800)
     ,(460800, B460800)
   {$IFDEF UNIX}
   {$IFDEF UNIX}
+    {$IFNDEF CPUARM}
     ,(500000, B500000),
     ,(500000, B500000),
     (576000, B576000),
     (576000, B576000),
     (921600, B921600),
     (921600, B921600),
@@ -250,6 +276,7 @@ const
     (3000000, B3000000),
     (3000000, B3000000),
     (3500000, B3500000),
     (3500000, B3500000),
     (4000000, B4000000)
     (4000000, B4000000)
+    {$ENDIF}
   {$ENDIF}
   {$ENDIF}
 {$ENDIF}
 {$ENDIF}
     );
     );
@@ -261,10 +288,27 @@ const // From fcntl.h
   O_SYNC = $0080;  { synchronous writes }
   O_SYNC = $0080;  { synchronous writes }
 {$ENDIF}
 {$ENDIF}
 
 
+{$IFDEF ANDROID}
+const
+  TIOCMSET = $5418;
+  TIOCMGET = $5415;
+  TCSBRK   = $5409;
+{$ENDIF}
+
 const
 const
   sOK = 0;
   sOK = 0;
   sErr = integer(-1);
   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
 type
 
 
   {:Possible status event types for @link(THookSerialStatus)}
   {:Possible status event types for @link(THookSerialStatus)}
@@ -345,9 +389,11 @@ type
     procedure GetComNr(Value: string); virtual;
     procedure GetComNr(Value: string); virtual;
     function PreTestFailing: boolean; virtual;{HGJ}
     function PreTestFailing: boolean; virtual;{HGJ}
     function TestCtrlLine: Boolean; virtual;
     function TestCtrlLine: Boolean; virtual;
-{$IFDEF UNIX}    
+{$IFNDEF MSWINDOWS}
     procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
     procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
     procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
     procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
+{$ENDIF}
+{$IFDEF USE_LINUX_LOCK}
     function ReadLockfile: integer; virtual;
     function ReadLockfile: integer; virtual;
     function LockfileName: String; virtual;
     function LockfileName: String; virtual;
     procedure CreateLockfile(PidNr: integer); virtual;
     procedure CreateLockfile(PidNr: integer); virtual;
@@ -358,7 +404,7 @@ type
     {: data Control Block with communication parameters. Usable only when you
     {: data Control Block with communication parameters. Usable only when you
      need to call API directly.}
      need to call API directly.}
     DCB: Tdcb;
     DCB: Tdcb;
-{$IFDEF UNIX}
+{$IFNDEF MSWINDOWS}
     TermiosStruc: termios;
     TermiosStruc: termios;
 {$ENDIF}
 {$ENDIF}
     {:Object constructor.}
     {:Object constructor.}
@@ -636,7 +682,7 @@ type
 
 
     {:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
     {:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
     procedure RaiseSynaError(ErrNumber: integer); virtual;
     procedure RaiseSynaError(ErrNumber: integer); virtual;
-{$IFDEF UNIX}
+{$IFDEF USE_LINUX_LOCK}
     function  cpomComportAccessible: boolean; virtual;{HGJ}
     function  cpomComportAccessible: boolean; virtual;{HGJ}
     procedure cpomReleaseComport; virtual; {HGJ}
     procedure cpomReleaseComport; virtual; {HGJ}
 {$ENDIF}
 {$ENDIF}
@@ -828,7 +874,7 @@ begin
   end;
   end;
   if InstanceActive then
   if InstanceActive then
   begin
   begin
-    {$IFDEF UNIX}
+    {$IFDEF USE_LINUX_LOCK}
     if FLinuxLock then
     if FLinuxLock then
       cpomReleaseComport;
       cpomReleaseComport;
     {$ENDIF}
     {$ENDIF}
@@ -908,7 +954,7 @@ begin
         sleep(x);
         sleep(x);
       end;
       end;
     end;
     end;
-    Next := GetTick + Trunc((Length / MaxB) * 1000);
+    Next := GetTick + LongWord(Trunc((Length / MaxB) * 1000));
   end;
   end;
 end;
 end;
 
 
@@ -981,23 +1027,34 @@ begin
 {$IFNDEF ULTIBO}
 {$IFNDEF ULTIBO}
   if FComNr <> PortIsClosed then
   if FComNr <> PortIsClosed then
     FDevice := '/dev/ttyS' + IntToStr(FComNr);
     FDevice := '/dev/ttyS' + IntToStr(FComNr);
-  // Comport already owned by another process?          {HGJ}
-  if FLinuxLock then
-    if not cpomComportAccessible then
-    begin
-      RaiseSynaError(ErrAlreadyOwned);
-      Exit;
-    end;
+  {$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}
   {$IFNDEF FPC}
-  FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
+    {$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}
   {$ELSE}
-  FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
+    FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
   {$ENDIF}
   {$ENDIF}
   if FHandle = INVALID_HANDLE_VALUE then  //because THandle is not integer on all platforms!
   if FHandle = INVALID_HANDLE_VALUE then  //because THandle is not integer on all platforms!
     SerialCheck(-1)
     SerialCheck(-1)
   else
   else
     SerialCheck(0);
     SerialCheck(0);
-  {$IFDEF UNIX}
+  {$IFDEF USE_LINUX_LOCK}
   if FLastError <> sOK then
   if FLastError <> sOK then
     if FLinuxLock then
     if FLinuxLock then
       cpomReleaseComport;
       cpomReleaseComport;
@@ -1066,7 +1123,7 @@ begin
     {$ELSE}
     {$ELSE}
     FileClose(FHandle);         {HGJ}
     FileClose(FHandle);         {HGJ}
     {$ENDIF}
     {$ENDIF}
-    {$IFDEF UNIX}
+    {$IFDEF USE_LINUX_LOCK}
     if FLinuxLock then
     if FLinuxLock then
       cpomReleaseComport;                {HGJ}
       cpomReleaseComport;                {HGJ}
     {$ENDIF}                             {HGJ}
     {$ENDIF}                             {HGJ}
@@ -1786,7 +1843,11 @@ end;
 procedure TBlockSerial.SetCommState;
 procedure TBlockSerial.SetCommState;
 begin
 begin
   DcbToTermios(dcb, termiosstruc);
   DcbToTermios(dcb, termiosstruc);
-  SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
+  {$IfDef POSIX}
+    ioctl(Fhandle, TCSANOW, PInteger(@TermiosStruc));
+  {$Else}
+    SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
+  {$EndIf}
   ExceptCheck;
   ExceptCheck;
 end;
 end;
 {$ELSE}
 {$ELSE}
@@ -2101,7 +2162,7 @@ end;
 {$IFNDEF ULTIBO}
 {$IFNDEF ULTIBO}
 function TBlockSerial.CanRead(Timeout: integer): boolean;
 function TBlockSerial.CanRead(Timeout: integer): boolean;
 var
 var
-  FDSet: TFDSet;
+  FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF};
   TimeVal: PTimeVal;
   TimeVal: PTimeVal;
   TimeV: TTimeVal;
   TimeV: TTimeVal;
   x: Integer;
   x: Integer;
@@ -2113,7 +2174,7 @@ begin
     TimeVal := nil;
     TimeVal := nil;
   {$IFNDEF FPC}
   {$IFNDEF FPC}
   FD_ZERO(FDSet);
   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);
   x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
   {$ELSE}
   {$ELSE}
   fpFD_ZERO(FDSet);
   fpFD_ZERO(FDSet);
@@ -2164,7 +2225,7 @@ end;
 {$IFNDEF ULTIBO}
 {$IFNDEF ULTIBO}
 function TBlockSerial.CanWrite(Timeout: integer): boolean;
 function TBlockSerial.CanWrite(Timeout: integer): boolean;
 var
 var
-  FDSet: TFDSet;
+  FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF};
   TimeVal: PTimeVal;
   TimeVal: PTimeVal;
   TimeV: TTimeVal;
   TimeV: TTimeVal;
   x: Integer;
   x: Integer;
@@ -2176,7 +2237,7 @@ begin
     TimeVal := nil;
     TimeVal := nil;
   {$IFNDEF FPC}
   {$IFNDEF FPC}
   FD_ZERO(FDSet);
   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);
   x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
   {$ELSE}
   {$ELSE}
   fpFD_ZERO(FDSet);
   fpFD_ZERO(FDSet);
@@ -2277,17 +2338,20 @@ begin
 end;
 end;
 
 
 procedure TBlockSerial.Flush;
 procedure TBlockSerial.Flush;
+var
+  Data : Integer;
 begin
 begin
 {$IFNDEF MSWINDOWS}
 {$IFNDEF MSWINDOWS}
-{$IFNDEF ULTIBO}
-  SerialCheck(tcdrain(FHandle));
-{$ELSE}
-  SetSynaError(sOK);
-  while SendingData > 0 do
-  begin
-   Sleep(0);
-  end;
-{$ENDIF}    
+  {$IFDEF ANDROID}
+    Data := 1;
+    {$IFNDEF FPC}
+    ioctl(FHandle, TCSBRK, 1);
+    {$ELSE}
+    FpIOCtl(FHandle, TCSBRK, @Data);
+    {$ENDIF}    
+  {$ELSE}
+    SerialCheck(tcdrain(FHandle));
+  {$ENDIF}
 {$ELSE}
 {$ELSE}
   SetSynaError(sOK);
   SetSynaError(sOK);
   if not Flushfilebuffers(FHandle) then
   if not Flushfilebuffers(FHandle) then
@@ -2568,7 +2632,7 @@ end;
   Ownership Manager.
   Ownership Manager.
 }
 }
 
 
-{$IFDEF UNIX}
+{$IFDEF USE_LINUX_LOCK}
 
 
 function TBlockSerial.LockfileName: String;
 function TBlockSerial.LockfileName: String;
 var
 var
@@ -2580,8 +2644,13 @@ end;
 
 
 procedure TBlockSerial.CreateLockfile(PidNr: integer);
 procedure TBlockSerial.CreateLockfile(PidNr: integer);
 var
 var
-  f: TextFile;
   s: string;
   s: string;
+{$IFDEF FPC}
+  m: Word;
+  FS: TFileStream;
+{$ELSE}
+  f: TextFile;
+{$ENDIF}
 begin
 begin
   // Create content for file
   // Create content for file
   s := IntToStr(PidNr);
   s := IntToStr(PidNr);
@@ -2589,6 +2658,7 @@ begin
     s := ' ' + s;
     s := ' ' + s;
   // Create file
   // Create file
   try
   try
+{$IFNDEF FPC}
     AssignFile(f, LockfileName);
     AssignFile(f, LockfileName);
     try
     try
       Rewrite(f);
       Rewrite(f);
@@ -2596,6 +2666,21 @@ begin
     finally
     finally
       CloseFile(f);
       CloseFile(f);
     end;
     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
     // Allow all users to enjoy the benefits of cpom
     s := 'chmod a+rw ' + LockfileName;
     s := 'chmod a+rw ' + LockfileName;
   {$IFNDEF FPC}
   {$IFNDEF FPC}
@@ -2642,10 +2727,10 @@ begin
   if not DirectoryExists(LockfileDirectory) then
   if not DirectoryExists(LockfileDirectory) then
     CreateDir(LockfileDirectory);
     CreateDir(LockfileDirectory);
   // Check the Lockfile
   // Check the Lockfile
-  if not FileExists (Filename) then
+  if not FileExists(Filename) then
   begin // comport is not locked. Lock it for us.
   begin // comport is not locked. Lock it for us.
     CreateLockfile(MyPid);
     CreateLockfile(MyPid);
-    result := true;
+    result := FileExists(Filename);
     exit;  // done.
     exit;  // done.
   end;
   end;
   // Is port owned by orphan? Then it's time for error recovery.
   // Is port owned by orphan? Then it's time for error recovery.
@@ -2655,7 +2740,7 @@ begin
   begin //  Lockfile was left from former desaster
   begin //  Lockfile was left from former desaster
     DeleteFile(Filename); // error recovery
     DeleteFile(Filename); // error recovery
     CreateLockfile(MyPid);
     CreateLockfile(MyPid);
-    result := true;
+    result := FileExists(Filename);
     exit;
     exit;
   end;
   end;
   {$ENDIF}
   {$ENDIF}
@@ -2702,13 +2787,15 @@ end;
 {$IFNDEF MSWINDOWS}
 {$IFNDEF MSWINDOWS}
 {$IFNDEF ULTIBO}
 {$IFNDEF ULTIBO}
 function GetSerialPortNames: string;
 function GetSerialPortNames: string;
+const
+  ATTR = {$IFDEF POSIX}$7FFFFFFF{$ELSE}$FFFFFFFF{$ENDIF};
 var
 var
   sr : TSearchRec;
   sr : TSearchRec;
 begin
 begin
   Result := '';
   Result := '';
-  if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then
+  if FindFirst('/dev/ttyS*', ATTR, sr) = 0 then
     repeat
     repeat
-      if (sr.Attr and $FFFFFFFF) = Sr.Attr then
+      if (sr.Attr and ATTR) = Sr.Attr then
       begin
       begin
         if Result <> '' then
         if Result <> '' then
           Result := Result + ',';
           Result := Result + ',';
@@ -2716,18 +2803,18 @@ begin
       end;
       end;
     until FindNext(sr) <> 0;
     until FindNext(sr) <> 0;
   FindClose(sr);
   FindClose(sr);
-  if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin
+  if FindFirst('/dev/ttyUSB*', ATTR, sr) = 0 then begin
     repeat
     repeat
-      if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
+      if (sr.Attr and ATTR) = Sr.Attr then begin
         if Result <> '' then Result := Result + ',';
         if Result <> '' then Result := Result + ',';
         Result := Result + '/dev/' + sr.Name;
         Result := Result + '/dev/' + sr.Name;
       end;
       end;
     until FindNext(sr) <> 0;
     until FindNext(sr) <> 0;
   end;
   end;
   FindClose(sr);
   FindClose(sr);
-  if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin
+  if FindFirst('/dev/ttyAM*', ATTR, sr) = 0 then begin
     repeat
     repeat
-      if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
+      if (sr.Attr and ATTR) = Sr.Attr then begin
         if Result <> '' then Result := Result + ',';
         if Result <> '' then Result := Result + ',';
         Result := Result + '/dev/' + sr.Name;
         Result := Result + '/dev/' + sr.Name;
       end;
       end;

+ 5 - 0
synautil.pas

@@ -59,6 +59,11 @@
   {$WARN IMPLICIT_STRING_CAST OFF}
   {$WARN IMPLICIT_STRING_CAST OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
   {$WARN SUSPICIOUS_TYPECAST OFF}
   {$WARN SUSPICIOUS_TYPECAST OFF}
+  {$WARN SYMBOL_DEPRECATED OFF}
+{$ENDIF}
+
+{$IFDEF NEXTGEN}
+  {$ZEROBASEDSTRINGS OFF}
 {$ENDIF}
 {$ENDIF}
 
 
 unit synautil;
 unit synautil;

+ 3 - 6
synsock.pas

@@ -1,9 +1,9 @@
 {==============================================================================|
 {==============================================================================|
-| Project : Ararat Synapse                                       | 005.002.003 |
+| Project : Ararat Synapse                                       | 005.002.004 |
 |==============================================================================|
 |==============================================================================|
 | Content: Socket Independent Platform Layer                                   |
 | Content: Socket Independent Platform Layer                                   |
 |==============================================================================|
 |==============================================================================|
-| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| Copyright (c)1999-2022, Lukas Gebauer                                        |
 | All rights reserved.                                                         |
 | All rights reserved.                                                         |
 |                                                                              |
 |                                                                              |
 | Redistribution and use in source and binary forms, with or without           |
 | Redistribution and use in source and binary forms, with or without           |
@@ -33,7 +33,7 @@
 | DAMAGE.                                                                      |
 | DAMAGE.                                                                      |
 |==============================================================================|
 |==============================================================================|
 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 | 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.                                                         |
 | All Rights Reserved.                                                         |
 |==============================================================================|
 |==============================================================================|
 | Contributor(s):                                                              |
 | Contributor(s):                                                              |
@@ -85,9 +85,6 @@ unit synsock;
     {$ENDIF}
     {$ENDIF}
   {$ENDIF}
   {$ENDIF}
 {$ENDIF}
 {$ENDIF}
-//{$IFDEF POSIX}
-//   {$I ssposix.inc} //experimental!
-//{$ENDIF}
 
 
 end.
 end.