first release

Project2.dpr

@@ -0,0 +1,14 @@
+program Project2;
+
+uses
+  Vcl.Forms,
+  Unit2 in 'Unit2.pas' {Form2};
+
+{$R *.res}
+
+begin
+  Application.Initialize;
+  Application.MainFormOnTaskbar := True;
+  Application.CreateForm(TForm2, Form2);
+  Application.Run;
+end.

Project2.dproj

@@ -0,0 +1,121 @@
+<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+    <PropertyGroup>
+        <ProjectGuid>{F46C6246-B90C-4984-B610-497F767B46C6}</ProjectGuid>
+        <ProjectVersion>15.4</ProjectVersion>
+        <FrameworkType>VCL</FrameworkType>
+        <MainSource>Project2.dpr</MainSource>
+        <Base>True</Base>
+        <Config Condition="'$(Config)'==''">Debug</Config>
+        <Platform Condition="'$(Platform)'==''">Win32</Platform>
+        <TargetedPlatforms>1</TargetedPlatforms>
+        <AppType>Application</AppType>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
+        <Base_Win32>true</Base_Win32>
+        <CfgParent>Base</CfgParent>
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
+        <Base_Win64>true</Base_Win64>
+        <CfgParent>Base</CfgParent>
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''">
+        <Cfg_1>true</Cfg_1>
+        <CfgParent>Base</CfgParent>
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
+        <Cfg_1_Win32>true</Cfg_1_Win32>
+        <CfgParent>Cfg_1</CfgParent>
+        <Cfg_1>true</Cfg_1>
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
+        <Cfg_2>true</Cfg_2>
+        <CfgParent>Base</CfgParent>
+        <Base>true</Base>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Base)'!=''">
+        <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
+        <SanitizedProjectName>Project2</SanitizedProjectName>
+        <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
+        <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput>
+        <DCC_ExeOutput>.\$(Platform)\$(Config)</DCC_ExeOutput>
+        <DCC_E>false</DCC_E>
+        <DCC_N>false</DCC_N>
+        <DCC_S>false</DCC_S>
+        <DCC_F>false</DCC_F>
+        <DCC_K>false</DCC_K>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Base_Win32)'!=''">
+        <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
+        <VerInfo_Locale>1033</VerInfo_Locale>
+        <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
+        <DCC_UsePackage>EurekaLogCore;JvGlobus;RVASpellPkgDXE6;JvMM;vquery200;zexmlsslib;IndyProtocols200;JvManagedThreads;pgprovider200;FireDACSqliteDriver;TestPack;uniSF20;uniSFChart20;DBXSqliteDriver;FireDACPgDriver;VCLXDBGrid200;accessprovider200;fmx;uniGUI20Core;JvDlgs;JvCrypt;TeeDB;tethering;inetdbbde;vclib;DBXInterBaseDriver;RichViewActionsDXE6;JvNet;RVIndyDXE6;JvDotNetCtrls;RvXmlDXE6;mongoprovider200;DbxCommonDriver;crcontrols200;vclimg;RVPkgDXE6;dbxcds;IndySystem200;dbfprovider200;JvXPCtrls;tdsprovider200;RvHtmlDXE6;vcldb;vcldsnap;liteprovider200;uniGUI20VCL;odbcprovider200;fmxFireDAC;dacvcl200;CustomIPTransport;JvCore;RVDBPkgDXE6;vclribbon;adsprovider200;dsnap;fmxase;vcl;dacfmx200;oraprovider200;CloudService;CodeSiteExpressPkg;FmxTeeUI;FireDACIBDriver;JvAppFrm;soapserver;JvDB;JvRuntimeDesign;inetdbxpress;dsnapxml;JclDeveloperTools;uSynEdit_R2016;JvDocking;adortl;JvWizards;FireDACASADriver;JvHMI;aseprovider200;AviPack;RVMathDXE6;uniTools20;bindcompfmx;JvBands;vcldbx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;DSPack_DXE2;FireDACCommon;bindcomp;inetdb;IndyCore200;JvPluginSystem;dac200;uniGUI20;Tee;JclContainers;tb2k_d16;JvCmp;vclFireDAC;JvSystem;xmlrtl;svnui;ibxpress;JvTimeFramework;JvControls;uniGUI20m;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;soaprtl;bindengine;vclactnband;FMXTee;TeeUI;bindcompvcl;ibprovider200;db2provider200;unidacvcl200;vclie;Jcl;JvStdCtrls;JvCustom;unidacfmx200;FireDACADSDriver;vcltouch;JvJans;JvPageComps;unidac200;myprovider200;JvPrintPreview;PngComponents;uIndy20;VclSmp;FireDAC;VCLRESTComponents;CoolTrayIconD16;Intraweb;RVHunSpellPkgDXE6;gtPDFkitDXE6ProP;dsnapcon;uniGUI20Chart;inet;fmxobj;JclVcl;JvPascalInterpreter;FireDACMySQLDriver;soapmidas;vclx;svn;fmxdae;RESTComponents;bdertl;FFmpeg_DXE6;AwSlider70;FireDACMSAccDriver;dbexpress;SpTBXLib;JvBDE;$(DCC_UsePackage)</DCC_UsePackage>
+        <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File>
+        <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Base_Win64)'!=''">
+        <DCC_UsePackage>vquery200;IndyProtocols200;pgprovider200;FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;accessprovider200;fmx;uniGUI20Core;TeeDB;tethering;vclib;DBXInterBaseDriver;mongoprovider200;DbxCommonDriver;crcontrols200;vclimg;dbxcds;IndySystem200;dbfprovider200;tdsprovider200;vcldb;vcldsnap;liteprovider200;uniGUI20VCL;odbcprovider200;fmxFireDAC;dacvcl200;CustomIPTransport;JvCore;RVDBPkgDXE6;vclribbon;adsprovider200;dsnap;fmxase;vcl;dacfmx200;oraprovider200;CloudService;FmxTeeUI;FireDACIBDriver;soapserver;inetdbxpress;dsnapxml;uSynEdit_R2016;adortl;FireDACASADriver;aseprovider200;AviPack;uniTools20;bindcompfmx;FireDACODBCDriver;RESTBackendComponents;rtl;dbrtl;DbxClientDriver;DSPack_DXE2;FireDACCommon;bindcomp;inetdb;IndyCore200;dac200;uniGUI20;Tee;vclFireDAC;xmlrtl;ibxpress;uniGUI20m;DBXMySQLDriver;FireDACCommonDriver;bindcompdbx;soaprtl;bindengine;vclactnband;FMXTee;TeeUI;bindcompvcl;ibprovider200;db2provider200;unidacvcl200;vclie;unidacfmx200;FireDACADSDriver;vcltouch;unidac200;myprovider200;PngComponents;uIndy20;VclSmp;FireDAC;VCLRESTComponents;CoolTrayIconD16;Intraweb;dsnapcon;uniGUI20Chart;inet;fmxobj;FireDACMySQLDriver;soapmidas;vclx;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;SpTBXLib;JvBDE;$(DCC_UsePackage)</DCC_UsePackage>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Cfg_1)'!=''">
+        <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
+        <DCC_DebugDCUs>true</DCC_DebugDCUs>
+        <DCC_Optimize>false</DCC_Optimize>
+        <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
+        <DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
+        <DCC_RemoteDebug>true</DCC_RemoteDebug>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
+        <DCC_RemoteDebug>false</DCC_RemoteDebug>
+    </PropertyGroup>
+    <PropertyGroup Condition="'$(Cfg_2)'!=''">
+        <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
+        <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
+        <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
+        <DCC_DebugInformation>0</DCC_DebugInformation>
+    </PropertyGroup>
+    <ItemGroup>
+        <DelphiCompile Include="$(MainSource)">
+            <MainSource>MainSource</MainSource>
+        </DelphiCompile>
+        <DCCReference Include="Unit2.pas">
+            <Form>Form2</Form>
+            <FormType>dfm</FormType>
+        </DCCReference>
+        <BuildConfiguration Include="Release">
+            <Key>Cfg_2</Key>
+            <CfgParent>Base</CfgParent>
+        </BuildConfiguration>
+        <BuildConfiguration Include="Base">
+            <Key>Base</Key>
+        </BuildConfiguration>
+        <BuildConfiguration Include="Debug">
+            <Key>Cfg_1</Key>
+            <CfgParent>Base</CfgParent>
+        </BuildConfiguration>
+    </ItemGroup>
+    <ProjectExtensions>
+        <Borland.Personality>Delphi.Personality.12</Borland.Personality>
+        <Borland.ProjectType/>
+        <BorlandProject>
+            <Delphi.Personality>
+                <Source>
+                    <Source Name="MainSource">Project2.dpr</Source>
+                </Source>
+            </Delphi.Personality>
+            <Deployment/>
+            <Platforms>
+                <Platform value="Win32">True</Platform>
+                <Platform value="Win64">False</Platform>
+            </Platforms>
+        </BorlandProject>
+        <ProjectFileVersion>12</ProjectFileVersion>
+    </ProjectExtensions>
+    <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
+    <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/>
+</Project>

SynHttpSrv.pas

@@ -0,0 +1,3332 @@
+{--------------------------------------------------------------}
+
+{  SynHttpSrv.pas - HTTP server over Synapse                   }
+
+ {  Author:     Semi                                            }
+ {  Started:    070528                                          }
+
+{--------------------------------------------------------------}
+unit SynHttpSrv;
+
+{$IFDEF FPC}
+  {$MODE Delphi}
+{$ENDIF}
+
+interface
+
+uses
+ {$IFDEF MSWINDOWS}
+ Windows,
+ {$ELSE}
+ SynaUtil,
+ {$ENDIF}
+ ssl_openssl,
+ SysUtils,
+ Classes,
+ synsock,
+ blcksock,
+ SynSrv;
+//-------------------------------------------------------------
+
+{$undef DEBUG}
+//{$define DEBUG}
+
+//!!!TODO: SSL/https
+
+//{$define CIL} //only for dotnet testing...
+
+type
+ // Result: True=found/stop, False=continue
+ THeaderEnum = function(const Value: string; LParam: NativeUInt): boolean of object;
+
+ THeaderList = class(TStringList)
+ private
+  function GetValueByName(const Name: string): string;
+  procedure SetValueByName(const Name, Value: string);
+  function GetNameByIndex(Index: integer): string;
+  function GetValueByIndex(Index: integer): string;
+  function CheckHttpFindValue(const Value: string; LParam: NativeUInt): boolean;
+  function GetSubValue(const Name, SubName: string): string;
+  procedure SetSubValue(const Name, SubName, Value: string);
+ protected
+  procedure Put(Index: integer; const S: string); override;
+ public
+  property Values[const Name: string]: string Read GetValueByName Write SetValueByName; default;
+  //
+  property Names[Index: integer]: string Read GetNameByIndex;
+  property ValuesByIndex[Index: integer]: string Read GetValueByIndex;
+  property SubValues[const Name, SubName: string]: string Read GetSubValue Write SetSubValue;
+  // for 'ContentType: text/html; charset="Windows-1250"', SubValues['Content-Type','charset']
+  //
+  function IndexOfName(const Name: string): integer; reintroduce;
+  procedure AddValue(const Name, Value: string); // add (possibly duplicate) value...
+  function RemoveValue(const Name: string): boolean; // used also by writing Values[Name]:='';
+  //
+  // Enumerates duplicated or comma-separated headers:
+  procedure EnumHeaders(const Name: string; const Enum: THeaderEnum; const Sep: char; LParam: NativeUInt = 0);
+  function HasValue(const Name, Value: string): boolean; // Connection: upgrade, close
+  function Add(const S: string): integer; override;
+  procedure Insert(Index: integer; const S: string); override;
+ end;
+
+ THttpCookie = class(TCollectionItem)
+ private
+  FName:    string;
+  FValue:   string;
+  FDomain:  string;
+  FPath:    string;
+  FExpires: string;
+  FVersion: string;
+  FMaxAge:  string;
+  FComment: string;
+  FSecure:  boolean;
+  FSameSite:boolean;
+  function GetText: string;
+ public
+  property Name: string Read FName Write FName;
+  property Value: string Read FValue Write FValue;
+  property Text: string Read GetText;
+  //
+  property Domain: string Read FDomain Write FDomain;
+  property Path: string Read FPath Write FPath;
+  property Version: string Read FVersion Write FVersion;
+  property MaxAge: string Read FMaxAge Write FMaxAge;
+  property Comment: string Read FComment Write FComment;
+  property Secure: boolean Read FSecure Write FSecure;
+  property SameSite: boolean Read FSameSite Write FSameSite;
+  property Expires: string Read FExpires Write FExpires; // obsolette...
+  //
+  procedure DeleteCookie; // set MaxAge:='0'; so that client will delete the cookie...
+  //
+  procedure Assign(Source: TPersistent); override;
+  //
+  function GetServerCookie: string; // Set-Cookie: format... (for sending server->client)
+  function GetClientCookie: string; // Cookie:     format... (for sending client->server)
+  function ParseValue(Line: string; Version: NativeUInt): boolean;
+  // parse either Cookie: or SetCookie: header part, 1 cookie at a time...
+  function MatchPath(const aPath: string): boolean; // is it cookie for this path?
+ end;
+
+ { THttpCookies }
+
+ THttpCookies = class(TCollection)
+ private
+  function GetCookieItem(Index: integer): THttpCookie;
+  function AddCookieValue(const Value: string; LParam: NativeUInt): boolean;
+  function GetValue(const Name: string): string;
+  procedure SetValue(const Name, Value: string);
+  function GetCommaText: string;
+ public
+  constructor Create;
+  //
+  property Cookies[Index: integer]: THttpCookie Read GetCookieItem; default;
+  function IndexOf(const Name: string): integer;
+  function Find(const Name: string): THttpCookie;
+  //
+  // Load cookies from client, used in server... (Cookie: headers)
+  procedure LoadClientCookies(Headers: THeaderList);
+  // Save cookies to client, used in server...
+  procedure SaveServerCookies(Headers: THeaderList; const DefaultDomain, DefaultPath: string);
+  //
+  // Load cookies from server, used in client... (Set-Cookie: headers)
+  procedure LoadServerCookies(Headers: THeaderList);
+  // Save cookies to server, used in client...
+  procedure SaveClientCookies(Headers: THeaderList; const Path: string);
+  //
+  // Other client-side functions:
+  procedure MergeCookies(Source: THttpCookies);
+  procedure SetDefaultPath;
+  procedure SetSameSite;
+
+  property Values[const Name: string]: string Read GetValue Write SetValue;
+
+  property CommaText: string Read GetCommaText;
+ end;
+
+ // HTTP request and response object
+
+ { THttpRequest }
+
+ THttpRequest = class(TPersistent)
+ private
+  FHeaders:      THeaderList;
+  FCookies:      THttpCookies;
+  FParams:       TStringList;
+  FPostStream:   TStream;
+  FUrl:          string;
+  FMethod:       string;
+  FProtocol:     string;
+  FContent:      string;
+  //FContentStream: TStream;
+  FStatusCode:   integer;
+  FStatusMsg:    string;
+  FConnection:   TObject;
+  FFlags:        integer;
+  FResponseSent: boolean;
+  FCharSet:      string;
+  FDocument:     string;
+  procedure SetHeaders(Value: THeaderList);
+  procedure SetCookies(Value: THttpCookies);
+  procedure SetStatusCode(Value: integer);
+  function GetFlagBool(Index: integer): boolean;
+  procedure SetFlagBool(Index: integer; Value: boolean);
+  function GetStrProp(Index: integer): string;
+  procedure SetStrProp(Index: integer; const Value: string);
+  function GetDateProp(Index: integer): TDateTime;
+  procedure SetDateProp(Index: integer; const Value: TDateTime);
+  //
+  procedure ApplyHeaders(bnIsServer: boolean); virtual;
+  // parse Cookies and possibly other things from Headers... used by TSynHttpServer.ReadRequest
+  function AddMultiPartFormItem(Headers: THeaderList; const FieldName, Content: string): boolean;
+  procedure SetCharSet(const Value: string);
+ public
+  constructor Create;
+  destructor Destroy; override;
+  procedure Assign(Source: TPersistent); override;
+  //
+  property Headers: THeaderList Read FHeaders Write SetHeaders;  // Set assigns copy...
+  //
+  property Cookies: THttpCookies Read FCookies Write SetCookies; // Set assigns copy...
+  //
+  property Url: string Read FUrl;                 // '/index.html'
+  property Document: string Read FDocument;
+  property Method: string Read FMethod;        // 'GET'
+  property Protocol: string Read FProtocol;  // 'HTTP/1.1'
+  // also MUST include Headers['Host'] value...
+  //
+  property StatusCode: integer Read FStatusCode Write SetStatusCode; // 200
+  property StatusMsg: string Read FStatusMsg Write FStatusMsg;       // 'OK'
+  //
+  property Content: string Read FContent Write FContent;
+  //property ContentStream: TStream Read FContentStream Write FContentStream; // stream is owned by the Request...
+  property SendChunked: boolean index 1 Read GetFlagBool Write SetFlagBool;
+  // set to True to prevent asking Stream.Size and send in chunked mode (without Content-length)
+  //
+  property Connection: TObject Read FConnection Write FConnection; // TSynTcpSrvConnection usually...
+  //
+  // Params contain 'Name=Value' for parameters in ?params in url and for POST params inside content:
+  // When posting files, Params does NOT contain file data, only FileName, use GetPostFormParam to retrieve file data...
+  property Params: TStringList Read FParams; // use  Request.Params.Values[ParamName]
+  property PostStream: TStream Read FPostStream Write FPostStream;
+  function GetPostFormParam(const ParamName: string; var ParamData: string): boolean;
+  // get 1 param from multipart/form-data or application/x-www-form-urlencoded...
+  //
+  // Common operations for application for making reply:
+  procedure ServeFile(const LocalFileName: string);
+  // open file in ContentStream, set Last-Modified, Content-Length, Content-Type
+  procedure Redirect(const aUrl: string); // set 302 redirection and Location: header
+  //
+  // Functions used by server/client:
+  procedure ParseFirstRequestLine(Line: string);  // parse:  'GET /index.html HTTP/1.1'  // used by server
+  procedure ParseFirstResponseLine(Line: string); // parse:  'HTTP/1.1 200 OK'           // used by client
+  function GetFirstResponseLine: string;         // format: 'HTTP/1.1 200 OK'           // used by server
+  function GetFirstRequestLine: string;          // format: 'GET /index.html HTTP/1.1'  // used by client
+  procedure ParsePostFormData;
+  // parse Content string into Params, used usually by Server (for POST requests with propper Content-Type)
+  //
+  function MatchTag(Etags: string): boolean;
+  // Etags may have multiple tags, comma-separated... returns True, if some of them is identical with Etag...
+  //
+  // Common Header properties:
+  property ContentType: string index 0 Read GetStrProp Write SetStrProp;  // 'text/html; charset="Windows-1250"'
+  property BaseContentType: string index 1 Read GetStrProp;               // 'text/html'
+  property CharSet: string Read FCharSet Write SetCharSet;
+  property ContentDisposition: string index 2 Read GetStrProp Write SetStrProp;
+  // 'attachment; filename=targetfile.html'
+  property TargetFileName: string index 3 Read GetStrProp Write SetStrProp;
+  // name, by which this should be saved by client (in Content-Disposition)
+  property Location: string index 4 Read GetStrProp Write SetStrProp;       // Location: header
+  property Etag: string index 5 Read GetStrProp Write SetStrProp;
+  // Etag is used for caches, so that they may know, that their copy is exactly identical with current data (having same Etag for same URL means it is exactly identical...)
+  property Host: string index 6 Read GetStrProp Write SetStrProp;           // must be in Request
+  property Referer: string index 7 Read GetStrProp Write SetStrProp;
+  property UserAgent: string index 8 Read GetStrProp Write SetStrProp;
+  property Vary: string index 9 Read GetStrProp Write SetStrProp;
+  // list of headers, for which the response varies... used by caches...
+  property WwwAuthenticate: string index 10 Read GetStrProp Write SetStrProp;
+  // authentication challenge, used with 401 status-code... see RFC2617...
+  property Authorization: string index 11 Read GetStrProp Write SetStrProp; // Authorization: value, sent by client
+  property Boundary: string index 12 Read GetStrProp Write SetStrProp;
+  // Content-Type: multipart/any; boundary=0123456789
+  property ContentEncoding: string index 13 Read GetStrProp Write SetStrProp;
+  property CacheControl: string index 14 Read GetStrProp Write SetStrProp;
+  property Pragma: string index 15 Read GetStrProp Write SetStrProp;
+  property ServerSoftware: string index 16 Read GetStrProp Write SetStrProp;
+  property AcceptEncoding: string index 17 Read GetStrProp Write SetStrProp;
+  property ContentLength: string index 18 Read GetStrProp Write SetStrProp;
+  property TransferEncoding: string index 19 Read GetStrProp Write SetStrProp;
+  //
+  property Date: TDateTime index 0 Read GetDateProp Write SetDateProp;
+  // local date of serving the request (is converted to UTC)    (filled by Server)
+  property LastModified: TDateTime index 1 Read GetDateProp Write SetDateProp;
+  // local date of file modification (is converted to UTC)   (filled by ServeFile method)
+  property LastModifiedUTC: TDateTime index 2 Read GetDateProp Write SetDateProp;
+  // UTC date of file modification   (filled by ServeFile method)
+  property Expires: TDateTime index 3 Read GetDateProp Write SetDateProp;
+  // UTC date of expiration (for caches, allows caching of otherwise-non-cacheable responses)
+  property ResponseSent: boolean Read FResponseSent Write FResponseSent;
+ end;
+
+ TSynOnHttpGet = procedure(Sender: TObject; Connection: TSynTcpSrvConnection;
+  Request, Response: THttpRequest) of object;
+ TSynOnHttpExpect = procedure(Sender: TObject; Request: THttpRequest; var bnContinue: boolean) of object;
+ TSynHTTPCreatePostStream = procedure(Sender: TObject; Request: THttpRequest; var PostStream: TStream) of object;
+
+ // Virtual HTTP server.
+ // This level does some RFC2616 stuff for you,
+ // but it does NOT resolve URL->filename, which must be done in OnHttpGet method.
+
+ { TSynHttpServer }
+
+ TSynHttpServer = class(TSynTcpServer)
+ private
+  FOnCreatePostStream: TSynHTTPCreatePostStream;
+  FOnHttpGet:  TSynOnHttpGet;
+  FOnExpect:   TSynOnHttpExpect;
+  FCertFile:   string;
+  FKeyFile:    string;
+  FKeyPass:    string;
+  FCaCertFile: string;
+  procedure HandleClientCommand(Connection: TSynTcpSrvConnection; Command: string);
+  procedure CreatePostStream(Request: THttpRequest);
+ protected
+  procedure ReadRequest(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest; Command: string); virtual;
+  procedure DoHttpGet(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); virtual;
+  procedure SetActive(Value: boolean); override;
+ public
+  constructor Create(AOwner: TComponent); override;
+  //
+  procedure InitHttps(const CertFile, KeyFile, KeyPassword, CaCertFile: string);
+  procedure SendReply(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest); virtual;
+  //
+ published
+  property Port;//default '80';
+  //
+  property OnHttpGet: TSynOnHttpGet Read FOnHttpGet Write FOnHttpGet;
+  property OnExpect: TSynOnHttpExpect Read FOnExpect Write FOnExpect;
+  property OnCreatePostStream: TSynHTTPCreatePostStream Read FOnCreatePostStream Write FOnCreatePostStream;
+ end;
+
+var
+ // Value for Server: header...
+ ServerValue: string = 'SynHttpSrv/1.0';
+
+function ReadHeadersFromSocket(Socket: TTCPBlockSocket; Headers: THeaderList; LineTimeout: integer = 0): boolean;
+
+function SendSocketStream(Socket: TTcpBlockSocket; Stream: TStream; MaxSize: int64 = -1;
+ bnHttpChunked: boolean = False): boolean;
+
+const
+ cProtoHttp10 = 'HTTP/1.0';
+ cProtoHttp11 = 'HTTP/1.1';
+
+function GetHttpStatusMsg(StatusCode: integer; var StatusMsg: string): boolean;
+
+ //-----------------------------------------------------------------------------
+ // string utility functions:
+
+// Trim(Copy(S,Pos,Count));
+function TrimCopy(const S: string; Pos, Count: integer): string;
+// trim inplace:
+procedure DoTrim(var S: string);
+// remove first token, no quoting:
+function FetchToken(var Line: string; const Sep: string; bnTrim: boolean): string;
+// "Quote value, using \" and \\ inside..."
+function QuoteValue(const Value: string): string;
+// remove first comma-separated value, possibly quoted
+function FetchQSepValue(var Line: string; const Sep: string): string;
+// for parsing: remove first  Name="Value", separators either ";" or ","
+function FetchDequoted(var Line: string; out Name, Value: string): boolean;
+// get value from Name="Value" in multi-prop header value:  (from 'text/html; charset="Windows-1250"' can extract charset...)
+function GetHeaderSubValue(Header: string; const Name: string): string;
+procedure ReplaceHeaderSubValue(var Header: string; const Name, Value: string);
+function CombineStrings(Strings: TStrings; const Separator: string): string;
+// SameHead == SameText(Copy(Str,1,Length(SHead)),SHead)
+function SameHead(const Str, SHead: string): boolean;
+// multipart parsing...
+type
+ // Result: True=found/stop, False=continue
+ TMultipartEnumCallback = function(Headers: THeaderList; const FieldName, Content: string): boolean of object;
+
+procedure EnumMultiPart(ContentData, Boundary: string; const Enum: TMultipartEnumCallback);
+
+// Date - in HTTP (RFC2616), all dates MUST be in GMT (utc) format...
+function FormatHttpDate(LocalDate: TDateTime; bnIsLocal: boolean): string;
+function ParseHttpDate(Str: string; out DateTime: TDateTime): boolean;
+function LocalToUtcDateTime(LocalDate: TDateTime): TDateTime;
+function UtcToLocalDateTime(UtcDate: TDateTime): TDateTime;
+function TimeZoneBiasTime: TDateTime;
+function GetFileDateUtc(const FileName: string): TDateTime;
+
+// Content-Type detection used by THttpRequest.ServeFile
+function DetectContentType(const FileName: string): string;
+function GetContentTypeByExt(const Ext: string): string;
+// RegisterContentType can be used to register content-types by extension from user configuration:
+procedure RegisterContentType(const Ext, ContentType: string);
+{$ifdef MSWINDOWS}
+// Automatically register content-types for all file extensions from registry...
+procedure RegisterContentTypesFromRegistry;
+{$endif MSWINDOWS}
+
+// convert 'Documents%20and%20Settings'  to 'Documents and Settings', also handles utf8 encoded in %C4%8D...
+function ConvertUrlChars(Url: string): string;
+procedure TryDecodeUtf8(var Url: string); // used by ConvertUrlChars...
+
+var
+ // location of /error.html file, used by THttpRequest.ServerFile:
+ Error404Url:     string;
+ // contents of 404 error doc, used by THttpRequest.ServerFile, only if Error404Url is empty:
+ Error404DocText: string;
+
+
+procedure Register;
+
+implementation
+
+procedure Register;
+begin
+ RegisterComponents('Samples', [TSynHttpServer]);
+end;
+
+function SendSocketStream(Socket: TTcpBlockSocket; Stream: TStream; MaxSize: int64; bnHttpChunked: boolean): boolean;
+var
+ Buffer: array[0..16383] of char;
+ BlockSize, Size: integer;
+label
+ _Complete;
+begin
+ if (MaxSize < 0) then
+  MaxSize := $10000000000; // 16Gb...
+ //
+ // Send Stream, without asking its Size... This allows sending from TDecompressionStream etc...
+ BlockSize := Socket.SendMaxChunk;
+ if (BlockSize > SizeOf(Buffer)) then
+  BlockSize := SizeOf(Buffer); // no real need to send >4k packets...
+ //
+ while True do
+ begin
+  if (BlockSize > MaxSize) then
+  begin
+   // Last block...
+   if (MaxSize = 0) then
+   begin
+    Result := True;
+    goto _Complete;
+   end;
+   BlockSize := MaxSize;
+  end;
+  //
+  Size := Stream.Read(Buffer[0], BlockSize);
+  if (Size <= 0) then
+  begin
+   // EOF
+   Result := (Size = 0); // stream complete...
+   _Complete:
+    if Result and bnHttpChunked then
+    begin
+     Socket.SendString('0'#13#10#13#10);
+     Result := True;
+    end;
+   exit;
+  end;
+  //
+  if bnHttpChunked then
+   Socket.SendString(UTF8Encode(Format('%x'#13#10, [Size])));
+  //
+  Socket.SendBuffer(@Buffer, Size);
+  if (Socket.LastError <> 0) then
+   break;
+ end;
+ // Failed due to LastError
+ Result := False;
+end;
+
+// read header lines until empty line is received...
+function ReadHeadersFromSocket(Socket: TTCPBlockSocket; Headers: THeaderList; LineTimeout: integer): boolean;
+var
+ Line: string;
+begin
+ if (LineTimeout = 0) then
+  LineTimeout := SynSrv.cDefLineTimeout; // default 2 minutes...
+ //
+ while True do
+ begin
+  Line := string(Socket.RecvString(LineTimeout));
+  if (Line = '') then
+  begin
+   if (Socket.LastError <> 0) then
+   begin
+    // error (either timeout or client disconnected)
+    Result := False;
+    exit;
+   end;
+   // Headers complete (terminated by empty line)
+      {$ifdef DEBUG}
+      Debug('Request headers:'#13#10'%s',[Headers.Text]);
+      {$endif DEBUG}
+   Result := True;
+   exit;
+  end;
+  Headers.Add(Line);
+ end;
+end;
+
+function TrimCopy(const S: string; Pos, Count: integer): string;
+var
+ len, maxlen: integer;
+begin
+ //Result:=Trim(Copy(S,Pos,Count));
+ // Optimized - trim before allocating result:
+ len := Length(S);
+ while (Pos <= len) and (S[Pos] <= ' ') do
+  Inc(Pos);
+ if (Pos <= len) then
+ begin
+  maxlen := len - Pos + 1;
+  if (Count > maxlen) then
+   Count := maxlen;
+  while (Count > 0) and (S[Pos + Count - 1] <= ' ') do
+   Dec(Count);
+ end;
+ Result := Copy(S, Pos, Count);
+end;
+
+procedure DoTrim(var S: string);
+var
+ len: integer;
+begin
+ len := Length(S);
+ if (len > 0) and ((S[1] <= ' ') or (S[len] <= ' ')) then
+  S := Trim(S);
+end;
+
+function FetchToken(var Line: string; const Sep: string; bnTrim: boolean): string;
+var
+ p: integer;
+begin
+ p := Pos(Sep, Line);
+ if (p > 0) then
+ begin
+  // give part until separator:
+  if bnTrim then
+  begin
+   Result := TrimCopy(Line, 1, p - 1);
+   Delete(Line, 1, p + Length(Sep) - 1);
+   DoTrim(Line);
+  end else
+  begin
+   Result := Copy(Line, 1, p - 1);
+   Delete(Line, 1, p + Length(Sep) - 1);
+  end;
+ end else
+ begin
+  // give all rest:
+  Result := Line;
+  Line := '';
+  if bnTrim then
+   DoTrim(Result);
+ end;
+end;
+
+procedure AdjustHeaderLine(var Line: string);
+var
+ p, len: integer;
+ Name: string;
+begin
+ // Right-trim:
+ len := Length(Line);
+ if (len = 0) then
+  exit;
+ if (Line[1] <= ' ') then
+  Line := Trim(Line)
+ else
+ if (Line[len] <= ' ') then
+  Line := TrimRight(Line);
+ // Normalize arround ":"...
+ p := Pos(':', Line);
+ if (p > 1) then
+  if (Line[p - 1] <= ' ') or not (Line[p + 1] <= ' ') or (Line[p + 2] <= ' ') then
+  begin
+   // Needs normalize...
+   Name := FetchToken(Line, ':', True);
+   //
+   Line := Name + ': ' + Line;
+  end;
+end;
+
+ // for parsing: remove first  Name="Value", separators either ";" or ","
+ // Value may be quoted, but does not need to be quoted
+ // Name may be missing (if no "=" is found, whole is Value)
+function FetchDequoted(var Line: string; out Name, Value: string): boolean;
+var
+ len, startname, lenname, startvalue, lenvalue, Skip, rest, p: integer;
+ bnName, bnSlash: boolean;
+begin
+ len := Length(Line);
+ // LTrim name:
+ startname := 1;
+ while (startname <= len) and (Line[startname] <= ' ') do
+  Inc(startname);
+ startvalue := startname;
+ //
+ if (startname > len) then
+ begin
+  // Line was empty (or blank)...
+  Line  := '';
+  Name  := '';
+  Value := '';
+  Result := False;
+  exit;
+ end;
+ //
+ // Seek end of name:
+ bnName  := False;
+ lenname := 0;
+ lenvalue := 0;
+ while (startname + lenname <= len) do
+ begin
+  case Line[startname + lenname] of
+   ';', ',', '"': break;
+   '=':
+   begin
+    // End of name:
+    startvalue := startname + lenname + 1;
+    bnName := True;
+    break;
+   end;
+  end;
+  Inc(lenname);
+ end;
+ if not bnName then
+ begin
+  // no name...
+  //startvalue:=startname; // already...
+  lenvalue := lenname;
+  lenname  := 0;
+ end;
+ Name := TrimCopy(Line, startname, lenname);
+ //
+ Skip := 0;
+ bnSlash := False;
+ if (lenvalue = 0) then
+ begin
+  // ltrim:
+  while (startvalue <= len) and (Line[startvalue] <= ' ') do
+   Inc(startvalue);
+  lenvalue := 0;
+  if (Line[startvalue] = '"') then
+  begin
+   // quoted:
+   Inc(startvalue);
+   lenvalue := 0;
+   while (startvalue + lenvalue <= len) do
+   begin
+    case Line[startvalue + lenvalue] of
+     '\':
+     begin
+      bnSlash := True;
+      Inc(lenvalue);
+     end;
+     '"':
+     begin
+      // end-quote...
+      Skip := 1;
+      break;
+     end;
+    end;
+    Inc(lenvalue);
+   end;
+  end else
+   while (startvalue + lenvalue <= len) do
+   begin
+    case Line[startvalue + lenvalue] of
+     ';', ',': break;
+    end;
+    Inc(lenvalue);
+   end// separated:
+  ;
+ end;
+ Value := TrimCopy(Line, startvalue, lenvalue);
+ //
+ rest  := startvalue + lenvalue + Skip;
+ while (rest <= len) and (Line[rest] <= ' ') do
+  Inc(rest);
+ if (rest <= len) and (CharInSet(Line[rest], [';', ','])) then
+  Inc(rest);
+ Line := TrimCopy(Line, rest, Length(Line) - rest + 1);
+ //
+ if bnSlash then
+ begin
+  // Remove middle quoting markup:
+  len := Length(Value);
+  p := 1;
+  while (p <= len) do
+  begin
+   if (Value[p] = '\') then
+   begin
+    Delete(Value, p, 1);
+    Dec(len);
+   end;
+   Inc(p);
+  end;
+ end;
+ //
+ Result := True;
+end;
+
+function GetHeaderSubValue(Header: string; const Name: string): string;
+var
+ S: string;
+begin
+ Result := '';
+ while (Header <> '') do
+ begin
+  FetchDequoted(Header, S, Result);
+  if SameText(S, Name) then
+   break;//exit;
+  Result := '';
+ end;
+end;
+
+procedure ReplaceHeaderSubValue(var Header: string; const Name, Value: string);
+var
+ Parts: TStringList;
+ S, S2: string;
+ ls2: integer;
+begin
+ // find existing Name="Value", value may be quoted and may be not quoted, Name= may occur inside other quoted value so may not use simple Pos()...
+ Parts := TStringList.Create;
+ try
+  S2  := Name + '=';
+  ls2 := Length(S2);
+  //
+  while (Header <> '') do
+  begin
+   S := Trim(FetchQSepValue(Header, ';'));
+   //
+   if (S <> '') and (ls2 >= Length(S)) and (S[ls2] = '=') and SameHead(S, S2)
+   //and SameText(Copy(S,1,ls2),S2)
+   then
+   begin
+    // Replace this:
+    S := S2 + QuoteValue(Value);
+    ls2 := 0;
+   end;
+   //
+   Parts.Add(S);
+  end;
+  //
+  if (ls2 > 0) then
+   Parts.Add(S2 + QuoteValue(Value))// was not found...
+  ;
+  //
+  // Combine into string:
+  Header := CombineStrings(Parts, '; ');
+  //
+ finally
+  Parts.Free;
+ end;
+end;
+
+function CombineStrings(Strings: TStrings; const Separator: string): string;
+var
+ S: string;
+ i: integer;
+begin
+ Result := '';
+ for i := 0 to Strings.Count - 1 do
+ begin
+  S := Strings[i];
+  if (i > 0) then
+   Result := Result + Separator + S
+  else
+   Result := Result + S;
+ end;
+end;
+
+function SameHead(const Str, SHead: string): boolean;
+begin
+ Result := SameText(Copy(Str, 1, Length(SHead)), SHead);
+end;
+
+const
+ // SysUtils.ShortDayNames may be translated with resources... here use constants:
+ UsShortDayNames: array[1..7] of string = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
+ UsShortMonthNames: array[1..12] of string =
+  ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
+
+function FormatHttpDate(LocalDate: TDateTime; bnIsLocal: boolean): string;
+var
+ UtcDate: TDateTime;
+ d, m, y, h, n, s, z: word;
+begin
+ if (LocalDate <= 1) then
+ begin
+  Result := '';
+  exit;
+ end;
+ // This format is recomended by RFC2616. it MUST be in GMT time-zone...
+ // Sun, 06 Nov 1994 08:49:37 GMT  ; RFC 822, updated by RFC 1123
+ if bnIsLocal then
+  UtcDate := LocalToUtcDateTime(LocalDate)
+ else
+  UtcDate := LocalDate;
+ DecodeDate(UtcDate, y, m, d);
+ DecodeTime(UtcDate, h, n, s, z);
+ Result := Format('%s, %.2d %s %.4d %.2d:%.2d:%.2d GMT', [UsShortDayNames[DayOfWeek(UtcDate)],
+  d, UsShortMonthNames[m], y, h, n, s]);
+end;
+
+function LocalToUtcDateTime(LocalDate: TDateTime): TDateTime;
+begin
+ // UTC = local_time + bias
+ if (LocalDate <> 0) then
+  Result := LocalDate + TimeZoneBiasTime()
+ else
+  Result := 0;
+end;
+
+function UtcToLocalDateTime(UtcDate: TDateTime): TDateTime;
+begin
+ // local_time = UTC - bias
+ if (UtcDate <> 0) then
+  Result := UtcDate - TimeZoneBiasTime()
+ else
+  Result := 0;
+end;
+
+const
+ cMinuteToDateTime = 1 / (24 * 60);
+
+{$undef WIN32FILETIME}
+{$undef WIN32TZ}
+{$ifdef MSWINDOWS} {$ifndef CIL}
+
+{$define WIN32TZ}
+function TimeZoneBiasTime: TDateTime;
+var
+ tzi:  TTimeZoneInformation;
+ Bias: integer;
+begin
+ case GetTimeZoneInformation(tzi) of
+  TIME_ZONE_ID_UNKNOWN: Bias  := tzi.Bias;
+  TIME_ZONE_ID_STANDARD: Bias := tzi.Bias + tzi.StandardBias;
+  TIME_ZONE_ID_DAYLIGHT: Bias := tzi.Bias + tzi.DaylightBias;
+  else
+   Bias := 0;
+ end;
+ if (Bias <> 0) then
+  Result := Bias * cMinuteToDateTime
+ else
+  Result := 0;
+end;
+
+{$define WIN32FILETIME}
+function FileTimeToUtcDateTime(const FileTime: TFileTime): TDateTime;
+var
+ Sys: TSystemTime;
+begin
+ if FileTimeToSystemTime(FileTime, Sys) then
+  Result := EncodeDate(Sys.wYear, Sys.wMonth, Sys.wDay) + EncodeTime(Sys.wHour, Sys.wMinute,
+   Sys.wSecond, Sys.wMilliseconds)
+ else
+  Result := 0;
+end;
+
+{$endif}{$endif}
+//
+{$ifndef WIN32TZ} // fallback for dotnet & linux:
+//const
+//  cMinuteToDateTime=1/(24*60);
+
+function TimeZoneBiasTime: TDateTime;
+begin
+ Result := SynaUtil.TimeZoneBias*cMinuteToDateTime;
+end;
+{$endif}
+
+function GetFileDateUtc(const FileName: string): TDateTime;
+var
+ SR: TSearchRec;
+begin
+ // This could work on linux also?
+ if (FindFirst(FileName, faAnyFile, SR) = 0) then
+ begin
+  FindClose(SR);
+  //
+    {$ifdef WIN32FILETIME}// WIN32
+  // Here we have directly UTC date-time:
+  Result := FileTimeToUtcDateTime(SR.FindData.ftLastWriteTime);
+    {$else ->fallback}
+    Result:=LocalToUtcDateTime(FileDateToDateTime(SR.Time));
+    {$endif}
+ end else
+  Result := 0;
+end;
+
+function ParseShortMonthName(const Token: string): integer;
+var
+ i: integer;
+begin
+ for i := 1 to 12 do
+  if SameText(Token, UsShortMonthNames[i]) then
+  begin
+   Result := i;
+   exit;
+  end;
+ Result := 0;
+end;
+
+function ParseHttpDate(Str: string; out DateTime: TDateTime): boolean;
+var
+ Token: string;
+ Int, y, m, d, h, n, s, tzh, tzm, tokencount: integer;
+ TzOffset: double;
+begin
+ DateTime := 0;
+ // This format is recomended by RFC2616. it MUST be in GMT time-zone...
+ // Sun, 06 Nov 1994 08:49:37 GMT  ; RFC 822, updated by RFC 1123
+ // These formats are also possible:
+ // Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
+ // Sun Nov  6 08:49:37 1994       ; ANSI C's asctime() format
+ // Anyhow due to robustness we will parse +0000 and -0000 timezones also...
+ y := 0;
+ m := 0;
+ d := 0;
+ h := 0;
+ n := 0;
+ s := 0;
+ tokencount := 0;
+ TzOffset := 0;
+ while (Str <> '') do
+ begin
+  Token := FetchToken(Str, ' ', True);
+  if (Token = '') then
+   continue;
+  //
+  Inc(tokencount);
+  if (tokencount > 31) then
+   break;
+  //
+  Int := -1;
+  if (CharInSet(Token[1], ['0'..'9'])) then
+   Int := StrToIntDef(Token, -1);
+  //
+  case Length(Token) of
+   1, 2: if (d = 0) and (Int > 0) then
+     d := Int;// Day...
+
+   3: if (m = 0) and (Int < 0) then
+     m := ParseShortMonthName(Token);// Sun, GMT, Nov
+
+   4: if (y = 0) and (Int >= 1900) and (Int <= 2200) then
+     y := Int;// 1999
+
+   5: if (CharInSet(Token[1], ['-', '+'])) and (CharInSet(Token[2], ['0'..'2'])) then
+    begin
+     // +0200, -0200
+     tzh := StrToIntDef(Copy(Token, 2, 2), -1);
+     tzm := StrToIntDef(Copy(Token, 4, 2), -1);
+     if (tzh >= 0) and (tzm >= 0) then
+     begin
+      TzOffset := (tzh * (1 / 24)) + (tzm * (1 / (24 * 60)));
+      if (Token[1] = '+') then
+       TzOffset := -TzOffset;
+     end;
+    end;
+   else
+    if (Pos(':', Token) > 0) then
+    begin
+     // Time...
+     h := StrToIntDef(FetchToken(Token, ':', True), 0);
+     n := StrToIntDef(FetchToken(Token, ':', True), 0);
+     s := StrToIntDef(FetchToken(Token, ':', True), 0);
+    end else
+    if (d = 0) and (Pos('-', Token) > 0) then
+    begin
+     // 06-Nov-94
+     d := StrToIntDef(FetchToken(Token, '-', True), 0);
+     m := ParseShortMonthName(FetchToken(Token, '-', True));
+     if (m <> 0) then
+     begin
+      y := StrToIntDef(Token, -1);
+      if (y >= 0) then
+       if (y > 50) then
+        Inc(y, 1900)
+       else
+        Inc(y, 2000);
+     end;
+    end;
+  end;
+ end;
+ //
+ if (m > 0) and (m <= 12) and (y >= 1900) and (d > 0) and (d <= MonthDays[IsLeapYear(y), m]) then
+ begin
+  // Valid date...
+  DateTime := EncodeDate(y, m, d);
+  // Check time:
+  if (h >= 0) and (h <= 23) and (n >= 0) and (n <= 59) and (s >= 0) and (s <= 59) then
+   DateTime := DateTime + EncodeTime(h, n, s, 0) + TzOffset;
+  Result := True;
+ end else
+  Result := False;
+end;
+
+
+{$ifdef MSWINDOWS} {$ifndef CIL} {$define LOCALUTF} {$endif}{$endif}
+
+{$ifdef LOCALUTF}
+//For compatibility with Delphi5, use our and kernel functions...
+
+ //U+00000000 - U+0000007F   0xxxxxxx
+ //U+00000080 - U+000007FF   110xxxxx 10xxxxxx
+ //U+00000800 - U+0000FFFF   1110xxxx 10xxxxxx 10xxxxxx
+ //U+00010000 - U+001FFFFF   11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ //U+00200000 - U+03FFFFFF   111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ //U+04000000 - U+7FFFFFFF   1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+
+function GetUtfCharLen(pc: PChar): integer;
+var
+ b: byte;
+begin
+ b := Ord(pc[0]);
+ case b and $C0 of
+  0, $40: Result := 1;
+  $C0: case b and $30 of
+    $00, $10: if (Ord(pc[1]) and $C0 = $80) then
+      Result := 2
+     else
+      Result := 0;// 2 bytes:
+
+    $20: if (Ord(pc[1]) and $C0 = $80) and (Ord(pc[2]) and $C0 = $80) then
+      Result := 3
+     else
+      Result := 0;// 3 bytes:
+
+    else
+     Result := 0;
+     // Longer than UCS-2 (unicode >$FFFF) not supported...
+   end;// Start multi-byte:
+
+  else
+   Result := 0; // illegal
+ end;
+end;
+
+function IsUtf8(pc: PChar): boolean;
+var
+ bn80: boolean;
+ Len:  integer;
+begin
+ bn80 := False;
+ while (pc^ <> #0) do
+  if (byte(pc^) and $80 <> 0) then
+  begin
+   bn80 := True;
+   Len  := GetUtfCharLen(pc);
+   if (Len > 0) then
+    Inc(pc, Len)
+   else
+   begin
+    // illegal bytes...
+    Result := False;
+    exit;
+   end;
+  end else
+   Inc(pc);
+ Result := bn80;
+end;
+
+function FromUtf8ToWin(const S: string): string;
+var
+ WideBuf: PWideChar;
+ Len, WideLen: integer;
+begin
+ Len := Length(S);
+ WideBuf := AllocMem(Len * 2 + 16);
+ try
+  WideLen := MultiByteToWideChar(CP_UTF8, 0, Pointer(S), Len, WideBuf, Len);
+  if (WideLen = 0) then
+  begin
+   Result := '';
+   exit;
+  end;
+  SetString(Result, PChar(nil), WideLen);
+  Len := WideCharToMultiByte(0, 0, WideBuf, WideLen, Pointer(Result), WideLen, '@', nil);
+  if (Len < WideLen) then
+   SetLength(Result, WideLen);
+ finally
+  FreeMem(WideBuf);
+ end;
+end;
+
+procedure TryDecodeUtf8(var Url: string);
+begin
+ if IsUtf8(PChar(Url)) then
+  Url := FromUtf8ToWin(Url);
+end;
+
+{$else ->Delphi7+}
+
+// For Delphi7+ can use function in pascal System unit...
+procedure TryDecodeUtf8(var Url: string);
+var S: string;
+begin
+  S:=UTF8ToString(Url); // returns empty, if not valid Utf8...
+  if (S<>'') then
+    Url:=S;
+end;
+{$endif}
+
+function ValHex(const S: string; var Value: integer): boolean;
+var
+ code: integer;
+begin
+ Val('$' + S, Value, Code);
+ Result := Code = 0;
+end;
+
+function ConvertUrlChars(Url: string): string;
+var
+ p, len, code: integer;
+ bnUtf: boolean;
+ buff:  ansistring;
+begin
+ // convert 'Documents%20and%20Settings'  to 'Documents and Settings'
+ // and A+B to A B
+ Url := Url.Replace('+', ' ');
+ p := Pos('%', Url);
+ if (p = 0) then
+  Exit(Url);
+ //
+ // Exit(TIdURI.URLDecode(Url));
+ buff := ansistring(Url);
+ bnUtf := False;
+ len := Length(buff);
+ while (p <= len) do
+ begin
+  if (buff[p] = '%') then
+   if ValHex(Copy(string(buff), p + 1, 2), code) then
+   begin
+    Delete(buff, p + 1, 2);
+    Dec(len, 2);
+    buff[p] := ansichar(code);
+    if (code > $80) then
+     bnUtf := True;
+   end;
+  Inc(p);
+ end;
+ //
+ if bnUtf then
+  Result := UTF8ToString(RawByteString(buff))
+ else
+  Result := string(buff);
+end;
+
+{ THeaderList }
+
+function THeaderList.Add(const S: string): integer;
+var
+ Index: integer;
+ Line:  string;
+begin
+ // No empty lines:
+ Line := S;
+ if (Line = '') then
+  Exit(-1);
+ // Check multi-line headers:
+ if (Line[1] <= ' ') then
+ begin
+  Index := Count - 1;
+  if (Index >= 0) then
+  begin
+   // Append to last line:
+   Strings[Index] := Strings[Index] + #13#10 + Line; // line includes leading blank...
+   Exit(Index);
+  end;
+ end;
+ // Common adjustment (trim and normalize arround ":")
+ AdjustHeaderLine(Line);
+ //
+ Result := inherited Add(Line);
+end;
+
+procedure THeaderList.Insert(Index: integer; const S: string);
+var
+ S2: string;
+begin
+ S2 := S;
+ if (S2 <> '') then
+ begin
+  // Common adjustment (trim and normalize arround ":")
+  AdjustHeaderLine(S2);
+  //
+  inherited Insert(Index, S2);
+ end;
+end;
+
+procedure THeaderList.Put(Index: integer; const S: string);
+var
+ S2: string;
+begin
+ S2 := S;
+ if (S2 <> '') then
+ begin
+  // Common adjustment (trim and normalize arround ":")
+  AdjustHeaderLine(S2);
+  //
+  inherited Put(Index, S2);
+ end;
+end;
+
+procedure THeaderList.AddValue(const Name, Value: string);
+var
+ S: string;
+begin
+ if (Name <> '') and (Value <> '') then
+ begin
+  S := Name + ': ' + Value;
+  AdjustHeaderLine(S);
+  inherited Add(S);
+ end;
+end;
+
+function THeaderList.IndexOfName(const Name: string): integer;
+var
+ i, len: integer;
+ S: string;
+begin
+ Result := -1;
+ len := Length(Name);
+ if (len > 0) then
+  for i := 0 to Count - 1 do
+  begin
+   S := Strings[i];
+   if (Length(S) > len) and (S[len + 1] = ':') and SameHead(S, Name) //and SameText(Copy(S,1,len),Name)
+   then
+   begin
+    Result := i;
+    break;//exit;
+   end;
+  end;
+end;
+
+function IsName(const Line, Name: string): boolean;
+var
+ len: integer;
+begin
+ len := Length(Name);
+ if (len > 0) and (Length(Line) > len) and (Line[len + 1] = ':') and SameHead(Line, Name)
+ //and SameText(Copy(Line,1,len),Name)
+ then
+  Result := True
+ else
+  Result := False;
+end;
+
+procedure LStrDel(var S: string; Index, Count: integer);
+begin
+ Delete(S, Index, Count);
+end;
+
+// returns pos after quote...
+function StrSkipQuoted(const S: string; pquote: integer): integer;
+var
+ Q: char;
+ p, len: integer;
+begin
+ p := pquote;
+ Q := S[p];
+ Inc(p);
+ len := Length(S);
+ while (p <= len) do
+  if (S[p] = Q) then
+  begin
+   // Found...
+   Inc(p);
+   Exit(p);
+  end else
+  if (S[p] = '\') then
+   Inc(p, 2)
+  else
+   Inc(p);
+ Result := 0;
+end;
+
+// seek next occurence after this pos:
+function StrSeek(const S: string; C: char; StartPos: integer): integer;
+var
+ p, len: integer;
+begin
+ len := Length(S);
+ p := StartPos;
+ if (p <= 0) then
+  p := 1;
+ while (p <= len) do
+ begin
+  if (S[p] = C) then
+   Exit(p);
+  Inc(p);
+ end;
+ Result := len + 1;
+end;
+
+// remove first comma-separated value
+function FetchQSepValue(var Line: string; const Sep: string): string;
+var
+ pcomma, pquote, p, len: integer;
+begin
+ // values are separated by "," but there may be another such in quotes...
+ pcomma := Pos(Sep, Line);
+ if (pcomma = 0) then
+ begin
+  // whole line is last part:
+  Result := Trim(Line);
+  Line := '';
+  Exit;
+ end;
+ // skip quoted content:
+ pquote := Pos('"', Line);
+ while (pquote > 0) and (pquote < pcomma) do
+ begin
+  // May be quoted, may have multiple quoted parts...
+  p := StrSkipQuoted(Line, pquote);
+  pquote := StrSeek(Line, '"', p);
+  pcomma := StrSeek(Line, Sep[1], p);
+  if (pcomma = 0) then
+  begin
+   // whole line is last part:
+   Result := Trim(Line);
+   Line := '';
+   exit;
+  end;
+ end;
+ // Extract part:
+ Result := TrimCopy(Line, 1, pcomma - 1);
+ // Remove part, comma and spaces:
+ len := Length(Line);
+ p := pcomma;
+ while (p < len) and ((Line[p + 1] <= ' ') or (Line[p + 1] = Sep[1])) do
+  Inc(p);
+ Delete(Line, 1, p);
+end;
+
+// according to RFC2616, comma-separated headers may be also duplicated...
+procedure THeaderList.EnumHeaders(const Name: string; const Enum: THeaderEnum; const Sep: char;
+ LParam: NativeUInt = 0);
+var
+ i, Index, Cnt: integer;
+ Line, Value: string;
+begin
+ Index := IndexOfName(Name);
+ if (Index >= 0) then
+ begin
+  i := Index;
+  Line := Strings[i];
+  while True do
+  begin
+   // Process this line:
+   LStrDel(Line, 1, Length(Name) + 2); // remove 'Name: '
+   Line := Trim(Line);
+   //
+   while (Line <> '') do
+   begin
+    Value := FetchQSepValue(Line, Sep);
+    if (Value <> '') then
+     if Enum(Value, LParam) then
+      Exit;
+   end;
+   // find next...
+   Inc(i);
+   Cnt := Count;
+   while (i < Cnt) do
+   begin
+    Line := Strings[i];
+    if IsName(Line, Name) then
+     break;
+    Inc(i);
+   end;
+   if (i >= Cnt) then
+    break;
+  end;
+ end;
+end;
+
+{$ifndef CIL}
+// Simple pascal:
+type
+ PHeaderFinder = ^THeaderFinder;
+
+ THeaderFinder = record
+  FindValue: PString;
+  Found: boolean;
+ end;
+
+{$else ->dotnet is more complicated}
+type
+  THeaderFinder=class(TObject)
+  public
+    FindValue: string;
+    Found: Boolean;
+    function CheckHttpFindValue(const Value: string; LParam: Longint): Boolean;
+  end;
+  PHeaderFinder=THeaderFinder;
+
+function THeaderFinder.CheckHttpFindValue(const Value: string; LParam: Longint): Boolean;
+var S: string;
+begin
+  S:=Value;
+  if SameText(FetchToken(S,'=',True),FindValue) then begin
+    Found:=True;
+    Result:=True; // stop.
+  end else
+    Result:=False; // continue...
+end;
+{$endif}
+
+function THeaderList.CheckHttpFindValue(const Value: string; LParam: NativeUInt): boolean;
+{$ifndef CIL}
+var
+ S: string;
+ Finder: PHeaderFinder;
+{$endif}
+begin
+  {$ifndef CIL}
+ Finder := PHeaderFinder(LParam);
+ S := Value;
+ if SameText(FetchToken(S, '=', True), Finder.FindValue^) then
+ begin
+  Finder.Found := True;
+  Result := True; // stop.
+ end else
+  {$endif}
+  Result := False; // continue...
+end;
+
+function THeaderList.HasValue(const Name, Value: string): boolean;
+var
+ Finder: THeaderFinder;
+begin
+  {$ifndef CIL}
+ // Simple:
+ Finder.FindValue := @Value;
+ Finder.Found := False;
+ //
+ EnumHeaders(Name, Self.CheckHttpFindValue, ',', NativeUInt(@Finder));
+ Result := Finder.Found;
+ //
+  {$else ->dotnet, little more complicated}
+  //
+  Finder:=THeaderFinder.Create;
+  Finder.FindValue:=Value;
+  Finder.Found:=False;
+  EnumHeaders(Name,Finder.CheckHttpFindValue,0);
+  Result:=Finder.Found;
+  Finder.Free;
+  {$endif}
+end;
+
+function THeaderList.GetValueByName(const Name: string): string;
+var
+ Index, p: integer;
+begin
+ Index := IndexOfName(Name);
+ if (Index >= 0) then
+ begin
+  //Result:=GetValueByIndex(Index);
+  Result := Strings[Index];
+  //System.Delete(Result,Length(Name)+2); // remove 'Name: '
+  p := Length(Name) + 2;
+  Result := Copy(Result, p + 1, Length(Result) - p);
+ end else
+  Result := '';
+end;
+
+procedure THeaderList.SetValueByName(const Name, Value: string);
+var
+ Index: integer;
+ S: string;
+begin
+ if (Name <> '') then
+  if (Value <> '') then
+  begin
+   Index := IndexOfName(Name);
+   S := Trim(Name) + ': ' + Trim(Value);
+   if (Index >= 0) then
+    inherited Put(Index, S) //Strings[Index]:=S
+   else
+    inherited Add(S);
+  end else
+   RemoveValue(Name);
+end;
+
+function THeaderList.RemoveValue(const Name: string): boolean;
+var
+ Index, Count: integer;
+begin
+ Result := False;
+ Index  := IndexOfName(Name);
+ if (Index >= 0) then
+ begin
+  Delete(Index);
+  Result := True;
+  //
+  // Remove all occurences:
+  Count  := Self.Count;
+  while (Index < Count) do
+   if IsName(Strings[Index], Name) then
+   begin
+    Delete(Index);
+    Dec(Count);
+   end else
+    Inc(Index);
+ end;
+end;
+
+function THeaderList.GetNameByIndex(Index: integer): string;
+var
+ p: integer;
+begin
+ Result := Strings[Index];
+ p := Pos(':', Result);
+ if (p > 0) then
+  Result := Copy(Result, 1, p - 1)
+ else
+  Result := '';
+end;
+
+function THeaderList.GetValueByIndex(Index: integer): string;
+var
+ p: integer;
+begin
+ Result := Strings[Index];
+ p := Pos(':', Result);
+ if (p > 0) then
+ begin
+  Inc(p); // remove space after colon also...
+  Result := TrimCopy(Result, p + 1, Length(Result) - p);
+ end;
+end;
+
+function THeaderList.GetSubValue(const Name, SubName: string): string;
+begin
+ Result := Values[Name];
+ if (Result <> '') then
+  Result := GetHeaderSubValue(Result, SubName);
+end;
+
+procedure THeaderList.SetSubValue(const Name, SubName, Value: string);
+var
+ S: string;
+ Index: integer;
+begin
+ Index := IndexOfName(Name);
+ if (Index >= 0) then
+  S := ValuesByIndex[Index]//Values[Name];
+ else
+  S := '';
+ //
+ if (S <> '') then
+  ReplaceHeaderSubValue(S, SubName, Value)// Replace in existing header:
+ else
+  S := Format('%s=%s', [SubName, QuoteValue(Value)]);
+ //
+ S := Trim(Name) + ': ' + Trim(S);
+ //
+ if (Index >= 0) then
+  inherited Put(Index, S)
+ else
+  inherited Add(S);
+end;
+
+{ THttpRequest }
+
+constructor THttpRequest.Create;
+begin
+ inherited Create;
+ FHeaders := THeaderList.Create;
+ FParams  := TStringList.Create;
+ FCookies := THttpCookies.Create;
+end;
+
+destructor THttpRequest.Destroy;
+begin
+ FreeAndNil({FContentStream}FPostStream);
+ FreeAndNil(FHeaders);
+ FreeAndNil(FParams);
+ FreeAndNil(FCookies);
+ inherited;
+end;
+
+procedure THttpRequest.Assign(Source: TPersistent);
+var
+ Req: THttpRequest;
+ Lines: TStrings;
+ Temp2: TStringList;
+ i, Count: integer;
+ S: string;
+begin
+ if (Source is THttpRequest) then
+ begin
+  Req := THttpRequest(Source);
+  FHeaders.Assign(Req.FHeaders);
+  FCookies.Assign(Req.FCookies);
+  FUrl := Req.FUrl;
+  FMethod := Req.FMethod;
+  FProtocol := Req.FProtocol;
+  FContent := Req.FContent;
+  //FContentStream := Req.FContentStream;
+  //Req.FContentStream := nil; // only 1 request may own the content stream...
+  FPostStream := Req.FPostStream;
+  Req.FPostStream := nil; // only 1 request may own the content stream...
+  FStatusCode := Req.FStatusCode;
+  FStatusMsg := Req.FStatusMsg;
+  FConnection := Req.FConnection;
+  FFlags := Req.FFlags;
+ end else
+ if (Source is TStrings) then
+ begin
+  Lines := TStrings(Source);
+  Temp2 := nil;
+  try
+   // Load headers:
+   Headers.Clear;
+   i := 0;
+   Count := Lines.Count;
+   while (i < Count) do
+   begin
+    S := Lines[i];
+    if (S = '') then
+    begin
+     // End of headers...
+     Inc(i);
+     break;
+    end;
+    Headers.Add(S);
+    Inc(i);
+   end;
+   //
+   if (i < Count) then
+   begin
+    // Load content:
+    // It is usually much faster to copy strings to new list than to delete items from start...
+    Temp2 := TStringList.Create;
+    Temp2.Capacity := Count - i;
+    while (i < Count) do
+    begin
+     Temp2.Add(Lines[i]);
+     Inc(i);
+    end;
+    FreeAndNil(Temp2);
+    FContent := Temp2.Text;
+   end;
+  finally
+   FreeAndNil(Temp2);
+  end;
+ end else
+  inherited;
+end;
+
+procedure THttpRequest.SetHeaders(Value: THeaderList);
+begin
+ if (Value <> nil) then
+  FHeaders.Assign(Value)
+ else
+  FHeaders.Clear;
+end;
+
+procedure THttpRequest.SetCookies(Value: THttpCookies);
+begin
+ if (Value <> nil) then
+  FCookies.Assign(Value)
+ else
+  FCookies.Clear;
+end;
+
+type
+ THttpStatusMsg = record
+  Code: integer;
+  Msg:  string;
+ end;
+
+const
+ // status codes defined in RFC2616:
+ HttpStatusMsgs: array[0..39] of THttpStatusMsg = (
+  // Common codes:
+  (Code: 200; Msg: 'OK'),
+  (Code: 403; Msg: 'Forbidden'),
+  (Code: 404; Msg: 'Not Found'),
+  (Code: 401; Msg: 'Unauthorized'),
+  (Code: 500; Msg: 'Internal Server Error'),
+  (Code: 302; Msg: 'Found'), // use this for redirection
+  (Code: 304; Msg: 'Not Modified'),
+  (Code: 206; Msg: 'Partial Content'),
+  //
+  (Code: 100; Msg: 'Continue'),
+  (Code: 101; Msg: 'Switching Protocols'),
+  (Code: 201; Msg: 'Created'),
+  (Code: 202; Msg: 'Accepted'),
+  (Code: 203; Msg: 'Non-Authoritative Information'),
+  (Code: 204; Msg: 'No Content'),
+  (Code: 205; Msg: 'Reset Content'),
+  (Code: 300; Msg: 'Multiple Choices'),  //also possible for redirection...
+  (Code: 301; Msg: 'Moved Permanently'), //also possible for redirection...
+  (Code: 303; Msg: 'See Other'),         //also possible for redirection...
+  (Code: 305; Msg: 'Use Proxy'),         //also possible for redirection...
+  (Code: 307; Msg: 'Temporary Redirect'),//also possible for redirection...
+  (Code: 400; Msg: 'Bad Request'),
+  (Code: 402; Msg: 'Payment Required'),
+  (Code: 405; Msg: 'Method Not Allowed'),
+  (Code: 406; Msg: 'Not Acceptable'),
+  (Code: 407; Msg: 'Proxy Authentication Required'),
+  (Code: 408; Msg: 'Request Timeout'),
+  (Code: 409; Msg: 'Conflict'),
+  (Code: 410; Msg: 'Gone'),
+  (Code: 411; Msg: 'Length Required'),
+  (Code: 412; Msg: 'Precondition Failed'),
+  (Code: 413; Msg: 'Request Entity Too Large'),
+  (Code: 414; Msg: 'Request-URI Too Long'),
+  (Code: 415; Msg: 'Unsupported Media Type'),
+  (Code: 416; Msg: 'Requested Range Not Satisfiable'),
+  (Code: 417; Msg: 'Expectation Failed'),
+  (Code: 501; Msg: 'Not Implemented'),
+  (Code: 502; Msg: 'Bad Gateway'),
+  (Code: 503; Msg: 'Service Unavailable'),
+  (Code: 504; Msg: 'Gateway Timeout'),
+  (Code: 505; Msg: 'HTTP Version Not Supported')
+  );
+
+procedure THttpRequest.SetStatusCode(Value: integer);
+begin
+ FStatusCode := Value;
+ GetHttpStatusMsg(FStatusCode, FStatusMsg);
+end;
+
+function GetHttpStatusMsg(StatusCode: integer; var StatusMsg: string): boolean;
+var
+ i: integer;
+begin
+ for i := Low(HttpStatusMsgs) to High(HttpStatusMsgs) do
+  if (HttpStatusMsgs[i].Code = StatusCode) then
+  begin
+   StatusMsg := HttpStatusMsgs[i].Msg;
+   Result := True;
+   exit;
+  end;
+ Result := False;
+end;
+
+function THttpRequest.GetFlagBool(Index: integer): boolean;
+var
+ Mask: integer;
+begin
+ Mask := 1 shl Index;
+ Result := (FFlags and Mask <> 0);
+end;
+
+procedure THttpRequest.SetFlagBool(Index: integer; Value: boolean);
+var
+ Mask: integer;
+begin
+ Mask := 1 shl Index;
+ if Value then
+  FFlags := FFlags or Mask
+ else
+  FFlags := FFlags and not Mask;
+end;
+
+procedure THttpRequest.ApplyHeaders(bnIsServer: boolean);
+var
+ S: string;
+ p: integer;
+begin
+ if bnIsServer then
+  Cookies.LoadClientCookies(Headers)
+ else
+  Cookies.LoadServerCookies(Headers);
+ //
+ // Parse parameters in URL:
+ FParams.Clear;
+ p := Pos('?', Url);
+ if (p > 0) then
+ begin
+  S := Copy(Url, p + 1, Length(Url) - p);
+  while (S <> '') do
+   FParams.Add(ConvertUrlChars(Trim(FetchQSepValue(S, '&'))));
+ end;
+end;
+
+{Sample from RFC1867:
+
+Content-type: multipart/form-data, boundary=AaB03x
+
+--AaB03x
+content-disposition: form-data; name="field1"
+
+Joe Blow
+--AaB03x
+content-disposition: form-data; name="pics"; filename="file1.txt"
+Content-Type: text/plain
+
+ ... contents of file1.txt ...
+--AaB03x--
+{}
+
+procedure THttpRequest.ParsePostFormData;
+var
+ S: string;
+ //p: integer;
+begin
+ if Content.StartsWith('--') then
+  EnumMultiPart(Content, Boundary, AddMultiPartFormItem)
+ else
+ begin
+  S := Content;
+  while (S <> '') do
+   FParams.Add(ConvertUrlChars(Trim(FetchQSepValue(S, '&'))));
+ end;
+end;
+
+function THttpRequest.AddMultiPartFormItem(Headers: THeaderList; const FieldName, Content: string): boolean;
+var
+ S: string;
+begin
+ S := Headers.SubValues['Content-Disposition', 'filename'];
+ if (S <> '') then // will add FieldName=filename
+ else
+  S := Content// will add FieldName=Content
+ ;
+ //
+ if (FieldName <> '') then
+  FParams.Add(FieldName + '=' + S)
+ else
+  FParams.Add(S);
+ //
+ Result := False; // all...
+end;
+
+type
+ TGetPostParamInfo = class(TObject)
+ public
+  ParamName: string;
+  ParamData: string;
+  bnFound: boolean;
+  function FindParamEnum(Headers: THeaderList; const FieldName, Content: string): boolean;
+ end;
+
+function TGetPostParamInfo.FindParamEnum(Headers: THeaderList; const FieldName, Content: string): boolean;
+begin
+ if SameText(FieldName, ParamName) then
+ begin
+  ParamData := Content;
+  bnFound := True;
+  Result  := True; // stop.
+ end else
+  Result := False; // continue...
+end;
+
+function THttpRequest.GetPostFormParam(const ParamName: string; var ParamData: string): boolean;
+var
+ Info: TGetPostParamInfo;
+begin
+ Info := TGetPostParamInfo.Create;
+ try
+  Info.ParamName := ParamName;
+  Info.ParamData := ParamData;
+  EnumMultiPart(FContent, Boundary, Info.FindParamEnum);
+  ParamData := Info.ParamData;
+  Result := Info.bnFound;
+ finally
+  Info.Free;
+ end;
+end;
+
+procedure EnumMultiPart(ContentData, Boundary: string; const Enum: TMultipartEnumCallback);
+
+ function FetchLine(var Rest: string): string;
+ begin
+  Result := FetchToken(Rest, #13#10, False);
+ end;
+
+var
+ Line: string;
+ Headers: THeaderList;
+ p, lbound: integer;
+ bnTerm, bnPart: boolean;
+begin
+ // cannot use TStringList, since it would damage binary parts (uploaded files)?!
+ // could consume leading part of ContentData, but it can be very slow on large uploads... well, dotnet is slow anyway...
+ //
+ if (Boundary = '') then
+ begin
+  // autodetect boundary:
+  while (ContentData <> '') do
+  begin
+   Line := FetchLine(ContentData);
+   if (Line <> '') and (Line[1] = '-') and (Line[2] = '-') then
+   begin
+    //Delete(Line,1,2); Boundary:='--'+Line;
+    Boundary := Line; // contains leading '--'
+    break;
+   end;
+  end;
+ end else
+ begin
+  // Seek leading boundary:
+  Insert('--', Boundary, 1);
+  while (ContentData <> '') do
+  begin
+   Line := FetchLine(ContentData);
+   if (Line = '') then
+    continue;
+   if (Line = Boundary) then
+    break;
+   if (Line = Boundary + '--') then
+    exit;
+  end;
+ end;
+ lbound  := Length(Boundary);
+ //
+ Headers := THeaderList.Create;
+ try
+  while (ContentData <> '') do
+  begin
+   // Parse part headers:
+   Headers.Clear;
+   while (ContentData <> '') do
+   begin
+    Line := FetchLine(ContentData);
+    if (Line = '') then
+     break;
+    Headers.Add(Line);
+   end;
+   // Parse part body:
+   bnTerm := False;
+   bnPart := False;
+   p := 1;
+   while (p < Length(ContentData)) do
+   begin
+    if (ContentData[p] = #13) and (ContentData[p + 1] = #10) and (ContentData[p + 2] = '-') and
+     (ContentData[p + 3] = '-') and CharInSet(ContentData[p + 2 + lbound], [#13, '-']) and
+     CharInSet(ContentData[p + 3 + lbound], [#10, '-']) then
+    begin
+     Line := Copy(ContentData, p + 2, lbound);
+     if (Line = Boundary) then
+     begin
+      // End of part body here:
+      Line := Copy(ContentData, 1, p - 1);
+      Inc(p, 2); // skip #13#10
+      Inc(p, lbound); // skip '--Boundary'
+      bnTerm := (ContentData[p] = '-');
+      Inc(p, 2); // skip either #13#10 or '--'
+      Delete(ContentData, 1, p);
+      //
+      if Enum(Headers, Headers.SubValues['Content-Disposition', 'name'], Line) then
+       exit;
+      Line := '';
+      //
+      bnPart := True;
+      break;
+     end;
+    end;
+    Inc(p);
+   end;
+   //
+   if bnTerm then // final boundary reached...
+    break;
+   if not bnPart then // input was incomplete, no boundary after data was found...
+    break;
+  end;
+ finally
+  Headers.Free;
+ end;
+end;
+
+const
+ StrPropNames: array[0..19] of string = (
+  'Content-Type',             // 0
+  'Content-Type',             // 1
+  'Content-Disposition',      // 2
+  'Content-Disposition',      // 3
+  'Location',                 // 4
+  'Etag',                     // 5
+  'Host',                     // 6
+  'Referer',                  // 7
+  'User-Agent',               // 8
+  'Vary',                     // 9
+  'WWW-Authenticate',         //10   //!!!TODO
+  'Authorization',            //11
+  'Content-Type',             //12
+  'Content-Encoding',         //13
+  'Cache-control',            //14
+  'Pragma',                   //15
+  'Server',                   //16
+  'Accept-Encoding',          //17
+  'Content-Length',           //18
+  'Transfer-Encoding'         //19
+  );
+
+function THttpRequest.GetStrProp(Index: integer): string;
+var
+ p: integer;
+begin
+ Result := '';
+ if (Index >= 0) and (Index <= High(StrPropNames)) then
+ begin
+  Result := Headers[StrPropNames[Index]];
+  //
+  case Index of
+   1:
+   begin
+    // BaseContentType... remove sub-type...
+    p := Pos(';', Result);
+    if (p > 0) then
+     Result := TrimCopy(Result, 1, p - 1);
+   end;
+   3: Result  := GetHeaderSubValue(Result, 'filename');// TargetFileName, extract it:
+   // Content-Disposition: attachment; filename="Filename"    also works without the "attachment"...
+   12: Result := GetHeaderSubValue(Result, 'boundary');// Boundary:
+  end;
+ end;
+end;
+
+procedure THttpRequest.SetStrProp(Index: integer; const Value: string);
+var
+ i: integer;
+begin
+ if (Index >= 0) and (Index <= High(StrPropNames)) then
+  case Index of
+   3:
+    Headers.SubValues[StrPropNames[Index], 'filename'] := Value;// TargetFileName:
+   // Content-Disposition: attachment; filename="Filename"    also works without the "attachment"...
+   12:
+   begin
+    // Boundary:
+    if (Headers.Values[StrPropNames[Index]] = '') then
+     Headers.Values[StrPropNames[Index]] := 'multipart/mixed';
+    //
+    Headers.SubValues[StrPropNames[Index], 'boundary'] := Value;
+   end;
+   18:
+   begin
+    i := 0;
+    if TryStrToInt(Value, i) and (i > 0) then
+     Headers[StrPropNames[Index]] := Value;
+   end
+   else
+    Headers[StrPropNames[Index]] := Value;
+  end;
+end;
+
+const
+ DatePropNames: array[0..3] of string = (
+  'Date',
+  'Last-Modified',
+  'Last-Modified',
+  'Expires'
+  );
+ DatePropIsLocal: array[0..3] of boolean = (
+  True,
+  True,
+  False,
+  False
+  );
+
+procedure THttpRequest.SetCharSet(const Value: string);
+begin
+ FCharSet := Value;
+ Headers.SubValues['Content-Type', 'charset'] := Value;
+end;
+
+function THttpRequest.GetDateProp(Index: integer): TDateTime;
+begin
+ if (Index >= 0) and (Index <= High(DatePropNames)) and ParseHttpDate(Headers[DatePropNames[Index]], Result) then
+ begin
+  if DatePropIsLocal[Index] then
+   Result := UtcToLocalDateTime(Result);
+  exit;
+ end;
+ //
+ Result := 0;
+end;
+
+procedure THttpRequest.SetDateProp(Index: integer; const Value: TDateTime);
+var
+ bnIsLocal: boolean;
+begin
+ if (Index >= 0) and (Index <= High(DatePropNames)) then
+ begin
+  bnIsLocal := DatePropIsLocal[Index];
+  Headers[DatePropNames[Index]] := FormatHttpDate(Value, bnIsLocal);
+ end;
+end;
+
+procedure THttpRequest.ServeFile(const LocalFileName: string);
+begin
+ FreeAndNil({FContentStream}FPostStream);
+ //
+ if FileExists(LocalFileName) then
+ begin
+  //LastModified:=GetFileDateUtc(LocalFileName); // LastModified property is in LOCAL time, converting to UTC!
+  Headers[DatePropNames[1]{'Last-Modified'}] := FormatHttpDate(GetFileDateUtc(LocalFileName), False);
+  //
+  //FreeAndNil(FContentStream);
+  {ContentStream}PostStream := TFileStream.Create(LocalFileName, fmOpenRead or fmShareDenyWrite);
+  //
+  ContentType := DetectContentType(LocalFileName);
+  //
+  StatusCode  := 200; // OK
+  //
+ end else
+ begin
+  // File not found:
+  StatusCode := 404; // Not Found
+  // Give some message:
+  if (Error404Url <> '') then
+   Redirect(Error404Url)
+  else
+  if (Error404DocText <> '') then
+  begin
+   Content := Error404DocText;
+   ContentType := 'text/html';
+  end else
+  begin
+   // Fallback:
+   Content := '404 - not found.';
+   ContentType := 'text/plain';
+  end;
+ end;
+end;
+
+function DetectContentType(const FileName: string): string;
+var
+ Ext: string;
+begin
+ // By file extension:
+ Ext := ExtractFileExt(FileName);
+ Result := GetContentTypeByExt(Ext);
+ //if (Result <> '') then
+ // Exit;
+ //
+ // Auto-detect by contents?
+ // Not here...
+ //Result := '';
+end;
+
+var
+ ContentTypes: TStringList;
+
+procedure RegisterContentType(const Ext, ContentType: string);
+var
+ S, Prev: string;
+ Index: integer;
+begin
+ S := Ext + '=' + ContentType;
+ if (S[1] = '=') then
+  exit;
+ if (S[1] <> '.') then
+  Insert('.', S, 1);
+ //
+ //
+ Index := 0;
+ ContentTypes.Find(S, Index);
+ if (Index < ContentTypes.Count) then
+ begin
+  Prev := ContentTypes[Index];
+  if SameText(FetchToken(Prev, '=', True), Ext) then
+  begin
+   ContentTypes[Index] := S;
+   S := '';//exit;
+  end;
+ end;
+ if (S <> '') then
+  ContentTypes.Add(S);
+end;
+
+procedure RegisterInternalContentTypes;
+begin
+ // register some basic content types...
+ // other get registered from configuration or from registry:
+ RegisterContentType('.htm', 'text/html');
+ RegisterContentType('.html', 'text/html');
+ RegisterContentType('.xml', 'text/xml');
+ RegisterContentType('.json', 'application/json');
+ RegisterContentType('.txt', 'text/plain');
+ RegisterContentType('.jpg', 'image/jpeg');
+ RegisterContentType('.gif', 'image/gif');
+ RegisterContentType('.png', 'image/png');
+ RegisterContentType('.css', 'text/css');
+ RegisterContentType('.ico', 'image/x-icon');
+ RegisterContentType('.bmp', 'image/bmp');
+ RegisterContentType('.htc', 'text/x-component');
+ RegisterContentType('.js', 'text/javascript');
+end;
+
+function GetContentTypeByExt(const Ext: string): string;
+var
+ Index: integer;
+begin
+ Result := '';
+ ContentTypes.Find(Ext + '=', Index);
+ if (Index < ContentTypes.Count) then
+ begin
+  Result := ContentTypes[Index];
+  if not SameText(FetchToken(Result, '=', True), Ext) then
+   Result := '';
+ end;
+end;
+
+{$ifdef MSWINDOWS}
+ // Win32 specific...
+ //[HKEY_CLASSES_ROOT\.xsl]
+ //@="xslfile"
+ //"Content Type"="text/xml"
+
+procedure RegisterContentTypesFromRegistry;
+var
+ Key, SubKey: HKEY;
+ KeyIndex: integer;
+ CbName, CbData: DWORD;
+ KeyName, Value: string;
+begin
+ KeyIndex := 0;
+ Key := HKEY_CLASSES_ROOT;
+ CbName := 128;//x080922: 16;
+ SetLength(KeyName, CbName);
+ while (RegEnumKeyEx(Key, KeyIndex, @KeyName[1], CbName, nil, nil, nil, nil) = 0) do
+ begin
+  SetLength(KeyName, CbName);
+  if (KeyName <> '') and (KeyName[1] = '.') and (RegOpenKeyEx(Key, PChar(KeyName), 0, KEY_READ, SubKey) = 0) then
+  begin
+   CbData := 64;
+   SetLength(Value, CbData + 8);
+   if (RegQueryValueEx(SubKey, 'Content Type', nil, nil, @Value[1], @CbData) = 0) and (Value <> '') then
+   begin
+    SetLength(Value, CbData);
+    RegisterContentType(KeyName, Value);
+   end;
+   RegCloseKey(SubKey);
+  end;
+  //
+  Inc(KeyIndex);
+  CbName := 128;//x080922: 16;
+  SetLength(KeyName, CbName);
+ end;
+end;
+
+{$endif MSWINDOWS}
+
+procedure THttpRequest.Redirect(const aUrl: string);
+begin
+ //StatusCode := 302; // there are other 30x codes, but some HTTP/1.0 browsers do not understand them and understand only 302...
+ Self.Location := aUrl;
+end;
+
+// parse:  'GET /index.html HTTP/1.1'  // used by server
+procedure THttpRequest.ParseFirstRequestLine(Line: string);
+var
+ p: integer;
+begin
+ Self.FMethod := FetchToken(Line, ' ', True); // this trims Command...
+ p := Length(Line) - 7;
+ if (p > 0) and SameText(Copy(Line, p, 4), 'HTTP') then
+ begin
+  Self.FProtocol := Copy(Line, p, 8);
+  Self.FUrl := TrimCopy(Line, 1, p - 1);
+ end else
+ begin
+  Self.FUrl := FetchToken(Line, ' ', True);
+  Self.FProtocol := Line;
+ end;
+ p := Pos('?', Url) - 1;
+ if p > 0 then
+  FDocument := Copy(Url, 1, p)
+ else
+  FDocument := Url;
+end;
+
+// parse:  'HTTP/1.1 200 OK'           // used by client
+procedure THttpRequest.ParseFirstResponseLine(Line: string);
+begin
+ FProtocol  := FetchToken(Line, ' ', True);
+ FStatusCode := StrToIntDef(FetchToken(Line, ' ', True), 0);
+ FStatusMsg := Line;
+end;
+
+// format: 'HTTP/1.1 200 OK'           // used by server
+function THttpRequest.GetFirstResponseLine: string;
+begin
+ if (FProtocol = '') then
+  FProtocol := 'HTTP/1.0';
+ if (FStatusCode = 0) then
+  StatusCode := 500; // Internal server error - did not set StatusCode...?
+ //
+ Result := Format('%s %d %s', [FProtocol, StatusCode, StatusMsg]);
+end;
+
+// format: 'GET /index.html HTTP/1.1'  // used by client
+function THttpRequest.GetFirstRequestLine: string;
+begin
+ if (FMethod = '') then
+  FMethod := 'GET';
+ if (FUrl = '') then
+  FUrl := '/';
+ if (FProtocol = '') then
+  FProtocol := 'HTTP/1.0';
+ //
+ Result := Format('%s %s %s', [FMethod, FUrl, FProtocol]);
+end;
+
+function THttpRequest.MatchTag(Etags: string): boolean;
+var
+ E: string;
+begin
+ Result := False;
+ // If-Match header may specify more tags, comma-separated...
+ while (Etags <> '') do
+ begin
+  E := FetchQSepValue(Etags, ',');
+  if (E = '') then
+   continue;
+  if (E = '*') then
+  begin
+   Result := (Self.Etag <> '');
+   break;//exit;
+  end;
+  if (E = Self.Etag) then
+  begin
+   Result := True;
+   break;//exit;
+  end;
+ end;
+end;
+
+{ THttpCookies }
+
+constructor THttpCookies.Create;
+begin
+ inherited Create(THttpCookie);
+end;
+
+function THttpCookies.GetCommaText: string;
+var
+ i: integer;
+begin
+ Result := '';
+ for i := 0 to Count - 1 do
+  Result := Result + Cookies[i].Name + '=' + Cookies[i].Value + ',';
+ System.Delete(Result, High(Result), 1);
+end;
+
+function THttpCookies.GetCookieItem(Index: integer): THttpCookie;
+begin
+ Result := THttpCookie(inherited Items[Index]);
+end;
+
+function THttpCookies.GetValue(const Name: string): string;
+var
+ Cookie: THttpCookie;
+begin
+ Cookie := Find(Name);
+ if Assigned(Cookie) then
+  Result := Cookie.Value
+ else
+  Result := '';
+end;
+
+function THttpCookies.IndexOf(const Name: string): integer;
+var
+ i: integer;
+begin
+ for i := 0 to Count - 1 do
+  if SameText(Cookies[i].Name, Name) then
+  begin
+   Result := i;
+   exit;
+  end;
+ Result := -1;
+end;
+
+function THttpCookies.Find(const Name: string): THttpCookie;
+var
+ Index: integer;
+begin
+ Index := IndexOf(Name);
+ if (Index >= 0) then
+  Result := Cookies[Index]
+ else
+  Result := nil;
+end;
+
+procedure THttpCookies.LoadClientCookies(Headers: THeaderList);
+begin
+ Clear;
+ Headers.EnumHeaders('Cookie', AddCookieValue, ';', 1);
+ //x: Headers.EnumHeaders('Cookie2',AddCookieValue,2);
+end;
+
+procedure THttpCookies.SaveServerCookies(Headers: THeaderList; const DefaultDomain, DefaultPath: string);
+var
+ i: integer;
+ Cookie: THttpCookie;
+begin
+ Headers.RemoveValue('Set-Cookie');
+ for i := 0 to Count - 1 do
+ begin
+  Cookie := Cookies[i];
+  if (Cookie.Domain = '') then
+   Cookie.Domain := Copy(DefaultDomain, 1, Pos(':', DefaultDomain) - 1);
+  if (Cookie.Path = '') then
+   Cookie.Path := DefaultPath;
+  Headers.AddValue('Set-Cookie', Cookie.GetServerCookie);
+ end;
+end;
+
+procedure THttpCookies.SetDefaultPath;
+var
+ i: integer;
+begin
+ for i := 0 to Count - 1 do
+  if Cookies[i].Path.IsEmpty then
+   Cookies[i].Path := '/';
+end;
+
+procedure THttpCookies.SetSameSite;
+var
+ i: integer;
+begin
+ for i := 0 to Count - 1 do
+ begin
+  Cookies[i].Secure := True;
+  Cookies[i].SameSite := True;
+ end;
+end;
+
+procedure THttpCookies.SetValue(const Name, Value: string);
+var
+ Cookie: THttpCookie;
+begin
+ Cookie := Find(Name);
+ if Assigned(Cookie) then
+  Cookie.Value := Value
+ else
+ begin
+  Cookie := THttpCookie(Add);
+  Cookie.Name := Name;
+  Cookie.Value := Value;
+ end;
+end;
+
+procedure THttpCookies.LoadServerCookies(Headers: THeaderList);
+begin
+ Clear;
+ Headers.EnumHeaders('Set-Cookie', AddCookieValue, ',', 1);
+ Headers.EnumHeaders('Set-Cookie2', AddCookieValue, ',', 2);
+end;
+
+procedure THttpCookies.SaveClientCookies(Headers: THeaderList; const Path: string);
+var
+ i: integer;
+ Cookie: THttpCookie;
+begin
+ Headers.RemoveValue('Cookie');
+ for i := 0 to Count - 1 do
+ begin
+  Cookie := Cookies[i];
+  if (Path = '') or Cookie.MatchPath(Path) then
+   Headers.AddValue('Cookie', Cookie.GetClientCookie);
+ end;
+end;
+
+function THttpCookies.AddCookieValue(const Value: string; LParam: NativeUInt): boolean;
+var
+ Cookie: THttpCookie;
+begin
+ Cookie := THttpCookie.Create(nil);
+ if Cookie.ParseValue(Value, LParam) then
+  Cookie.Collection := Self
+ else
+  Cookie.Free;
+ //
+ Result := False; // all...
+end;
+
+procedure THttpCookies.MergeCookies(Source: THttpCookies);
+var
+ i: integer;
+ Src, Dst: THttpCookie;
+begin
+ for i := 0 to Source.Count - 1 do
+ begin
+  Src := Source[i];
+  Dst := Self.Find(Src.Name);
+  if (Dst = nil) then
+   Dst := THttpCookie.Create(nil);
+  Dst.Assign(Src);
+  Dst.Collection := Self;
+ end;
+end;
+
+{ THttpCookie }
+
+procedure THttpCookie.Assign(Source: TPersistent);
+begin
+ if (Source is THttpCookie) then
+ begin
+  FName  := THttpCookie(Source).FName;
+  FValue := THttpCookie(Source).FValue;
+  FDomain := THttpCookie(Source).FDomain;
+  FPath  := THttpCookie(Source).FPath;
+  FExpires := THttpCookie(Source).FExpires;
+  FSecure := THttpCookie(Source).FSecure;
+  FMaxAge := THttpCookie(Source).FMaxAge;
+ end else
+  inherited;
+end;
+
+procedure THttpCookie.DeleteCookie;
+begin
+ // RFC2109:
+ //Optional.  The Max-Age attribute defines the lifetime of the
+ //cookie, in seconds.  The delta-seconds value is a decimal non-
+ //negative integer.  After delta-seconds seconds elapse, the client
+ //should discard the cookie.  A value of zero means the cookie
+ //should be discarded immediately.
+ FMaxAge := '0';
+end;
+
+function QuoteValue(const Value: string): string;
+var
+ p, len: integer;
+begin
+ Result := Value;
+ //
+ len := Length(Result);
+ p := 1;
+ while (p <= len) do
+ begin
+  case Result[p] of
+   '"', '\':
+   begin
+    Insert('\', Result, p);
+    Inc(p);
+    Inc(len);
+   end;
+  end;
+  Inc(p);
+ end;
+ //
+ Result := '"' + Result + '"';
+end;
+
+function NeedsCookieValueQuoting(const S: string): boolean;
+var
+ p: integer;
+begin
+ if (S = '') then
+ begin
+  Result := True;
+  exit;
+ end;
+ //
+ p := Length(S);
+ while (p > 0) do
+ begin
+  case S[p] of
+   '"', '=', ';', ',', #1..' ':
+   begin
+    Result := True;
+    exit;
+   end;
+  end;
+  Dec(p);
+ end;
+ Result := False;
+end;
+
+function AddCookieProp(const Cookie, Name, Value: string; bnQuoted: boolean): string;
+var
+ Sep, QVal: string;
+begin
+ Result := Cookie;
+ if (Value <> '') then
+ begin
+  Sep := '';
+  if (Result <> '') then
+   Sep := '; ';
+  //
+  QVal := Value;
+  // values may be quoted, but do not need to be quoted...
+  if bnQuoted and NeedsCookieValueQuoting(Value) then
+   QVal := QuoteValue(Value);
+  //
+  Result := Result + Sep + Name + '=' + QVal;
+ end;
+end;
+
+function THttpCookie.GetServerCookie: string; // Set-Cookie: format... (for sending server->client)
+begin
+ Result := AddCookieProp('', FName, FValue, True);
+ Result := AddCookieProp(Result, 'Version', FVersion, True);
+ Result := AddCookieProp(Result, 'Path', FPath, True);
+ Result := AddCookieProp(Result, 'Domain', FDomain, True);
+ Result := AddCookieProp(Result, 'Max-Age', FMaxAge, True);
+ Result := AddCookieProp(Result, 'Comment', FComment, True);
+ if FSameSite then
+  Result := AddCookieProp(Result, 'SameSite', 'none', False);
+ //
+ //Expires= is in this format:  Wdy, DD-Mon-YY HH:MM:SS GMT
+ //in Netscape format, also must not use quotes or spaces elsewhere than in Expires...
+ //
+ if FSecure then
+  Result := Result + '; secure';
+ if FValue = '' then
+  Result := FName + '=;' + Result;
+end;
+
+function THttpCookie.GetText: string;
+begin
+ Result := FName + '=' + ConvertUrlChars(FValue.Replace('\', ''));
+end;
+
+function THttpCookie.GetClientCookie: string; // Cookie:     format... (for sending client->server)
+begin
+ if (Version <> '') then
+  Result :=
+   AddCookieProp(AddCookieProp(AddCookieProp(AddCookieProp('', '$Version', Version, True), FName, FValue, True),
+   '$Path', FPath, True), '$Domain', FDomain, True)// RFC2109 format... should have Version='1'
+ // Cookie: $Version="1"; Name="Value"; $Path="Path", $Domain="Domain"
+ else
+  Result := AddCookieProp('', FName, FValue, False)// Simple Netscape format, just Name=Value, no quoting
+ //Result:=FName+'='+FValue;
+ ;
+end;
+
+function THttpCookie.ParseValue(Line: string; Version: NativeUInt): boolean;
+var
+ Value, Name: string;
+ bnFirst, bnSpecial: boolean;
+begin
+ bnFirst := True;
+ while (Line <> '') do
+ begin
+  Value := FetchQSepValue(Line, ';');
+  if (Value <> '') then
+  begin
+   Name := FetchToken(Value, '=', True);
+   //
+   if (Name <> '') and (Name[1] = '$') then
+   begin
+    bnSpecial := True;
+    Delete(Name, 1, 1);
+   end else
+    bnSpecial := False;
+   //
+   if bnFirst and not bnSpecial then
+   begin
+    FName  := Name;
+    FValue := Value;
+    bnFirst := False;
+   end else if SameText(Name, 'path') then // do not localize...
+    FPath := Value
+   else
+   if SameText(Name, 'expires') then
+    FExpires := Value
+   else
+   if SameText(Name, 'domain') then
+    FDomain := Value
+   else
+   if SameText(Name, 'secure') then
+    FSecure := True
+   else
+   if SameText(Name, 'version') then
+    FVersion := Value// other values:
+   ;
+  end;
+ end;
+ Result := not bnFirst;
+end;
+
+function THttpCookie.MatchPath(const aPath: string): boolean;
+var
+ Len: integer;
+begin
+ Len := Length(Self.Path);
+ //
+ if (Length(aPath) >= Len) and SameHead(aPath, Self.Path) //and SameText(Copy(aPath,1,Len),Self.Path)
+ then
+  Result := True
+ else
+  Result := False;
+end;
+
+{ TSynHttpServer }
+
+constructor TSynHttpServer.Create(AOwner: TComponent);
+begin
+ inherited;
+ Port := '80';
+ //
+ //FConnClass:=TSynTcpSrvConnection; // we are using generic connection class...
+ //
+ if not (csDesigning in ComponentState) then
+  OnCommand := HandleClientCommand;
+end;
+
+procedure TSynHttpServer.SetActive(Value: boolean);
+begin
+  {$ifdef DEBUG}
+  if (Value=Self.Active) then
+    exit;
+  if Value then
+    Debug('%s http server on port %s',['Starting',Port])
+  else
+    Debug('%s http server on port %s',['Stoping',Port]);
+  {$endif DEBUG}
+ //
+ inherited;
+ //
+  {$ifdef DEBUG}
+  Debug('Done.');
+  {$endif DEBUG}
+end;
+
+(*function GetStreamSize(Stream: TStream): int64;
+var
+ Pos: int64;
+begin
+ Pos := Stream.Position;
+ Result := Stream.Size;
+ //
+  {$ifdef MSWINDOWS}
+  // Workarround for Delphi 5, where stream does not return Int64...
+  if (Stream is TFileStream) then begin
+    LARGE_INTEGER(Pos).HighPart:=0;
+    LARGE_INTEGER(Pos).LowPart:=SetFilePointer(TFileStream(Stream).Handle,0,@LARGE_INTEGER(Pos).HighPart,FILE_CURRENT);
+    LARGE_INTEGER(Result).HighPart:=0;
+    LARGE_INTEGER(Result).LowPart:=SetFilePointer(TFileStream(Stream).Handle,0,@LARGE_INTEGER(Result).HighPart,FILE_END);
+    //
+    SetFilePointer(TFileStream(Stream).Handle,LARGE_INTEGER(Pos).LowPart,@LARGE_INTEGER(Pos).HighPart,FILE_BEGIN);
+  end;
+  {$endif}
+ //
+ Result := Result - Pos;
+end;
+
+procedure StreamSeek(Stream: TStream; Offset: int64);
+var
+ This: longint;
+begin
+ // Workarround for Delphi 5, where TStream cannot seek by Int64...
+ while (Offset > 0) do
+ begin
+  if (Offset < $20000000) then
+   This := Offset
+  else
+   This := $20000000;
+  Dec(Offset, This);
+  Stream.Seek(This, soFromCurrent);
+ end;
+end;*)
+
+function ParseRangeRequest(S: string; var RangeStart, RangeLength: int64; const ContentSize: int64;
+ bnSizeKnown: boolean): boolean;
+var
+ p: integer;
+ S1, S2: string;
+ RangeEnd: int64;
+begin
+ Result := False;
+ // bytes=0-1000
+ // bytes=1000-
+ // bytes=-1000
+ // bytes=0-1000,2000-3000   this form is not parsed here and is ignored... this way we can avoid sending multipart/byte-ranges response...
+ //
+ if SameHead(S, 'bytes') //if SameText(Copy(S,1,5),'bytes')
+ then
+ begin
+  Delete(S, 1, 5);
+  DoTrim(S); // can have space: bytes = ...
+  if (S <> '') and (S[1] = '=') then
+  begin
+   Delete(S, 1, 1);
+   DoTrim(S);
+  end;
+  //
+  p := Pos('-', S);
+  if (p = 0) then
+   exit;
+  //
+  S1 := TrimCopy(S, 1, p - 1);
+  S2 := TrimCopy(S, p + 1, 63);
+  //
+  RangeStart := StrToInt64Def(S1, -1);
+  RangeEnd := StrToInt64Def(S2, -1);
+  //
+  if (S1 = '') then
+  begin
+   if (S2 = '') or not bnSizeKnown or (RangeEnd < 0) then
+    exit;
+   // bytes=-tailsize
+   RangeStart := ContentSize - RangeEnd;
+   RangeLength := RangeEnd;
+   Result := True;
+  end else
+  if (S2 = '') then
+  begin
+   // bytes=startpos-
+   if (RangeStart < 0) or not bnSizeKnown then
+    exit;
+   RangeLength := ContentSize - RangeStart;
+   Result := True;
+  end else
+  if (RangeStart >= 0) and (RangeEnd >= 0) then
+  begin
+   // bytes=startpos-endpos
+   RangeLength := RangeEnd - RangeStart + 1;
+   Result := True;
+  end;
+ end;
+end;
+
+// this function is the body of http request handling:
+procedure TSynHttpServer.HandleClientCommand(Connection: TSynTcpSrvConnection; Command: string);
+var
+ Request, Reply: THttpRequest;
+begin
+ // Command is first line of request:   GET /index.html HTTP/1.1
+ Request := THttpRequest.Create;
+ Reply := THttpRequest.Create;
+ try
+  ReadRequest(Connection, Request, Reply, Command);
+  DoHttpGet(Connection, Request, Reply);
+  //-------------------------------------------------------------------------
+  // Pass to application:
+  if (Reply = nil) then
+   Exit;// There is a chance for application to send reply, free it and give us NIL instead, to prevent further processing...
+  //-------------------------------------------------------------------------
+  SendReply(Connection, Request, Reply);
+  //
+ finally
+  Reply.Free;
+  Request.Free;
+ end;
+end;
+
+procedure TSynHttpServer.CreatePostStream(Request: THttpRequest);
+begin
+ if Assigned(OnCreatePostStream) then
+  OnCreatePostStream(Self, Request, Request.FPostStream);
+end;
+
+procedure TSynHttpServer.ReadRequest(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest; Command: string);
+var
+ bnContinue, bnHttp11: boolean;
+ S: string;
+
+ function PreparePostStream: boolean;
+ var
+  i, Size: integer;
+ begin
+  Result := False;
+  if (Request.TransferEncoding <> '') and (not SameText(Request.TransferEncoding, 'identity')) then
+  begin
+   if Pos('chunked', LowerCase(Request.TransferEncoding)) = 0 then
+   begin
+    Reply.StatusCode := 400; // bad request
+    //Reply.WriteHeader;
+    Connection.Terminate;
+    Exit;
+   end;
+   CreatePostStream(Request);
+   if Request.FPostStream = nil then
+    Request.FPostStream := TMemoryStream.Create;
+   Request.PostStream.Position := 0;
+   repeat
+    S := string(Connection.Socket.RecvString(cDefLineTimeout));
+    if (Connection.Socket.LastError <> 0) then
+     Exit;
+    i := Pos(';', S); {do not localize}
+    if i > 0 then
+     S := Copy(S, 1, i - 1);
+    Size := StrToIntDef('$' + Trim(S), 0);      {do not localize}
+    if Size = 0 then
+     Break;
+    Connection.Socket.RecvStreamSize(Request.PostStream, cDefLineTimeout, Size);
+    Connection.Socket.RecvString(cDefLineTimeout); // CRLF at end of chunk data
+   until False;
+   // skip trailer headers
+   repeat
+   until Connection.Socket.RecvString(cDefLineTimeout) = '';
+   Request.PostStream.Position := 0;
+  end
+  else if Request.ContentLength <> '' then
+  begin
+   CreatePostStream(Request);
+   if Request.FPostStream = nil then
+    Request.FPostStream := TMemoryStream.Create;
+   Request.PostStream.Position := 0;
+   if Request.ContentLength > '0' then
+   begin
+    Size := StrToIntDef(Request.ContentLength, 0);
+    Connection.Socket.RecvStreamSize(Request.PostStream, cDefLineTimeout, Size);
+    Request.PostStream.Position := 0;
+   end;
+  end
+  // If HTTP Pipelining is used by the client, bytes may exist that belong to
+  // the NEXT request!  We need to look at the CURRENT request and only check
+  // for misreported body data if a body is actually expected.  GET and HEAD
+  // requests do not have bodies...
+  else if SameText(Request.Method, 'POST') or SameText(Request.Method, 'PUT') then
+  begin
+   // TODO: need to handle the case where the ContentType is 'multipart/...',
+   // which is self-terminating and does not strictly require the above headers...
+   if Connection.Socket.LineBuffer = '' then
+    Connection.Socket.CanReadEx(cDefLineTimeout);
+   if Connection.Socket.LineBuffer <> '' then
+   begin
+    Reply.StatusCode := 411; // length required
+    Connection.Terminate;
+    Exit;
+   end;
+  end;
+  Result := True;
+ end;
+
+begin
+ //
+ // Connect objects:
+ Request.FConnection := Connection;
+ Reply.FConnection := Connection;
+ //
+ // Parse first line:
+  {$ifdef DEBUG} Debug('Command:'#13#10'%s',[Command]); {$endif}
+ Request.ParseFirstRequestLine(Command);
+ //
+ // Read rest of headers:
+ if not ReadHeadersFromSocket(Connection.Socket, Request.Headers,
+  {Connection.Socket.GetRecvTimeout}cDefLineTimeout) then
+ begin
+  Connection.Terminate;
+  Exit;
+ end;
+ Request.ApplyHeaders(True);
+ //
+ if (Request.Protocol >= 'HTTP/1.1') and SameHead(Request.Protocol, 'HTTP')
+ //and SameText(Copy(Request.Protocol,1,4),'HTTP')
+ then
+ begin
+  bnHttp11 := True;
+  Reply.FProtocol := 'HTTP/1.1'; // we are compliant...
+  //
+  S := Request.Headers['Expect'];
+  if (S <> '') then
+  begin
+   // RFC2616:
+   //A server that does not understand or is unable to comply with any of
+   //the expectation values in the Expect field of a request MUST respond
+   //with appropriate error status. The server MUST respond with a 417
+   //(Expectation Failed) status if any of the expectations cannot be met
+   //or, if there are other problems with the request, some other 4xx
+   //status.
+   bnContinue := SameText(S, '100-continue'); // we understand only this Expect value...
+   if Assigned(FOnExpect) then
+    FOnExpect(Self, Request, bnContinue);
+   //
+   if bnContinue then
+   begin
+    Reply.StatusCode := 100; // 100 continue
+    Connection.Socket.SendString(UTF8Encode(Reply.GetFirstResponseLine + #13#10#13#10));
+   end else
+   begin
+    // RFC2616:
+    //If it responds with a final status
+    //code, it MAY close the transport connection
+    Reply.StatusCode := 417; // Expectation failed
+    Connection.Socket.SendString(UTF8Encode(Reply.GetFirstResponseLine + #13#10#13#10));
+    Connection.Terminate;
+    Exit;
+   end;
+  end;
+ end else
+ if (Request.Protocol = 'HTTP/1.0') then
+ begin
+  Reply.FProtocol := 'HTTP/1.0';
+  bnHttp11 := False;
+ end else
+ begin
+  // Do not serve just any non-sense, written to our port...
+  // Chance for getting HTTP/0.9 request is very small,
+  // but chance for getting for ex. SMTP communication into the server port is much better...
+  Connection.Terminate;
+  Exit;
+ end;
+ //
+ // Read body:
+ if not PreparePostStream then
+  Exit;
+ if Assigned(Request.PostStream) and SameText(Request.Method, 'POST') then
+ begin
+  S := Request.ContentType;
+  if S.StartsWith('application/x-www-form-urlencoded', True) {or S.StartsWith('multipart/form-data', True)} then
+   with TStringStream.Create do
+   begin
+    CopyFrom(Request.PostStream, Request.PostStream.Size);
+    Request.FContent := DataString;
+    Free;
+   end;
+ end;
+ //
+ // Set some defaults:
+ Reply.StatusCode := 404; // default to Not-found...
+ if bnHttp11 then
+ begin
+  // HTTP/1.1 clients should default to keep-alive (rfc2616):
+  if not Request.Headers.HasValue('Connection', 'close') then
+   Reply.Headers['Connection'] := 'keep-alive'
+  else
+   Reply.Headers['Connection'] := 'close';
+ end else if Request.Headers.HasValue('Connection', 'keep-alive') then
+  Reply.Headers['Connection'] := 'keep-alive'
+ else
+  Reply.Headers['Connection'] := 'close'// HTTP/1.0 clients should default to close (rfc2616):
+ ;
+ //
+ // Cookies:
+ //??? Reply.Cookies.Assign(Request.Cookies);
+ //
+ // POST parameters:
+ if Request.FContent <> '' then
+  Request.ParsePostFormData;
+ //
+ Reply.Headers['Server'] := ServerValue;
+end;
+
+procedure TSynHttpServer.DoHttpGet(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest);
+begin
+ if Assigned(FOnHttpGet) then
+  FOnHttpGet(Self, Connection, Request, Reply);
+end;
+
+function IsWithin(Value, Min, Max: integer): boolean;
+begin
+ Result := (Value >= Min) and (Value <= Max);
+end;
+
+function ExtractUrlPath(const Url: string): string;
+var
+ p: integer;
+ bnFound: boolean;
+begin
+ Result := Url;
+ p := Pos('://', Result);
+ if (p > 0) then
+ begin
+  Delete(Result, 1, p + 2); // remove http://
+  p := Pos('/', Result);
+  if (p > 0) then
+   Delete(Result, 1, p); // remove hostname
+ end;
+ //
+ p := Pos('?', Result);
+ if (p = 0) then
+  p := Length(Result) + 1;
+ bnFound := False;
+ while (p > 1) do
+ begin
+  Dec(p);
+  if (Result[p] = '/') then
+  begin
+   SetLength(Result, p - 1);
+   bnFound := True;
+   break;
+  end;
+ end;
+ //
+ if not bnFound or (Result = '') then
+  Result := '/';
+end;
+
+procedure TSynHttpServer.SendReply(Connection: TSynTcpSrvConnection; Request, Reply: THttpRequest);
+var
+ bnBody, bnSize: boolean;
+ S: string;
+ Size, RangeStart, RangeLength: int64;
+ Date, Date2: TDateTime;
+
+ function AlwaysUpdate(const Url: string): boolean;
+ begin
+  Result := (Url = '/') or (Url.ToLower.Contains('.html'));
+ end;
+
+begin
+ if Reply.ResponseSent then
+  Exit;
+ // Adjust Reply:
+ //
+ // Cookies:
+ Reply.Cookies.SetDefaultPath;
+ if FHTTPSEnabled then
+  Reply.Cookies.SetSameSite;
+ Reply.Cookies.SaveServerCookies(Reply.Headers, Request.Host, ExtractUrlPath(Request.Url));
+ //
+ // Fill other values:
+ if (Reply.Headers['Date'] = '') then
+  Reply.Headers['Date'] := FormatHttpDate(Now, True);
+ //
+ // Content-Length and Transfer-Encoding:
+ if Reply.SendChunked then
+ begin
+  Reply.ContentLength := '';
+  Reply.TransferEncoding := 'chunked';
+  Size := -1;
+  bnSize := False;
+ end else
+ begin
+  S := Reply.ContentLength;
+  if (S = '') then
+  begin
+   // Fill Content-Length:
+   if (Reply.PostStream <> nil) then
+   begin
+    //Size:=Reply.ContentStream.Size;
+    Size := Reply.PostStream.Size;
+    bnSize := True;
+   end else
+   if (Reply.Content <> '') then
+   begin
+    Size := Length(UTF8Encode(Reply.Content));
+    bnSize := True;
+   end else
+   begin
+    Size := 0;
+    bnSize := False;
+   end;
+   //
+   Reply.ContentLength := IntToStr(Size);
+   //
+  end else
+  begin
+   // Content-Length was filled by application:
+   Size := StrToInt64Def(S, -1);
+   bnSize := (Size >= 0);
+  end;
+ end;
+ //
+ //? if (Reply.StatusCode=404) then Reply.Headers['Connection']:='close';
+ //
+ if IsWithin(Reply.StatusCode, 200, 299) and not AlwaysUpdate(Request.Url) then
+ begin
+  //
+  // Check If-Modified-Since:
+  S := Request.Headers['If-Modified-Since'];
+  if (S <> '') and ParseHttpDate(S, Date) then
+  begin
+      {$ifdef DEBUG}
+      Debug('If-Modified-Since: %s',[S]);
+      Debug('Last-Modified: %s',[Reply.Headers['Last-Modified']]);
+      {$endif DEBUG}
+   //
+   Date2 := Reply.LastModifiedUtc;
+   if (Date2 <> 0) and (Date2 > Date) then // is modified...
+{$ifdef DEBUG}
+{$endif DEBUG}
+   else
+   begin
+    // Is not modified...
+    Reply.StatusCode := 304; // Not Modified
+    //!!!TODO/bug
+    // mozilla hangs in transfer, when it gets the 304 responses??
+    //if (Copy(Request.Headers['User-Agent'], 1, 7) = 'Mozilla') then
+    // Reply.Headers['Connection'] := 'close';
+   end;
+  end else
+  begin
+      {$ifdef DEBUG}
+      if (S<>'') then
+        Debug('Failed parse date "%s"',[S]);
+      {$endif DEBUG}
+   //
+   S := Request.Headers['If-Unmodified-Since'];
+   if (S <> '') and ParseHttpDate(S, Date) then
+   begin
+    Date2 := Reply.LastModifiedUtc;
+    if (Date2 <> 0) and (Date2 > Date) then
+     Reply.StatusCode := 412// is modified
+    // Precondition Failed
+    ;
+   end;
+  end;
+ end;
+ //
+ if IsWithin(Reply.StatusCode, 200, 299) then
+ begin
+  //
+  // Check If-Range - if the condition fails, we will ignore Range: header...
+  S := Request.Headers['If-Range'];
+  if (S <> '') then
+   if (CharInSet(S[1], ['w', 'W'])) and (S[2] = '/') // W/"tag"
+    or (S[1] = '"')                // "tag"
+   then
+   begin
+    if not Request.Headers.HasValue('Etag', S) then
+     Request.Headers['Range'] := ''; // does not have this Etag...
+   end else if ParseHttpDate(S, Date) then
+   begin
+    Date2 := Reply.LastModifiedUtc;
+    if (Date2 = 0) or (Date2 <= Date) then // is not modified since...
+    else
+    begin
+     // was modified since...
+     Request.Headers['Range'] := ''; // will send whole...
+    end;
+   end else
+    Request.Headers['Range'] := ''// Http-date:  like If-Unmodified-Since...
+  // we do not understand If-Range header, so we will send whole body...
+  // If-Range = "If-Range" ":" ( entity-tag | HTTP-date )
+  ;
+  //
+  // Check Range: header
+  RangeStart := 0;
+  RangeLength := 0;
+  S := Request.Headers['Range'];
+  if (S <> '') and ParseRangeRequest(S, RangeStart, RangeLength, Size, bnSize) then
+   if (bnSize and (RangeStart >= Size)) or (RangeLength <= 0) then
+   begin
+    Reply.StatusCode := 416; // Requested Range Not Satisfiable
+    Reply.ContentLength := '';
+    if bnSize then
+     Reply.Headers['Content-Range'] := Format('*/%d', [Size]); // we SHOULD send this with 416 code...
+    Size := 0; // do not send body... //we will not send body, filtered also below...
+   end else
+   begin
+    // Valid range:
+    if bnSize then
+     S := IntToStr(Size)
+    else
+     S := '*';
+    Reply.StatusCode := 206; // Partial Content
+    Reply.Headers['Content-Range'] :=
+     Format('bytes %d-%d/%s', [RangeStart, RangeStart + RangeLength - 1, S]);
+    if bnSize then
+     Reply.ContentLength := IntToStr(RangeLength);
+    //
+    if (RangeStart <> 0) then
+     if (Reply.PostStream <> nil) then
+      Reply.PostStream.Seek(RangeStart, soCurrent)
+     else
+     if (Reply.Content <> '') then
+      Delete(Reply.FContent, 1, RangeStart);
+    //
+    if (RangeLength <> 0) then
+    begin
+     Size := RangeLength;
+     if (Reply.PostStream = nil) and (Reply.Content <> '') and (Size < Length(Reply.Content)) then
+      SetLength(Reply.FContent, Size);
+    end;
+   end//
+  ;
+ end;
+ //
+ if IsWithin(Reply.StatusCode, 200, 299) then
+ begin
+  // Check Etag headers (If-Match, If-None-Match)
+  S := Request.Headers['If-Match'];
+  if (S <> '') then
+   if not Reply.MatchTag(S) then
+    Reply.StatusCode := 412// Precondition Failed
+  // reply may have more tags, comma-separated, some week...
+  // also If-Match may specify more tags...
+  ;
+  S := Request.Headers['If-None-Match'];
+  if (S <> '') then
+   if Reply.MatchTag(S) then
+    Reply.StatusCode := 412// Precondition Failed
+  ;
+ end;
+ //
+ //-------------------------------------------------------------------------
+ // Write reply to client:
+ S := Reply.GetFirstResponseLine + #13#10 + Reply.Headers.Text + #13#10; // include 1 empty line after headers...
+  {$ifdef DEBUG}Debug('Response headers:'#13#10'%s',[S]);{$endif}
+ Connection.Socket.SendString(UTF8Encode(S));
+ Reply.ResponseSent := True;
+ if (Connection.Socket.LastError <> 0) then
+ begin
+  Connection.Terminate;
+  Exit;
+ end;
+ //
+ bnBody := True;
+ if SameText(Request.Method, 'HEAD') then
+  bnBody := False // MUST NOT send entity body with HEAD, but should send Content-Length...
+ else
+  case Reply.StatusCode of
+   412, // this is not in RFC, but we will not send entity body with 412 precondition failed anyway...
+   416, // this is not in RFC, but we will not send entity body with 416 code (Requested Range Not Satisfiable) anyway...
+   100..199, 204, 304:
+   begin
+    bnBody := False; // we MUST NOT send entity body with these status-codes...
+    // Do not send Content-Length and Content-Type fields
+    Reply.Headers['Content-Length'] := '';
+    Reply.Headers['Content-Type'] := '';
+   end;
+  end;
+ //
+ if bnBody then
+ begin
+  // Send body:
+  if (Reply.PostStream <> nil) then
+   SendSocketStream(Connection.Socket, Reply.PostStream, Size, Reply.SendChunked)
+  //x: we cannot use this, since it uses Stream.Size: Connection.Socket.SendStreamRaw(Reply.ContentStream);
+  else
+  if (Reply.Content <> '') then
+   if not Reply.SendChunked then
+    Connection.Socket.SendString(UTF8Encode(Reply.Content))
+   else
+   begin
+    // Send 1 chunk:
+    Connection.Socket.SendString(UTF8Encode(Format('%x'#13#10, [Length(Reply.Content)])));
+    if (Connection.Socket.LastError = 0) then
+     Connection.Socket.SendString(UTF8Encode(Reply.Content));
+    if (Connection.Socket.LastError = 0) then
+     Connection.Socket.SendString('0'#13#10#13#10);
+   end;
+  //
+  if (Connection.Socket.LastError <> 0) then
+  begin
+   Connection.Terminate;
+   exit;
+  end;
+ end;
+ //
+ if Reply.Headers.HasValue('Connection', 'close') then
+  Connection.Terminate;
+end;
+
+procedure TSynHttpServer.InitHttps(const CertFile, KeyFile, KeyPassword, CaCertFile: string);
+begin
+ if not FileExists(CertFile) or not FileExists(KeyFile) then
+  Exit;
+ FCertFile := CertFile;
+ FKeyFile  := KeyFile;
+ FKeyPass  := KeyPassword;
+ FCaCertFile := CaCertFile;
+ //FSynapseServer.Socket.SSL.CertCAFile := ExtractFilePath(ParamStr(0)) + 's_cabundle.pem';
+ FSynapseServer.Socket.SSL.CertificateFile := FCertFile;
+ FSynapseServer.Socket.SSL.PrivateKeyFile := FKeyFile;
+ FSynapseServer.Socket.SSL.KeyPassword := FKeyPass;
+ FSynapseServer.Socket.SSL.VerifyCert := True;
+ //
+ //if (Self.Port = '80') then
+ //Self.Port := '443';
+end;
+
+initialization
+ ContentTypes := TStringList.Create;
+ ContentTypes.Sorted := True;
+ RegisterInternalContentTypes;
+
+finalization
+ FreeAndNil(ContentTypes);
+end.

SynSrv.pas

@@ -0,0 +1,317 @@
+{--------------------------------------------------------------}
+{                                                              }
+{  SynSrv.pas - generic TCP server over Synapse library        }
+{                                                              }
+{  Author:     Semi                                            }
+{  Started:    070528                                          }
+{                                                              }
+{--------------------------------------------------------------}
+unit SynSrv;
+
+{$IFDEF FPC}
+  {$MODE Delphi}
+{$ENDIF}
+
+interface
+
+uses
+ SysUtils,
+ Classes,
+ synsock,
+ blcksock,
+ Generics.Collections;
+//-------------------------------------------------------------
+
+const
+ // Default timeout to receive 1 line from connection:
+ cDefLineTimeout = 120000; // default 2 minutes...
+
+type
+ TSynTcpSrvConnection = class;
+ TSynTcpServer        = class;
+
+ { TListenerThread }
+
+ TListenerThread = class(TThread)
+ private
+  FThreadList: TObjectList<TSynTcpSrvConnection>;
+  FSocket:     TTCPBlockSocket;
+  FPort:       string;
+  FHost:       string;
+  FTcpServer:  TSynTcpServer;
+  procedure ClearFinishedThreads;
+  procedure BindSocket;
+ protected
+  procedure Execute; override;
+ public
+  constructor Create(ASuspended: boolean; ATcpServer: TSynTcpServer);
+  destructor Destroy; override;
+  property Host: string Read FHost Write FHost;
+  property Port: string Read FPort Write FPort;
+  property Socket: TTCPBlockSocket Read FSocket;
+ end;
+
+ TSynTcpSrvConnection = class(TThread)
+ private
+  FTcpServer: TSynTcpServer;
+  FFinished:  boolean;
+  FSocket:    TTCPBlockSocket;
+  function GetClientAddress: string;
+  function GetClientPort: integer;
+ protected
+  procedure Execute; override;
+ public
+  destructor Destroy; override;
+  constructor Create(ASuspended: boolean; ASocket: TSocket; ATcpServer: TSynTcpServer);
+  property Socket: TTCPBlockSocket Read FSocket Write FSocket; // client socket
+  property ClientAddress: string Read GetClientAddress;        // '123.45.67.89'
+  property ClientPort: integer Read GetClientPort;
+ end;
+
+ TCommandHandler = procedure(Connection: TSynTcpSrvConnection; Command: string) of object;
+
+ // TSynTcpServer - Generic TCP server component
+ TSynTcpServer = class(TComponent)
+ protected
+  FActive:        boolean;
+  FPort:          string;
+  FHost:          string;
+  FHTTPSEnabled:  boolean;
+  //
+  FOnCommand:     TCommandHandler;
+  //
+  FSynapseServer: TListenerThread;
+  procedure SetPort(const Value: string);
+  procedure SetLocalAddr(const Value: string);
+  procedure SetActive(Value: boolean); virtual;
+ public
+  constructor Create(AOwner: TComponent); override;
+  //
+  //
+ published
+  // Host may be assigned to 'localhost' to serve only on localhost interface...
+  property Host: string Read FHost Write FHost;
+  //
+  // Port must be assigned.
+  property Port: string Read FPort Write SetPort; // MUST assign port...
+  //
+  // Set Active:=True to start server, set Active:=False to stop server
+  property Active: boolean Read FActive Write SetActive default False;
+  //
+  // Or assign OnCommand to parse commands (text lines) from connection:
+  // (this is used by TSynHttpServer and TSynFtpServer etc...)
+  property OnCommand: TCommandHandler Read FOnCommand Write FOnCommand;
+  property HTTPSEnabled: boolean Read FHTTPSEnabled Write FHTTPSEnabled;
+ end;
+
+//-------------------------------------------------------------
+implementation
+//-------------------------------------------------------------
+
+{ TSynTcpServer }
+
+constructor TSynTcpServer.Create(AOwner: TComponent);
+begin
+ inherited;
+ //
+ FHost := '0.0.0.0';
+end;
+
+procedure TSynTcpServer.SetPort(const Value: string);
+begin
+ SetActive(False);
+ FPort := Value;
+end;
+
+procedure TSynTcpServer.SetLocalAddr(const Value: string);
+begin
+ SetActive(False);
+ FHost := Value;
+end;
+
+procedure TSynTcpServer.SetActive(Value: boolean);
+begin
+ if (csDesigning in ComponentState) then
+ begin
+  // No real server at design-time...
+  FActive := Value;
+  Exit;
+ end;
+ if (csLoading in ComponentState) then
+  Exit;
+ //
+ if (FActive <> Value) then
+ begin
+  FActive := Value;
+  if FActive then
+  begin
+   if (FPort = '') then
+    raise ESynapseError.Create('Missing server Port');
+   FSynapseServer := TListenerThread.Create(True, Self);
+   FSynapseServer.Port := FPort;
+   FSynapseServer.Host := FHost;
+   try
+    FSynapseServer.BindSocket
+   except
+    FreeAndNil(FSynapseServer);
+    FActive := False;
+    raise ESocketBindError.Create(Format('Couldnt bind socket on %s port', [FPort]));
+   end;
+   FSynapseServer.Start;
+  end
+  else
+  if Assigned(FSynapseServer) then
+  begin
+   FSynapseServer.Terminate;
+   FSynapseServer.WaitFor;
+   FreeAndNil(FSynapseServer);
+   //StopAllSessions;
+  end;
+ end;
+end;
+
+{ TListenerThread }
+
+procedure TListenerThread.ClearFinishedThreads;
+var
+ i: integer;
+begin
+ for i := FThreadList.Count - 1 downto 0 do
+  if FThreadList[i].FFinished then
+   FThreadList.Remove(FThreadList[i]);
+end;
+
+procedure TListenerThread.BindSocket;
+var
+ e: ESynapseError;
+begin
+ FSocket.CreateSocket;
+ FSocket.Bind(FHost, FPort);
+ if FSocket.LastError = 0 then
+ begin
+  FSocket.EnableReuse(True);
+  FSocket.Listen;
+ end
+ else
+ begin
+  e := ESynapseError.Create(Format('ListenThreadException %d: %s', [FSocket.LastError, FSocket.LastErrorDesc]));
+  e.ErrorCode := FSocket.LastError;
+  e.ErrorMessage := FSocket.LastErrorDesc;
+  raise e;
+ end;
+end;
+
+constructor TListenerThread.Create(ASuspended: boolean; ATcpServer: TSynTcpServer);
+begin
+ FSocket := TTCPBlockSocket.Create;
+ FThreadList := TObjectList<TSynTcpSrvConnection>.Create;
+ FTcpServer := ATcpServer;
+ inherited Create(ASuspended);
+end;
+
+destructor TListenerThread.Destroy;
+var
+ i: integer;
+begin
+ FSocket.CloseSocket;
+ for i := 0 to FThreadList.Count - 1 do
+ begin
+  FThreadList[i].Terminate;
+  FThreadList[i].Socket.CloseSocket;
+ end;
+ ClearFinishedThreads;
+ FreeAndNil(FThreadList);
+ FreeAndNil(FSocket);
+ inherited;
+end;
+
+procedure TListenerThread.Execute;
+var
+ SynapseConnect: TSynTcpSrvConnection;
+begin
+ inherited;
+ repeat
+  if FSocket.CanRead(100) then
+  begin
+   SynapseConnect := TSynTcpSrvConnection.Create(True, FSocket.Accept, FTcpServer);
+   FThreadList.Add(SynapseConnect);
+   SynapseConnect.Start;
+  end;
+  ClearFinishedThreads;
+ until Terminated;
+ try
+  FSocket.CloseSocket;
+ except
+ end;
+end;
+
+{ TSynTcpSrvConnection }
+
+constructor TSynTcpSrvConnection.Create(ASuspended: boolean; ASocket: TSocket; ATcpServer: TSynTcpServer);
+begin
+ inherited Create(ASuspended);
+ FSocket := TTCPBlockSocket.Create;
+ FSocket.Owner := Self;
+ FSocket.SSL.CertificateFile:= ATcpServer.FSynapseServer.FSocket.SSL.CertificateFile;
+ FSocket.SSL.PrivateKeyFile:= ATcpServer.FSynapseServer.FSocket.SSL.PrivateKeyFile;
+ FSocket.SSL.KeyPassword:= ATcpServer.FSynapseServer.FSocket.SSL.KeyPassword;
+ FSocket.SSL.VerifyCert:= ATcpServer.FSynapseServer.FSocket.SSL.VerifyCert;
+ FTcpServer := ATcpServer;
+ if ASocket <> INVALID_SOCKET then
+ begin
+  FSocket.Socket := ASocket;
+  FSocket.GetSins;
+ end;
+end;
+
+destructor TSynTcpSrvConnection.Destroy;
+begin
+ FSocket.CloseSocket;
+ inherited;
+ FreeAndNil(FSocket);
+end;
+
+procedure TSynTcpSrvConnection.Execute;
+var
+ Command: string;
+begin
+ inherited;
+ if FSocket.SSL.VerifyCert then
+  try
+   if (not FSocket.SSLAcceptConnection) or (FSocket.SSL.LastError <> 0) then
+   begin
+    FFinished := True;
+   end;
+  except
+   FFinished := True;
+  end;
+ if not FFinished then
+ try
+  while not Terminated do
+  begin
+   Command := string(FSocket.RecvString({FSocket.GetRecvTimeout)}cDefLineTimeout));
+   // Disconnect on timeout:
+   if (Command = '') and (FSocket.LastError <> 0) then
+    Break;
+   //
+   if Assigned(FTcpServer.FOnCommand) then // could be de-assigned?
+    FTcpServer.FOnCommand(Self, Command)
+   else
+    Break;
+  end;
+ finally
+  FFinished := True;
+ end;
+end;
+
+function TSynTcpSrvConnection.GetClientAddress: string;
+begin
+ Result := FSocket.GetRemoteSinIP;
+end;
+
+function TSynTcpSrvConnection.GetClientPort: integer;
+begin
+ Result := FSocket.GetRemoteSinPort;
+end;
+
+end.

Unit2.dfm

@@ -0,0 +1,25 @@
+object Form2: TForm2
+  Left = 0
+  Top = 0
+  Caption = 'Form2'
+  ClientHeight = 231
+  ClientWidth = 505
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  PixelsPerInch = 96
+  TextHeight = 13
+  object Button1: TButton
+    Left = 208
+    Top = 96
+    Width = 75
+    Height = 25
+    Caption = 'Button1'
+    TabOrder = 0
+    OnClick = Button1Click
+  end
+end

Unit2.pas

@@ -0,0 +1,86 @@
+unit Unit2;
+
+interface
+
+uses
+ Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
+ Vcl.Controls, Vcl.Forms, Vcl.Dialogs, SynHttpSrv, Vcl.StdCtrls, SynSrv;
+
+type
+ TForm2 = class(TForm)
+  Button1: TButton;
+  procedure Button1Click(Sender: TObject);
+ private
+  FSynHttpServer: TSynHttpServer;
+  { Private declarations }
+  procedure SynHttpServer1HttpGet(Sender: TObject; Connection: TSynTcpSrvConnection;
+   ARequestInfo, AResponseInfo: THttpRequest);
+ public
+  { Public declarations }
+ end;
+
+var
+ Form2: TForm2;
+
+implementation
+
+{$R *.dfm}
+
+procedure TForm2.Button1Click(Sender: TObject);
+
+ procedure TryToOpenWebPort;
+ var
+  s: string;
+ begin
+  try
+   if not FSynHttpServer.Active then
+    FSynHttpServer.Active := True;
+  except
+   on E: Exception do
+   begin
+    s := Format('Exception %s occurred while trying activate http or https connection. Message:"%s".',
+     [E.ClassName, E.Message]);
+    //Log(s);
+   end;
+  end;
+ end;
+
+begin
+ FSynHttpServer := TSynHttpServer.Create(Self);
+ FSynHttpServer.OnHttpGet := SynHttpServer1HttpGet;
+ FSynHttpServer.Port := '8080';
+ TryToOpenWebPort;
+end;
+
+procedure TForm2.SynHttpServer1HttpGet(Sender: TObject; Connection: TSynTcpSrvConnection;
+ ARequestInfo, AResponseInfo: THttpRequest);
+
+ procedure WriteData;
+ begin
+  try
+   FSynHttpServer.SendReply(Connection, ARequestInfo, AResponseInfo);
+  except
+   On E: Exception do
+    if (Pos('10054', E.Message) = 0) and (Pos('10053', E.Message) = 0) then
+     {Log('Error; Exception occured. ' + E.Message)};
+  end;
+ end;
+
+ procedure RespString(const Str: string; const CharSet: string = '');
+ begin
+  if Str.IsEmpty then
+   AResponseInfo.Content := ' '
+  else
+   AResponseInfo.Content := Str;
+  AResponseInfo.ContentType := 'text/html';
+  AResponseInfo.CharSet := CharSet;
+  AResponseInfo.StatusCode := 200;
+  WriteData;
+ end;
+
+begin
+ if ARequestInfo.Params.Values['Ping'] = 'Ping' then
+  RespString('Pong');
+end;
+
+end.

asn1util.pas

@@ -0,0 +1,521 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.001.000 |
+|==============================================================================|
+| Content: support for ASN.1 BER coding and decoding                           |
+|==============================================================================|
+| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2014                |
+| Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Hernan Sanchez ([email protected])                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(Utilities for handling ASN.1 BER encoding)
+By this unit you can parse ASN.1 BER encoded data to elements or build back any
+ elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
+ human readable form for easy debugging, too.
+
+Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
+ ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
+ ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
+
+For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
+}
+
+{$Q-}
+{$H+}
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit asn1util;
+
+interface
+
+uses
+  SysUtils, Classes, synautil;
+
+const
+  ASN1_BOOL = $01;
+  ASN1_INT = $02;
+  ASN1_OCTSTR = $04;
+  ASN1_NULL = $05;
+  ASN1_OBJID = $06;
+  ASN1_ENUM = $0a;
+  ASN1_SEQ = $30;
+  ASN1_SETOF = $31;
+  ASN1_IPADDR = $40;
+  ASN1_COUNTER = $41;
+  ASN1_GAUGE = $42;
+  ASN1_TIMETICKS = $43;
+  ASN1_OPAQUE = $44;
+  ASN1_COUNTER64 = $46;
+
+{:Encodes OID item to binary form.}
+function ASNEncOIDItem(Value: Int64): AnsiString;
+
+{:Decodes an OID item of the next element in the "Buffer" from the "Start"
+ position.}
+function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64;
+
+{:Encodes the length of ASN.1 element to binary.}
+function ASNEncLen(Len: Integer): AnsiString;
+
+{:Decodes length of next element in "Buffer" from the "Start" position.}
+function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
+
+{:Encodes a signed integer to ASN.1 binary}
+function ASNEncInt(Value: Int64): AnsiString;
+
+{:Encodes unsigned integer into ASN.1 binary}
+function ASNEncUInt(Value: Integer): AnsiString;
+
+{:Encodes ASN.1 object to binary form.}
+function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
+
+{:Beginning with the "Start" position, decode the ASN.1 item of the next element
+ in "Buffer". Type of item is stored in "ValueType."}
+function ASNItem(var Start: Integer; const Buffer: AnsiString;
+  var ValueType: Integer): AnsiString;
+
+{:Encodes an MIB OID string to binary form.}
+function MibToId(Mib: String): AnsiString;
+
+{:Decodes MIB OID from binary form to string form.}
+function IdToMib(const Id: AnsiString): String;
+
+{:Encodes an one number from MIB OID to binary form. (used internally from
+@link(MibToId))}
+function IntMibToStr(const Value: AnsiString): AnsiString;
+
+{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
+function ASNdump(const Value: AnsiString): AnsiString;
+
+implementation
+
+{==============================================================================}
+function ASNEncOIDItem(Value: Int64): AnsiString;
+var
+  x: Int64;
+  xm: Byte;
+  b: Boolean;
+begin
+  x := Value;
+  b := False;
+  Result := '';
+  repeat
+    xm := x mod 128;
+    x := x div 128;
+    if b then
+      xm := xm or $80;
+    if x > 0 then
+      b := True;
+    Result := AnsiChar(xm) + Result;
+  until x = 0;
+end;
+
+{==============================================================================}
+function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Int64;
+var
+  x: Integer;
+  b: Boolean;
+begin
+  Result := 0;
+  repeat
+    Result := Result * 128;
+    x := Ord(Buffer[Start]);
+    Inc(Start);
+    b := x > $7F;
+    x := x and $7F;
+    Result := Result + x;
+  until not b;
+end;
+
+{==============================================================================}
+function ASNEncLen(Len: Integer): AnsiString;
+var
+  x, y: Integer;
+begin
+  if Len < $80 then
+    Result := AnsiChar(Len)
+  else
+  begin
+    x := Len;
+    Result := '';
+    repeat
+      y := x mod 256;
+      x := x div 256;
+      Result := AnsiChar(y) + Result;
+    until x = 0;
+    y := Length(Result);
+    y := y or $80;
+    Result := AnsiChar(y) + Result;
+  end;
+end;
+
+{==============================================================================}
+function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
+var
+  x, n: Integer;
+begin
+  x := Ord(Buffer[Start]);
+  Inc(Start);
+  if x < $80 then
+    Result := x
+  else
+  begin
+    Result := 0;
+    x := x and $7F;
+    for n := 1 to x do
+    begin
+      Result := Result * 256;
+      x := Ord(Buffer[Start]);
+      Inc(Start);
+      Result := Result + x;
+    end;
+  end;
+end;
+
+{==============================================================================}
+function ASNEncInt(Value: Int64): AnsiString;
+var
+  x: Int64;
+  y: byte;
+  neg: Boolean;
+begin
+  neg := Value < 0;
+  x := Abs(Value);
+  if neg then
+    x := x - 1;
+  Result := '';
+  repeat
+    y := x mod 256;
+    x := x div 256;
+    if neg then
+      y := not y;
+    Result := AnsiChar(y) + Result;
+  until x = 0;
+  if (not neg) and (Result[1] > #$7F) then
+    Result := #0 + Result;
+  if (neg) and (Result[1] < #$80) then
+    Result := #$FF + Result;
+end;
+
+{==============================================================================}
+function ASNEncUInt(Value: Integer): AnsiString;
+var
+  x, y: Integer;
+  neg: Boolean;
+begin
+  neg := Value < 0;
+  x := Value;
+  if neg then
+    x := x and $7FFFFFFF;
+  Result := '';
+  repeat
+    y := x mod 256;
+    x := x div 256;
+    Result := AnsiChar(y) + Result;
+  until x = 0;
+  if neg then
+    Result[1] := AnsiChar(Ord(Result[1]) or $80);
+end;
+
+{==============================================================================}
+function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
+begin
+  Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
+end;
+
+{==============================================================================}
+function ASNItem(var Start: Integer; const Buffer: AnsiString;
+  var ValueType: Integer): AnsiString;
+var
+  ASNType: Integer;
+  ASNSize: Integer;
+  y: int64;
+  n: Integer;
+  x: byte;
+  s: AnsiString;
+  c: AnsiChar;
+  neg: Boolean;
+  l: Integer;
+begin
+  Result := '';
+  ValueType := ASN1_NULL;
+  l := Length(Buffer);
+  if l < (Start + 1) then
+    Exit;
+  s := '';
+  ASNType := Ord(Buffer[Start]);
+  ValueType := ASNType;
+  Inc(Start);
+  ASNSize := ASNDecLen(Start, Buffer);
+  if (Start + ASNSize - 1) > l then
+    Exit;
+  if (ASNType and $20) > 0 then
+//    Result := '$' + IntToHex(ASNType, 2)
+    Result := Copy(Buffer, Start, ASNSize)
+  else
+    case ASNType of
+      ASN1_INT, ASN1_ENUM, ASN1_BOOL:
+        begin
+          y := 0;
+          neg := False;
+          for n := 1 to ASNSize do
+          begin
+            x := Ord(Buffer[Start]);
+            if (n = 1) and (x > $7F) then
+              neg := True;
+            if neg then
+              x := not x;
+            y := y * 256 + x;
+            Inc(Start);
+          end;
+          if neg then
+            y := -(y + 1);
+          Result := IntToStr(y);
+        end;
+      ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS, ASN1_COUNTER64:
+        begin
+          y := 0;
+          for n := 1 to ASNSize do
+          begin
+            y := y * 256 + Ord(Buffer[Start]);
+            Inc(Start);
+          end;
+          Result := IntToStr(y);
+        end;
+      ASN1_OCTSTR, ASN1_OPAQUE:
+        begin
+          for n := 1 to ASNSize do
+          begin
+            c := AnsiChar(Buffer[Start]);
+            Inc(Start);
+            s := s + c;
+          end;
+          Result := s;
+        end;
+      ASN1_OBJID:
+        begin
+          for n := 1 to ASNSize do
+          begin
+            c := AnsiChar(Buffer[Start]);
+            Inc(Start);
+            s := s + c;
+          end;
+          Result := IdToMib(s);
+        end;
+      ASN1_IPADDR:
+        begin
+          s := '';
+          for n := 1 to ASNSize do
+          begin
+            if (n <> 1) then
+              s := s + '.';
+            y := Ord(Buffer[Start]);
+            Inc(Start);
+            s := s + IntToStr(y);
+          end;
+          Result := s;
+        end;
+      ASN1_NULL:
+        begin
+          Result := '';
+          Start := Start + ASNSize;
+        end;
+    else // unknown
+      begin
+        for n := 1 to ASNSize do
+        begin
+          c := AnsiChar(Buffer[Start]);
+          Inc(Start);
+          s := s + c;
+        end;
+        Result := s;
+      end;
+    end;
+end;
+
+{==============================================================================}
+function MibToId(Mib: String): AnsiString;
+var
+  x: Integer;
+
+  function WalkInt(var s: String): Integer;
+  var
+    x: Integer;
+    t: AnsiString;
+  begin
+    x := Pos('.', s);
+    if x < 1 then
+    begin
+      t := s;
+      s := '';
+    end
+    else
+    begin
+      t := Copy(s, 1, x - 1);
+      s := Copy(s, x + 1, Length(s) - x);
+    end;
+    Result := StrToIntDef(t, 0);
+  end;
+
+begin
+  Result := '';
+  x := WalkInt(Mib);
+  x := x * 40 + WalkInt(Mib);
+  Result := ASNEncOIDItem(x);
+  while Mib <> '' do
+  begin
+    x := WalkInt(Mib);
+    Result := Result + ASNEncOIDItem(x);
+  end;
+end;
+
+{==============================================================================}
+function IdToMib(const Id: AnsiString): String;
+var
+  x, y, n: Integer;
+begin
+  Result := '';
+  n := 1;
+  while Length(Id) + 1 > n do
+  begin
+    x := ASNDecOIDItem(n, Id);
+    if (n - 1) = 1 then
+    begin
+      y := x div 40;
+      x := x mod 40;
+      Result := IntToStr(y);
+    end;
+    Result := Result + '.' + IntToStr(x);
+  end;
+end;
+
+{==============================================================================}
+function IntMibToStr(const Value: AnsiString): AnsiString;
+var
+  n, y: Integer;
+begin
+  y := 0;
+  for n := 1 to Length(Value) - 1 do
+    y := y * 256 + Ord(Value[n]);
+  Result := IntToStr(y);
+end;
+
+{==============================================================================}
+function ASNdump(const Value: AnsiString): AnsiString;
+var
+  i, at, x, n: integer;
+  s, indent: AnsiString;
+  il: TStringList;
+begin
+  il := TStringList.Create;
+  try
+    Result := '';
+    i := 1;
+    indent := '';
+    while i < Length(Value) do
+    begin
+      for n := il.Count - 1 downto 0 do
+      begin
+        x := StrToIntDef(il[n], 0);
+        if x <= i then
+        begin
+          il.Delete(n);
+          Delete(indent, 1, 2);
+        end;
+      end;
+      s := ASNItem(i, Value, at);
+      Result := Result + indent + '$' + IntToHex(at, 2);
+      if (at and $20) > 0 then
+      begin
+        x := Length(s);
+        Result := Result + ' constructed: length ' + IntToStr(x);
+        indent := indent + '  ';
+        il.Add(IntToStr(x + i - 1));
+      end
+      else
+      begin
+        case at of
+          ASN1_BOOL:
+            Result := Result + ' BOOL: ';
+          ASN1_INT:
+            Result := Result + ' INT: ';
+          ASN1_ENUM:
+            Result := Result + ' ENUM: ';
+          ASN1_COUNTER:
+            Result := Result + ' COUNTER: ';
+          ASN1_GAUGE:
+            Result := Result + ' GAUGE: ';
+          ASN1_TIMETICKS:
+            Result := Result + ' TIMETICKS: ';
+          ASN1_OCTSTR:
+            Result := Result + ' OCTSTR: ';
+          ASN1_OPAQUE:
+            Result := Result + ' OPAQUE: ';
+          ASN1_OBJID:
+            Result := Result + ' OBJID: ';
+          ASN1_IPADDR:
+            Result := Result + ' IPADDR: ';
+          ASN1_NULL:
+            Result := Result + ' NULL: ';
+          ASN1_COUNTER64:
+            Result := Result + ' COUNTER64: ';
+        else // other
+          Result := Result + ' unknown: ';
+        end;
+        if IsBinaryString(s) then
+          s := DumpExStr(s);
+        Result := Result + s;
+      end;
+      Result := Result + #$0d + #$0a;
+    end;
+  finally
+    il.Free;
+  end;
+end;
+
+{==============================================================================}
+
+end.

blcksock.pas

@@ -0,0 +1,4603 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 009.010.000 |
+|==============================================================================|
+| Content: Library base                                                        |
+|==============================================================================|
+| Copyright (c)1999-2017, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)1999-2017.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{
+Special thanks to Gregor Ibic <[email protected]>
+ (Intelicom d.o.o., http://www.intelicom.si)
+ for good inspiration about SSL programming.
+}
+
+{$DEFINE ONCEWINSOCK}
+{Note about define ONCEWINSOCK:
+If you remove this compiler directive, then socket interface is loaded and
+initialized on constructor of TBlockSocket class for each socket separately.
+Socket interface is used only if your need it.
+
+If you leave this directive here, then socket interface is loaded and
+initialized only once at start of your program! It boost performace on high
+count of created and destroyed sockets. It eliminate possible small resource
+leak on Windows systems too.
+}
+
+{$DEFINE RAISEEXCEPT}
+{When you enable this define, then is Raiseexcept property is on by default
+}
+
+{:@abstract(Synapse's library core)
+
+Core with implementation basic socket classes.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+{$ENDIF}
+{$Q-}
+{$H+}
+{$M+}
+{$TYPEDADDRESS OFF}
+
+
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit blcksock;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synafpc, synabyte,
+  synsock, synautil, synacode, synaip
+{$IFDEF NEXTGEN}
+  , System.Generics.Collections,
+  System.Generics.Defaults
+{$ENDIF}
+{$IFDEF CIL}
+  ,System.Net
+  ,System.Net.Sockets
+  ,System.Text
+{$ENDIF}
+  ;
+
+const
+
+  SynapseRelease = '40';
+
+  cLocalhost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  cBroadcast = '255.255.255.255';
+  c6Localhost = '::1';
+  c6AnyHost = '::0';
+  c6Broadcast = 'ffff::1';
+  cAnyPort = '0';
+  CR = #$0d;
+  LF = #$0a;
+  CRLF = CR + LF;
+  c64k = 65536;
+
+type
+
+  {:@abstract(Exception clas used by Synapse)
+   When you enable generating of exceptions, this exception is raised by
+   Synapse's units.}
+  ESocketBindError = class(Exception);
+
+  { ESynapseError }
+
+  ESynapseError = class(Exception)
+  private
+    FErrorCode: Integer;
+    FErrorMessage: string;
+  public
+    constructor CreateErrorCode(AErrorCode:Integer; const AErrorDesc: string);
+  published
+    {:Code of error. Value depending on used operating system}
+    property ErrorCode: Integer read FErrorCode Write FErrorCode;
+    {:Human readable description of error.}
+    property ErrorMessage: string read FErrorMessage Write FErrorMessage;
+  end;
+
+  ESynProtocolError = class(ESynapseError);
+  EResetByPeer = class (ESynapseError);
+  ECouldNotBindSocket = class (ESynapseError);
+  EConnectionResetByPeer = class (ESynapseError);
+  ESockectIsnotConnected = class (ESynapseError);
+  EConnectionTimedOut = class (ESynapseError);
+  EConnectionRefused = class (ESynapseError);
+  ECantAssignAddress = class (ESynapseError);
+  ESocketMinus2 = class (ESynapseError);
+
+  {:Types of OnStatus events}
+  THookSocketReason = (
+    {:Resolving is begin. Resolved IP and port is in parameter in format like:
+     'localhost.somewhere.com:25'.}
+    HR_ResolvingBegin,
+    {:Resolving is done. Resolved IP and port is in parameter in format like:
+     'localhost.somewhere.com:25'. It is always same as in HR_ResolvingBegin!}
+    HR_ResolvingEnd,
+    {:Socket created by CreateSocket method. It reporting Family of created
+     socket too!}
+    HR_SocketCreate,
+    {:Socket closed by CloseSocket method.}
+    HR_SocketClose,
+    {:Socket binded to IP and Port. Binded IP and Port is in parameter in format
+     like: 'localhost.somewhere.com:25'.}
+    HR_Bind,
+    {:Socket connected to IP and Port. Connected IP and Port is in parameter in
+     format like: 'localhost.somewhere.com:25'.}
+    HR_Connect,
+    {:Called when CanRead method is used with @True result.}
+    HR_CanRead,
+    {:Called when CanWrite method is used with @True result.}
+    HR_CanWrite,
+    {:Socket is swithed to Listen mode. (TCP socket only)}
+    HR_Listen,
+    {:Socket Accepting client connection. (TCP socket only)}
+    HR_Accept,
+    {:report count of bytes readed from socket. Number is in parameter string.
+     If you need is in integer, you must use StrToInt function!}
+    HR_ReadCount,
+    {:report count of bytes writed to socket. Number is in parameter string. If
+     you need is in integer, you must use StrToInt function!}
+    HR_WriteCount,
+    {:If is limiting of bandwidth on, then this reason is called when sending or
+     receiving is stopped for satisfy bandwidth limit. Parameter is count of
+     waiting milliseconds.}
+    HR_Wait,
+    {:report situation where communication error occured. When raiseexcept is
+     @true, then exception is called after this Hook reason.}
+    HR_Error
+    );
+
+  {:Procedural type for OnStatus event. Sender is calling TBlockSocket object,
+   Reason is one of set Status events and value is optional data.}
+  THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
+    const Value: string) of object;
+
+  {:This procedural type is used for DataFilter hooks.}
+  THookDataFilter = procedure(Sender: TObject; var Value: string) of object;
+
+  {:This procedural type is used for hook OnCreateSocket. By this hook you can
+   insert your code after initialisation of socket. (you can set special socket
+   options, etc.)}
+  THookCreateSocket = procedure(Sender: TObject) of object;
+
+  {:This procedural type is used for monitoring of communication.}
+  THookMonitor = procedure(Sender: TObject; Writing: Boolean;
+    const Buffer: TMemory; Len: Integer) of object;
+
+  {:This procedural type is used for hook OnAfterConnect. By this hook you can
+   insert your code after TCP socket has been sucessfully connected.}
+  THookAfterConnect = procedure(Sender: TObject) of object;
+
+  {:This procedural type is used for hook OnVerifyCert. By this hook you can
+   insert your additional certificate verification code. Usefull to verify server
+   CN against URL. }
+
+  THookVerifyCert = function(Sender: TObject):boolean of object;
+
+ {:This procedural type is used for hook OnHeartbeat. By this hook you can
+   call your code repeately during long socket operations.
+   You must enable heartbeats by @Link(HeartbeatRate) property!}
+  THookHeartbeat = procedure(Sender: TObject) of object;
+
+  {:Specify family of socket.}
+  TSocketFamily = (
+    {:Default mode. Socket family is defined by target address for connection.
+     It allows instant access to IPv4 and IPv6 nodes. When you need IPv6 address
+     as destination, then is used IPv6 mode. othervise is used IPv4 mode.
+     However this mode not working properly with preliminary IPv6 supports!}
+    SF_Any,
+    {:Turn this class to pure IPv4 mode. This mode is totally compatible with
+     previous Synapse releases.}
+    SF_IP4,
+    {:Turn to only IPv6 mode.}
+    SF_IP6
+    );
+
+  {:specify possible values of SOCKS modes.}
+  TSocksType = (
+    ST_Socks5,
+    ST_Socks4
+    );
+
+  {:Specify requested SSL/TLS version for secure connection.}
+  TSSLType = (
+    LT_all,
+    LT_SSLv2,
+    LT_SSLv3,
+    LT_TLSv1,
+    LT_TLSv1_1,
+    LT_TLSv1_2,
+    LT_SSHv2
+    );
+
+  {:Specify type of socket delayed option.}
+  TSynaOptionType = (
+    SOT_Linger,
+    SOT_RecvBuff,
+    SOT_SendBuff,
+    SOT_NonBlock,
+    SOT_RecvTimeout,
+    SOT_SendTimeout,
+    SOT_Reuse,
+    SOT_TTL,
+    SOT_Broadcast,
+    SOT_MulticastTTL,
+    SOT_MulticastLoop,
+    SOT_NoDelay // TCP_NODELAY
+    );
+
+  {:@abstract(this object is used for remember delayed socket option set.)}
+  TSynaOption = class(TObject)
+  public
+    Option: TSynaOptionType;
+    Enabled: Boolean;
+    Value: Integer;
+  end;
+
+  TCustomSSL = class;
+  TSSLClass = class of TCustomSSL;
+
+  TBlockSocket = class;
+
+{$IFDEF NEXTGEN}
+  TOptionList = TList<TSynaOption>;
+  TSocketList = TList<TBlockSocket>;
+{$ELSE}
+  TOptionList = TList;
+  TSocketList = TList;
+{$ENDIF}
+  {:@abstract(Basic IP object.)
+   This is parent class for other class with protocol implementations. Do not
+   use this class directly! Use @link(TICMPBlockSocket), @link(TRAWBlockSocket),
+   @link(TTCPBlockSocket) or @link(TUDPBlockSocket) instead.}
+  TBlockSocket = class(TObject)
+  private
+    FOnStatus: THookSocketStatus;
+    FOnReadFilter: THookDataFilter;
+    FOnCreateSocket: THookCreateSocket;
+    FOnMonitor: THookMonitor;
+    FOnHeartbeat: THookHeartbeat;
+    FLocalSin: TVarSin;
+    FRemoteSin: TVarSin;
+    FTag: integer;
+    FBuffer: TSynaBytes;
+    FRaiseExcept: Boolean;
+    FNonBlockMode: Boolean;
+    FMaxLineLength: Integer;
+    FMaxSendBandwidth: Integer;
+    FNextSend: LongWord;
+    FMaxRecvBandwidth: Integer;
+    FNextRecv: LongWord;
+    FConvertLineEnd: Boolean;
+    FLastCR: Boolean;
+    FLastLF: Boolean;
+    FBinded: Boolean;
+    FFamily: TSocketFamily;
+    FFamilySave: TSocketFamily;
+    FIP6used: Boolean;
+    FPreferIP4: Boolean;
+    FDelayedOptions: TOptionList;
+    FInterPacketTimeout: Boolean;
+    {$IFNDEF CIL}
+    FFDSet: TFDSet;
+    {$ENDIF}
+    FRecvCounter: Integer;
+    FSendCounter: Integer;
+    FSendMaxChunk: Integer;
+    FStopFlag: Boolean;
+    FNonblockSendTimeout: Integer;
+    FHeartbeatRate: integer;
+    FConnectionTimeout: integer;
+    {$IFNDEF ONCEWINSOCK}
+    FWsaDataOnce: TWSADATA;
+    {$ENDIF}
+    FSocket: TSocket;
+    FLastError: Integer;
+    FLastErrorDesc: string;
+    FOwner: TObject;
+    function GetSizeRecvBuffer: Integer;
+    procedure SetSizeRecvBuffer(Size: Integer);
+    function GetSizeSendBuffer: Integer;
+    procedure SetSizeSendBuffer(Size: Integer);
+    procedure SetNonBlockMode(Value: Boolean);
+    procedure SetTTL(TTL: integer);
+    function GetTTL:integer;
+    procedure SetFamily(Value: TSocketFamily); virtual;
+    procedure SetSocket(Value: TSocket); virtual;
+    function GetWsaData: TWSAData;
+    function FamilyToAF(f: TSocketFamily): TAddrFamily;
+    procedure SetNagleMode(Value: Boolean);
+    procedure SetDelayedOption(const Value: TSynaOption);
+    procedure DelayedOption(const Value: TSynaOption);
+    procedure ProcessDelayedOptions;
+    procedure InternalCreateSocket(Sin: TVarSin);
+    procedure SetSin(var Sin: TVarSin; const IP, Port: string);
+    function GetSinIP(Sin: TVarSin): string;
+    function GetSinPort(Sin: TVarSin): Integer;
+    procedure DoStatus(Reason: THookSocketReason; const Value: string);
+    procedure DoReadFilter(Buffer: TMemory; var Len: Integer);
+    procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
+    procedure DoCreateSocket;
+    procedure DoHeartbeat;
+    procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
+    procedure SetBandwidth(Value: Integer);
+    function TestStopFlag: Boolean;
+    procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual;
+    function InternalCanRead(Timeout: Integer): Boolean; virtual;
+    function InternalCanWrite(Timeout: Integer): Boolean; virtual;
+  protected
+    FDisconnected: Boolean;
+  public
+    constructor Create;
+
+    {:Create object and load all necessary socket library. What library is
+     loaded is described by STUB parameter. If STUB is empty string, then is
+     loaded default libraries.}
+    constructor CreateAlternate(Stub: string);
+    destructor Destroy; override;
+
+    {:If @link(family) is not SF_Any, then create socket with type defined in
+     @link(Family) property. If family is SF_Any, then do nothing! (socket is
+     created automaticly when you know what type of socket you need to create.
+     (i.e. inside @link(Connect) or @link(Bind) call.) When socket is created,
+     then is aplyed all stored delayed socket options.}
+    procedure CreateSocket;
+
+    {:It create socket. Address resolving of Value tells what type of socket is
+     created. If Value is resolved as IPv4 IP, then is created IPv4 socket. If
+     value is resolved as IPv6 address, then is created IPv6 socket.}
+    procedure CreateSocketByName(const Value: string);
+
+    {:Destroy socket in use. This method is also automatically called from
+     object destructor.}
+    procedure CloseSocket; virtual;
+
+    {:Abort any work on Socket and destroy them.}
+    procedure AbortSocket; virtual;
+
+    {:Connects socket to local IP address and PORT. IP address may be numeric or
+     symbolic ('192.168.74.50', 'cosi.nekde.cz', 'ff08::1'). The same for PORT
+     - it may be number or mnemonic port ('23', 'telnet').
+
+     If port value is '0', system chooses itself and conects unused port in the
+     range 1024 to 4096 (this depending by operating system!). Structure
+     LocalSin is filled after calling this method.
+
+     Note: If you call this on non-created socket, then socket is created
+     automaticly.
+
+     Warning: when you call : Bind('0.0.0.0','0'); then is nothing done! In this
+     case is used implicit system bind instead.}
+    procedure Bind(const IP, Port: string);
+
+    {:Connects socket to remote IP address and PORT. The same rules as with
+     @link(BIND) method are valid. The only exception is that PORT with 0 value
+     will not be connected!
+
+     Structures LocalSin and RemoteSin will be filled with valid values.
+
+     When you call this on non-created socket, then socket is created
+     automaticly. Type of created socket is by @link(Family) property. If is
+     used SF_IP4, then is created socket for IPv4. If is used SF_IP6, then is
+     created socket for IPv6. When you have family on SF_Any (default!), then
+     type of created socket is determined by address resolving of destination
+     address. (Not work properly on prilimitary winsock IPv6 support!)}
+    procedure Connect(const IP, Port: string); virtual;
+
+    {:Sets socket to receive mode for new incoming connections. It is necessary
+     to use @link(TBlockSocket.BIND) function call before this method to select
+     receiving port!}
+    procedure Listen; virtual;
+
+    {:Waits until new incoming connection comes. After it comes a new socket is
+     automatically created (socket handler is returned by this function as
+     result).}
+    function Accept: TSocket; virtual;
+
+    {:Sends data of LENGTH from BUFFER address via connected socket. System
+     automatically splits data to packets.}
+    function SendBuffer(const Buffer: Tmemory; Length: Integer): Integer; virtual;
+
+    {:One data BYTE is sent via connected socket.}
+    procedure SendByte(Data: Byte); virtual;
+
+    {:Send data string via connected socket. Any terminator is not added! If you
+     need send true string with CR-LF termination, you must add CR-LF characters
+     to sended string! Because any termination is not added automaticly, you can
+     use this function for sending any binary data in binary string.}
+    procedure SendString(Data: TSynaBytes); virtual;
+
+    {:Send integer as four bytes to socket.}
+    procedure SendInteger(Data: integer); virtual;
+
+    {:Send data as one block to socket. Each block begin with 4 bytes with
+     length of data in block. This 4 bytes is added automaticly by this
+     function.}
+    procedure SendBlock(const Data: string); virtual;
+
+    {:Send data from stream to socket.}
+    procedure SendStreamRaw(const Stream: TStream); virtual;
+
+    {:Send content of stream to socket. It using @link(SendBlock) method}
+    procedure SendStream(const Stream: TStream); virtual;
+
+    {:Send content of stream to socket. It using @link(SendBlock) method and
+    this is compatible with streams in Indy library.}
+    procedure SendStreamIndy(const Stream: TStream); virtual;
+
+    {:Note: This is low-level receive function. You must be sure if data is
+     waiting for read before call this function for avoid deadlock!
+
+     Waits until allocated buffer is filled by received data. Returns number of
+     data received, which equals to LENGTH value under normal operation. If it
+     is not equal the communication channel is possibly broken.
+
+     On stream oriented sockets if is received 0 bytes, it mean 'socket is
+     closed!"
+
+     On datagram socket is readed first waiting datagram.}
+    function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions!
+
+     Method waits until data is received. If no data is received within TIMEOUT
+     (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT. Methods
+     serves for reading any size of data (i.e. one megabyte...). This method is
+     preffered for reading from stream sockets (like TCP).}
+    function RecvBufferEx(Buffer: Tmemory; Len: Integer;
+      Timeout: Integer): Integer; virtual;
+
+    {:Similar to @link(RecvBufferEx), but readed data is stored in binary
+     string, not in memory buffer.}
+    function RecvBufferStr(Len: Integer; Timeout: Integer): TSynaBytes; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions.
+
+     Waits until one data byte is received which is also returned as function
+     result. If no data is received within TIMEOUT (in milliseconds)period,
+     @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
+    function RecvByte(Timeout: Integer): Byte; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions.
+
+     Waits until one four bytes are received and return it as one Ineger Value.
+     If no data is received within TIMEOUT (in milliseconds)period,
+     @link(LastError) is set to WSAETIMEDOUT and result have value 0.}
+    function RecvInteger(Timeout: Integer): Integer; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions.
+
+     Method waits until data string is received. This string is terminated by
+     CR-LF characters. The resulting string is returned without this termination
+     (CR-LF)! If @link(ConvertLineEnd) is used, then CR-LF sequence may not be
+     exactly CR-LF. See @link(ConvertLineEnd) description. If no data is
+     received within TIMEOUT (in milliseconds) period, @link(LastError) is set
+     to WSAETIMEDOUT. You may also specify maximum length of reading data by
+     @link(MaxLineLength) property.}
+    function RecvString(Timeout: Integer): string; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions.
+
+     Method waits until data string is received. This string is terminated by
+     Terminator string. The resulting string is returned without this
+     termination. If no data is received within TIMEOUT (in milliseconds)
+     period, @link(LastError) is set to WSAETIMEDOUT. You may also specify
+     maximum length of reading data by @link(MaxLineLength) property.}
+    function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual;
+
+    {:Note: This is high-level receive function. It using internal
+     @link(LineBuffer) and you can combine this function freely with other
+     high-level functions.
+
+     Method reads all data waiting for read. If no data is received within
+     TIMEOUT (in milliseconds) period, @link(LastError) is set to WSAETIMEDOUT.
+     Methods serves for reading unknown size of data. Because before call this
+     function you don't know size of received data, returned data is stored in
+     dynamic size binary string. This method is preffered for reading from
+     stream sockets (like TCP). It is very goot for receiving datagrams too!
+     (UDP protocol)}
+    function RecvPacket(Timeout: Integer): TSynaBytes; virtual;
+
+    {:Read one block of data from socket. Each block begin with 4 bytes with
+     length of data in block. This function read first 4 bytes for get lenght,
+     then it wait for reported count of bytes.}
+    function RecvBlock(Timeout: Integer): string; virtual;
+
+    {:Read all data from socket to stream until socket is closed (or any error
+     occured.)}
+    procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
+    {:Read requested count of bytes from socket to stream.}
+    procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
+
+    {:Receive data to stream. It using @link(RecvBlock) method.}
+    procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
+
+    {:Receive data to stream. This function is compatible with similar function
+    in Indy library. It using @link(RecvBlock) method.}
+    procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
+
+    {:Same as @link(RecvBuffer), but readed data stays in system input buffer.
+    Warning: this function not respect data in @link(LineBuffer)! Is not
+    recommended to use this function!}
+    function PeekBuffer(Buffer: TMemory; Length: Integer): Integer; virtual;
+
+    {:Same as @link(RecvByte), but readed data stays in input system buffer.
+     Warning: this function not respect data in @link(LineBuffer)! Is not
+    recommended to use this function!}
+    function PeekByte(Timeout: Integer): Byte; virtual;
+
+    {:On stream sockets it returns number of received bytes waiting for picking.
+     0 is returned when there is no such data. On datagram socket it returns
+     length of the first waiting datagram. Returns 0 if no datagram is waiting.}
+    function WaitingData: Integer; virtual;
+
+    {:Same as @link(WaitingData), but if exists some of data in @link(Linebuffer),
+     return their length instead.}
+    function WaitingDataEx: Integer;
+
+    {:Clear all waiting data for read from buffers.}
+    procedure Purge;
+
+    {:Sets linger. Enabled linger means that the system waits another LINGER
+     (in milliseconds) time for delivery of sent data. This function is only for
+     stream type of socket! (TCP)}
+    procedure SetLinger(Enable: Boolean; Linger: Integer);
+
+    {:Actualize values in @link(LocalSin).}
+    procedure GetSinLocal;
+
+    {:Actualize values in @link(RemoteSin).}
+    procedure GetSinRemote;
+
+    {:Actualize values in @link(LocalSin) and @link(RemoteSin).}
+    procedure GetSins;
+
+    {:Reset @link(LastError) and @link(LastErrorDesc) to non-error state.}
+    procedure ResetLastError;
+
+    {:If you "manually" call Socket API functions, forward their return code as
+     parameter to this function, which evaluates it, eventually calls
+     GetLastError and found error code returns and stores to @link(LastError).}
+    function SockCheck(SockResult: Integer): Integer; virtual;
+
+    {:If @link(LastError) contains some error code and @link(RaiseExcept)
+     property is @true, raise adequate exception.}
+    procedure ExceptCheck;
+
+    {:Returns local computer name as numerical or symbolic value. It try get
+     fully qualified domain name. Name is returned in the format acceptable by
+     functions demanding IP as input parameter.}
+    function LocalName: string;
+
+    {:Try resolve name to all possible IP address. i.e. If you pass as name
+     result of @link(LocalName) method, you get all IP addresses used by local
+     system.}
+    procedure ResolveNameToIP(const Name: string; const IPList: TStrings);
+
+    {:Try resolve name to primary IP address. i.e. If you pass as name result of
+     @link(LocalName) method, you get primary IP addresses used by local system.}
+    function ResolveName(const Name: string): string;
+
+    {:Try resolve IP to their primary domain name. If IP not have domain name,
+     then is returned original IP.}
+    function ResolveIPToName(IP: string): string;
+
+    {:Try resolve symbolic port name to port number. (i.e. 'Echo' to 8)}
+    function ResolvePort(const Port: string): Word;
+
+    {:Set information about remote side socket. It is good for seting remote
+     side for sending UDP packet, etc.}
+    procedure SetRemoteSin(const IP, Port: string);
+
+    {:Picks IP socket address from @link(LocalSin).}
+    function GetLocalSinIP: string; virtual;
+
+    {:Picks IP socket address from @link(RemoteSin).}
+    function GetRemoteSinIP: string; virtual;
+
+    {:Picks socket PORT number from @link(LocalSin).}
+    function GetLocalSinPort: Integer; virtual;
+
+    {:Picks socket PORT number from @link(RemoteSin).}
+    function GetRemoteSinPort: Integer; virtual;
+
+    {:Return @TRUE, if you can read any data from socket or is incoming
+     connection on TCP based socket. Status is tested for time Timeout (in
+     milliseconds). If value in Timeout is 0, status is only tested and
+     continue. If value in Timeout is -1, run is breaked and waiting for read
+     data maybe forever.
+
+     This function is need only on special cases, when you need use
+     @link(RecvBuffer) function directly! read functioms what have timeout as
+     calling parameter, calling this function internally.}
+    function CanRead(Timeout: Integer): Boolean; virtual;
+
+    {:Same as @link(CanRead), but additionally return @TRUE if is some data in
+     @link(LineBuffer).}
+    function CanReadEx(Timeout: Integer): Boolean; virtual;
+
+    {:Return @TRUE, if you can to socket write any data (not full sending
+     buffer). Status is tested for time Timeout (in milliseconds). If value in
+     Timeout is 0, status is only tested and continue. If value in Timeout is
+     -1, run is breaked and waiting for write data maybe forever.
+
+     This function is need only on special cases!}
+    function CanWrite(Timeout: Integer): Boolean; virtual;
+
+    {:Same as @link(SendBuffer), but send datagram to address from
+     @link(RemoteSin). Usefull for sending reply to datagram received by
+     function @link(RecvBufferFrom).}
+    function SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; virtual;
+
+    {:Note: This is low-lever receive function. You must be sure if data is
+     waiting for read before call this function for avoid deadlock!
+
+     Receives first waiting datagram to allocated buffer. If there is no waiting
+     one, then waits until one comes. Returns length of datagram stored in
+     BUFFER. If length exceeds buffer datagram is truncated. After this
+     @link(RemoteSin) structure contains information about sender of UDP packet.}
+    function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; virtual;
+{$IFNDEF CIL}
+    {:This function is for check for incoming data on set of sockets. Whitch
+    sockets is checked is decribed by SocketList Tlist with TBlockSocket
+    objects. TList may have maximal number of objects defined by FD_SETSIZE
+    constant. Return @TRUE, if you can from some socket read any data or is
+    incoming connection on TCP based socket. Status is tested for time Timeout
+    (in milliseconds). If value in Timeout is 0, status is only tested and
+    continue. If value in Timeout is -1, run is breaked and waiting for read
+    data maybe forever. If is returned @TRUE, CanReadList TList is filled by all
+    TBlockSocket objects what waiting for read.}
+    function GroupCanRead(const SocketList: TSocketList; Timeout: Integer;
+      const CanReadList: TSocketList): Boolean;
+{$ENDIF}
+    {:By this method you may turn address reuse mode for local @link(bind). It
+     is good specially for UDP protocol. Using this with TCP protocol is
+     hazardous!}
+    procedure EnableReuse(Value: Boolean);
+
+    {:Try set timeout for all sending and receiving operations, if socket
+     provider can do it. (It not supported by all socket providers!)}
+    procedure SetTimeout(Timeout: Integer);
+
+    {:Try set timeout for all sending operations, if socket provider can do it.
+     (It not supported by all socket providers!)}
+    procedure SetSendTimeout(Timeout: Integer);
+
+    {:Try set timeout for all receiving operations, if socket provider can do
+     it. (It not supported by all socket providers!)}
+    procedure SetRecvTimeout(Timeout: Integer);
+
+    function GetSendTimeout: Integer;
+
+    function GetRecvTimeout: integer;
+
+    {:Return value of socket type.}
+    function GetSocketType: integer; Virtual;
+
+    {:Return value of protocol type for socket creation.}
+    function GetSocketProtocol: integer; Virtual;
+
+    {:WSA structure with information about socket provider. On non-windows
+     platforms this structure is simulated!}
+    property WSAData: TWSADATA read GetWsaData;
+
+    {:FDset structure prepared for usage with this socket.}
+    property FDset: TFDSet read FFDset;
+
+    {:Structure describing local socket side.}
+    property LocalSin: TVarSin read FLocalSin write FLocalSin;
+
+    {:Structure describing remote socket side.}
+    property RemoteSin: TVarSin read FRemoteSin write FRemoteSin;
+
+    {:Socket handler. Suitable for "manual" calls to socket API or manual
+     connection of socket to a previously created socket (i.e by Accept method
+     on TCP socket)}
+    property Socket: TSocket read FSocket write SetSocket;
+
+    {:Last socket operation error code. Error codes are described in socket
+     documentation. Human readable error description is stored in
+     @link(LastErrorDesc) property.}
+    property LastError: Integer read FLastError;
+
+    {:Human readable error description of @link(LastError) code.}
+    property LastErrorDesc: string read FLastErrorDesc;
+
+    {:Buffer used by all high-level receiving functions. This buffer is used for
+     optimized reading of data from socket. In normal cases you not need access
+     to this buffer directly!}
+    property LineBuffer: TSynaBytes read FBuffer write FBuffer;
+
+    {:Size of Winsock receive buffer. If it is not supported by socket provider,
+     it return as size one kilobyte.}
+    property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
+
+    {:Size of Winsock send buffer. If it is not supported by socket provider, it
+     return as size one kilobyte.}
+    property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
+
+    {:If @True, turn class to non-blocking mode. Not all functions are working
+     properly in this mode, you must know exactly what you are doing! However
+     when you have big experience with non-blocking programming, then you can
+     optimise your program by non-block mode!}
+    property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
+
+    {:Set Time-to-live value. (if system supporting it!)}
+    property TTL: Integer read GetTTL Write SetTTL;
+
+    {:If is @true, then class in in IPv6 mode.}
+    property IP6used: Boolean read FIP6used;
+
+    {:Return count of received bytes on this socket from begin of current
+     connection.}
+    property RecvCounter: Integer read FRecvCounter;
+
+    {:Return count of sended bytes on this socket from begin of current
+     connection.}
+    property SendCounter: Integer read FSendCounter;
+  published
+    {:Return descriptive string for given error code. This is class function.
+     You may call it without created object!}
+    class function GetErrorDesc(ErrorCode: Integer): string;
+
+    {:Return descriptive string for @link(LastError).}
+    function GetErrorDescEx: string; virtual;
+
+    {:this value is for free use.}
+    property Tag: Integer read FTag write FTag;
+
+    {:If @true, winsock errors raises exception. Otherwise is setted
+    @link(LastError) value only and you must check it from your program! Default
+    value is @false.}
+    property RaiseExcept: Boolean read FRaiseExcept write FRaiseExcept;
+
+    {:Define maximum length in bytes of @link(LineBuffer) for high-level
+     receiving functions. If this functions try to read more data then this
+     limit, error is returned! If value is 0 (default), no limitation is used.
+     This is very good protection for stupid attacks to your server by sending
+     lot of data without proper terminator... until all your memory is allocated
+     by LineBuffer!
+
+     Note: This maximum length is checked only in functions, what read unknown
+     number of bytes! (like @link(RecvString) or @link(RecvTerminated))}
+    property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
+
+    {:Define maximal bandwidth for all sending operations in bytes per second.
+     If value is 0 (default), bandwidth limitation is not used.}
+    property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
+
+    {:Define maximal bandwidth for all receiving operations in bytes per second.
+     If value is 0 (default), bandwidth limitation is not used.}
+    property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
+
+    {:Define maximal bandwidth for all sending and receiving operations in bytes
+     per second. If value is 0 (default), bandwidth limitation is not used.}
+    property MaxBandwidth: Integer Write SetBandwidth;
+
+    {:Do a conversion of non-standard line terminators to CRLF. (Off by default)
+     If @True, then terminators like sigle CR, single LF or LFCR are converted
+     to CRLF internally. This have effect only in @link(RecvString) method!}
+    property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
+
+    {:Specified Family of this socket. When you are using Windows preliminary
+     support for IPv6, then I recommend to set this property!}
+    property Family: TSocketFamily read FFamily Write SetFamily;
+
+    {:When resolving of domain name return both IPv4 and IPv6 addresses, then
+     specify if is used IPv4 (dafault - @true) or IPv6.}
+    property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4;
+
+    {:By default (@true) is all timeouts used as timeout between two packets in
+     reading operations. If you set this to @false, then Timeouts is for overall
+     reading operation!}
+    property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
+
+    {:All sended datas was splitted by this value.}
+    property SendMaxChunk: Integer read FSendMaxChunk Write FSendMaxChunk;
+
+    {:By setting this property to @true you can stop any communication. You can
+     use this property for soft abort of communication.}
+    property StopFlag: Boolean read FStopFlag Write FStopFlag;
+
+    {:Timeout for data sending by non-blocking socket mode.}
+    property NonblockSendTimeout: Integer read FNonblockSendTimeout Write FNonblockSendTimeout;
+
+    property NagleMode: Boolean write SetNagleMode; // True (Default) - TCP_NODELAY OFF
+                                                    // False - TCP_NODELAY ON
+
+    {:Timeout for @link(Connect) call. Default value 0 means default system timeout.
+     Non-zero value means timeout in millisecond.}
+    property ConnectionTimeout: Integer read FConnectionTimeout write FConnectionTimeout;
+
+    {:This event is called by various reasons. It is good for monitoring socket,
+     create gauges for data transfers, etc.}
+    property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
+
+    {:this event is good for some internal thinks about filtering readed datas.
+     It is used by telnet client by example.}
+    property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
+
+    {:This event is called after real socket creation for setting special socket
+     options, because you not know when socket is created. (it is depended on
+     Ipv4, IPv6 or automatic mode)}
+    property OnCreateSocket: THookCreateSocket read FOnCreateSocket write FOnCreateSocket;
+
+    {:This event is good for monitoring content of readed or writed datas.}
+    property OnMonitor: THookMonitor read FOnMonitor write FOnMonitor;
+
+    {:This event is good for calling your code during long socket operations.
+      (Example, for refresing UI if class in not called within the thread.)
+      Rate of heartbeats can be modified by @link(HeartbeatRate) property.}
+    property OnHeartbeat: THookHeartbeat read FOnHeartbeat write FOnHeartbeat;
+
+    {:Specify typical rate of @link(OnHeartbeat) event and @link(StopFlag) testing.
+      Default value 0 disabling heartbeats! Value is in milliseconds.
+      Real rate can be higher or smaller then this value, because it depending
+      on real socket operations too!
+      Note: Each heartbeat slowing socket processing.}
+    property HeartbeatRate: integer read FHeartbeatRate Write FHeartbeatRate;
+    {:What class own this socket? Used by protocol implementation classes.}
+    property Owner: TObject read FOwner Write FOwner;
+  end;
+
+  {:@abstract(Support for SOCKS4 and SOCKS5 proxy)
+   Layer with definition all necessary properties and functions for
+   implementation SOCKS proxy client. Do not use this class directly.}
+  TSocksBlockSocket = class(TBlockSocket)
+  private
+    FSocksIP: string;
+    FSocksPort: string;
+    FSocksTimeout: integer;
+    FSocksUsername: string;
+    FSocksPassword: string;
+    FUsingSocks: Boolean;
+    FSocksResolver: Boolean;
+    FSocksLastError: integer;
+    FSocksResponseIP: string;
+    FSocksResponsePort: string;
+    FSocksLocalIP: string;
+    FSocksLocalPort: string;
+    FSocksRemoteIP: string;
+    FSocksRemotePort: string;
+    FBypassFlag: Boolean;
+    FSocksType: TSocksType;
+    function SocksCode(IP: string; const Port: string): string;
+    function SocksDecode(const Value: string): integer;
+  public
+    constructor Create;
+
+    {:Open connection to SOCKS proxy and if @link(SocksUsername) is set, do
+     authorisation to proxy. This is needed only in special cases! (it is called
+     internally!)}
+    function SocksOpen: Boolean;
+
+    {:Send specified request to SOCKS proxy. This is needed only in special
+     cases! (it is called internally!)}
+    function SocksRequest(Cmd: Byte; const IP, Port: string): Boolean;
+
+    {:Receive response to previosly sended request. This is needed only in
+     special cases! (it is called internally!)}
+    function SocksResponse: Boolean;
+
+    {:Is @True when class is using SOCKS proxy.}
+    property UsingSocks: Boolean read FUsingSocks;
+
+    {:If SOCKS proxy failed, here is error code returned from SOCKS proxy.}
+    property SocksLastError: integer read FSocksLastError;
+  published
+    {:Address of SOCKS server. If value is empty string, SOCKS support is
+     disabled. Assingning any value to this property enable SOCKS mode.
+     Warning: You cannot combine this mode with HTTP-tunneling mode!}
+    property SocksIP: string read FSocksIP write FSocksIP;
+
+    {:Port of SOCKS server. Default value is '1080'.}
+    property SocksPort: string read FSocksPort write FSocksPort;
+
+    {:If you need authorisation on SOCKS server, set username here.}
+    property SocksUsername: string read FSocksUsername write FSocksUsername;
+
+    {:If you need authorisation on SOCKS server, set password here.}
+    property SocksPassword: string read FSocksPassword write FSocksPassword;
+
+    {:Specify timeout for communicatin with SOCKS server. Default is one minute.}
+    property SocksTimeout: integer read FSocksTimeout write FSocksTimeout;
+
+    {:If @True, all symbolic names of target hosts is not translated to IP's
+     locally, but resolving is by SOCKS proxy. Default is @True.}
+    property SocksResolver: Boolean read FSocksResolver write FSocksResolver;
+
+    {:Specify SOCKS type. By default is used SOCKS5, but you can use SOCKS4 too.
+     When you select SOCKS4, then if @link(SOCKSResolver) is enabled, then is
+     used SOCKS4a. Othervise is used pure SOCKS4.}
+    property SocksType: TSocksType read FSocksType write FSocksType;
+  end;
+
+  {:@abstract(Implementation of TCP socket.)
+   Supported features: IPv4, IPv6, SSL/TLS or SSH (depending on used plugin),
+   SOCKS5 proxy (outgoing connections and limited incomming), SOCKS4/4a proxy
+   (outgoing connections and limited incomming), TCP through HTTP proxy tunnel.}
+  TTCPBlockSocket = class(TSocksBlockSocket)
+  private
+    FOnAfterConnect: THookAfterConnect;
+    FSSL: TCustomSSL;
+    FHTTPTunnelIP: string;
+    FHTTPTunnelPort: string;
+    FHTTPTunnel: Boolean;
+    FHTTPTunnelRemoteIP: string;
+    FHTTPTunnelRemotePort: string;
+    FHTTPTunnelUser: string;
+    FHTTPTunnelPass: string;
+    FHTTPTunnelTimeout: integer;
+    procedure SocksDoConnect(const IP, Port: string);
+    procedure HTTPTunnelDoConnect(IP, Port: string);
+    procedure DoAfterConnect;
+  public
+    {:Create TCP socket class with default plugin for SSL/TSL/SSH implementation
+    (see @link(SSLImplementation))}
+    constructor Create;
+
+    {:Create TCP socket class with desired plugin for SSL/TSL/SSH implementation}
+    constructor CreateWithSSL(SSLPlugin: TSSLClass);
+    destructor Destroy; override;
+
+    {:See @link(TBlockSocket.CloseSocket)}
+    procedure CloseSocket; override;
+
+    {:See @link(TBlockSocket.WaitingData)}
+    function WaitingData: Integer; override;
+
+    {:Sets socket to receive mode for new incoming connections. It is necessary
+     to use @link(TBlockSocket.BIND) function call before this method to select
+     receiving port!
+
+     If you use SOCKS, activate incoming TCP connection by this proxy. (By BIND
+     method of SOCKS.)}
+    procedure Listen; override;
+
+    {:Waits until new incoming connection comes. After it comes a new socket is
+     automatically created (socket handler is returned by this function as
+     result).
+
+     If you use SOCKS, new socket is not created! In this case is used same
+     socket as socket for listening! So, you can accept only one connection in
+     SOCKS mode.}
+    function Accept: TSocket; override;
+
+    {:Connects socket to remote IP address and PORT. The same rules as with
+     @link(TBlockSocket.BIND) method are valid. The only exception is that PORT
+     with 0 value will not be connected. After call to this method
+     a communication channel between local and remote socket is created. Local
+     socket is assigned automatically if not controlled by previous call to
+     @link(TBlockSocket.BIND) method. Structures @link(TBlockSocket.LocalSin)
+     and @link(TBlockSocket.RemoteSin) will be filled with valid values.
+
+     If you use SOCKS, activate outgoing TCP connection by SOCKS proxy specified
+     in @link(TSocksBlockSocket.SocksIP). (By CONNECT method of SOCKS.)
+
+     If you use HTTP-tunnel mode, activate outgoing TCP connection by HTTP
+     tunnel specified in @link(HTTPTunnelIP). (By CONNECT method of HTTP
+     protocol.)
+
+     Note: If you call this on non-created socket, then socket is created
+     automaticly.}
+    procedure Connect(const IP, Port: string); override;
+
+    {:If you need upgrade existing TCP connection to SSL/TLS (or SSH2, if plugin
+     allows it) mode, then call this method. This method switch this class to
+     SSL mode and do SSL/TSL handshake.}
+    procedure SSLDoConnect;
+
+    {:By this method you can downgrade existing SSL/TLS connection to normal TCP
+     connection.}
+    procedure SSLDoShutdown;
+
+    {:If you need use this component as SSL/TLS TCP server, then after accepting
+     of inbound connection you need start SSL/TLS session by this method. Before
+     call this function, you must have assigned all neeeded certificates and
+     keys!}
+    function SSLAcceptConnection: Boolean;
+
+    {:See @link(TBlockSocket.GetLocalSinIP)}
+    function GetLocalSinIP: string; override;
+
+    {:See @link(TBlockSocket.GetRemoteSinIP)}
+    function GetRemoteSinIP: string; override;
+
+    {:See @link(TBlockSocket.GetLocalSinPort)}
+    function GetLocalSinPort: Integer; override;
+
+    {:See @link(TBlockSocket.GetRemoteSinPort)}
+    function GetRemoteSinPort: Integer; override;
+
+    {:See @link(TBlockSocket.SendBuffer)}
+    function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override;
+
+    {:See @link(TBlockSocket.RecvBuffer)}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+
+    {:Return value of socket type. For TCP return SOCK_STREAM.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For TCP return
+     IPPROTO_TCP.}
+    function GetSocketProtocol: integer; override;
+
+    function Connected: boolean;
+
+    {:Class implementing SSL/TLS support. It is allways some descendant
+     of @link(TCustomSSL) class. When programmer not select some SSL plugin
+     class, then is used @link(TSSLNone)}
+    property SSL: TCustomSSL read FSSL;
+
+    {:@True if is used HTTP tunnel mode.}
+    property HTTPTunnel: Boolean read FHTTPTunnel;
+
+    property Disconnected: Boolean read FDisconnected write FDisconnected;
+
+  published
+    {:Return descriptive string for @link(LastError). On case of error
+     in SSL/TLS subsystem, it returns right error description.}
+    function GetErrorDescEx: string; override;
+
+    {:Specify IP address of HTTP proxy. Assingning non-empty value to this
+     property enable HTTP-tunnel mode. This mode is for tunnelling any outgoing
+     TCP connection through HTTP proxy server. (If policy on HTTP proxy server
+     allow this!) Warning: You cannot combine this mode with SOCK5 mode!}
+    property HTTPTunnelIP: string read FHTTPTunnelIP Write FHTTPTunnelIP;
+
+    {:Specify port of HTTP proxy for HTTP-tunneling.}
+    property HTTPTunnelPort: string read FHTTPTunnelPort Write FHTTPTunnelPort;
+
+    {:Specify authorisation username for access to HTTP proxy in HTTP-tunnel
+     mode. If you not need authorisation, then let this property empty.}
+    property HTTPTunnelUser: string read FHTTPTunnelUser Write FHTTPTunnelUser;
+
+    {:Specify authorisation password for access to HTTP proxy in HTTP-tunnel
+     mode.}
+    property HTTPTunnelPass: string read FHTTPTunnelPass Write FHTTPTunnelPass;
+
+    {:Specify timeout for communication with HTTP proxy in HTTPtunnel mode.}
+    property HTTPTunnelTimeout: integer read FHTTPTunnelTimeout Write FHTTPTunnelTimeout;
+
+    {:This event is called after sucessful TCP socket connection.}
+    property OnAfterConnect: THookAfterConnect read FOnAfterConnect write FOnAfterConnect;
+  end;
+
+  {:@abstract(Datagram based communication)
+   This class implementing datagram based communication instead default stream
+   based communication style.}
+  TDgramBlockSocket = class(TSocksBlockSocket)
+  protected
+    FUseConnect: Boolean;
+  public
+    {:Fill @link(TBlockSocket.RemoteSin) structure. This address is used for
+     sending data.}
+    procedure Connect(const IP, Port: string); override;
+
+    {:Silently redirected to @link(TBlockSocket.SendBufferTo).}
+    function SendBuffer(const Buffer: TMemory; Length: Integer): Integer; override;
+
+    {:Silently redirected to @link(TBlockSocket.RecvBufferFrom).}
+    function RecvBuffer(Buffer: TMemory; Length: Integer): Integer; override;
+    
+    {:Specify if connect should called on the underlying socket.}
+    property UseConnect: Boolean read FUseConnect Write FUseConnect;
+  end;
+
+  {:@abstract(Implementation of UDP socket.)
+   NOTE: in this class is all receiving redirected to RecvBufferFrom. You can
+   use for reading any receive function. Preffered is RecvPacket! Similary all
+   sending is redirected to SendbufferTo. You can use for sending UDP packet any
+   sending function, like SendString.
+
+   Supported features: IPv4, IPv6, unicasts, broadcasts, multicasts, SOCKS5
+   proxy (only unicasts! Outgoing and incomming.)}
+  TUDPBlockSocket = class(TDgramBlockSocket)
+  protected
+    FSocksControlSock: TTCPBlockSocket;
+    function UdpAssociation: Boolean;
+    procedure SetMulticastTTL(TTL: integer);
+    function GetMulticastTTL:integer;
+  public
+    destructor Destroy; override;
+
+    {:Enable or disable sending of broadcasts. If seting OK, result is @true.
+     This method is not supported in SOCKS5 mode! IPv6 does not support
+     broadcasts! In this case you must use Multicasts instead.}
+    procedure EnableBroadcast(Value: Boolean);
+
+    {:See @link(TBlockSocket.SendBufferTo)}
+    function SendBufferTo(const Buffer: TMemory; Length: Integer): Integer; override;
+
+    {:See @link(TBlockSocket.RecvBufferFrom)}
+    function RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer; override;
+{$IFNDEF CIL}
+    {:Add this socket to given multicast group. You cannot use Multicasts in
+     SOCKS mode!}
+    procedure AddMulticast(const MCastIP:string);
+
+    {:Remove this socket from given multicast group.}
+    procedure DropMulticast(const MCastIP:string);
+{$ENDIF}
+    {:All sended multicast datagrams is loopbacked to your interface too. (you
+     can read your sended datas.) You can disable this feature by this function.
+     This function not working on some Windows systems!}
+    procedure EnableMulticastLoop(Value: Boolean);
+
+    {:Return value of socket type. For UDP return SOCK_DGRAM.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For UDP return
+     IPPROTO_UDP.}
+    function GetSocketProtocol: integer; override;
+
+    {:Set Time-to-live value for multicasts packets. It define number of routers
+     for transfer of datas. If you set this to 1 (dafault system value), then
+     multicasts packet goes only to you local network. If you need transport
+     multicast packet to worldwide, then increase this value, but be carefull,
+     lot of routers on internet does not transport multicasts packets!}
+    property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
+  end;
+
+  {:@abstract(Implementation of RAW ICMP socket.)
+   For this object you must have rights for creating RAW sockets!}
+  TICMPBlockSocket = class(TDgramBlockSocket)
+  public
+    {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For ICMP returns
+     IPPROTO_ICMP or IPPROTO_ICMPV6}
+    function GetSocketProtocol: integer; override;
+  end;
+
+  {:@abstract(Implementation of RAW socket.)
+   For this object you must have rights for creating RAW sockets!}
+  TRAWBlockSocket = class(TBlockSocket)
+  public
+    {:Return value of socket type. For RAW and ICMP return SOCK_RAW.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For RAW returns
+     IPPROTO_RAW.}
+    function GetSocketProtocol: integer; override;
+  end;
+
+  {:@abstract(Implementation of PGM-message socket.)
+   Not all systems supports this protocol!}
+  TPGMMessageBlockSocket = class(TBlockSocket)
+  public
+    {:Return value of socket type. For PGM-message return SOCK_RDM.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For PGM-message returns
+     IPPROTO_RM.}
+    function GetSocketProtocol: integer; override;
+  end;
+
+  {:@abstract(Implementation of PGM-stream socket.)
+   Not all systems supports this protocol!}
+  TPGMStreamBlockSocket = class(TBlockSocket)
+  public
+    {:Return value of socket type. For PGM-stream return SOCK_STREAM.}
+    function GetSocketType: integer; override;
+
+    {:Return value of protocol type for socket creation. For PGM-stream returns
+     IPPROTO_RM.}
+    function GetSocketProtocol: integer; override;
+  end;
+
+  {:@abstract(Parent class for all SSL plugins.)
+   This is abstract class defining interface for other SSL plugins.
+
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+
+   Warning: not all methods and propertis can work in all existing SSL plugins!
+   Please, read documentation of used SSL plugin.}
+  TCustomSSL = class(TObject)
+  private
+    FOnVerifyCert: THookVerifyCert;
+    FCertCA: string;
+    FTrustCertificate: string;
+    FTrustCertificateFile: string;
+    FUsername: string;
+    FPassword: string;
+    FSSHChannelType: string;
+    FSSHChannelArg1: string;
+    FSSHChannelArg2: string;
+    FCertComplianceLevel: integer;
+    FSNIHost: string;
+    procedure ReturnError;
+    procedure SetCertCAFile(const Value: string); virtual;
+  protected
+    FCiphers: string;
+    FPrivateKey: string;
+    FSSLEnabled: Boolean;
+    FSocket: TTCPBlockSocket;
+    FKeyPassword: string;
+    FSSLType: TSSLType;
+    FVerifyCert: Boolean;
+    FCertificateFile: string;
+    FCertCAFile: string;
+    FPFXfile: string;
+    FPFX: string;
+    FPrivateKeyFile: string;
+    FLastErrorDesc: string;
+    FLastError: integer;
+    FCertificate: string;
+    function DoVerifyCert:boolean;
+    function CreateSelfSignedCert(Host: string): Boolean; virtual;
+  public
+    {: Create plugin class. it is called internally from @link(TTCPBlockSocket)}
+    constructor Create(const Value: TTCPBlockSocket); virtual;
+
+    {: Assign settings (certificates and configuration) from another SSL plugin
+     class.}
+    procedure Assign(const Value: TCustomSSL); virtual;
+
+    {: return description of used plugin. It usually return name and version
+     of used SSL library.}
+    function LibVersion: string; virtual;
+
+    {: return name of used plugin.}
+    function LibName: string; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for start SSL connection.}
+    function Connect: boolean; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for acept new SSL connection.}
+    function Accept: boolean; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for hard shutdown of SSL connection. (for example,
+     before socket is closed)}
+    function Shutdown: boolean; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for soft shutdown of SSL connection. (for example,
+     when you need to continue with unprotected connection.)}
+    function BiShutdown: boolean; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for sending some datas by SSL connection.}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for receiving some datas by SSL connection.}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; virtual;
+
+    {: Do not call this directly. It is used internally by @link(TTCPBlockSocket)!
+
+     Here is needed code for getting count of datas what waiting for read.
+     If SSL plugin not allows this, then it should return 0.}
+    function WaitingData: Integer; virtual;
+
+    {:Return string with identificator of SSL/TLS version of existing
+     connection.}
+    function GetSSLVersion: string; virtual;
+
+    {:Return subject of remote SSL peer.}
+    function GetPeerSubject: string; virtual;
+
+    {:Return Serial number if remote X509 certificate.}
+    function GetPeerSerialNo: integer; virtual;
+
+    {:Return issuer certificate of remote SSL peer.}
+    function GetPeerIssuer: string; virtual;
+
+    {:Return peer name from remote side certificate. This is good for verify,
+     if certificate is generated for remote side IP name.}
+    function GetPeerName: string; virtual;
+
+    {:Returns has of peer name from remote side certificate. This is good
+     for fast remote side authentication.}
+    function GetPeerNameHash: cardinal; virtual;
+
+    {:Return fingerprint of remote SSL peer.}
+    function GetPeerFingerprint: string; virtual;
+
+    function GetPeerFingerprintDigest(const ADigest: string): string; virtual; abstract;
+
+    {:Return all detailed information about certificate from remote side of
+     SSL/TLS connection. Result string can be multilined! Each plugin can return
+     this informations in different format!}
+    function GetCertInfo: string; virtual;
+
+    {:Return currently used Cipher.}
+    function GetCipherName: string; virtual;
+
+    {:Return currently used number of bits in current Cipher algorythm.}
+    function GetCipherBits: integer; virtual;
+
+    {:Return number of bits in current Cipher algorythm.}
+    function GetCipherAlgBits: integer; virtual;
+
+    {:Return result value of verify remote side certificate. Look to OpenSSL
+     documentation for possible values. For example 0 is successfuly verified
+     certificate, or 18 is self-signed certificate.}
+    function GetVerifyCert: integer; virtual;
+
+    {: Resurn @true if SSL mode is enabled on existing cvonnection.}
+    property SSLEnabled: Boolean read FSSLEnabled;
+
+    {:Return error code of last SSL operation. 0 is OK.}
+    property LastError: integer read FLastError;
+
+    {:Return error description of last SSL operation.}
+    property LastErrorDesc: string read FLastErrorDesc;
+  published
+    {:Here you can specify requested SSL/TLS mode. Default is autodetection, but
+     on some servers autodetection not working properly. In this case you must
+     specify requested SSL/TLS mode by your hand!}
+    property SSLType: TSSLType read FSSLType write FSSLType;
+
+    {:Password for decrypting of encoded certificate or key.}
+    property KeyPassword: string read FKeyPassword write FKeyPassword;
+
+    {:Username for possible credentials.}
+    property Username: string read FUsername write FUsername;
+
+    {:password for possible credentials.}
+    property Password: string read FPassword write FPassword;
+
+    {:By this property you can modify default set of SSL/TLS ciphers.}
+    property Ciphers: string read FCiphers write FCiphers;
+
+    {:Used for loading certificate from disk file. See to plugin documentation
+     if this method is supported and how!}
+    property CertificateFile: string read FCertificateFile write FCertificateFile;
+
+    {:Used for loading private key from disk file. See to plugin documentation
+     if this method is supported and how!}
+    property PrivateKeyFile: string read FPrivateKeyFile write FPrivateKeyFile;
+
+    {:Used for loading certificate from binary string. See to plugin documentation
+     if this method is supported and how!}
+    property Certificate: string read FCertificate write FCertificate;
+
+    {:Used for loading private key from binary string. See to plugin documentation
+     if this method is supported and how!}
+    property PrivateKey: string read FPrivateKey write FPrivateKey;
+
+    {:Used for loading PFX from binary string. See to plugin documentation
+     if this method is supported and how!}
+    property PFX: string read FPFX write FPFX;
+
+    {:Used for loading PFX from disk file. See to plugin documentation
+     if this method is supported and how!}
+    property PFXfile: string read FPFXfile write FPFXfile;
+
+    {:Used for loading trusted certificates from disk file. See to plugin documentation
+     if this method is supported and how!}
+    property TrustCertificateFile: string read FTrustCertificateFile write FTrustCertificateFile;
+
+    {:Used for loading trusted certificates from binary string. See to plugin documentation
+     if this method is supported and how!}
+    property TrustCertificate: string read FTrustCertificate write FTrustCertificate;
+
+    {:Used for loading CA certificates from binary string. See to plugin documentation
+     if this method is supported and how!}
+    property CertCA: string read FCertCA write FCertCA;
+
+    {:Used for loading CA certificates from disk file. See to plugin documentation
+     if this method is supported and how!}
+    property CertCAFile: string read FCertCAFile write SetCertCAFile;
+
+    {:If @true, then is verified client certificate. (it is good for writing
+     SSL/TLS servers.) When you are not server, but you are client, then if this
+     property is @true, verify servers certificate.}
+    property VerifyCert: Boolean read FVerifyCert write FVerifyCert;
+
+    {:channel type for possible SSH connections}
+    property SSHChannelType: string read FSSHChannelType write FSSHChannelType;
+
+    {:First argument of channel type for possible SSH connections}
+    property SSHChannelArg1: string read FSSHChannelArg1 write FSSHChannelArg1;
+
+    {:Second argument of channel type for possible SSH connections}
+    property SSHChannelArg2: string read FSSHChannelArg2 write FSSHChannelArg2;
+
+    {: Level of standards compliance level
+      (CryptLib: values in cryptlib.pas, -1: use default value )  }
+    property CertComplianceLevel:integer read FCertComplianceLevel write FCertComplianceLevel;
+
+    {:This event is called when verifying the server certificate immediatally after
+     a successfull verification in the ssl library.}
+    property OnVerifyCert: THookVerifyCert read FOnVerifyCert write FOnVerifyCert;
+
+    {: Server Name Identification. Host name to send to server. If empty the host name
+       found in URL will be used, which should be the normal use (http Header Host = SNI Host).
+       The value is cleared after the connection is established.
+      (SNI support requires OpenSSL 0.9.8k or later. Cryptlib not supported, yet )  }
+    property SNIHost:string read FSNIHost write FSNIHost;
+  end;
+
+  {:@abstract(Default SSL plugin with no SSL support.)
+   Dummy SSL plugin implementation for applications without SSL/TLS support.}
+  TSSLNone = class (TCustomSSL)
+  public
+    {:See @inherited}
+    function LibVersion: string; override;
+    {:See @inherited}
+    function LibName: string; override;
+  end;
+
+  {:@abstract(Record with definition of IP packet header.)
+   For reading data from ICMP or RAW sockets.}
+  TIPHeader = record
+    VerLen: Byte;
+    TOS: Byte;
+    TotalLen: Word;
+    Identifer: Word;
+    FragOffsets: Word;
+    TTL: Byte;
+    Protocol: Byte;
+    CheckSum: Word;
+    SourceIp: LongWord;
+    DestIp: LongWord;
+    Options: LongWord;
+  end;
+
+  {:@abstract(Parent class of application protocol implementations.)
+   By this class is defined common properties.}
+  TSynaClient = Class(TObject)
+  protected
+    FTargetHost: string;
+    FTargetPort: string;
+    FIPInterface: string;
+    FTimeout: integer;
+    FUserName: string;
+    FPassword: string;
+  public
+    constructor Create;
+  published
+    {:Specify terget server IP (or symbolic name). Default is 'localhost'.}
+    property TargetHost: string read FTargetHost Write FTargetHost;
+
+    {:Specify terget server port (or symbolic name).}
+    property TargetPort: string read FTargetPort Write FTargetPort;
+
+    {:Defined local socket address. (outgoing IP address). By default is used
+     '0.0.0.0' as wildcard for default IP.}
+    property IPInterface: string read FIPInterface Write FIPInterface;
+
+    {:Specify default timeout for socket operations.}
+    property Timeout: integer read FTimeout Write FTimeout;
+
+    {:If protocol need user authorization, then fill here username.}
+    property UserName: string read FUserName Write FUserName;
+
+    {:If protocol need user authorization, then fill here password.}
+    property Password: string read FPassword Write FPassword;
+  end;
+
+var
+  {:Selected SSL plugin. Default is @link(TSSLNone).
+
+   Do not change this value directly!!!
+
+   Just add your plugin unit to your project uses instead. Each plugin unit have
+   initialization code what modify this variable.}
+  SSLImplementation: TSSLClass = TSSLNone;
+
+implementation
+
+{$IFDEF ONCEWINSOCK}
+var
+  WsaDataOnce: TWSADATA;
+  e: ESynapseError;
+
+{ ESynapseError }
+
+constructor ESynapseError.CreateErrorCode(AErrorCode: Integer;
+  const AErrorDesc: string);
+var
+  Z: string;
+begin
+  Z := SysUtils.Trim(AErrorDesc);
+  inherited Create(Z);
+  FErrorCode := AErrorCode;
+  FErrorMessage := Z;
+end;
+
+{$ENDIF}
+
+
+constructor TBlockSocket.Create;
+begin
+  CreateAlternate('');
+end;
+
+constructor TBlockSocket.CreateAlternate(Stub: string);
+{$IFNDEF ONCEWINSOCK}
+var
+  e: ESynapseError;
+{$ENDIF}
+begin
+  inherited Create;
+  FDelayedOptions := TOptionList.Create;
+  FRaiseExcept := False;
+{$IFDEF RAISEEXCEPT}
+  FRaiseExcept := True;
+{$ENDIF}
+  FSocket := INVALID_SOCKET;
+  FBuffer := '';
+  FLastCR := False;
+  FLastLF := False;
+  FBinded := False;
+  FNonBlockMode := False;
+  FMaxLineLength := 0;
+  FMaxSendBandwidth := 0;
+  FNextSend := 0;
+  FMaxRecvBandwidth := 0;
+  FNextRecv := 0;
+  FConvertLineEnd := False;
+  FFamily := SF_Any;
+  FFamilySave := SF_Any;
+  FIP6used := False;
+  FPreferIP4 := True;
+  FInterPacketTimeout := True;
+  FRecvCounter := 0;
+  FSendCounter := 0;
+  FSendMaxChunk := c64k;
+  FStopFlag := False;
+  FNonblockSendTimeout := 15000;
+  FHeartbeatRate := 0;
+  FConnectionTimeout := 0;
+  FOwner := nil;
+{$IFNDEF ONCEWINSOCK}
+  if Stub = '' then
+    Stub := DLLStackName;
+  if not InitSocketInterface(Stub) then
+  begin
+    e := ESynapseError.Create('Error loading Socket interface (' + Stub + ')!');
+    e.ErrorCode := 0;
+    e.ErrorMessage := 'Error loading Socket interface (' + Stub + ')!';
+    raise e;
+  end;
+  SockCheck(synsock.WSAStartup(WinsockLevel, FWsaDataOnce));
+  ExceptCheck;
+{$ENDIF}
+end;
+
+destructor TBlockSocket.Destroy;
+var
+  n: integer;
+  p: TSynaOption;
+begin
+  CloseSocket;
+{$IFNDEF ONCEWINSOCK}
+  synsock.WSACleanup;
+  DestroySocketInterface;
+{$ENDIF}
+  for n := FDelayedOptions.Count - 1 downto 0 do
+    begin
+      p := TSynaOption(FDelayedOptions[n]);
+      p.Free;
+    end;
+  FDelayedOptions.Free;
+  inherited Destroy;
+end;
+
+function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily;
+begin
+  case f of
+    SF_ip4:
+      Result := AF_INET;
+    SF_ip6:
+      Result := AF_INET6;
+  else
+    Result := AF_UNSPEC;
+  end;
+end;
+
+procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption);
+var
+  li: TLinger;
+  x: integer;
+  buf: TMemory;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}  
+  timeval: TTimeval;
+{$ENDIF}
+{$ENDIF}
+begin
+  case value.Option of
+    SOT_Linger:
+      begin
+        {$IFDEF CIL}
+        li := TLinger.Create(Value.Enabled, Value.Value div 1000);
+        synsock.SetSockOptObj(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), li);
+        {$ELSE}
+        li.l_onoff := Ord(Value.Enabled);
+        li.l_linger := Value.Value div 1000;
+        buf := @li;
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_LINGER), buf, SizeOf(li)));
+        ExceptCheck;
+        {$ENDIF}
+      end;
+    SOT_RecvBuff:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        {$ELSE}
+        buf := @Value.Value;
+        {$ENDIF}
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF),
+          buf, SizeOf(Value.Value)));
+        ExceptCheck;
+      end;
+    SOT_SendBuff:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        {$ELSE}
+        buf := @Value.Value;
+        {$ENDIF}
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF),
+          buf, SizeOf(Value.Value)));
+        ExceptCheck;
+      end;
+    SOT_NonBlock:
+      begin
+        FNonBlockMode := Value.Enabled;
+        x := Ord(FNonBlockMode);
+        SockCheck(synsock.IoctlSocket(FSocket, FIONBIO, x));
+        ExceptCheck;
+      end;
+    SOT_RecvTimeout:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
+          buf, SizeOf(Value.Value));
+        {$ELSE}
+          {$IFDEF MSWINDOWS}
+        buf := @Value.Value;
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
+          buf, SizeOf(Value.Value)));
+        ExceptCheck;
+          {$ELSE}
+            {$IFDEF ULTIBO}
+        buf := @Value.Value;
+        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
+          buf, SizeOf(Value.Value));
+            {$ELSE}
+        timeval.tv_sec:=Value.Value div 1000;
+        timeval.tv_usec:=(Value.Value mod 1000) * 1000;
+        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVTIMEO),
+          @timeval, SizeOf(timeval));
+            {$ENDIF}
+          {$ENDIF}
+        {$ENDIF}
+      end;
+    SOT_SendTimeout:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        {$ELSE}
+          {$IFDEF MSWINDOWS}
+        buf := @Value.Value;
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
+          buf, SizeOf(Value.Value)));
+        ExceptCheck;
+          {$ELSE}
+            {$IFDEF ULTIBO}
+        buf := @Value.Value;
+        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
+          buf, SizeOf(Value.Value));
+            {$ELSE}
+        timeval.tv_sec:=Value.Value div 1000;
+        timeval.tv_usec:=(Value.Value mod 1000) * 1000;
+        synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDTIMEO),
+          @timeval, SizeOf(timeval));
+            {$ENDIF}
+          {$ENDIF}
+        {$ENDIF}
+      end;
+    SOT_Reuse:
+      begin
+        x := Ord(Value.Enabled);
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(x);
+        {$ELSE}
+        buf := @x;
+        {$ENDIF}
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_REUSEADDR), buf, SizeOf(x)));
+        ExceptCheck;
+      end;
+    SOT_TTL:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        {$ELSE}
+        buf := @Value.Value;
+        {$ENDIF}
+        if FIP6Used then
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_UNICAST_HOPS),
+            buf, SizeOf(Value.Value)))
+        else
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_TTL),
+            buf, SizeOf(Value.Value)));
+        ExceptCheck;
+      end;
+    SOT_Broadcast:
+      begin
+//#todo1 broadcasty na IP6
+        x := Ord(Value.Enabled);
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(x);
+        {$ELSE}
+        buf := @x;
+        {$ENDIF}
+        SockCheck(synsock.SetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_BROADCAST), buf, SizeOf(x)));
+        ExceptCheck;
+      end;
+    SOT_MulticastTTL:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(value.Value);
+        {$ELSE}
+        buf := @Value.Value;
+        {$ENDIF}
+        if FIP6Used then
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_HOPS),
+            buf, SizeOf(Value.Value)))
+        else
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_TTL),
+            buf, SizeOf(Value.Value)));
+        ExceptCheck;
+      end;
+   SOT_MulticastLoop:
+      begin
+        x := Ord(Value.Enabled);
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(x);
+        {$ELSE}
+        buf := @x;
+        {$ENDIF}
+        if FIP6Used then
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IPV6), integer(IPV6_MULTICAST_LOOP), buf, SizeOf(x)))
+        else
+          SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(IP_MULTICAST_LOOP), buf, SizeOf(x)));
+        ExceptCheck;
+      end;
+    SOT_NoDelay:
+      begin
+        {$IFDEF CIL}
+        buf := System.BitConverter.GetBytes(x);
+        {$ELSE}
+        buf := @x;
+        {$ENDIF}
+        x := Ord(Value.Enabled);
+        SockCheck(synsock.SetSockOpt(FSocket, integer(IPPROTO_IP), integer(TCP_NODELAY), buf, SizeOf(x)));
+        ExceptCheck;
+      end;
+  end;
+  Value.free;
+end;
+
+procedure TBlockSocket.DelayedOption(const Value: TSynaOption);
+begin
+  if FSocket = INVALID_SOCKET then
+  begin
+    FDelayedOptions.Insert(0, Value);
+  end
+  else
+    SetDelayedOption(Value);
+end;
+
+procedure TBlockSocket.ProcessDelayedOptions;
+var
+  n: integer;
+  d: TSynaOption;
+begin
+  for n := FDelayedOptions.Count - 1 downto 0 do
+  begin
+    d := TSynaOption(FDelayedOptions[n]);
+    SetDelayedOption(d);
+  end;
+  FDelayedOptions.Clear;
+end;
+
+procedure TBlockSocket.SetSin(var Sin: TVarSin; const IP, Port: string);
+var
+  f: TSocketFamily;
+begin
+  DoStatus(HR_ResolvingBegin, IP + ':' + Port);
+  ResetLastError;
+  //if socket exists, then use their type, else use users selection
+  f := SF_Any;
+  if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then
+  begin
+    if IsIP(IP) then
+      f := SF_IP4
+    else
+      if IsIP6(IP) then
+        f := SF_IP6;
+  end
+  else
+    f := FFamily;
+  FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f),
+    GetSocketprotocol, GetSocketType, FPreferIP4);
+  DoStatus(HR_ResolvingEnd, GetSinIP(sin) + ':' + IntTostr(GetSinPort(sin)));
+end;
+
+function TBlockSocket.GetSendTimeout: Integer;
+var
+ l: integer;
+begin
+ l:=SizeOf(Integer);
+ SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDTIMEO, @Result, l));
+ ExceptCheck;
+end;
+
+function TBlockSocket.GetSinIP(Sin: TVarSin): string;
+begin
+  Result := synsock.GetSinIP(sin);
+end;
+
+function TBlockSocket.GetSinPort(Sin: TVarSin): Integer;
+begin
+  Result := synsock.GetSinPort(sin);
+end;
+
+procedure TBlockSocket.CreateSocket;
+var
+  sin: TVarSin;
+begin
+  //dummy for SF_Any Family mode
+  ResetLastError;
+  if (FFamily <> SF_Any) and (FSocket = INVALID_SOCKET) then
+  begin
+    {$IFDEF CIL}
+    if FFamily = SF_IP6 then
+      sin := TVarSin.Create(IPAddress.Parse('::0'), 0)
+    else
+      sin := TVarSin.Create(IPAddress.Parse('0.0.0.0'), 0);
+    {$ELSE}
+    FillChar(Sin, Sizeof(Sin), 0);
+    if FFamily = SF_IP6 then
+      sin.sin_family := AF_INET6
+    else
+      sin.sin_family := AF_INET;
+    {$ENDIF}
+    InternalCreateSocket(Sin);
+  end;
+end;
+
+procedure TBlockSocket.CreateSocketByName(const Value: string);
+var
+  sin: TVarSin;
+begin
+  ResetLastError;
+  if FSocket = INVALID_SOCKET then
+  begin
+    SetSin(sin, value, '0');
+    if FLastError = 0 then
+      InternalCreateSocket(Sin);
+  end;
+end;
+
+procedure TBlockSocket.InternalCreateSocket(Sin: TVarSin);
+begin
+  FStopFlag := False;
+  FRecvCounter := 0;
+  FSendCounter := 0;
+  ResetLastError;
+  if FSocket = INVALID_SOCKET then
+  begin
+    FBuffer := '';
+    FBinded := False;
+    FIP6Used := Sin.AddressFamily = AF_INET6;
+    FSocket := synsock.Socket(integer(Sin.AddressFamily), GetSocketType, GetSocketProtocol);
+    if FSocket = INVALID_SOCKET then
+      FLastError := synsock.WSAGetLastError;
+    {$IFNDEF CIL}
+    FD_ZERO(FFDSet);
+    FD_SET(FSocket, FFDSet);
+    {$ENDIF}
+    ExceptCheck;
+    if FIP6used then
+      DoStatus(HR_SocketCreate, 'IPv6')
+    else
+      DoStatus(HR_SocketCreate, 'IPv4');
+    ProcessDelayedOptions;
+    DoCreateSocket;
+  end;
+end;
+
+procedure TBlockSocket.CloseSocket;
+begin
+  AbortSocket;
+end;
+
+procedure TBlockSocket.AbortSocket;
+var
+  n: integer;
+  p: TSynaOption;
+begin
+  if FSocket <> INVALID_SOCKET then
+    synsock.CloseSocket(FSocket);
+  FSocket := INVALID_SOCKET;
+  for n := FDelayedOptions.Count - 1 downto 0 do
+    begin
+      p := TSynaOption(FDelayedOptions[n]);
+      p.Free;
+    end;
+  FDelayedOptions.Clear;
+  FFamily := FFamilySave;
+  DoStatus(HR_SocketClose, '');
+  FDisconnected := False;
+end;
+
+procedure TBlockSocket.Bind(const IP, Port: string);
+var
+  Sin: TVarSin;
+begin
+  ResetLastError;
+  if (FSocket <> INVALID_SOCKET)
+    or not((FFamily = SF_ANY) and (IP = cAnyHost) and (Port = cAnyPort)) then
+  begin
+    SetSin(Sin, IP, Port);
+    if FLastError = 0 then
+    begin
+      if FSocket = INVALID_SOCKET then
+        InternalCreateSocket(Sin);
+      SockCheck(synsock.Bind(FSocket, Sin));
+      GetSinLocal;
+      FBuffer := '';
+      FBinded := True;
+    end;
+    ExceptCheck;
+    DoStatus(HR_Bind, IP + ':' + Port);
+  end;
+end;
+
+procedure TBlockSocket.Connect(const IP, Port: string);
+var
+  Sin: TVarSin;
+  b: boolean;
+  lError: Integer;
+begin
+  SetSin(Sin, IP, Port);
+  if FLastError = 0 then
+  begin
+    if FSocket = INVALID_SOCKET then
+      InternalCreateSocket(Sin);
+    if FConnectionTimeout > 0 then
+    begin
+      // connect in non-blocking mode
+      b := NonBlockMode;
+      NonBlockMode := true;
+      SockCheck(synsock.Connect(FSocket, Sin));
+      if (FLastError = WSAEINPROGRESS) OR (FLastError = WSAEWOULDBLOCK) then
+        if not CanWrite(FConnectionTimeout) then
+          FLastError := WSAETIMEDOUT;
+      lError := FLastError;
+      NonBlockMode := b;
+      FLastError := lError;
+    end
+    else
+      SockCheck(synsock.Connect(FSocket, Sin));
+    if FLastError = 0 then
+      GetSins;
+    FBuffer := '';
+    FLastCR := False;
+    FLastLF := False;
+  end;
+  ExceptCheck;
+  DoStatus(HR_Connect, IP + ':' + Port);
+end;
+
+procedure TBlockSocket.Listen;
+begin
+  SockCheck(synsock.Listen(FSocket, SOMAXCONN));
+  GetSins;
+  ExceptCheck;
+  DoStatus(HR_Listen, '');
+end;
+
+function TBlockSocket.Accept: TSocket;
+begin
+  Result := synsock.Accept(FSocket, FRemoteSin);
+///    SockCheck(Result);
+  ExceptCheck;
+  DoStatus(HR_Accept, '');
+end;
+
+procedure TBlockSocket.GetSinLocal;
+begin
+  synsock.GetSockName(FSocket, FLocalSin);
+end;
+
+procedure TBlockSocket.GetSinRemote;
+begin
+  synsock.GetPeerName(FSocket, FRemoteSin);
+end;
+
+procedure TBlockSocket.GetSins;
+begin
+  GetSinLocal;
+  GetSinRemote;
+end;
+
+procedure TBlockSocket.SetBandwidth(Value: Integer);
+begin
+  MaxSendBandwidth := Value;
+  MaxRecvBandwidth := Value;
+end;
+
+procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
+var
+  x: LongWord;
+  y: LongWord;
+  n: integer;
+begin
+  if FStopFlag then
+    exit;
+  if MaxB > 0 then
+  begin
+    y := GetTick;
+    if Next > y then
+    begin
+      x := Next - y;
+      if x > 0 then
+      begin
+        DoStatus(HR_Wait, IntToStr(x));
+        sleep(x mod 250);
+        for n := 1 to x div 250 do
+          if FStopFlag then
+            Break
+          else
+            sleep(250);
+      end;
+    end;
+    Next := GetTick + Trunc((Length / MaxB) * 1000);
+  end;
+end;
+
+function TBlockSocket.TestStopFlag: Boolean;
+begin
+  DoHeartbeat;
+  Result := FStopFlag;
+  if Result then
+  begin
+    FStopFlag := False;
+    FLastError := WSAECONNABORTED;
+    ExceptCheck;
+  end;
+end;
+
+
+function TBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer;
+{$IFNDEF CIL}
+var
+  x, y: integer;
+  l, r: integer;
+  p: Pointer;
+{$ENDIF}
+begin
+  Result := 0;
+  if TestStopFlag then
+    Exit;
+  DoMonitor(True, Buffer, Length);
+{$IFDEF CIL}
+  Result := synsock.Send(FSocket, Buffer, Length, 0);
+{$ELSE}
+  l := Length;
+  x := 0;
+  while x < l do
+  begin
+    y := l - x;
+    if y > FSendMaxChunk then
+      y := FSendMaxChunk;
+    if y > 0 then
+    begin
+      LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
+      p := IncPoint(Buffer, x);
+      r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
+      SockCheck(r);
+      if FLastError = WSAEWOULDBLOCK then
+      begin
+        if CanWrite(FNonblockSendTimeout) then
+        begin
+          r := synsock.Send(FSocket, p, y, MSG_NOSIGNAL);
+          SockCheck(r);
+        end
+        else
+          FLastError := WSAETIMEDOUT;
+      end;
+      if FLastError <> 0 then
+        Break;
+      Inc(x, r);
+      Inc(Result, r);
+      Inc(FSendCounter, r);
+      DoStatus(HR_WriteCount, IntToStr(r));
+    end
+    else
+      break;
+  end;
+{$ENDIF}
+  ExceptCheck;
+end;
+
+procedure TBlockSocket.SendByte(Data: Byte);
+{$IFDEF CIL}
+var
+  buf: TMemory;
+{$ENDIF}
+begin
+{$IFDEF CIL}
+  setlength(buf, 1);
+  buf[0] := Data;
+  SendBuffer(buf, 1);
+{$ELSE}
+  SendBuffer(@Data, 1);
+{$ENDIF}
+end;
+
+procedure TBlockSocket.SendString(Data: TSynaBytes);
+var
+  buf: TMemory;
+  count: Integer;
+begin
+  {$IFDEF CIL}
+    buf := BytesOf(Data);
+    count := Length(Data);
+  {$ELSE}
+    {$IFDEF UNICODE}
+      buf :=  TSynaBytes(Data).Data; //TSynaByte(Data)
+      count := Data.Length;  // avoid conversion
+    {$ELSE}
+      buf := Pointer(data);
+      count := Length(Data);
+    {$ENDIF}
+  {$ENDIF}
+  SendBuffer(buf, count);
+end;
+
+procedure TBlockSocket.SendInteger(Data: integer);
+var
+  buf: TMemory;
+begin
+  {$IFDEF CIL}
+  buf := System.BitConverter.GetBytes(Data);
+  {$ELSE}
+  buf := @Data;
+  {$ENDIF}
+  SendBuffer(buf, SizeOf(Data));
+end;
+
+procedure TBlockSocket.SendBlock(const Data: string);
+var
+  i: integer;
+begin
+  i := SwapBytes(Length(data));
+  SendString(Codelongint(i) + Data);
+end;
+
+procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean);
+var
+  l: integer;
+  yr: integer;
+  s: string;
+  b: boolean;
+{$IFDEF CIL}
+  buf: TMemory;
+{$ENDIF}
+begin
+  b := true;
+  l := 0;
+  if WithSize then
+  begin
+    l := Stream.Size - Stream.Position;;
+    if not Indy then
+      l := synsock.HToNL(l);
+  end;
+  repeat
+    {$IFDEF CIL}
+    Setlength(buf, FSendMaxChunk);
+    yr := Stream.read(buf, FSendMaxChunk);
+    if yr > 0 then
+    begin
+      if WithSize and b then
+      begin
+        b := false;
+        SendString(CodeLongInt(l));
+      end;
+      SendBuffer(buf, yr);
+      if FLastError <> 0 then
+        break;
+    end
+    {$ELSE}
+    Setlength(s, FSendMaxChunk);
+    yr := Stream.read(Pointer(s)^, FSendMaxChunk);
+    if yr > 0 then
+    begin
+      SetLength(s, yr);
+      if WithSize and b then
+      begin
+        b := false;
+        SendString(CodeLongInt(l) + s);
+      end
+      else
+        SendString(s);
+      if FLastError <> 0 then
+        break;
+    end
+    {$ENDIF}
+  until yr <= 0;
+end;
+
+procedure TBlockSocket.SendStreamRaw(const Stream: TStream);
+begin
+  InternalSendStream(Stream, false, false);
+end;
+
+procedure TBlockSocket.SendStreamIndy(const Stream: TStream);
+begin
+  InternalSendStream(Stream, true, true);
+end;
+
+procedure TBlockSocket.SendStream(const Stream: TStream);
+begin
+  InternalSendStream(Stream, true, false);
+end;
+
+function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
+begin
+  Result := 0;
+  if TestStopFlag then
+    Exit;
+  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
+  Result := synsock.Recv(FSocket, Buffer, Length, MSG_NOSIGNAL);
+  if Result = 0 then
+    FLastError := WSAECONNRESET
+  else
+    SockCheck(Result);
+  ExceptCheck;
+  if Result > 0 then
+  begin
+    Inc(FRecvCounter, Result);
+    DoStatus(HR_ReadCount, IntToStr(Result));
+    DoMonitor(False, Buffer, Result);
+    DoReadFilter(Buffer, Result);
+  end;
+end;
+
+function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer;
+  Timeout: Integer): Integer;
+var
+  s: TSynaBytes;
+  rl, l: integer;
+  ti: LongWord;
+{$IFDEF CIL}
+  n: integer;
+  b: TMemory;
+{$ENDIF}
+begin
+  ResetLastError;
+  Result := 0;
+  if Len > 0 then
+  begin
+    rl := 0;
+    repeat
+      ti := GetTick;
+      s := RecvPacket(Timeout);
+      l := s.length;
+      if (rl + l) > Len then
+        l := Len - rl;
+      {$IFDEF CIL}
+      b := BytesOf(s);
+      for n := 0 to l do
+        Buffer[rl + n] := b[n];
+      {$ELSE}
+      Move({$IFNDEF UNICODE}Pointer(s)^{$ELSE}s.Bytes[0]{$ENDIF},
+      IncPoint(Buffer, rl)^, l);
+      {$ENDIF}
+      rl := rl + l;
+      if FLastError <> 0 then
+        Break;
+      if rl >= Len then
+        Break;
+      if not FInterPacketTimeout then
+      begin
+        Timeout := Timeout - integer(TickDelta(ti, GetTick));
+        if Timeout <= 0 then
+        begin
+          FLastError := WSAETIMEDOUT;
+          Break;
+        end;
+      end;
+    until False;
+    DeleteInternal(s, 1, l);
+    FBuffer := s;
+    Result := rl;
+  end;
+end;
+
+function TBlockSocket.RecvBufferStr(Len: Integer; Timeout: Integer): TSynaBytes;
+var
+  x: integer;
+  buf: TBytes;
+begin
+  Result := '';
+  if Len > 0 then
+  begin
+    Setlength(Buf, Len);
+    x := RecvBufferEx(@buf[0], Len, Timeout);
+    if FLastError = 0 then
+    begin
+      SetLength(Buf, x);
+    {$IFDEF UNICODE}
+    Result.Length := x;
+    Move(Buf[0], Result.Bytes[0], x);
+    {$ELSE}
+    Result := StringOf(Buf);
+    {$ENDIF}
+    end
+    else
+      Result := '';
+    Setlength(Buf, 0);
+  end;
+end;
+
+function TBlockSocket.RecvPacket(Timeout: Integer): TSynaBytes;
+var
+  x: Integer;
+  buf: TBytes;
+begin
+  Result := '';
+  ResetLastError;
+  if FBuffer <> '' then
+  begin
+    Result := FBuffer;
+    FBuffer := '';
+  end
+  else
+  begin
+    {$IFDEF MSWINDOWS}
+    //not drain CPU on large downloads...
+    Sleep(0);
+    {$ENDIF}
+    x := WaitingData;
+    if x > 0 then
+    begin
+      SetLength(Buf, x);
+      x := RecvBuffer(Buf, x);
+      if x >= 0 then
+      begin
+        SetLength(Buf, x);
+        {$IFDEF UNICODE} Result := TSynaBytes(buf); {$ELSE} Result := StringOf(buf); {$ENDIF}
+      end;
+    end
+    else
+    begin
+      if CanRead(Timeout) then
+      begin
+        x := WaitingData;
+        if x = 0 then
+          FLastError := WSAECONNRESET;
+        if x > 0 then
+        begin
+          SetLength(Buf, x);
+          x := RecvBuffer(Buf, x);
+          if x >= 0 then
+          begin
+            SetLength(Buf, x);
+            {$IFDEF UNICODE} Result := TSynaBytes(buf); {$ELSE} Result := StringOf(buf); {$ENDIF}
+          end;
+          SetLength(Buf, 0);
+        end;
+      end
+      else
+        FLastError := WSAETIMEDOUT;
+    end;
+  end;
+  if FConvertLineEnd and (Result <> '') then
+  begin
+    if FLastCR and (Result[1] = LF) then
+      DeleteInternal(Result, 1, 1);
+    if FLastLF and (Result[1] = CR) then
+      DeleteInternal(Result, 1, 1);
+    FLastCR := False;
+    FLastLF := False;
+  end;
+  ExceptCheck;
+end;
+
+
+function TBlockSocket.RecvByte(Timeout: Integer): Byte;
+begin
+  Result := 0;
+  ResetLastError;
+  if FBuffer = '' then
+    FBuffer := RecvPacket(Timeout);
+  if (FLastError = 0) and (FBuffer <> '') then
+  begin
+    Result := Ord(FBuffer[1]);
+    {$IFNDEF UNICODE}
+    Delete(FBuffer, 1, 1);
+    {$ELSE}
+    FBuffer.Delete(1, 1); // TEST!
+    {$ENDIF}
+  end;
+  ExceptCheck;
+end;
+
+function TBlockSocket.RecvInteger(Timeout: Integer): Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  s := RecvBufferStr(4, Timeout);
+  if FLastError = 0 then
+    Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
+end;
+
+function TBlockSocket.RecvTerminated(Timeout: Integer; const Terminator: string): string;
+var
+  x: Integer;
+  s: TSynaBytes;
+  l: Integer;
+  CorCRLF: Boolean;
+  t: string;
+  tl: integer;
+  ti: LongWord;
+begin
+  ResetLastError;
+  Result := '';
+  l := Length(Terminator);
+  if l = 0 then
+    Exit;
+  tl := l;
+  CorCRLF := FConvertLineEnd and (Terminator = CRLF);
+  s := '';
+  x := 0;
+  repeat
+    //get rest of FBuffer or incomming new data...
+    ti := GetTick;
+    s := s + RecvPacket(Timeout);
+    if FLastError <> 0 then
+      Break;
+    x := 0;
+    if s.Length > 0 then
+      if CorCRLF then
+      begin
+        t := '';
+        x := PosCRLF(s, t);
+        tl := t.Length;
+        if t = CR then
+          FLastCR := True;
+        if t = LF then
+          FLastLF := True;
+      end
+      else
+      begin
+        x := pos(Terminator, s);
+        tl := l;
+      end;
+    if (FMaxLineLength <> 0) and (s.Length > FMaxLineLength) then
+    begin
+      FLastError := WSAENOBUFS;
+      Break;
+    end;
+    if x > 0 then
+      Break;
+    if not FInterPacketTimeout then
+    begin
+      Timeout := Timeout - integer(TickDelta(ti, GetTick));
+      if Timeout <= 0 then
+      begin
+        FLastError := WSAETIMEDOUT;
+        Break;
+      end;
+    end;
+  until False;
+  if x > 0 then
+  begin
+    Result := Copy(s, 1, x - 1);
+    DeleteInternal(s, 1, x + tl - 1);
+  end;
+  FBuffer := s;
+  ExceptCheck;
+end;
+
+function TBlockSocket.RecvString(Timeout: Integer): string;
+var
+  s: string;
+begin
+  Result := '';
+  s := RecvTerminated(Timeout, CRLF);
+  if FLastError = 0 then
+    Result := s;
+end;
+
+function TBlockSocket.RecvBlock(Timeout: Integer): string;
+var
+  x: integer;
+begin
+  Result := '';
+  x := RecvInteger(Timeout);
+  if FLastError = 0 then
+    Result := RecvBufferStr(x, Timeout);
+end;
+
+procedure TBlockSocket.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
+var
+  s: string;
+begin
+  repeat
+    s := RecvPacket(Timeout);
+    if FLastError = 0 then
+      WriteStrToStream(Stream, s);
+  until FLastError <> 0;
+end;
+
+procedure TBlockSocket.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
+var
+  s: TSynaBytes;
+  n: integer;
+{$IFDEF CIL}
+  buf: TMemory;
+{$ENDIF}
+begin
+  for n := 1 to (Size div FSendMaxChunk) do
+  begin
+    {$IFDEF CIL}
+    SetLength(buf, FSendMaxChunk);
+    RecvBufferEx(buf, FSendMaxChunk, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    Stream.Write(buf, FSendMaxChunk);
+    {$ELSE}
+    s := RecvBufferStr(FSendMaxChunk, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    WriteStrToStream(Stream, s);
+    {$ENDIF}
+  end;
+  n := Size mod FSendMaxChunk;
+  if n > 0 then
+  begin
+    {$IFDEF CIL}
+    SetLength(buf, n);
+    RecvBufferEx(buf, n, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    Stream.Write(buf, n);
+    {$ELSE}
+    s := RecvBufferStr(n, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    WriteStrToStream(Stream, s);
+    {$ENDIF}
+  end;
+end;
+
+procedure TBlockSocket.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
+var
+  x: integer;
+begin
+  x := RecvInteger(Timeout);
+  x := synsock.NToHL(x);
+  if FLastError = 0 then
+    RecvStreamSize(Stream, Timeout, x);
+end;
+
+procedure TBlockSocket.RecvStream(const Stream: TStream; Timeout: Integer);
+var
+  x: integer;
+begin
+  x := RecvInteger(Timeout);
+  if FLastError = 0 then
+    RecvStreamSize(Stream, Timeout, x);
+end;
+
+function TBlockSocket.PeekBuffer(Buffer: TMemory; Length: Integer): Integer;
+begin
+ {$IFNDEF CIL}
+//  Result := synsock.Recv(FSocket, Buffer^, Length, MSG_PEEK + MSG_NOSIGNAL);
+  Result := synsock.Recv(FSocket, Buffer, Length, MSG_PEEK + MSG_NOSIGNAL);
+  SockCheck(Result);
+  ExceptCheck;
+  {$ENDIF}
+end;
+
+function TBlockSocket.PeekByte(Timeout: Integer): Byte;
+var
+  s: string;
+begin
+ {$IFNDEF CIL}
+  Result := 0;
+  if CanRead(Timeout) then
+  begin
+    SetLength(s, 1);
+    PeekBuffer(Pointer(s), 1);
+    if s <> '' then
+      Result := Ord(s[1]);
+  end
+  else
+    FLastError := WSAETIMEDOUT;
+  ExceptCheck;
+  {$ENDIF}
+end;
+
+procedure TBlockSocket.ResetLastError;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+end;
+
+function TBlockSocket.SockCheck(SockResult: Integer): Integer;
+begin
+  ResetLastError;
+  if SockResult = integer(SOCKET_ERROR) then
+  begin
+    FLastError := synsock.WSAGetLastError;
+    if FLastError <= WSABASEERR then
+     Inc(FLastError, WSABASEERR);
+    FLastErrorDesc := GetErrorDescEx;
+  end;
+  Result := FLastError;
+end;
+
+procedure TBlockSocket.ExceptCheck;
+var
+  e: ESynapseError;
+begin
+  FLastErrorDesc := GetErrorDescEx;
+  if (LastError <> 0) and (LastError <> WSAEINPROGRESS)
+    and (LastError <> WSAEWOULDBLOCK) then
+  begin
+    DoStatus(HR_Error, IntToStr(FLastError) + ',' + FLastErrorDesc);
+    FDisconnected := True;
+    if FRaiseExcept then
+    begin
+      if FLastError = 104 then
+      e := EResetByPeer.Create(Format('Synapse TCP/IP socket error. Reset by peer %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10098 then
+      e := ECouldNotBindSocket.Create(Format('Synapse TCP/IP socket error. Could not bind socket %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10054 then
+      e := EConnectionResetByPeer.Create(Format('Synapse TCP/IP socket error. Connection reset by peer %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10057 then
+      e := ESockectIsnotConnected.Create(Format('Synapse TCP/IP socket error. Socket is not connected %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10060 then
+      e := EConnectionTimedOut.Create(Format('Synapse TCP/IP socket error. Connection timed out %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10061 then
+      e := EConnectionRefused.Create(Format('Synapse TCP/IP socket error. Connection refused %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = 10049 then
+      e := ECantAssignAddress.Create(Format('Synapse TCP/IP socket error. Can''t assign requested address %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else if FLastError = -2 then
+      e := ESocketMinus2.Create(Format('Synapse TCP/IP socket error %d: %s',
+        [FLastError, FLastErrorDesc]))
+      else e := ESynapseError.Create(Format('Synapse TCP/IP socket error %d: %s',
+        [FLastError, FLastErrorDesc]));
+      e.ErrorCode := FLastError;
+      e.ErrorMessage := FLastErrorDesc;
+      raise e;
+    end;
+  end;
+end;
+
+function TBlockSocket.WaitingData: Integer;
+var
+  x: Integer;
+begin
+  Result := 0;
+  if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then
+    Result := x;
+  if Result > c64k then
+    Result := c64k;
+end;
+
+function TBlockSocket.WaitingDataEx: Integer;
+begin
+  if FBuffer <> '' then
+    Result := FBuffer.Length
+  else
+    Result := WaitingData;
+end;
+
+procedure TBlockSocket.Purge;
+begin
+  Sleep(1);
+  try
+    while (FBuffer.Length > 0) or (WaitingData > 0) do
+    begin
+      RecvPacket(0);
+      if FLastError <> 0 then
+        break;
+    end;
+  except
+    on exception do;
+  end;
+  ResetLastError;
+end;
+
+procedure TBlockSocket.SetLinger(Enable: Boolean; Linger: Integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_Linger;
+  d.Enabled := Enable;
+  d.Value := Linger;
+  DelayedOption(d);
+end;
+
+function TBlockSocket.LocalName: string;
+begin
+  Result := synsock.GetHostName;
+  if Result = '' then
+    Result := '127.0.0.1';
+end;
+
+procedure TBlockSocket.ResolveNameToIP(const Name: string; const IPList:
+    TStrings);
+begin
+  IPList.Clear;
+  synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList);
+  if IPList.Count = 0 then
+    IPList.Add(cAnyHost);
+end;
+
+function TBlockSocket.ResolveName(const Name: string): string;
+var
+  l: TStringList;
+begin
+  l := TStringList.Create;
+  try
+    ResolveNameToIP(Name, l);
+    Result := l[0];
+  finally
+    l.Free;
+  end;
+end;
+
+function TBlockSocket.ResolvePort(const Port: string): Word;
+begin
+  Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
+end;
+
+function TBlockSocket.ResolveIPToName(IP: string): string;
+begin
+  if not IsIP(IP) and not IsIp6(IP) then
+    IP := ResolveName(IP);
+  Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType);
+end;
+
+procedure TBlockSocket.SetRemoteSin(const IP, Port: string);
+begin
+  SetSin(FRemoteSin, IP, Port);
+end;
+
+function TBlockSocket.GetLocalSinIP: string;
+begin
+  Result := GetSinIP(FLocalSin);
+end;
+
+function TBlockSocket.GetRecvTimeout: integer;
+var
+ l: integer;
+begin
+ l:=SizeOf(Integer);
+ SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVTIMEO, @Result, l));
+ ExceptCheck;
+end;
+
+function TBlockSocket.GetRemoteSinIP: string;
+begin
+  Result := GetSinIP(FRemoteSin);
+end;
+
+function TBlockSocket.GetLocalSinPort: Integer;
+begin
+  Result := GetSinPort(FLocalSin);
+end;
+
+function TBlockSocket.GetRemoteSinPort: Integer;
+begin
+  Result := GetSinPort(FRemoteSin);
+end;
+
+function TBlockSocket.InternalCanRead(Timeout: Integer): Boolean;
+{$IFDEF CIL}
+begin
+  Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectRead);
+{$ELSE}
+var
+  TimeVal: PTimeVal;
+  TimeV: TTimeVal;
+  x: Integer;
+  FDSet: TFDSet;
+begin
+  TimeV.tv_usec := (Timeout mod 1000) * 1000;
+  TimeV.tv_sec := Timeout div 1000;
+  TimeVal := @TimeV;
+  if Timeout = -1 then
+    TimeVal := nil;
+  FDSet := FFdSet;
+  x := synsock.Select(integer(FSocket + 1), @FDSet, nil, nil, TimeVal);
+  SockCheck(x);
+  if FLastError <> 0 then
+    x := 0;
+  Result := x > 0;
+{$ENDIF}
+end;
+
+function TBlockSocket.CanRead(Timeout: Integer): Boolean;
+var
+  ti, tr: Integer;
+  n: integer;
+begin
+  if (FHeartbeatRate <> 0) and (Timeout <> -1) then
+  begin
+    ti := Timeout div FHeartbeatRate;
+    tr := Timeout mod FHeartbeatRate;
+  end
+  else
+  begin
+    ti := 0;
+    tr := Timeout;
+  end;
+  Result := InternalCanRead(tr);
+  if not Result then
+    for n := 0 to ti do
+    begin
+      DoHeartbeat;
+      if FStopFlag then
+      begin
+        Result := False;
+        FStopFlag := False;
+        Break;
+      end;
+      Result := InternalCanRead(FHeartbeatRate);
+      if Result then
+        break;
+    end;
+  ExceptCheck;
+  if Result then
+    DoStatus(HR_CanRead, '');
+end;
+
+function TBlockSocket.InternalCanWrite(Timeout: Integer): Boolean;
+{$IFDEF CIL}
+begin
+  Result := FSocket.Poll(Timeout * 1000, SelectMode.SelectWrite);
+{$ELSE}
+var
+  TimeVal: PTimeVal;
+  TimeV: TTimeVal;
+  x: Integer;
+  FDSet: TFDSet;
+begin
+  TimeV.tv_usec := (Timeout mod 1000) * 1000;
+  TimeV.tv_sec := Timeout div 1000;
+  TimeVal := @TimeV;
+  if Timeout = -1 then
+    TimeVal := nil;
+  FDSet := FFdSet;
+  x := synsock.Select(FSocket + 1, nil, @FDSet, nil, TimeVal);
+  SockCheck(x);
+  if FLastError <> 0 then
+    x := 0;
+  Result := x > 0;
+{$ENDIF}
+end;
+
+function TBlockSocket.CanWrite(Timeout: Integer): Boolean;
+var
+  ti, tr: Integer;
+  n: integer;
+begin
+  if (FHeartbeatRate <> 0) and (Timeout <> -1) then
+  begin
+    ti := Timeout div FHeartbeatRate;
+    tr := Timeout mod FHeartbeatRate;
+  end
+  else
+  begin
+    ti := 0;
+    tr := Timeout;
+  end;
+  Result := InternalCanWrite(tr);
+  if not Result then
+    for n := 0 to ti do
+    begin
+      DoHeartbeat;
+      if FStopFlag then
+      begin
+        Result := False;
+        FStopFlag := False;
+        Break;
+      end;
+      Result := InternalCanWrite(FHeartbeatRate);
+      if Result then
+        break;
+    end;
+  ExceptCheck;
+  if Result then
+    DoStatus(HR_CanWrite, '');
+end;
+
+function TBlockSocket.CanReadEx(Timeout: Integer): Boolean;
+begin
+  if FBuffer <> '' then
+    Result := True
+  else
+    Result := CanRead(Timeout);
+end;
+
+function TBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer;
+begin
+  Result := 0;
+  if TestStopFlag then
+    Exit;
+  DoMonitor(True, Buffer, Length);
+  LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
+  Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
+  SockCheck(Result);
+  ExceptCheck;
+  Inc(FSendCounter, Result);
+  DoStatus(HR_WriteCount, IntToStr(Result));
+end;
+
+function TBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
+begin
+  Result := 0;
+  if TestStopFlag then
+    Exit;
+  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
+  Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin);
+  SockCheck(Result);
+  ExceptCheck;
+  Inc(FRecvCounter, Result);
+  DoStatus(HR_ReadCount, IntToStr(Result));
+  DoMonitor(False, Buffer, Result);
+end;
+
+function TBlockSocket.GetSizeRecvBuffer: Integer;
+var
+  l: Integer;
+{$IFDEF CIL}
+  buf: TMemory;
+{$ENDIF}
+begin
+{$IFDEF CIL}
+  setlength(buf, 4);
+  SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_RCVBUF), buf, l));
+  Result := System.BitConverter.ToInt32(buf,0);
+{$ELSE}
+  l := SizeOf(Result);
+  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_RCVBUF, @Result, l));
+  if FLastError <> 0 then
+    Result := 1024;
+  ExceptCheck;
+{$ENDIF}
+end;
+
+procedure TBlockSocket.SetSizeRecvBuffer(Size: Integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_RecvBuff;
+  d.Value := Size;
+  DelayedOption(d);
+end;
+
+function TBlockSocket.GetSizeSendBuffer: Integer;
+var
+  l: Integer;
+{$IFDEF CIL}
+  buf: TMemory;
+{$ENDIF}
+begin
+{$IFDEF CIL}
+  setlength(buf, 4);
+  SockCheck(synsock.GetSockOpt(FSocket, integer(SOL_SOCKET), integer(SO_SNDBUF), buf, l));
+  Result := System.BitConverter.ToInt32(buf,0);
+{$ELSE}
+  l := SizeOf(Result);
+  SockCheck(synsock.GetSockOpt(FSocket, SOL_SOCKET, SO_SNDBUF, @Result, l));
+  if FLastError <> 0 then
+    Result := 1024;
+  ExceptCheck;
+{$ENDIF}
+end;
+
+procedure TBlockSocket.SetSizeSendBuffer(Size: Integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_SendBuff;
+  d.Value := Size;
+  DelayedOption(d);
+end;
+
+procedure TBlockSocket.SetNagleMode(Value: Boolean);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_NoDelay;
+  d.Enabled := Value;
+  DelayedOption(d);
+end;
+
+procedure TBlockSocket.SetNonBlockMode(Value: Boolean);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_nonblock;
+  d.Enabled := Value;
+  DelayedOption(d);
+end;
+
+procedure TBlockSocket.SetTimeout(Timeout: Integer);
+begin
+  SetSendTimeout(Timeout);
+  SetRecvTimeout(Timeout);
+end;
+
+procedure TBlockSocket.SetSendTimeout(Timeout: Integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_sendtimeout;
+  d.Value := Timeout;
+  DelayedOption(d);
+end;
+
+procedure TBlockSocket.SetRecvTimeout(Timeout: Integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_recvtimeout;
+  d.Value := Timeout;
+  DelayedOption(d);
+end;
+
+{$IFNDEF CIL}
+function TBlockSocket.GroupCanRead(const SocketList: TSocketList; Timeout: Integer;
+  const CanReadList: TSocketList): boolean;
+var
+  FDSet: TFDSet;
+  TimeVal: PTimeVal;
+  TimeV: TTimeVal;
+  x, n: Integer;
+  Max: Integer;
+begin
+  TimeV.tv_usec := (Timeout mod 1000) * 1000;
+  TimeV.tv_sec := Timeout div 1000;
+  TimeVal := @TimeV;
+  if Timeout = -1 then
+    TimeVal := nil;
+  FD_ZERO(FDSet);
+  Max := 0;
+  for n := 0 to SocketList.Count - 1 do
+    if TObject(SocketList.Items[n]) is TBlockSocket then
+    begin
+      if TBlockSocket(SocketList.Items[n]).Socket > Max then
+        Max := TBlockSocket(SocketList.Items[n]).Socket;
+      FD_SET(TBlockSocket(SocketList.Items[n]).Socket, FDSet);
+    end;
+  x := synsock.Select(Max + 1, @FDSet, nil, nil, TimeVal);
+  SockCheck(x);
+  ExceptCheck;
+  if FLastError <> 0 then
+    x := 0;
+  Result := x > 0;
+  CanReadList.Clear;
+  if Result then
+    for n := 0 to SocketList.Count - 1 do
+      if TObject(SocketList.Items[n]) is TBlockSocket then
+        if FD_ISSET(TBlockSocket(SocketList.Items[n]).Socket, FDSet) then
+          CanReadList.Add(TBlockSocket(SocketList.Items[n]));
+end;
+{$ENDIF}
+
+procedure TBlockSocket.EnableReuse(Value: Boolean);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_reuse;
+  d.Enabled := Value;
+  DelayedOption(d);
+end;
+
+procedure TBlockSocket.SetTTL(TTL: integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_TTL;
+  d.Value := TTL;
+  DelayedOption(d);
+end;
+
+function TBlockSocket.GetTTL:integer;
+var
+  l: Integer;
+begin
+{$IFNDEF CIL}
+  l := SizeOf(Result);
+  if FIP6Used then
+    SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_UNICAST_HOPS, @Result, l))
+  else
+    SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l));
+  ExceptCheck;
+{$ENDIF}
+end;
+
+procedure TBlockSocket.SetFamily(Value: TSocketFamily);
+begin
+  FFamily := Value;
+  FFamilySave := Value;
+end;
+
+procedure TBlockSocket.SetSocket(Value: TSocket);
+begin
+  FRecvCounter := 0;
+  FSendCounter := 0;
+  FSocket := Value;
+{$IFNDEF CIL}
+  FD_ZERO(FFDSet);
+  FD_SET(FSocket, FFDSet);
+{$ENDIF}
+  GetSins;
+  FIP6Used := FRemoteSin.AddressFamily = AF_INET6;
+end;
+
+function TBlockSocket.GetWsaData: TWSAData;
+begin
+  {$IFDEF ONCEWINSOCK}
+  Result := WsaDataOnce;
+  {$ELSE}
+  Result := FWsaDataOnce;
+  {$ENDIF}
+end;
+
+function TBlockSocket.GetSocketType: integer;
+begin
+  Result := 0;
+end;
+
+function TBlockSocket.GetSocketProtocol: integer;
+begin
+  Result := integer(IPPROTO_IP);
+end;
+
+procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
+begin
+  if assigned(OnStatus) then
+    OnStatus(Self, Reason, Value);
+  if Reason = HR_SocketClose then
+    FDisconnected := True;
+end;
+
+procedure TBlockSocket.DoReadFilter(Buffer: TMemory; var Len: Integer);
+var
+  s: string;
+begin
+  if assigned(OnReadFilter) then
+    if Len > 0 then
+      begin
+        {$IFDEF CIL}
+        s := StringOf(Buffer);
+        {$ELSE}
+        SetLength(s, Len);
+        Move(Buffer^, Pointer(s)^, Len);
+        {$ENDIF}
+        OnReadFilter(Self, s);
+        if s.Length > Len then
+          SetLength(s, Len);
+        Len := s.Length;
+        {$IFDEF CIL}
+        Buffer := BytesOf(s);
+        {$ELSE}
+        Move(Pointer(s)^, Buffer^, Len);
+        {$ENDIF}
+      end;
+end;
+
+procedure TBlockSocket.DoCreateSocket;
+begin
+  if assigned(OnCreateSocket) then
+    OnCreateSocket(Self);
+end;
+
+procedure TBlockSocket.DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer);
+begin
+  if assigned(OnMonitor) then
+  begin
+    OnMonitor(Self, Writing, Buffer, Len);
+  end;
+end;
+
+procedure TBlockSocket.DoHeartbeat;
+begin
+  if assigned(OnHeartbeat) and (FHeartbeatRate <> 0) then
+  begin
+    OnHeartbeat(Self);
+  end;
+end;
+
+function TBlockSocket.GetErrorDescEx: string;
+begin
+  Result := GetErrorDesc(FLastError);
+end;
+
+class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
+begin
+{$IFDEF CIL}
+  if ErrorCode = 0 then
+    Result := ''
+  else
+  begin
+    Result := WSAGetLastErrorDesc;
+    if Result = '' then
+      Result := 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
+  end;
+{$ELSE}
+  case ErrorCode of
+    0:
+      Result := '';
+    WSAEINTR: {10004}
+      Result := 'Interrupted system call';
+    WSAEBADF: {10009}
+      Result := 'Bad file number';
+    WSAEACCES: {10013}
+      Result := 'Permission denied';
+    WSAEFAULT: {10014}
+      Result := 'Bad address';
+    WSAEINVAL: {10022}
+      Result := 'Invalid argument';
+    WSAEMFILE: {10024}
+      Result := 'Too many open files';
+    WSAEWOULDBLOCK: {10035}
+      Result := 'Operation would block';
+    WSAEINPROGRESS: {10036}
+      Result := 'Operation now in progress';
+    WSAEALREADY: {10037}
+      Result := 'Operation already in progress';
+    WSAENOTSOCK: {10038}
+      Result := 'Socket operation on nonsocket';
+    WSAEDESTADDRREQ: {10039}
+      Result := 'Destination address required';
+    WSAEMSGSIZE: {10040}
+      Result := 'Message too long';
+    WSAEPROTOTYPE: {10041}
+      Result := 'Protocol wrong type for Socket';
+    WSAENOPROTOOPT: {10042}
+      Result := 'Protocol not available';
+    WSAEPROTONOSUPPORT: {10043}
+      Result := 'Protocol not supported';
+    WSAESOCKTNOSUPPORT: {10044}
+      Result := 'Socket not supported';
+    WSAEOPNOTSUPP: {10045}
+      Result := 'Operation not supported on Socket';
+    WSAEPFNOSUPPORT: {10046}
+      Result := 'Protocol family not supported';
+    WSAEAFNOSUPPORT: {10047}
+      Result := 'Address family not supported';
+    WSAEADDRINUSE: {10048}
+      Result := 'Address already in use';
+    WSAEADDRNOTAVAIL: {10049}
+      Result := 'Can''t assign requested address';
+    WSAENETDOWN: {10050}
+      Result := 'Network is down';
+    WSAENETUNREACH: {10051}
+      Result := 'Network is unreachable';
+    WSAENETRESET: {10052}
+      Result := 'Network dropped connection on reset';
+    WSAECONNABORTED: {10053}
+      Result := 'Software caused connection abort';
+    WSAECONNRESET: {10054}
+      Result := 'Connection reset by peer';
+    WSAENOBUFS: {10055}
+      Result := 'No Buffer space available';
+    WSAEISCONN: {10056}
+      Result := 'Socket is already connected';
+    WSAENOTCONN: {10057}
+      Result := 'Socket is not connected';
+    WSAESHUTDOWN: {10058}
+      Result := 'Can''t send after Socket shutdown';
+    WSAETOOMANYREFS: {10059}
+      Result := 'Too many references:can''t splice';
+    WSAETIMEDOUT: {10060}
+      Result := 'Connection timed out';
+    WSAECONNREFUSED: {10061}
+      Result := 'Connection refused';
+    WSAELOOP: {10062}
+      Result := 'Too many levels of symbolic links';
+    WSAENAMETOOLONG: {10063}
+      Result := 'File name is too long';
+    WSAEHOSTDOWN: {10064}
+      Result := 'Host is down';
+    WSAEHOSTUNREACH: {10065}
+      Result := 'No route to host';
+    WSAENOTEMPTY: {10066}
+      Result := 'Directory is not empty';
+    WSAEPROCLIM: {10067}
+      Result := 'Too many processes';
+    WSAEUSERS: {10068}
+      Result := 'Too many users';
+    WSAEDQUOT: {10069}
+      Result := 'Disk quota exceeded';
+    WSAESTALE: {10070}
+      Result := 'Stale NFS file handle';
+    WSAEREMOTE: {10071}
+      Result := 'Too many levels of remote in path';
+    WSASYSNOTREADY: {10091}
+      Result := 'Network subsystem is unusable';
+    WSAVERNOTSUPPORTED: {10092}
+      Result := 'Winsock DLL cannot support this application';
+    WSANOTINITIALISED: {10093}
+      Result := 'Winsock not initialized';
+    WSAEDISCON: {10101}
+      Result := 'Disconnect';
+    WSAHOST_NOT_FOUND: {11001}
+      Result := 'Host not found';
+    WSATRY_AGAIN: {11002}
+      Result := 'Non authoritative - host not found';
+    WSANO_RECOVERY: {11003}
+      Result := 'Non recoverable error';
+    WSANO_DATA: {11004}
+      Result := 'Valid name, no data record of requested type'
+  else
+    Result := SysErrorMessage(ErrorCode) // 'Other Winsock error (' + IntToStr(ErrorCode) + ')';
+  end;
+{$ENDIF}
+end;
+
+{======================================================================}
+
+constructor TSocksBlockSocket.Create;
+begin
+  inherited Create;
+  FSocksIP:= '';
+  FSocksPort:= '1080';
+  FSocksTimeout:= 60000;
+  FSocksUsername:= '';
+  FSocksPassword:= '';
+  FUsingSocks := False;
+  FSocksResolver := True;
+  FSocksLastError := 0;
+  FSocksResponseIP := '';
+  FSocksResponsePort := '';
+  FSocksLocalIP := '';
+  FSocksLocalPort := '';
+  FSocksRemoteIP := '';
+  FSocksRemotePort := '';
+  FBypassFlag := False;
+  FSocksType := ST_Socks5;
+end;
+
+function TSocksBlockSocket.SocksOpen: boolean;
+var
+  Buf: string;
+  n: integer;
+begin
+  Result := False;
+  FUsingSocks := False;
+  if FSocksType <> ST_Socks5 then
+  begin
+    FUsingSocks := True;
+    Result := True;
+  end
+  else
+  begin
+    FBypassFlag := True;
+    try
+      if FSocksUsername = '' then
+        Buf := #5 + #1 + #0
+      else
+        Buf := #5 + #2 + #2 +#0;
+      SendString(Buf);
+      Buf := RecvBufferStr(2, FSocksTimeout);
+      if Buf.Length < 2 then
+        Exit;
+      if Buf[1] <> #5 then
+        Exit;
+      n := Ord(Buf[2]);
+      case n of
+        0: //not need authorisation
+          ;
+        2:
+          begin
+            buf := #1 + Char(Length(FSocksUsername)) + FSocksUsername +
+              Char(Length(FSocksPassword)) + FSocksPassword;
+            SendString(Buf);
+            Buf := RecvBufferStr(2, FSocksTimeout);
+            if Length(Buf) < 2 then
+              Exit;
+            if Buf[2] <> #0 then
+              Exit;
+          end;
+      else
+        //other authorisation is not supported!
+        Exit;
+      end;
+      FUsingSocks := True;
+      Result := True;
+    finally
+      FBypassFlag := False;
+    end;
+  end;
+end;
+
+function TSocksBlockSocket.SocksRequest(Cmd: Byte;
+  const IP, Port: string): Boolean;
+var
+  buf: string;
+begin
+  FBypassFlag := True;
+  try
+    if FSocksType <> ST_Socks5 then
+      Buf := #4 + Char(Cmd) + SocksCode(IP, Port)
+    else
+      Buf := #5 + Char(Cmd) + #0 + SocksCode(IP, Port);
+    SendString(Buf);
+    Result := FLastError = 0;
+  finally
+    FBypassFlag := False;
+  end;
+end;
+
+function TSocksBlockSocket.SocksResponse: Boolean;
+var
+  Buf, s, m, z: string;
+  x: integer;
+begin
+  Result := False;
+  FBypassFlag := True;
+  try
+    FSocksResponseIP := '';
+    FSocksResponsePort := '';
+    FSocksLastError := -1;
+    if FSocksType <> ST_Socks5 then
+    begin
+      Buf := RecvBufferStr(8, FSocksTimeout);
+      if FLastError <> 0 then
+        Exit;
+      if Buf[1] <> #0 then
+        Exit;
+      FSocksLastError := Ord(Buf[2]);
+    end
+    else
+    begin
+      Buf := RecvBufferStr(4, FSocksTimeout);
+      if FLastError <> 0 then
+        Exit;
+      if Buf[1] <> #5 then
+        Exit;
+      case Ord(Buf[4]) of
+        1:
+          s := RecvBufferStr(4, FSocksTimeout);
+        3:
+          begin
+            x := RecvByte(FSocksTimeout);
+            if FLastError <> 0 then
+              Exit;
+            s := Char(x) + RecvBufferStr(x, FSocksTimeout);
+          end;
+        4:
+          s := RecvBufferStr(16, FSocksTimeout);
+      else
+        Exit;
+      end;
+      Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
+      if FLastError <> 0 then
+        Exit;
+      FSocksLastError := Ord(Buf[2]);
+    end;
+    //---
+    if ((FSocksLastError <> 0) and (FSocksLastError <> $5A{90})) then
+    begin
+      case FSocksLastError of // http://en.wikipedia.org/wiki/SOCKS
+        // v4
+        $5a: m := 'request granted';
+        $5b: m := 'request rejected or failed';
+        $5c: m := 'request failed because client is not running identd (or not reachable from the server)';
+        $5d: m := 'request failed because client''s identd could not confirm the user ID string in the request';
+        // v5'
+        $00: m := 'request grant`ed';
+        $01: m := 'general failure';
+        $02: m := 'connection not allowed by ruleset';
+        $03: m := 'network unreachable';
+        $04: m := 'host unreachable';
+        $05: m := 'connection refused by destination host';
+        $06: m := 'TTL expired';
+        $07: m := 'command not supported / protocol error';
+        $08: m := 'address type not supported';
+        else
+          m := '';
+      end;
+      z := SysUtils.Format('Error 0x%x', [FSocksLastError]);
+      if m<>'' then
+        z := z + ' ' + m;
+      Exit;
+    end;
+    SocksDecode(Buf);
+    Result := True;
+  finally
+    FBypassFlag := False;
+  end;
+end;
+
+function TSocksBlockSocket.SocksCode(IP: string; const Port: string): string;
+var
+  ip6: TIp6Bytes;
+  n: integer;
+begin
+  if FSocksType <> ST_Socks5 then
+  begin
+    Result := CodeInt(ResolvePort(Port));
+    if not FSocksResolver then
+      IP := ResolveName(IP);
+    if IsIP(IP) then
+    begin
+      Result := Result + IPToID(IP);
+      Result := Result + FSocksUsername + #0;
+    end
+    else
+    begin
+      Result := Result + IPToID('0.0.0.1');
+      Result := Result + FSocksUsername + #0;
+      Result := Result + IP + #0;
+    end;
+  end
+  else
+  begin
+    if not FSocksResolver then
+      IP := ResolveName(IP);
+    if IsIP(IP) then
+      Result := #1 + IPToID(IP)
+    else
+      if IsIP6(IP) then
+      begin
+        ip6 := StrToIP6(IP);
+        Result := #4;
+        for n := 0 to 15 do
+          Result := Result + Char(ip6[n]);
+      end
+      else
+        Result := #3 + Char(Length(IP)) + IP;
+    Result := Result + CodeInt(ResolvePort(Port));
+  end;
+end;
+
+  function TSocksBlockSocket.SocksDecode(const Value: string): integer;
+var
+  Atyp: Byte;
+  y, n: integer;
+  w: Word;
+  ip6: TIp6Bytes;
+begin
+  FSocksResponsePort := '0';
+  Result := 0;
+  if FSocksType <> ST_Socks5 then
+  begin
+    if Length(Value) < 8 then
+      Exit;
+    Result := 3;
+    w := DecodeInt(Value, Result);
+    FSocksResponsePort := IntToStr(w);
+    FSocksResponseIP := Format('%d.%d.%d.%d',
+      [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
+    Result := 9;
+  end
+  else
+  begin
+    if Length(Value) < 4 then
+      Exit;
+    Atyp := Ord(Value[4]);
+    Result := 5;
+    case Atyp of
+      1:
+        begin
+          if Length(Value) < 10 then
+            Exit;
+          FSocksResponseIP := Format('%d.%d.%d.%d',
+              [Ord(Value[5]), Ord(Value[6]), Ord(Value[7]), Ord(Value[8])]);
+          Result := 9;
+        end;
+      3:
+        begin
+          y := Ord(Value[5]);
+          if Length(Value) < (5 + y + 2) then
+            Exit;
+          for n := 6 to 6 + y - 1 do
+            FSocksResponseIP := FSocksResponseIP + Value[n];
+          Result := 5 + y + 1;
+        end;
+      4:
+        begin
+          if Length(Value) < 22 then
+            Exit;
+          for n := 0 to 15 do
+            ip6[n] := ord(Value[n + 5]);
+          FSocksResponseIP := IP6ToStr(ip6);
+          Result := 21;
+        end;
+    else
+      Exit;
+    end;
+    w := DecodeInt(Value, Result);
+    FSocksResponsePort := IntToStr(w);
+    Result := Result + 2;
+  end;
+end;
+
+{======================================================================}
+
+procedure TDgramBlockSocket.Connect(const IP, Port: string);
+begin
+  SetRemoteSin(IP, Port);
+  InternalCreateSocket(FRemoteSin);
+  if UseConnect then
+  begin
+    SockCheck(synsock.Connect(FSocket, FRemoteSin));
+    if FLastError = 0 then
+      GetSins;
+  end;    
+  FBuffer := '';
+  DoStatus(HR_Connect, IP + ':' + Port);
+end;
+
+function TDgramBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer;
+begin
+  Result := RecvBufferFrom(Buffer, Length);
+end;
+
+function TDgramBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer;
+begin
+  Result := SendBufferTo(Buffer, Length);
+end;
+
+{======================================================================}
+
+destructor TUDPBlockSocket.Destroy;
+begin
+  if Assigned(FSocksControlSock) then
+    FSocksControlSock.Free;
+  inherited;
+end;
+
+procedure TUDPBlockSocket.EnableBroadcast(Value: Boolean);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_Broadcast;
+  d.Enabled := Value;
+  DelayedOption(d);
+end;
+
+function TUDPBlockSocket.UdpAssociation: Boolean;
+var
+  b: Boolean;
+begin
+  Result := True;
+  FUsingSocks := False;
+  if FSocksIP <> '' then
+  begin
+    Result := False;
+    if not Assigned(FSocksControlSock) then
+      FSocksControlSock := TTCPBlockSocket.Create;
+    FSocksControlSock.CloseSocket;
+    FSocksControlSock.CreateSocketByName(FSocksIP);
+    FSocksControlSock.Connect(FSocksIP, FSocksPort);
+    if FSocksControlSock.LastError <> 0 then
+      Exit;
+    // if not assigned local port, assign it!
+    if not FBinded then
+      Bind(cAnyHost, cAnyPort);
+    //open control TCP connection to SOCKS
+    FSocksControlSock.FSocksUsername := FSocksUsername;
+    FSocksControlSock.FSocksPassword := FSocksPassword;
+    b := FSocksControlSock.SocksOpen;
+    if b then
+      b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
+    if b then
+      b := FSocksControlSock.SocksResponse;
+    if not b and (FLastError = 0) then
+      FLastError := WSANO_RECOVERY;
+    FUsingSocks :=FSocksControlSock.UsingSocks;
+    FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
+    FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
+    Result := b and (FLastError = 0);
+  end;
+end;
+
+function TUDPBlockSocket.SendBufferTo(const Buffer: TMemory; Length: Integer): Integer;
+var
+  SIp: string;
+  SPort: integer;
+  Buf: string;
+begin
+  Result := 0;
+  FUsingSocks := False;
+  if (FSocksIP <> '') and (not UdpAssociation) then
+    FLastError := WSANO_RECOVERY
+  else
+  begin
+    if FUsingSocks then
+    begin
+{$IFNDEF CIL}
+      Sip := GetRemoteSinIp;
+      SPort := GetRemoteSinPort;
+      SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
+      SetLength(Buf,Length);
+      Move(Buffer^, Pointer(Buf)^, Length);
+      Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
+      Result := inherited SendBufferTo(Pointer(Buf), buf.Length);
+      SetRemoteSin(Sip, IntToStr(SPort));
+{$ENDIF}
+    end
+    else
+      Result := inherited SendBufferTo(Buffer, Length);
+  end;
+end;
+
+function TUDPBlockSocket.RecvBufferFrom(Buffer: TMemory; Length: Integer): Integer;
+var
+  Buf: string;
+  x: integer;
+begin
+  Result := inherited RecvBufferFrom(Buffer, Length);
+  if FUsingSocks then
+  begin
+{$IFNDEF CIL}
+    SetLength(Buf, Result);
+    Move(Buffer^, Pointer(Buf)^, Result);
+    x := SocksDecode(Buf);
+    Result := Result - x + 1;
+    Buf := Copy(Buf, x, Result);
+    Move(Pointer(Buf)^, Buffer^, Result);
+    SetRemoteSin(FSocksResponseIP, FSocksResponsePort);
+{$ENDIF}
+  end;
+end;
+
+{$IFNDEF CIL}
+procedure TUDPBlockSocket.AddMulticast(const MCastIP:string);
+var
+  Multicast: TIP_mreq;
+  Multicast6: TIPv6_mreq;
+  n: integer;
+  ip6: Tip6bytes;
+begin
+  if FIP6Used then
+  begin
+    ip6 := StrToIp6(MCastIP);
+    for n := 0 to 15 do
+{$IFNDEF POSIX}
+      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
+{$ELSE}
+      Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n];
+{$ENDIF}
+    Multicast6.ipv6mr_interface := 0;
+    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP,
+      Pointer(@Multicast6), SizeOf(Multicast6)));
+  end
+  else
+  begin
+    Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
+//    Multicast.imr_interface.S_addr := INADDR_ANY;
+    Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr;
+    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP,
+      Pointer(@Multicast), SizeOf(Multicast)));
+  end;
+  ExceptCheck;
+end;
+
+procedure TUDPBlockSocket.DropMulticast(const MCastIP:string);
+var
+  Multicast: TIP_mreq;
+  Multicast6: TIPv6_mreq;
+  n: integer;
+  ip6: Tip6bytes;
+begin
+  if FIP6Used then
+  begin
+    ip6 := StrToIp6(MCastIP);
+    for n := 0 to 15 do
+{$IFNDEF POSIX}
+      Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n];
+{$ELSE}
+      Multicast6.ipv6mr_multiaddr.s6_addr[n] := Ip6[n];
+{$ENDIF}
+
+    Multicast6.ipv6mr_interface := 0;
+    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP,
+      Pointer(@Multicast6), SizeOf(Multicast6)));
+  end
+  else
+  begin
+    Multicast.imr_multiaddr.S_addr := swapbytes(strtoip(MCastIP));
+//    Multicast.imr_interface.S_addr := INADDR_ANY;
+    Multicast.imr_interface.S_addr := FLocalSin.sin_addr.S_addr;
+    SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP,
+      Pointer(@Multicast), SizeOf(Multicast)));
+  end;
+  ExceptCheck;
+end;
+{$ENDIF}
+
+procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_MulticastTTL;
+  d.Value := TTL;
+  DelayedOption(d);
+end;
+
+function TUDPBlockSocket.GetMulticastTTL:integer;
+var
+  l: Integer;
+begin
+{$IFNDEF CIL}
+  l := SizeOf(Result);
+  if FIP6Used then
+    SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, @Result, l))
+  else
+    SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l));
+    ExceptCheck;
+{$ENDIF}
+end;
+
+procedure TUDPBlockSocket.EnableMulticastLoop(Value: Boolean);
+var
+  d: TSynaOption;
+begin
+  d := TSynaOption.Create;
+  d.Option := SOT_MulticastLoop;
+  d.Enabled := Value;
+  DelayedOption(d);
+end;
+
+function TUDPBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_DGRAM);
+end;
+
+function TUDPBlockSocket.GetSocketProtocol: integer;
+begin
+ Result := integer(IPPROTO_UDP);
+end;
+
+{======================================================================}
+constructor TTCPBlockSocket.CreateWithSSL(SSLPlugin: TSSLClass);
+begin
+  inherited Create;
+  FSSL := SSLPlugin.Create(self);
+  FHTTPTunnelIP := '';
+  FHTTPTunnelPort := '';
+  FHTTPTunnel := False;
+  FHTTPTunnelRemoteIP := '';
+  FHTTPTunnelRemotePort := '';
+  FHTTPTunnelUser := '';
+  FHTTPTunnelPass := '';
+  FHTTPTunnelTimeout := 30000;
+end;
+
+constructor TTCPBlockSocket.Create;
+begin
+  CreateWithSSL(SSLImplementation);
+end;
+
+destructor TTCPBlockSocket.Destroy;
+begin
+  inherited Destroy;
+  FSSL.Free;
+end;
+
+function TTCPBlockSocket.GetErrorDescEx: string;
+begin
+  Result := inherited GetErrorDescEx;
+  if (FLastError = WSASYSNOTREADY) and (self.SSL.LastError <> 0) then
+  begin
+    Result := self.SSL.LastErrorDesc;
+  end;
+end;
+
+const
+  SHUT_RDWR = 2;
+
+procedure TTCPBlockSocket.CloseSocket;
+begin
+  if FSSL.SSLEnabled then
+    FSSL.Shutdown;
+  if (FSocket <> INVALID_SOCKET) and (FLastError = 0) then
+  begin
+    SockCheck(Synsock.Shutdown(FSocket, SHUT_RDWR));
+    //ExceptCheck;
+    Purge;
+    SetLinger(True, 0);
+  end;
+  inherited CloseSocket;
+end;
+
+procedure TTCPBlockSocket.DoAfterConnect;
+begin
+  if Assigned(OnAfterConnect) then
+  begin
+    OnAfterConnect(Self);
+  end;
+end;
+
+function TTCPBlockSocket.WaitingData: Integer;
+begin
+  Result := 0;
+  if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then
+    Result := FSSL.WaitingData;
+  if Result = 0 then
+    Result := inherited WaitingData;
+end;
+
+procedure TTCPBlockSocket.Listen;
+var
+  b: Boolean;
+  Sip,SPort: string;
+begin
+  if FSocksIP = '' then
+  begin
+    inherited Listen;
+  end
+  else
+  begin
+    Sip := GetLocalSinIP;
+    if Sip = cAnyHost then
+      Sip := LocalName;
+    SPort := IntToStr(GetLocalSinPort);
+    inherited Connect(FSocksIP, FSocksPort);
+    b := SocksOpen;
+    if b then
+      b := SocksRequest(2, Sip, SPort);
+    if b then
+      b := SocksResponse;
+    if not b and (FLastError = 0) then
+      FLastError := WSANO_RECOVERY;
+    FSocksLocalIP := FSocksResponseIP;
+    if FSocksLocalIP = cAnyHost then
+      FSocksLocalIP := FSocksIP;
+    FSocksLocalPort := FSocksResponsePort;
+    FSocksRemoteIP := '';
+    FSocksRemotePort := '';
+    ExceptCheck;
+    DoStatus(HR_Listen, '');
+  end;
+end;
+
+function TTCPBlockSocket.Accept: TSocket;
+begin
+  if FUsingSocks then
+  begin
+    if not SocksResponse and (FLastError = 0) then
+      FLastError := WSANO_RECOVERY;
+    FSocksRemoteIP := FSocksResponseIP;
+    FSocksRemotePort := FSocksResponsePort;
+    Result := FSocket;
+    ExceptCheck;
+    DoStatus(HR_Accept, '');
+  end
+  else
+  begin
+    result := inherited Accept;
+  end;
+end;
+
+procedure TTCPBlockSocket.Connect(const IP, Port: string);
+begin
+  FDisconnected := False;
+  if FSocksIP <> '' then
+    SocksDoConnect(IP, Port)
+  else
+    if FHTTPTunnelIP <> '' then
+      HTTPTunnelDoConnect(IP, Port)
+    else
+      inherited Connect(IP, Port);
+  if FLasterror = 0 then
+    DoAfterConnect;
+end;
+
+function TTCPBlockSocket.Connected: boolean;
+begin
+ Result := (FSocket <> INVALID_SOCKET) and not FDisconnected;
+ {$IFNDEF UNIX}
+ if Result then
+ begin
+  CanRead(0);
+  Result := not FDisconnected;
+ end;
+ {$ENDIF}
+end;
+
+procedure TTCPBlockSocket.SocksDoConnect(const IP, Port: string);
+var
+  b: Boolean;
+begin
+  inherited Connect(FSocksIP, FSocksPort);
+  if FLastError = 0 then
+  begin
+    b := SocksOpen;
+    if b then
+      b := SocksRequest(1, IP, Port);
+    if b then
+      b := SocksResponse;
+    if not b and (FLastError = 0) then
+      FLastError := WSASYSNOTREADY;
+    FSocksLocalIP := FSocksResponseIP;
+    FSocksLocalPort := FSocksResponsePort;
+    FSocksRemoteIP := IP;
+    FSocksRemotePort := Port;
+  end;
+  ExceptCheck;
+  DoStatus(HR_Connect, IP + ':' + Port);
+end;
+
+procedure TTCPBlockSocket.HTTPTunnelDoConnect(IP, Port: string);
+//bugfixed by Mike Green ([email protected])
+var
+  s: string;
+begin
+  Port := IntToStr(ResolvePort(Port));
+  inherited Connect(FHTTPTunnelIP, FHTTPTunnelPort);
+  if FLastError <> 0 then
+    Exit;
+  FHTTPTunnel := False;
+  if IsIP6(IP) then
+    IP := '[' + IP + ']';
+  SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
+  if FHTTPTunnelUser <> '' then
+  Sendstring('Proxy-Authorization: Basic ' +
+    EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
+  SendString(CRLF);
+  repeat
+    s := RecvTerminated(FHTTPTunnelTimeout, #$0a);
+    if FLastError <> 0 then
+      Break;
+    if (Pos('HTTP/', s) = 1) and (Length(s) > 11) then
+      FHTTPTunnel := s[10] = '2';
+  until (s = '') or (s = #$0d);
+  if (FLasterror = 0) and not FHTTPTunnel then
+    FLastError := WSAECONNREFUSED;
+  FHTTPTunnelRemoteIP := IP;
+  FHTTPTunnelRemotePort := Port;
+  ExceptCheck;
+end;
+
+procedure TTCPBlockSocket.SSLDoConnect;
+begin
+  ResetLastError;
+  if not FSSL.Connect then
+    FLastError := WSASYSNOTREADY;
+  ExceptCheck;
+end;
+
+procedure TTCPBlockSocket.SSLDoShutdown;
+begin
+  ResetLastError;
+  FSSL.BiShutdown;
+end;
+
+function TTCPBlockSocket.GetLocalSinIP: string;
+begin
+  if FUsingSocks then
+    Result := FSocksLocalIP
+  else
+    Result := inherited GetLocalSinIP;
+end;
+
+function TTCPBlockSocket.GetRemoteSinIP: string;
+begin
+  if FUsingSocks then
+    Result := FSocksRemoteIP
+  else
+    if FHTTPTunnel then
+      Result := FHTTPTunnelRemoteIP
+    else
+      Result := inherited GetRemoteSinIP;
+end;
+
+function TTCPBlockSocket.GetLocalSinPort: Integer;
+begin
+  if FUsingSocks then
+    Result := StrToIntDef(FSocksLocalPort, 0)
+  else
+    Result := inherited GetLocalSinPort;
+end;
+
+function TTCPBlockSocket.GetRemoteSinPort: Integer;
+begin
+  if FUsingSocks then
+    Result := ResolvePort(FSocksRemotePort)
+  else
+    if FHTTPTunnel then
+      Result := StrToIntDef(FHTTPTunnelRemotePort, 0)
+    else
+      Result := inherited GetRemoteSinPort;
+end;
+
+function TTCPBlockSocket.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  if FSSL.SSLEnabled then
+  begin
+    Result := 0;
+    if TestStopFlag then
+      Exit;
+    ResetLastError;
+    LimitBandwidth(Len, FMaxRecvBandwidth, FNextRecv);
+    Result := FSSL.RecvBuffer(Buffer, Len);
+    if FSSL.LastError <> 0 then
+      FLastError := WSASYSNOTREADY;
+    ExceptCheck;
+    Inc(FRecvCounter, Result);
+    DoStatus(HR_ReadCount, IntToStr(Result));
+    DoMonitor(False, Buffer, Result);
+    DoReadFilter(Buffer, Result);
+  end
+  else
+    Result := inherited RecvBuffer(Buffer, Len);
+end;
+
+function TTCPBlockSocket.SendBuffer(const Buffer: TMemory; Length: Integer): Integer;
+var
+  x, y: integer;
+  l, r: integer;
+{$IFNDEF CIL}
+  p: Pointer;
+{$ENDIF}
+begin
+  if FSSL.SSLEnabled then
+  begin
+    Result := 0;
+    if TestStopFlag then
+      Exit;
+    ResetLastError;
+    DoMonitor(True, Buffer, Length);
+{$IFDEF CIL}
+    Result := FSSL.SendBuffer(Buffer, Length);
+    if FSSL.LastError <> 0 then
+      FLastError := WSASYSNOTREADY;
+    Inc(FSendCounter, Result);
+    DoStatus(HR_WriteCount, IntToStr(Result));
+{$ELSE}
+    l := Length;
+    x := 0;
+    while x < l do
+    begin
+      y := l - x;
+      if y > FSendMaxChunk then
+        y := FSendMaxChunk;
+      if y > 0 then
+      begin
+        LimitBandwidth(y, FMaxSendBandwidth, FNextsend);
+        p := IncPoint(Buffer, x);
+        r := FSSL.SendBuffer(p, y);
+        if FSSL.LastError <> 0 then
+          FLastError := WSASYSNOTREADY;
+        if Flasterror <> 0 then
+          Break;
+        Inc(x, r);
+        Inc(Result, r);
+        Inc(FSendCounter, r);
+        DoStatus(HR_WriteCount, IntToStr(r));
+      end
+      else
+        break;
+    end;
+{$ENDIF}
+    ExceptCheck;
+  end
+  else
+    Result := inherited SendBuffer(Buffer, Length);
+end;
+
+function TTCPBlockSocket.SSLAcceptConnection: Boolean;
+begin
+  ResetLastError;
+  if not FSSL.Accept then
+    FLastError := WSASYSNOTREADY;
+  ExceptCheck;
+  Result := FLastError = 0;
+end;
+
+function TTCPBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_STREAM);
+end;
+
+function TTCPBlockSocket.GetSocketProtocol: integer;
+begin
+  Result := integer(IPPROTO_TCP);
+end;
+
+{======================================================================}
+
+function TICMPBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_RAW);
+end;
+
+function TICMPBlockSocket.GetSocketProtocol: integer;
+begin
+  if FIP6Used then
+    Result := integer(IPPROTO_ICMPV6)
+  else
+    Result := integer(IPPROTO_ICMP);
+end;
+
+{======================================================================}
+
+function TRAWBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_RAW);
+end;
+
+function TRAWBlockSocket.GetSocketProtocol: integer;
+begin
+  Result := integer(IPPROTO_RAW);
+end;
+
+{======================================================================}
+
+function TPGMmessageBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_RDM);
+end;
+
+function TPGMmessageBlockSocket.GetSocketProtocol: integer;
+begin
+  Result := integer(IPPROTO_RM);
+end;
+
+{======================================================================}
+
+function TPGMstreamBlockSocket.GetSocketType: integer;
+begin
+  Result := integer(SOCK_STREAM);
+end;
+
+function TPGMstreamBlockSocket.GetSocketProtocol: integer;
+begin
+  Result := integer(IPPROTO_RM);
+end;
+
+{======================================================================}
+
+constructor TSynaClient.Create;
+begin
+  inherited Create;
+  FIPInterface := cAnyHost;
+  FTargetHost := cLocalhost;
+  FTargetPort := cAnyPort;
+  FTimeout := 5000;
+  FUsername := '';
+  FPassword := '';
+end;
+
+{======================================================================}
+
+constructor TCustomSSL.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create;
+  FSocket := Value;
+  FSSLEnabled := False;
+  FUsername := '';
+  FPassword := '';
+  FLastError := 0;
+  FLastErrorDesc := '';
+  FVerifyCert := False;
+  FSSLType := LT_all;
+  FKeyPassword := '';
+  FCiphers := '';
+  FCertificateFile := '';
+  FPrivateKeyFile := '';
+  FCertCAFile := '';
+  FCertCA := '';
+  FTrustCertificate := '';
+  FTrustCertificateFile := '';
+  FCertificate := '';
+  FPrivateKey := '';
+  FPFX := '';
+  FPFXfile := '';
+  FSSHChannelType := '';
+  FSSHChannelArg1 := '';
+  FSSHChannelArg2 := '';
+  FCertComplianceLevel := -1; //default
+  FSNIHost := '';
+end;
+
+procedure TCustomSSL.Assign(const Value: TCustomSSL);
+begin
+  FUsername := Value.Username;
+  FPassword := Value.Password;
+  FVerifyCert := Value.VerifyCert;
+  FSSLType := Value.SSLType;
+  FKeyPassword := Value.KeyPassword;
+  FCiphers := Value.Ciphers;
+  FCertificateFile := Value.CertificateFile;
+  FPrivateKeyFile := Value.PrivateKeyFile;
+  FCertCAFile := Value.CertCAFile;
+  FCertCA := Value.CertCA;
+  FTrustCertificate := Value.TrustCertificate;
+  FTrustCertificateFile := Value.TrustCertificateFile;
+  FCertificate := Value.Certificate;
+  FPrivateKey := Value.PrivateKey;
+  FPFX := Value.PFX;
+  FPFXfile := Value.PFXfile;
+  FCertComplianceLevel := Value.CertComplianceLevel;
+  FSNIHost := Value.FSNIHost;
+end;
+
+procedure TCustomSSL.ReturnError;
+begin
+  FLastError := -1;
+  FLastErrorDesc := 'SSL/TLS support is not compiled!';
+end;
+
+function TCustomSSL.LibVersion: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.LibName: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.CreateSelfSignedCert(Host: string): Boolean;
+begin
+  Result := False;
+end;
+
+function TCustomSSL.Connect: boolean;
+begin
+  ReturnError;
+  Result := False;
+end;
+
+function TCustomSSL.Accept: boolean;
+begin
+  ReturnError;
+  Result := False;
+end;
+
+function TCustomSSL.Shutdown: boolean;
+begin
+  ReturnError;
+  Result := False;
+end;
+
+function TCustomSSL.BiShutdown: boolean;
+begin
+  ReturnError;
+  Result := False;
+end;
+
+function TCustomSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  ReturnError;
+  Result := integer(SOCKET_ERROR);
+end;
+
+procedure TCustomSSL.SetCertCAFile(const Value: string);
+begin
+  FCertCAFile := Value;
+end;
+
+function TCustomSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  ReturnError;
+  Result := integer(SOCKET_ERROR);
+end;
+
+function TCustomSSL.WaitingData: Integer;
+begin
+  ReturnError;
+  Result := 0;
+end;
+
+function TCustomSSL.GetSSLVersion: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetPeerSubject: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetPeerSerialNo: integer;
+begin
+  Result := -1;
+end;
+
+function TCustomSSL.GetPeerName: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetPeerNameHash: cardinal;
+begin
+  Result := 0;
+end;
+
+function TCustomSSL.GetPeerIssuer: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetPeerFingerprint: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetCertInfo: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetCipherName: string;
+begin
+  Result := '';
+end;
+
+function TCustomSSL.GetCipherBits: integer;
+begin
+  Result := 0;
+end;
+
+function TCustomSSL.GetCipherAlgBits: integer;
+begin
+  Result := 0;
+end;
+
+function TCustomSSL.GetVerifyCert: integer;
+begin
+  Result := 1;
+end;
+
+function TCustomSSL.DoVerifyCert:boolean;
+begin
+  if assigned(OnVerifyCert) then
+  begin
+    result:=OnVerifyCert(Self);
+  end
+  else
+    result:=true;
+end;
+
+
+{======================================================================}
+
+function TSSLNone.LibVersion: string;
+begin
+  Result := 'Without SSL support';
+end;
+
+function TSSLNone.LibName: string;
+begin
+  Result := 'ssl_none';
+end;
+
+{======================================================================}
+
+initialization
+begin
+{$IFDEF ONCEWINSOCK}
+  if not InitSocketInterface(DLLStackName) then
+  begin
+    e := ESynapseError.Create('Error loading Socket interface (' + DLLStackName + ')!');
+    e.ErrorCode := 0;
+    e.ErrorMessage := 'Error loading Socket interface (' + DLLStackName + ')!';
+    raise e;
+  end;
+  synsock.WSAStartup(WinsockLevel, WsaDataOnce);
+{$ENDIF}
+end;
+
+finalization
+begin
+{$IFDEF ONCEWINSOCK}
+  synsock.WSACleanup;
+  DestroySocketInterface;
+{$ENDIF}
+end;
+
+end.

clamsend.pas

@@ -0,0 +1,277 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.001 |
+|==============================================================================|
+| Content: ClamAV-daemon client                                                |
+|==============================================================================|
+| Copyright (c)2005-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract( ClamAV-daemon client)
+
+This unit is capable to do antivirus scan of your data by TCP channel to ClamD
+daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit clamsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synsock, blcksock, synautil;
+
+const
+  cClamProtocol = '3310';
+
+type
+
+  {:@abstract(Implementation of ClamAV-daemon client protocol)
+   By this class you can scan any your data by ClamAV opensource antivirus.
+
+   This class can connect to ClamD by TCP channel, send your data to ClamD
+   and read result.}
+  TClamSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FDSock: TTCPBlockSocket;
+    FSession: boolean;
+    function Login: boolean; virtual;
+    function Logout: Boolean; virtual;
+    function OpenStream: Boolean; virtual;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Call any command to ClamD. Used internally by other methods.}
+    function DoCommand(const Value: AnsiString): AnsiString; virtual;
+
+    {:Return ClamAV version and version of loaded databases.}
+    function GetVersion: AnsiString; virtual;
+
+    {:Scan content of TStrings.}
+    function ScanStrings(const Value: TStrings): AnsiString; virtual;
+
+    {:Scan content of TStream.}
+    function ScanStream(const Value: TStream): AnsiString; virtual;
+
+    {:Scan content of TStrings by new 0.95 API.}
+    function ScanStrings2(const Value: TStrings): AnsiString; virtual;
+
+    {:Scan content of TStream by new 0.95 API.}
+    function ScanStream2(const Value: TStream): AnsiString; virtual;
+  published
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
+    property DSock: TTCPBlockSocket read FDSock;
+
+    {:Can turn-on session mode of communication with ClamD. Default is @false,
+     because ClamAV developers design their TCP code very badly and session mode
+     is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
+     and this mode will be possible in future.}
+    property Session: boolean read FSession write FSession;
+  end;
+
+implementation
+
+constructor TClamSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FDSock := TTCPBlockSocket.Create;
+  FDSock.Owner := self;
+  FTimeout := 60000;
+  FTargetPort := cClamProtocol;
+  FSession := false;
+end;
+
+destructor TClamSend.Destroy;
+begin
+  Logout;
+  FDSock.Free;
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.SendString(Value + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.SendString(Value + LF)
+    else
+      Exit;
+  end;
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+function TClamSend.Login: boolean;
+begin
+  Result := False;
+  Sock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  if FSession then
+    FSock.SendString('SESSION' + LF);
+  Result := FSock.LastError = 0;
+end;
+
+function TClamSend.Logout: Boolean;
+begin
+  FSock.SendString('END' + LF);
+  Result := FSock.LastError = 0;
+  FSock.CloseSocket;
+end;
+
+function TClamSend.GetVersion: AnsiString;
+begin
+  Result := DoCommand('nVERSION');
+end;
+
+function TClamSend.OpenStream: Boolean;
+var
+  S: AnsiString;
+begin
+  Result := False;
+  s := DoCommand('nSTREAM');
+  if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
+  begin
+    s := SeparateRight(s, ' ');
+    FDSock.CloseSocket;
+    FDSock.Bind(FIPInterface, cAnyPort);
+    if FDSock.LastError <> 0 then
+      Exit;
+    FDSock.Connect(FTargetHost, s);
+    if FDSock.LastError <> 0 then
+      Exit;
+    Result := True;
+  end;
+end;
+
+function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
+begin
+  Result := '';
+  if OpenStream then
+  begin
+    DSock.SendString(Value.Text);
+    DSock.CloseSocket;
+    Result := FSock.RecvTerminated(FTimeout, LF);
+  end;
+end;
+
+function TClamSend.ScanStream(const Value: TStream): AnsiString;
+begin
+  Result := '';
+  if OpenStream then
+  begin
+    DSock.SendStreamRaw(Value);
+    DSock.CloseSocket;
+    Result := FSock.RecvTerminated(FTimeout, LF);
+  end;
+end;
+
+function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.sendstring('nINSTREAM' + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.sendstring('nINSTREAM' + LF)
+    else
+      Exit;
+  end;
+  s := Value.text;
+  i := length(s);
+  FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+function TClamSend.ScanStream2(const Value: TStream): AnsiString;
+var
+  i: integer;
+begin
+  Result := '';
+  if not FSession then
+    FSock.CloseSocket
+  else
+    FSock.sendstring('nINSTREAM' + LF);
+  if not FSession or (FSock.LastError <> 0) then
+  begin
+    if Login then
+      FSock.sendstring('nINSTREAM' + LF)
+    else
+      Exit;
+  end;
+  i := value.Size;
+  FSock.SendString(CodeLongint(i));
+  FSock.SendStreamRaw(Value);
+  FSock.SendString(#0#0#0#0);
+  Result := FSock.RecvTerminated(FTimeout, LF);
+end;
+
+end.

dnssend.pas

@@ -0,0 +1,603 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.007.006 |
+|==============================================================================|
+| Content: DNS client                                                          |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+{: @abstract(DNS client by UDP or TCP)
+Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
+ transfers too!
+
+Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit dnssend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synaip, synsock;
+
+const
+  cDnsProtocol = '53';
+
+  QTYPE_A = 1;
+  QTYPE_NS = 2;
+  QTYPE_MD = 3;
+  QTYPE_MF = 4;
+  QTYPE_CNAME = 5;
+  QTYPE_SOA = 6;
+  QTYPE_MB = 7;
+  QTYPE_MG = 8;
+  QTYPE_MR = 9;
+  QTYPE_NULL = 10;
+  QTYPE_WKS = 11; //
+  QTYPE_PTR = 12;
+  QTYPE_HINFO = 13;
+  QTYPE_MINFO = 14;
+  QTYPE_MX = 15;
+  QTYPE_TXT = 16;
+
+  QTYPE_RP = 17;
+  QTYPE_AFSDB = 18;
+  QTYPE_X25 = 19;
+  QTYPE_ISDN = 20;
+  QTYPE_RT = 21;
+  QTYPE_NSAP = 22;
+  QTYPE_NSAPPTR = 23;
+  QTYPE_SIG = 24; // RFC-2065
+  QTYPE_KEY = 25; // RFC-2065
+  QTYPE_PX = 26;
+  QTYPE_GPOS = 27;
+  QTYPE_AAAA = 28;
+  QTYPE_LOC = 29; // RFC-1876
+  QTYPE_NXT = 30; // RFC-2065
+
+  QTYPE_SRV = 33;
+  QTYPE_NAPTR = 35; // RFC-2168
+  QTYPE_KX = 36;
+  QTYPE_SPF = 99;
+
+  QTYPE_AXFR = 252;
+  QTYPE_MAILB = 253; //
+  QTYPE_MAILA = 254; //
+  QTYPE_ALL = 255;
+
+type
+  {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TDNSSend = class(TSynaClient)
+  private
+    FID: Word;
+    FRCode: Integer;
+    FBuffer: AnsiString;
+    FSock: TUDPBlockSocket;
+    FTCPSock: TTCPBlockSocket;
+    FUseTCP: Boolean;
+    FAnswerInfo: TStringList;
+    FNameserverInfo: TStringList;
+    FAdditionalInfo: TStringList;
+    FAuthoritative: Boolean;
+    FTruncated: Boolean;
+    function CompressName(const Value: AnsiString): AnsiString;
+    function CodeHeader: AnsiString;
+    function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
+    function DecodeLabels(var From: Integer): AnsiString;
+    function DecodeString(var From: Integer): AnsiString;
+    function DecodeResource(var i: Integer; const Info: TStringList;
+      QType: Integer): AnsiString;
+    function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
+    function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
+      QType: Integer):boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Query a DNSHost for QType resources correspond to a name. Supported QType
+     values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
+     Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
+     Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
+     Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
+     Qtype_KX.
+
+     Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
+
+     "Name" is domain name or host name for queried resource. If "name" is
+     IP address, automatically convert to reverse domain form (.in-addr.arpa).
+
+     If result is @true, Reply contains resource records. One record on one line.
+     If Resource record have multiple fields, they are stored on line divided by
+     comma. (example: MX record contains value 'rs.cesnet.cz' with preference
+     number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
+     in resource are converted to string form.}
+    function DNSQuery(Name: AnsiString; QType: Integer;
+      const Reply: TStrings): Boolean;
+  published
+
+    {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TUDPBlockSocket read FSock;
+
+    {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
+    property TCPSock: TTCPBlockSocket read FTCPSock;
+
+    {:if @true, then is used TCP protocol instead UDP. It is needed for zone
+     transfers, etc.}
+    property UseTCP: Boolean read FUseTCP Write FUseTCP;
+
+    {:After DNS operation contains ResultCode of DNS operation.
+      Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
+      4-not implemented, 5-refused.}
+    property RCode: Integer read FRCode;
+
+    {:@True, if answer is authoritative.}
+    property Authoritative: Boolean read FAuthoritative;
+
+    {:@True, if answer is truncated to 512 bytes.}
+    property Truncated: Boolean read FTRuncated;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed information about query reply.}
+    property AnswerInfo: TStringList read FAnswerInfo;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed information about nameserver.}
+    property NameserverInfo: TStringList read FNameserverInfo;
+
+    {:Detailed informations from name server reply. One record per line. Record
+     have comma delimited entries with type number, TTL and data filelds.
+     This information contains detailed additional information.}
+    property AdditionalInfo: TStringList read FAdditionalInfo;
+  end;
+
+{:A very useful function, and example of it's use is found in the TDNSSend object.
+ This function is used to get mail servers for a domain and sort them by
+ preference numbers. "Servers" contains only the domain names of the mail
+ servers in the right order (without preference number!). The first domain name
+ will always be the highest preferenced mail server. Returns boolean @TRUE if
+ all went well.}
+function GetMailServers(const DNSHost, Domain: AnsiString;
+  const Servers: TStrings): Boolean;
+
+implementation
+
+constructor TDNSSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FSock.Owner := self;
+  FTCPSock := TTCPBlockSocket.Create;
+  FTCPSock.Owner := self;
+  FUseTCP := False;
+  FTimeout := 10000;
+  FTargetPort := cDnsProtocol;
+  FAnswerInfo := TStringList.Create;
+  FNameserverInfo := TStringList.Create;
+  FAdditionalInfo := TStringList.Create;
+  Randomize;
+end;
+
+destructor TDNSSend.Destroy;
+begin
+  FAnswerInfo.Free;
+  FNameserverInfo.Free;
+  FAdditionalInfo.Free;
+  FTCPSock.Free;
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
+var
+  n: Integer;
+  s: AnsiString;
+begin
+  Result := '';
+  if Value = '' then
+    Result := #0
+  else
+  begin
+    s := '';
+    for n := 1 to Length(Value) do
+      if Value[n] = '.' then
+      begin
+        Result := Result + AnsiChar(Length(s)) + s;
+        s := '';
+      end
+      else
+        s := s + Value[n];
+    if s <> '' then
+      Result := Result + AnsiChar(Length(s)) + s;
+    Result := Result + #0;
+  end;
+end;
+
+function TDNSSend.CodeHeader: AnsiString;
+begin
+  FID := Random(32767);
+  Result := CodeInt(FID); // ID
+  Result := Result + CodeInt($0100); // flags
+  Result := Result + CodeInt(1); // QDCount
+  Result := Result + CodeInt(0); // ANCount
+  Result := Result + CodeInt(0); // NSCount
+  Result := Result + CodeInt(0); // ARCount
+end;
+
+function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
+begin
+  Result := CompressName(Name);
+  Result := Result + CodeInt(QType);
+  Result := Result + CodeInt(1); // Type INTERNET
+end;
+
+function TDNSSend.DecodeString(var From: Integer): AnsiString;
+var
+  Len: integer;
+begin
+  Len := Ord(FBuffer[From]);
+  Inc(From);
+  Result := Copy(FBuffer, From, Len);
+  Inc(From, Len);
+end;
+
+function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
+var
+  l, f: Integer;
+begin
+  Result := '';
+  while True do
+  begin
+    if From >= Length(FBuffer) then
+      Break;
+    l := Ord(FBuffer[From]);
+    Inc(From);
+    if l = 0 then
+      Break;
+    if Result <> '' then
+      Result := Result + '.';
+    if (l and $C0) = $C0 then
+    begin
+      f := l and $3F;
+      f := f * 256 + Ord(FBuffer[From]) + 1;
+      Inc(From);
+      Result := Result + DecodeLabels(f);
+      Break;
+    end
+    else
+    begin
+      Result := Result + Copy(FBuffer, From, l);
+      Inc(From, l);
+    end;
+  end;
+end;
+
+function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
+  QType: Integer): AnsiString;
+var
+  Rname: AnsiString;
+  RType, Len, j, x, y, z, n: Integer;
+  R: AnsiString;
+  t1, t2, ttl: integer;
+  ip6: TIp6bytes;
+begin
+  Result := '';
+  R := '';
+  Rname := DecodeLabels(i);
+  RType := DecodeInt(FBuffer, i);
+  Inc(i, 4);
+  t1 := DecodeInt(FBuffer, i);
+  Inc(i, 2);
+  t2 := DecodeInt(FBuffer, i);
+  Inc(i, 2);
+  ttl := t1 * 65536 + t2;
+  Len := DecodeInt(FBuffer, i);
+  Inc(i, 2); // i point to begin of data
+  j := i;
+  i := i + len; // i point to next record
+  if Length(FBuffer) >= (i - 1) then
+    case RType of
+      QTYPE_A:
+        begin
+          R := IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+          Inc(j);
+          R := R + '.' + IntToStr(Ord(FBuffer[j]));
+        end;
+      QTYPE_AAAA:
+        begin
+          for n := 0 to 15 do
+            ip6[n] := ord(FBuffer[j + n]);
+          R := IP6ToStr(ip6);
+        end;
+      QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
+        QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
+        QTYPE_NSAPPTR:
+        R := DecodeLabels(j);
+      QTYPE_SOA:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+          for n := 1 to 5 do
+          begin
+            x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
+            Inc(j, 4);
+            R := R + ',' + IntToStr(x);
+          end;
+        end;
+      QTYPE_NULL:
+        begin
+        end;
+      QTYPE_WKS:
+        begin
+        end;
+      QTYPE_HINFO:
+        begin
+          R := DecodeString(j);
+          R := R + ',' + DecodeString(j);
+        end;
+      QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_TXT, QTYPE_SPF:
+        begin
+          R := '';
+          while j < i do
+            R := R + DecodeString(j);
+        end;
+      QTYPE_GPOS:
+        begin
+          R := DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_PX:
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);
+          R := R + ',' + DecodeLabels(j);
+          R := R + ',' + DecodeLabels(j);
+        end;
+      QTYPE_SRV:
+      // Author: Dan <[email protected]>
+        begin
+          x := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          y := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          z := DecodeInt(FBuffer, j);
+          Inc(j, 2);
+          R := IntToStr(x);                     // Priority
+          R := R + ',' + IntToStr(y);           // Weight
+          R := R + ',' + IntToStr(z);           // Port
+          R := R + ',' + DecodeLabels(j);       // Server DNS Name
+        end;
+    end;
+  if R <> '' then
+    Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
+  if QType = RType then
+    Result := R;
+end;
+
+function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
+var
+  l: integer;
+begin
+  Result := '';
+  l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
+  if l > 0 then
+    Result := WorkSock.RecvBufferStr(l, FTimeout);
+end;
+
+function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
+  QType: Integer):boolean;
+var
+  n, i: Integer;
+  flag, qdcount, ancount, nscount, arcount: Integer;
+  s: AnsiString;
+begin
+  Result := False;
+  Reply.Clear;
+  FAnswerInfo.Clear;
+  FNameserverInfo.Clear;
+  FAdditionalInfo.Clear;
+  FAuthoritative := False;
+  if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
+  begin
+    Result := True;
+    flag := DecodeInt(Buf, 3);
+    FRCode := Flag and $000F;
+    FAuthoritative := (Flag and $0400) > 0;
+    FTruncated := (Flag and $0200) > 0;
+    if FRCode = 0 then
+    begin
+      qdcount := DecodeInt(Buf, 5);
+      ancount := DecodeInt(Buf, 7);
+      nscount := DecodeInt(Buf, 9);
+      arcount := DecodeInt(Buf, 11);
+      i := 13; //begin of body
+      if (qdcount > 0) and (Length(Buf) > i) then //skip questions
+        for n := 1 to qdcount do
+        begin
+          while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
+            Inc(i);
+          Inc(i, 5);
+        end;
+      if (ancount > 0) and (Length(Buf) > i) then // decode reply
+        for n := 1 to ancount do
+        begin
+          s := DecodeResource(i, FAnswerInfo, QType);
+          if s <> '' then
+            Reply.Add(s);
+        end;
+      if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
+        for n := 1 to nscount do
+          DecodeResource(i, FNameserverInfo, QType);
+      if (arcount > 0) and (Length(Buf) > i) then // decode additional info
+        for n := 1 to arcount do
+          DecodeResource(i, FAdditionalInfo, QType);
+    end;
+  end;
+end;
+
+function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
+  const Reply: TStrings): Boolean;
+var
+  WorkSock: TBlockSocket;
+  t: TStringList;
+  b: boolean;
+begin
+  Result := False;
+  if IsIP(Name) then
+    Name := ReverseIP(Name) + '.in-addr.arpa';
+  if IsIP6(Name) then
+    Name := ReverseIP6(Name) + '.ip6.arpa';
+  FBuffer := CodeHeader + CodeQuery(Name, QType);
+  if FUseTCP then
+    WorkSock := FTCPSock
+  else
+    WorkSock := FSock;
+  WorkSock.Bind(FIPInterface, cAnyPort);
+  WorkSock.Connect(FTargetHost, FTargetPort);
+  if FUseTCP then
+    FBuffer := Codeint(length(FBuffer)) + FBuffer;
+  WorkSock.SendString(FBuffer);
+  if FUseTCP then
+    FBuffer := RecvTCPResponse(WorkSock)
+  else
+    FBuffer := WorkSock.RecvPacket(FTimeout);
+  if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
+  begin
+    t := TStringList.Create;
+    try
+      repeat
+        b := DecodeResponse(FBuffer, Reply, QType);
+        if (t.Count > 1) and (AnswerInfo.Count > 0) then  //find end of transfer
+          b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
+        if b then
+        begin
+          t.AddStrings(AnswerInfo);
+          FBuffer := RecvTCPResponse(WorkSock);
+          if FBuffer = '' then
+            Break;
+          if WorkSock.LastError <> 0 then
+            Break;
+        end;
+      until not b;
+      Reply.Assign(t);
+      Result := True;
+    finally
+      t.free;
+    end;
+  end
+  else //normal query
+    if WorkSock.LastError = 0 then
+      Result := DecodeResponse(FBuffer, Reply, QType);
+end;
+
+{==============================================================================}
+
+function GetMailServers(const DNSHost, Domain: AnsiString;
+  const Servers: TStrings): Boolean;
+var
+  DNS: TDNSSend;
+  t: TStringList;
+  n, m, x: Integer;
+begin
+  Result := False;
+  Servers.Clear;
+  t := TStringList.Create;
+  DNS := TDNSSend.Create;
+  try
+    DNS.TargetHost := DNSHost;
+    if DNS.DNSQuery(Domain, QType_MX, t) then
+    begin
+      { normalize preference number to 5 digits }
+      for n := 0 to t.Count - 1 do
+      begin
+        x := Pos(',', t[n]);
+        if x > 0 then
+          for m := 1 to 6 - x do
+            t[n] := '0' + t[n];
+      end;
+      { sort server list }
+      t.Sorted := True;
+      { result is sorted list without preference numbers }
+      for n := 0 to t.Count - 1 do
+      begin
+        x := Pos(',', t[n]);
+        Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
+      end;
+      Result := True;
+    end;
+  finally
+    DNS.Free;
+    t.Free;
+  end;
+end;
+
+end.

ftpsend.pas

@@ -0,0 +1,1964 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 004.000.000 |
+|==============================================================================|
+| Content: FTP client                                                          |
+|==============================================================================|
+| Copyright (c)1999-2011, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2010.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Petr Esner <[email protected]>                                           |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(FTP client protocol)
+
+Used RFC: RFC-959, RFC-2228, RFC-2428
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$TYPEINFO ON}// Borland changed defualt Visibility from Public to Published
+                // and it requires RTTI to be generated $M+
+{$M+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit ftpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synaip, synsock;
+
+const
+  cFtpProtocol = '21';
+  cFtpDataProtocol = '20';
+
+  {:Terminating value for TLogonActions}
+  FTP_OK = 255;
+  {:Terminating value for TLogonActions}
+  FTP_ERR = 254;
+
+type
+  {:Array for holding definition of logon sequence.}
+  TLogonActions = array [0..17] of byte;
+
+  {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object.
+   Value is FTP command or reply to this comand. (if it is reply, Response
+   is @True).}
+  TFTPStatus = procedure(Sender: TObject; Response: Boolean;
+    const Value: string) of object;
+
+  {: @abstract(Object for holding file information) parsed from directory
+   listing of FTP server.}
+  TFTPListRec = class(TObject)
+  private
+    FFileName: String;
+    FDirectory: Boolean;
+    FReadable: Boolean;
+    FFileSize: int64;
+    FFileTime: TDateTime;
+    FOriginalLine: string;
+    FMask: string;
+    FPermission: String;
+  public
+    {: You can assign another TFTPListRec to this object.}
+    procedure Assign(Value: TFTPListRec); virtual;
+    {:name of file}
+    property FileName: string read FFileName write FFileName;
+    {:if name is subdirectory not file.}
+    property Directory: Boolean read FDirectory write FDirectory;
+    {:if you have rights to read}
+    property Readable: Boolean read FReadable write FReadable;
+    {:size of file in bytes}
+    property FileSize: int64 read FFileSize write FFileSize;
+    {:date and time of file. Local server timezone is used. Any timezone
+     conversions was not done!}
+    property FileTime: TDateTime read FFileTime write FFileTime;
+    {:original unparsed line}
+    property OriginalLine: string read FOriginalLine write FOriginalLine;
+    {:mask what was used for parsing}
+    property Mask: string read FMask write FMask;
+    {:permission string (depending on used mask!)}
+    property Permission: string read FPermission write FPermission;
+  end;
+
+  {:@abstract(This is TList of TFTPListRec objects.)
+   This object is used for holding lististing of all files information in listed
+   directory on FTP server.}
+  TFTPList = class(TObject)
+  protected
+    FList: TList;
+    FLines: TStringList;
+    FMasks: TStringList;
+    FUnparsedLines: TStringList;
+    Monthnames: string;
+    BlockSize: string;
+    DirFlagValue: string;
+    FileName: string;
+    VMSFileName: string;
+    Day: string;
+    Month: string;
+    ThreeMonth: string;
+    YearTime: string;
+    Year: string;
+    Hours: string;
+    HoursModif: string;
+    Minutes: string;
+    Seconds: string;
+    Size: string;
+    Permissions: string;
+    DirFlag: string;
+    function GetListItem(Index: integer): TFTPListRec; virtual;
+    function ParseEPLF(Value: string): Boolean; virtual;
+    procedure ClearStore; virtual;
+    function ParseByMask(Value, NextValue, Mask: string): Integer; virtual;
+    function CheckValues: Boolean; virtual;
+    procedure FillRecord(const Value: TFTPListRec); virtual;
+  public
+    {:Constructor. You not need create this object, it is created by TFTPSend
+     class as their property.}
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Clear list.}
+    procedure Clear; virtual;
+
+    {:count of holded @link(TFTPListRec) objects}
+    function Count: integer; virtual;
+
+    {:Assigns one list to another}
+    procedure Assign(Value: TFTPList); virtual;
+
+    {:try to parse raw directory listing in @link(lines) to list of
+     @link(TFTPListRec).}
+    procedure ParseLines; virtual;
+
+    {:By this property you have access to list of @link(TFTPListRec).
+     This is for compatibility only. Please, use @link(Items) instead.}
+    property List: TList read FList;
+
+    {:By this property you have access to list of @link(TFTPListRec).}
+    property Items[Index: Integer]: TFTPListRec read GetListItem; default;
+
+    {:Set of lines with RAW directory listing for @link(parseLines)}
+    property Lines: TStringList read FLines;
+
+    {:Set of masks for directory listing parser. It is predefined by default,
+    however you can modify it as you need. (for example, you can add your own
+    definition mask.) Mask is same as mask used in TotalCommander.}
+    property Masks: TStringList read FMasks;
+
+    {:After @link(ParseLines) it holding lines what was not sucessfully parsed.}
+    property UnparsedLines: TStringList read FUnparsedLines;
+  end;
+
+  {:@abstract(Implementation of FTP protocol.)
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object! (Username and Password have default values
+   for "anonymous" FTP login)
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TFTPSend = class(TSynaClient)
+  protected
+    FOnStatus: TFTPStatus;
+    FSock: TTCPBlockSocket;
+    FDSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FAccount: string;
+    FFWHost: string;
+    FFWPort: string;
+    FFWUsername: string;
+    FFWPassword: string;
+    FFWMode: integer;
+    FDataStream: TMemoryStream;
+    FDataIP: string;
+    FDataPort: string;
+    FDirectFile: Boolean;
+    FDirectFileName: string;
+    FCanResume: Boolean;
+    FPassiveMode: Boolean;
+    FForceDefaultPort: Boolean;
+    FForceOldPort: Boolean;
+    FFtpList: TFTPList;
+    FBinaryMode: Boolean;
+    FAutoTLS: Boolean;
+    FIsTLS: Boolean;
+    FIsDataTLS: Boolean;
+    FTLSonData: Boolean;
+    FFullSSL: Boolean;
+    function Auth(Mode: integer): Boolean; virtual;
+    function Connect: Boolean; virtual;
+    function InternalStor(const Command: string; RestoreAt: int64): Boolean; virtual;
+    function DataSocket: Boolean; virtual;
+    function AcceptDataSocket: Boolean; virtual;
+    procedure DoStatus(Response: Boolean; const Value: string); virtual;
+  public
+    {:Custom definition of login sequence. You can use this when you set
+     @link(FWMode) to value -1.}
+    CustomLogon: TLogonActions;
+
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Waits and read FTP server response. You need this only in special cases!}
+    function ReadResult: Integer; virtual;
+
+    {:Parse remote side information of data channel from value string (returned
+     by PASV command). This function you need only in special cases!}
+    procedure ParseRemote(Value: string); virtual;
+
+    {:Parse remote side information of data channel from value string (returned
+     by EPSV command). This function you need only in special cases!}
+    procedure ParseRemoteEPSV(Value: string); virtual;
+
+    {:Send Value as FTP command to FTP server. Returned result code is result of
+     this function.
+     This command is good for sending site specific command, or non-standard
+     commands.}
+    function FTPCommand(const Value: string): integer; virtual;
+
+    {:Connect and logon to FTP server. If you specify any FireWall, connect to
+     firewall and throw them connect to FTP server. Login sequence depending on
+     @link(FWMode).}
+    function Login: Boolean; virtual;
+
+    {:Logoff and disconnect from FTP server.}
+    function Logout: Boolean; virtual;
+
+    {:Break current transmission of data. (You can call this method from
+     Sock.OnStatus event, or from another thread.)}
+    procedure Abort; virtual;
+
+    {:Break current transmission of data. It is same as Abort, but it send abort
+     telnet commands prior ABOR FTP command. Some servers need it. (You can call
+     this method from Sock.OnStatus event, or from another thread.)}
+    procedure TelnetAbort; virtual;
+
+    {:Download directory listing of Directory on FTP server. If Directory is
+     empty string, download listing of current working directory.
+     If NameList is @true, download only names of files in directory.
+     (internally use NLST command instead LIST command)
+     If NameList is @false, returned list is also parsed to @link(FTPList)
+     property.}
+    function List(Directory: string; NameList: Boolean): Boolean; virtual;
+
+    {:Read data from FileName on FTP server. If Restore is @true and server
+     supports resume dowloads, download is resumed. (received is only rest
+     of file)}
+    function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual;
+
+    {:Send data to FileName on FTP server. If Restore is @true and server
+     supports resume upload, upload is resumed. (send only rest of file)
+     In this case if remote file is same length as local file, nothing will be
+     done. If remote file is larger then local, resume is disabled and file is
+     transfered from begin!}
+    function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual;
+
+    {:Send data to FTP server and assing unique name for this file.}
+    function StoreUniqueFile: Boolean; virtual;
+
+    {:Append data to FileName on FTP server.}
+    function AppendFile(const FileName: string): Boolean; virtual;
+
+    {:Rename on FTP server file with OldName to NewName.}
+    function RenameFile(const OldName, NewName: string): Boolean; virtual;
+
+    {:Delete file FileName on FTP server.}
+    function DeleteFile(const FileName: string): Boolean; virtual;
+
+    {:Return size of Filename file on FTP server. If command failed (i.e. not
+     implemented), return -1.}
+    function FileSize(const FileName: string): int64; virtual;
+
+    {:Send NOOP command to FTP server for preserve of disconnect by inactivity
+     timeout.}
+    function NoOp: Boolean; virtual;
+
+    {:Change currect working directory to Directory on FTP server.}
+    function ChangeWorkingDir(const Directory: string): Boolean; virtual;
+
+    {:walk to upper directory on FTP server.}
+    function ChangeToParentDir: Boolean; virtual;
+
+    {:walk to root directory on FTP server. (May not work with all servers properly!)}
+    function ChangeToRootDir: Boolean; virtual;
+
+    {:Delete Directory on FTP server.}
+    function DeleteDir(const Directory: string): Boolean; virtual;
+
+    {:Create Directory on FTP server.}
+    function CreateDir(const Directory: string): Boolean; virtual;
+
+    {:Return current working directory on FTP server.}
+    function GetCurrentDir: String; virtual;
+
+    {:Establish data channel to FTP server and retrieve data.
+     This function you need only in special cases, i.e. when you need to implement
+     some special unsupported FTP command!}
+    function DataRead(const DestStream: TStream): Boolean; virtual;
+
+    {:Establish data channel to FTP server and send data.
+     This function you need only in special cases, i.e. when you need to implement
+     some special unsupported FTP command.}
+    function DataWrite(const SourceStream: TStream): Boolean; virtual;
+  published
+    {:After FTP command contains result number of this operation.}
+    property ResultCode: Integer read FResultCode;
+
+    {:After FTP command contains main line of result.}
+    property ResultString: string read FResultString;
+
+    {:After any FTP command it contains all lines of FTP server reply.}
+    property FullResult: TStringList read FFullResult;
+
+    {:Account information used in some cases inside login sequence.}
+    property Account: string read FAccount Write FAccount;
+
+    {:Address of firewall. If empty string (default), firewall not used.}
+    property FWHost: string read FFWHost Write FFWHost;
+
+    {:port of firewall. standard value is same port as ftp server used. (21)}
+    property FWPort: string read FFWPort Write FFWPort;
+
+    {:Username for login to firewall. (if needed)}
+    property FWUsername: string read FFWUsername Write FFWUsername;
+
+    {:password for login to firewall. (if needed)}
+    property FWPassword: string read FFWPassword Write FFWPassword;
+
+    {:Type of Firewall. Used only if you set some firewall address. Supported
+     predefined firewall login sequences are described by comments in source
+     file where you can see pseudocode decribing each sequence.}
+    property FWMode: integer read FFWMode Write FFWMode;
+
+    {:Socket object used for TCP/IP operation on control channel. Good for
+     seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:Socket object used for TCP/IP operation on data channel. Good for seting
+     OnStatus hook, etc.}
+    property DSock: TTCPBlockSocket read FDSock;
+
+    {:If you not use @link(DirectFile) mode, all data transfers is made to or
+     from this stream.}
+    property DataStream: TMemoryStream read FDataStream;
+
+    {:After data connection is established, contains remote side IP of this
+     connection.}
+    property DataIP: string read FDataIP;
+
+    {:After data connection is established, contains remote side port of this
+     connection.}
+    property DataPort: string read FDataPort;
+
+    {:Mode of data handling by data connection. If @False, all data operations
+     are made to or from @link(DataStream) TMemoryStream.
+     If @true, data operations is made directly to file in your disk. (filename
+     is specified by @link(DirectFileName) property.) Dafault is @False!}
+    property DirectFile: Boolean read FDirectFile Write FDirectFile;
+
+    {:Filename for direct disk data operations.}
+    property DirectFileName: string read FDirectFileName Write FDirectFileName;
+
+    {:Indicate after @link(Login) if remote server support resume downloads and
+     uploads.}
+    property CanResume: Boolean read FCanResume;
+
+    {:If true (default value), all transfers is made by passive method.
+     It is safer method for various firewalls.}
+    property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;
+
+    {:Force to listen for dataconnection on standard port (20). Default is @false,
+     dataconnections will be made to any non-standard port reported by PORT FTP
+     command. This setting is not used, if you use passive mode.}
+    property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
+
+    {:When is @true, then is disabled EPSV and EPRT support. However without this
+     commands you cannot use IPv6! (Disabling of this commands is needed only
+     when you are behind some crap firewall/NAT.}
+    property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort;
+
+    {:You may set this hook for monitoring FTP commands and replies.}
+    property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
+
+    {:After LIST command is here parsed list of files in given directory.}
+    property FtpList: TFTPList read FFtpList;
+
+    {:if @true (default), then data transfers is in binary mode. If this is set
+     to @false, then ASCII mode is used.}
+    property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;
+
+    {:if is true, then if server support upgrade to SSL/TLS mode, then use them.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:if server listen on SSL/TLS port, then you set this to true.}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Signalise, if control channel is in SSL/TLS mode.}
+    property IsTLS: Boolean read FIsTLS;
+
+    {:Signalise, if data transfers is in SSL/TLS mode.}
+    property IsDataTLS: Boolean read FIsDataTLS;
+
+    {:If @true (default), then try to use SSL/TLS on data transfers too.
+     If @false, then SSL/TLS is used only for control connection.}
+    property TLSonData: Boolean read FTLSonData write FTLSonData;
+  end;
+
+{:A very useful function, and example of use can be found in the TFtpSend object.
+ Dowload specified file from FTP server to LocalFile.}
+function FtpGetFile(const IP, Port, FileName, LocalFile,
+  User, Pass: string): Boolean;
+
+{:A very useful function, and example of use can be found in the TFtpSend object.
+ Upload specified LocalFile to FTP server.}
+function FtpPutFile(const IP, Port, FileName, LocalFile,
+  User, Pass: string): Boolean;
+
+{:A very useful function, and example of use can be found in the TFtpSend object.
+ Initiate transfer of file between two FTP servers.}
+function FtpInterServerTransfer(
+  const FromIP, FromPort, FromFile, FromUser, FromPass: string;
+  const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
+
+implementation
+
+constructor TFTPSend.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FDataStream := TMemoryStream.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.ConvertLineEnd := True;
+  FDSock := TTCPBlockSocket.Create;
+  FDSock.Owner := self;
+  FFtpList := TFTPList.Create;
+  FTimeout := 300000;
+  FTargetPort := cFtpProtocol;
+  FUsername := 'anonymous';
+  FPassword := 'anonymous@' + FSock.LocalName;
+  FDirectFile := False;
+  FPassiveMode := True;
+  FForceDefaultPort := False;
+  FForceOldPort := false;
+  FAccount := '';
+  FFWHost := '';
+  FFWPort := cFtpProtocol;
+  FFWUsername := '';
+  FFWPassword := '';
+  FFWMode := 0;
+  FBinaryMode := True;
+  FAutoTLS := False;
+  FFullSSL := False;
+  FIsTLS := False;
+  FIsDataTLS := False;
+  FTLSonData := True;
+end;
+
+destructor TFTPSend.Destroy;
+begin
+  FDSock.Free;
+  FSock.Free;
+  FFTPList.Free;
+  FDataStream.Free;
+  FFullResult.Free;
+  inherited Destroy;
+end;
+
+procedure TFTPSend.DoStatus(Response: Boolean; const Value: string);
+begin
+  if assigned(OnStatus) then
+    OnStatus(Self, Response, Value);
+end;
+
+function TFTPSend.ReadResult: Integer;
+var
+  s, c: string;
+begin
+  FFullResult.Clear;
+  c := '';
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if c = '' then
+      if length(s) > 3 then
+        if s[4] in [' ', '-'] then
+          c :=Copy(s, 1, 3);
+    FResultString := s;
+    FFullResult.Add(s);
+    DoStatus(True, s);
+    if FSock.LastError <> 0 then
+      Break;
+  until (c <> '') and (Pos(c + ' ', s) = 1);
+  Result := StrToIntDef(c, 0);
+  FResultCode := Result;
+end;
+
+function TFTPSend.FTPCommand(const Value: string): integer;
+begin
+  FSock.Purge;
+  FSock.SendString(Value + CRLF);
+  DoStatus(False, Value);
+  Result := ReadResult;
+end;
+
+// based on idea by Petr Esner <[email protected]>
+function TFTPSend.Auth(Mode: integer): Boolean;
+const
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action0: TLogonActions =
+    (0, FTP_OK, 3,
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if SITE <FTPServer> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action1: TLogonActions =
+    (3, 6, 3,
+     4, 6, FTP_ERR,
+     5, FTP_ERR, 9,
+     0, FTP_OK, 12,
+     1, FTP_OK, 15,
+     2, FTP_OK, FTP_ERR);
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if USER <UserName>'@'<FTPServer> then OK!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
+  Action2: TLogonActions =
+    (3, 6, 3,
+     4, 6, FTP_ERR,
+     6, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0);
+
+  //if not USER <FWusername> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action3: TLogonActions =
+    (3, 6, 3,
+     4, 6, FTP_ERR,
+     0, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0);
+
+  //OPEN <FTPserver>
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action4: TLogonActions =
+    (7, 3, 3,
+     0, FTP_OK, 6,
+     1, FTP_OK, 9,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0);
+
+  //if USER <UserName>'@'<FTPServer> then OK!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
+  Action5: TLogonActions =
+    (6, FTP_OK, 3,
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <FWUserName>@<FTPServer> then
+  //  if not PASS <FWPassword> then ERROR!
+  //if not USER <username> then
+  //  if not PASS <password> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action6: TLogonActions =
+    (8, 6, 3,
+     4, 6, FTP_ERR,
+     0, FTP_OK, 9,
+     1, FTP_OK, 12,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0);
+
+  //if USER <UserName>@<FTPServer> <FWUserName> then ERROR!
+  //if not PASS <password> then
+  //  if not ACCT <account> then ERROR!
+  //OK!
+  Action7: TLogonActions =
+    (9, FTP_ERR, 3,
+     1, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+
+  //if not USER <UserName>@<FWUserName>@<FTPServer> then
+  //  if not PASS <Password>@<FWPassword> then
+  //    if not ACCT <account> then ERROR!
+  //OK!
+  Action8: TLogonActions =
+    (10, FTP_OK, 3,
+     11, FTP_OK, 6,
+     2, FTP_OK, FTP_ERR,
+     0, 0, 0, 0, 0, 0, 0, 0, 0);
+var
+  FTPServer: string;
+  LogonActions: TLogonActions;
+  i: integer;
+  s: string;
+  x: integer;
+begin
+  Result := False;
+  if FFWHost = '' then
+    Mode := 0;
+  if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
+    FTPServer := FTargetHost
+  else
+    FTPServer := FTargetHost + ':' + FTargetPort;
+  case Mode of
+    -1:
+      LogonActions := CustomLogon;
+    1:
+      LogonActions := Action1;
+    2:
+      LogonActions := Action2;
+    3:
+      LogonActions := Action3;
+    4:
+      LogonActions := Action4;
+    5:
+      LogonActions := Action5;
+    6:
+      LogonActions := Action6;
+    7:
+      LogonActions := Action7;
+    8:
+      LogonActions := Action8;
+  else
+    LogonActions := Action0;
+  end;
+  i := 0;
+  repeat
+    case LogonActions[i] of
+      0:  s := 'USER ' + FUserName;
+      1:  s := 'PASS ' + FPassword;
+      2:  s := 'ACCT ' + FAccount;
+      3:  s := 'USER ' + FFWUserName;
+      4:  s := 'PASS ' + FFWPassword;
+      5:  s := 'SITE ' + FTPServer;
+      6:  s := 'USER ' + FUserName + '@' + FTPServer;
+      7:  s := 'OPEN ' + FTPServer;
+      8:  s := 'USER ' + FFWUserName + '@' + FTPServer;
+      9:  s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName;
+      10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer;
+      11: s := 'PASS ' + FPassword + '@' + FFWPassword;
+    end;
+    x := FTPCommand(s);
+    x := x div 100;
+    if (x <> 2) and (x <> 3) then
+      Exit;
+    i := LogonActions[i + x - 1];
+    case i of
+      FTP_ERR:
+        Exit;
+      FTP_OK:
+        begin
+          Result := True;
+          Exit;
+        end;
+    end;
+  until False;
+end;
+
+
+function TFTPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    if FFWHost = '' then
+      FSock.Connect(FTargetHost, FTargetPort)
+    else
+      FSock.Connect(FFWHost, FFWPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TFTPSend.Login: Boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  FCanResume := False;
+  if not Connect then
+    Exit;
+  FIsTLS := FFullSSL;
+  FIsDataTLS := False;
+  repeat
+    x := ReadResult div 100;
+  until x <> 1;
+  if x <> 2 then
+    Exit;
+  if FAutoTLS and not(FIsTLS) then
+    if (FTPCommand('AUTH TLS') div 100) = 2 then
+    begin
+      FSock.SSLDoConnect;
+      FIsTLS := FSock.LastError = 0;
+      if not FIsTLS then
+      begin
+        Result := False;
+        Exit;
+      end;
+    end;
+  if not Auth(FFWMode) then
+    Exit;
+  if FIsTLS then
+  begin
+    FTPCommand('PBSZ 0');
+    if FTLSonData then
+      FIsDataTLS := (FTPCommand('PROT P') div 100) = 2;
+    if not FIsDataTLS then
+      FTPCommand('PROT C');
+  end;
+  FTPCommand('TYPE I');
+  FTPCommand('STRU F');
+  FTPCommand('MODE S');
+  if FTPCommand('REST 0') = 350 then
+    if FTPCommand('REST 1') = 350 then
+    begin
+      FTPCommand('REST 0');
+      FCanResume := True;
+    end;
+  Result := True;
+end;
+
+function TFTPSend.Logout: Boolean;
+begin
+  Result := (FTPCommand('QUIT') div 100) = 2;
+  FSock.CloseSocket;
+end;
+
+procedure TFTPSend.ParseRemote(Value: string);
+var
+  n: integer;
+  nb, ne: integer;
+  s: string;
+  x: integer;
+begin
+  Value := trim(Value);
+  nb := Pos('(',Value);
+  ne := Pos(')',Value);
+  if (nb = 0) or (ne = 0) then
+  begin
+    nb:=RPos(' ',Value);
+    s:=Copy(Value, nb + 1, Length(Value) - nb);
+  end
+  else
+  begin
+    s:=Copy(Value,nb+1,ne-nb-1);
+  end;
+  for n := 1 to 4 do
+    if n = 1 then
+      FDataIP := Fetch(s, ',')
+    else
+      FDataIP := FDataIP + '.' + Fetch(s, ',');
+  x := StrToIntDef(Fetch(s, ','), 0) * 256;
+  x := x + StrToIntDef(Fetch(s, ','), 0);
+  FDataPort := IntToStr(x);
+end;
+
+procedure TFTPSend.ParseRemoteEPSV(Value: string);
+var
+  n: integer;
+  s, v: string;
+begin
+  s := SeparateRight(Value, '(');
+  s := Trim(SeparateLeft(s, ')'));
+  Delete(s, Length(s), 1);
+  v := '';
+  for n := Length(s) downto 1 do
+    if s[n] in ['0'..'9'] then
+      v := s[n] + v
+    else
+      Break;
+  FDataPort := v;
+  FDataIP := FTargetHost;
+end;
+
+function TFTPSend.DataSocket: boolean;
+var
+  s: string;
+begin
+  Result := False;
+  if FIsDataTLS then
+    FPassiveMode := True;
+  if FPassiveMode then
+  begin
+    if FSock.IP6used then
+      s := '2'
+    else
+      s := '1';
+    if FSock.IP6used and not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then
+    begin
+      ParseRemoteEPSV(FResultString);
+    end
+    else
+      if FSock.IP6used then
+        Exit
+      else
+      begin
+        if (FTPCommand('PASV') div 100) <> 2 then
+          Exit;
+        ParseRemote(FResultString);
+      end;
+    FDSock.CloseSocket;
+    FDSock.Bind(FIPInterface, cAnyPort);
+    FDSock.Connect(FDataIP, FDataPort);
+    Result := FDSock.LastError = 0;
+  end
+  else
+  begin
+    FDSock.CloseSocket;
+    if FForceDefaultPort then
+      s := cFtpDataProtocol
+    else
+      s := '0';
+    //data conection from same interface as command connection
+    FDSock.Bind(FSock.GetLocalSinIP, s);
+    if FDSock.LastError <> 0 then
+      Exit;
+    FDSock.SetLinger(True, 10000);
+    FDSock.Listen;
+    FDSock.GetSins;
+    FDataIP := FDSock.GetLocalSinIP;
+    FDataIP := FDSock.ResolveName(FDataIP);
+    FDataPort := IntToStr(FDSock.GetLocalSinPort);
+    if FSock.IP6used and (not FForceOldPort) then
+    begin
+      if IsIp6(FDataIP) then
+        s := '2'
+      else
+        s := '1';
+      s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|';
+      Result := (FTPCommand(s) div 100) = 2;
+    end;
+    if not Result and IsIP(FDataIP) then
+    begin
+      s := ReplaceString(FDataIP, '.', ',');
+      s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
+        + ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
+      Result := (FTPCommand(s) div 100) = 2;
+    end;
+  end;
+end;
+
+function TFTPSend.AcceptDataSocket: Boolean;
+var
+  x: TSocket;
+begin
+  if FPassiveMode then
+    Result := True
+  else
+  begin
+    Result := False;
+    if FDSock.CanRead(FTimeout) then
+    begin
+      x := FDSock.Accept;
+      if not FDSock.UsingSocks then
+        FDSock.CloseSocket;
+      FDSock.Socket := x;
+      Result := True;
+    end;
+  end;
+  if Result and FIsDataTLS then
+  begin
+    FDSock.SSL.Assign(FSock.SSL);
+    FDSock.SSLDoConnect;
+    Result := FDSock.LastError = 0;
+  end;
+end;
+
+function TFTPSend.DataRead(const DestStream: TStream): Boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  try
+    if not AcceptDataSocket then
+      Exit;
+    FDSock.RecvStreamRaw(DestStream, FTimeout);
+    FDSock.CloseSocket;
+    x := ReadResult;
+    Result := (x div 100) = 2;
+  finally
+    FDSock.CloseSocket;
+  end;
+end;
+
+function TFTPSend.DataWrite(const SourceStream: TStream): Boolean;
+var
+  x: integer;
+  b: Boolean;
+begin
+  Result := False;
+  try
+    if not AcceptDataSocket then
+      Exit;
+    FDSock.SendStreamRaw(SourceStream);
+    b := FDSock.LastError = 0;
+    FDSock.CloseSocket;
+    x := ReadResult;
+    Result := b and ((x div 100) = 2);
+  finally
+    FDSock.CloseSocket;
+  end;
+end;
+
+function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  FDataStream.Clear;
+  FFTPList.Clear;
+  if Directory <> '' then
+    Directory := ' ' + Directory;
+  FTPCommand('TYPE A');
+  if not DataSocket then
+    Exit;
+  if NameList then
+    x := FTPCommand('NLST' + Directory)
+  else
+    x := FTPCommand('LIST' + Directory);
+  if (x div 100) <> 1 then
+    Exit;
+  Result := DataRead(FDataStream);
+  if (not NameList) and Result then
+  begin
+    FDataStream.Position := 0;
+    FFTPList.Lines.LoadFromStream(FDataStream);
+    FFTPList.ParseLines;
+  end;
+  FDataStream.Position := 0;
+end;
+
+function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean;
+var
+  RetrStream: TStream;
+begin
+  Result := False;
+  if FileName = '' then
+    Exit;
+  if not DataSocket then
+    Exit;
+  Restore := Restore and FCanResume;
+  if FDirectFile then
+    if Restore and FileExists(FDirectFileName) then
+      RetrStream := TFileStream.Create(FDirectFileName,
+        fmOpenReadWrite  or fmShareExclusive)
+    else
+      RetrStream := TFileStream.Create(FDirectFileName,
+        fmCreate or fmShareDenyWrite)
+  else
+    RetrStream := FDataStream;
+  try
+    if FBinaryMode then
+      FTPCommand('TYPE I')
+    else
+      FTPCommand('TYPE A');
+    if Restore then
+    begin
+      RetrStream.Position := RetrStream.Size;
+      if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
+        Exit;
+    end
+    else
+      if RetrStream is TMemoryStream then
+        TMemoryStream(RetrStream).Clear;
+    if (FTPCommand('RETR ' + FileName) div 100) <> 1 then
+      Exit;
+    Result := DataRead(RetrStream);
+    if not FDirectFile then
+      RetrStream.Position := 0;
+  finally
+    if FDirectFile then
+      RetrStream.Free;
+  end;
+end;
+
+function TFTPSend.InternalStor(const Command: string; RestoreAt: int64): Boolean;
+var
+  SendStream: TStream;
+  StorSize: int64;
+begin
+  Result := False;
+  if FDirectFile then
+    if not FileExists(FDirectFileName) then
+      Exit
+    else
+      SendStream := TFileStream.Create(FDirectFileName,
+        fmOpenRead or fmShareDenyWrite)
+  else
+    SendStream := FDataStream;
+  try
+    if not DataSocket then
+      Exit;
+    if FBinaryMode then
+      FTPCommand('TYPE I')
+    else
+      FTPCommand('TYPE A');
+    StorSize := SendStream.Size;
+    if not FCanResume then
+      RestoreAt := 0;
+    if (StorSize > 0) and (RestoreAt = StorSize) then
+    begin
+      Result := True;
+      Exit;
+    end;
+    if RestoreAt > StorSize then
+      RestoreAt := 0;
+    FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
+    if FCanResume then
+      if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
+        Exit;
+    SendStream.Position := RestoreAt;
+    if (FTPCommand(Command) div 100) <> 1 then
+      Exit;
+    Result := DataWrite(SendStream);
+  finally
+    if FDirectFile then
+      SendStream.Free;
+  end;
+end;
+
+function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean;
+var
+  RestoreAt: int64;
+begin
+  Result := False;
+  if FileName = '' then
+    Exit;
+  RestoreAt := 0;
+  Restore := Restore and FCanResume;
+  if Restore then
+  begin
+    RestoreAt := Self.FileSize(FileName);
+    if RestoreAt < 0 then
+      RestoreAt := 0;
+  end;
+  Result := InternalStor('STOR ' + FileName, RestoreAt);
+end;
+
+function TFTPSend.StoreUniqueFile: Boolean;
+begin
+  Result := InternalStor('STOU', 0);
+end;
+
+function TFTPSend.AppendFile(const FileName: string): Boolean;
+begin
+  Result := False;
+  if FileName = '' then
+    Exit;
+  Result := InternalStor('APPE ' + FileName, 0);
+end;
+
+function TFTPSend.NoOp: Boolean;
+begin
+  Result := (FTPCommand('NOOP') div 100) = 2;
+end;
+
+function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
+begin
+  Result := False;
+  if (FTPCommand('RNFR ' + OldName) div 100) <> 3  then
+    Exit;
+  Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
+end;
+
+function TFTPSend.DeleteFile(const FileName: string): Boolean;
+begin
+  Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
+end;
+
+function TFTPSend.FileSize(const FileName: string): int64;
+var
+  s: string;
+begin
+  Result := -1;
+  if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
+  begin
+    s := Trim(SeparateRight(ResultString, ' '));
+    s := Trim(SeparateLeft(s, ' '));
+    {$IFDEF VER100}
+      Result := StrToIntDef(s, -1);
+    {$ELSE}
+      Result := StrToInt64Def(s, -1);
+    {$ENDIF}
+  end;
+end;
+
+function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
+begin
+  Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
+end;
+
+function TFTPSend.ChangeToParentDir: Boolean;
+begin
+  Result := (FTPCommand('CDUP') div 100) = 2;
+end;
+
+function TFTPSend.ChangeToRootDir: Boolean;
+begin
+  Result := ChangeWorkingDir('/');
+end;
+
+function TFTPSend.DeleteDir(const Directory: string): Boolean;
+begin
+  Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
+end;
+
+function TFTPSend.CreateDir(const Directory: string): Boolean;
+begin
+  Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
+end;
+
+function TFTPSend.GetCurrentDir: String;
+begin
+  Result := '';
+  if (FTPCommand('PWD') div 100) = 2 then
+  begin
+    Result := SeparateRight(FResultString, '"');
+    Result := Trim(Separateleft(Result, '"'));
+  end;
+end;
+
+procedure TFTPSend.Abort;
+begin
+  FSock.SendString('ABOR' + CRLF);
+  FDSock.StopFlag := True;
+end;
+
+procedure TFTPSend.TelnetAbort;
+begin
+  FSock.SendString(#$FF + #$F4 + #$FF + #$F2);
+  Abort;
+end;
+
+{==============================================================================}
+
+procedure TFTPListRec.Assign(Value: TFTPListRec);
+begin
+  FFileName := Value.FileName;
+  FDirectory := Value.Directory;
+  FReadable := Value.Readable;
+  FFileSize := Value.FileSize;
+  FFileTime := Value.FileTime;
+  FOriginalLine := Value.OriginalLine;
+  FMask := Value.Mask;
+end;
+
+constructor TFTPList.Create;
+begin
+  inherited Create;
+  FList := TList.Create;
+  FLines := TStringList.Create;
+  FMasks := TStringList.Create;
+  FUnparsedLines := TStringList.Create;
+  //various UNIX
+  FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*');
+  FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*');
+  FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*');  //mostly used UNIX format
+  FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
+  //MacOS
+  FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*');
+  FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*');
+  //Novell
+  FMasks.add('d            $!S*$TTT$DD$UUUUU$n*');
+  //Windows
+  FMasks.add('MM DD YY  hh mmH !S* n*');
+  FMasks.add('MM DD YY  hh mmH $ d!n*');
+  FMasks.add('MM DD YYYY  hh mmH !S* n*');
+  FMasks.add('MM DD YYYY  hh mmH $ d!n*');
+  FMasks.add('DD MM YYYY  hh mmH !S* n*');
+  FMasks.add('DD MM YYYY  hh mmH $ d!n*');
+  //VMS
+  FMasks.add('v*$  DD TTT YYYY hh mm');
+  FMasks.add('v*$!DD TTT YYYY hh mm');
+  FMasks.add('n*$                 YYYY MM DD hh mm$S*');
+  //AS400
+  FMasks.add('!S*$MM DD YY hh mm ss !n*');
+  FMasks.add('!S*$DD MM YY hh mm ss !n*');
+  FMasks.add('n*!S*$MM DD YY hh mm ss d');
+  FMasks.add('n*!S*$DD MM YY hh mm ss d');
+  //VxWorks
+  FMasks.add('$S*    TTT DD YYYY  hh mm ss $n* $ d');
+  FMasks.add('$S*    TTT DD YYYY  hh mm ss $n*');
+  //Distinct
+  FMasks.add('d    $S*$TTT DD YYYY  hh mm$n*');
+  FMasks.add('d    $S*$TTT DD$hh mm$n*');
+  //PC-NFSD
+  FMasks.add('nnnnnnnn.nnn  dSSSSSSSSSSS MM DD YY  hh mmH');
+  //VOS
+  FMasks.add('-   SSSSS            YY MM DD hh mm ss  n*');
+  FMasks.add('- d=  SSSSS  YY MM DD hh mm ss  n*');
+  //Unissys ClearPath
+  FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn               SSSSSSSSS MM DD YYYY hh mm');
+  FMasks.add('n*\x                                               SSSSSSSSS MM DD YYYY hh mm');
+  //IBM
+  FMasks.add('-     SSSSSSSSSSSS           d   MM DD YYYY   hh mm  n*');
+  //OS9
+  FMasks.add('-         YY MM DD hhmm d                        SSSSSSSSS n*');
+  //tandem
+  FMasks.add('nnnnnnnn                   SSSSSSS DD TTT YY hh mm ss');
+  //MVS
+  FMasks.add('-             YYYY MM DD                     SSSSS   d=O n*');
+  //BullGCOS8
+  FMasks.add('             $S* MM DD YY hh mm ss  !n*');
+  FMasks.add('d            $S* MM DD YY           !n*');
+  //BullGCOS7
+  FMasks.add('                                         TTT DD  YYYY n*');
+  FMasks.add('  d                                                   n*');
+end;
+
+destructor TFTPList.Destroy;
+begin
+  Clear;
+  FList.Free;
+  FLines.Free;
+  FMasks.Free;
+  FUnparsedLines.Free;
+  inherited Destroy;
+end;
+
+procedure TFTPList.Clear;
+var
+  n:integer;
+begin
+  for n := 0 to FList.Count - 1 do
+    if Assigned(FList[n]) then
+      TFTPListRec(FList[n]).Free;
+  FList.Clear;
+  FLines.Clear;
+  FUnparsedLines.Clear;
+end;
+
+function TFTPList.Count: integer;
+begin
+  Result := FList.Count;
+end;
+
+function TFTPList.GetListItem(Index: integer): TFTPListRec;
+begin
+  Result := nil;
+  if Index < Count then
+    Result := TFTPListRec(FList[Index]);
+end;
+
+procedure TFTPList.Assign(Value: TFTPList);
+var
+  flr: TFTPListRec;
+  n: integer;
+begin
+  Clear;
+  for n := 0 to Value.Count - 1 do
+  begin
+    flr := TFTPListRec.Create;
+    flr.Assign(Value[n]);
+    Flist.Add(flr);
+  end;
+  Lines.Assign(Value.Lines);
+  Masks.Assign(Value.Masks);
+  UnparsedLines.Assign(Value.UnparsedLines);
+end;
+
+procedure TFTPList.ClearStore;
+begin
+  Monthnames := '';
+  BlockSize := '';
+  DirFlagValue := '';
+  FileName := '';
+  VMSFileName := '';
+  Day := '';
+  Month := '';
+  ThreeMonth := '';
+  YearTime := '';
+  Year := '';
+  Hours := '';
+  HoursModif := '';
+  Minutes := '';
+  Seconds := '';
+  Size := '';
+  Permissions := '';
+  DirFlag := '';
+end;
+
+function TFTPList.ParseByMask(Value, NextValue, Mask: string): Integer;
+var
+  Ivalue, IMask: integer;
+  MaskC, LastMaskC: char;
+  c: char;
+  s: string;
+begin
+  ClearStore;
+  Result := 0;
+  if Value = '' then
+    Exit;
+  if Mask = '' then
+    Exit;
+  Ivalue := 1;
+  IMask := 1;
+  Result := 1;
+  LastMaskC := ' ';
+  while Imask <= Length(mask) do
+  begin
+    if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then
+    begin
+      Result := 0;
+      Exit;
+    end;
+    MaskC := Mask[Imask];
+    if Ivalue > Length(Value) then
+      Exit;
+    c := Value[Ivalue];
+    case MaskC of
+      'n':
+        FileName := FileName + c;
+      'v':
+        VMSFileName := VMSFileName + c;
+      '.':
+        begin
+          if c in ['.', ' '] then
+            FileName := TrimSP(FileName) + '.'
+          else
+          begin
+            Result := 0;
+            Exit;
+          end;
+        end;
+      'D':
+        Day := Day + c;
+      'M':
+        Month := Month + c;
+      'T':
+        ThreeMonth := ThreeMonth + c;
+      'U':
+        YearTime := YearTime + c;
+      'Y':
+        Year := Year + c;
+      'h':
+        Hours := Hours + c;
+      'H':
+        HoursModif := HoursModif + c;
+      'm':
+        Minutes := Minutes + c;
+      's':
+        Seconds := Seconds + c;
+      'S':
+        Size := Size + c;
+      'p':
+        Permissions := Permissions + c;
+      'd':
+        DirFlag := DirFlag + c;
+      'x':
+        if c <> ' ' then
+          begin
+            Result := 0;
+            Exit;
+          end;
+      '*':
+        begin
+          s := '';
+          if LastMaskC in ['n', 'v'] then
+          begin
+            if Imask = Length(Mask) then
+              s := Copy(Value, IValue, Maxint)
+            else
+              while IValue <= Length(Value) do
+              begin
+                if Value[Ivalue] = ' ' then
+                  break;
+                s := s + Value[Ivalue];
+                Inc(Ivalue);
+              end;
+            if LastMaskC = 'n' then
+              FileName := FileName + s
+            else
+              VMSFileName := VMSFileName + s;
+          end
+          else
+          begin
+            while IValue <= Length(Value) do
+            begin
+              if not(Value[Ivalue] in ['0'..'9']) then
+                break;
+              s := s + Value[Ivalue];
+              Inc(Ivalue);
+            end;
+            case LastMaskC of
+              'S':
+                Size := Size + s;
+            end;
+          end;
+          Dec(IValue);
+        end;
+      '!':
+        begin
+          while IValue <= Length(Value) do
+          begin
+            if Value[Ivalue] = ' ' then
+              break;
+            Inc(Ivalue);
+          end;
+          while IValue <= Length(Value) do
+          begin
+            if Value[Ivalue] <> ' ' then
+              break;
+            Inc(Ivalue);
+          end;
+          Dec(IValue);
+        end;
+      '$':
+        begin
+          while IValue <= Length(Value) do
+          begin
+            if not(Value[Ivalue] in [' ', #9]) then
+              break;
+            Inc(Ivalue);
+          end;
+          Dec(IValue);
+        end;
+      '=':
+        begin
+          s := '';
+          case LastmaskC of
+            'S':
+              begin
+                while Imask <= Length(Mask) do
+                begin
+                  if not(Mask[Imask] in ['0'..'9']) then
+                    break;
+                  s := s + Mask[Imask];
+                  Inc(Imask);
+                end;
+                Dec(Imask);
+                BlockSize := s;
+              end;
+            'T':
+              begin
+                Monthnames := Copy(Mask, IMask, 12 * 3);
+                Inc(IMask, 12 * 3);
+              end;
+            'd':
+              begin
+                Inc(Imask);
+                DirFlagValue := Mask[Imask];
+              end;
+          end;
+        end;
+      '\':
+        begin
+          Value := NextValue;
+          IValue := 0;
+          Result := 2;
+        end;
+    end;
+    Inc(Ivalue);
+    Inc(Imask);
+    LastMaskC := MaskC;
+  end;
+end;
+
+function TFTPList.CheckValues: Boolean;
+var
+  x, n: integer;
+begin
+  Result := false;
+  if FileName <> '' then
+  begin
+    if pos('?', VMSFilename) > 0 then
+      Exit;
+    if pos('*', VMSFilename) > 0 then
+      Exit;
+  end;
+  if VMSFileName <> '' then
+    if pos(';', VMSFilename) <= 0 then
+      Exit;
+  if (FileName = '') and (VMSFileName = '') then
+    Exit;
+  if Permissions <> '' then
+  begin
+    if length(Permissions) <> 10 then
+      Exit;
+    for n := 1 to 10 do
+      if not(Permissions[n] in
+        ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then
+        Exit;
+  end;
+  if Day <> '' then
+  begin
+    Day := TrimSP(Day);
+    x := StrToIntDef(day, -1);
+    if (x < 1) or (x > 31) then
+      Exit;
+  end;
+  if Month <> '' then
+  begin
+    Month := TrimSP(Month);
+    x := StrToIntDef(Month, -1);
+    if (x < 1) or (x > 12) then
+      Exit;
+  end;
+  if Hours <> '' then
+  begin
+    Hours := TrimSP(Hours);
+    x := StrToIntDef(Hours, -1);
+    if (x < 0) or (x > 24) then
+      Exit;
+  end;
+  if HoursModif <> '' then
+  begin
+    if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then
+      Exit;
+  end;
+  if Minutes <> '' then
+  begin
+    Minutes := TrimSP(Minutes);
+    x := StrToIntDef(Minutes, -1);
+    if (x < 0) or (x > 59) then
+      Exit;
+  end;
+  if Seconds <> '' then
+  begin
+    Seconds := TrimSP(Seconds);
+    x := StrToIntDef(Seconds, -1);
+    if (x < 0) or (x > 59) then
+      Exit;
+  end;
+  if Size <> '' then
+  begin
+    Size := TrimSP(Size);
+    for n := 1 to Length(Size) do
+      if not (Size[n] in ['0'..'9']) then
+        Exit;
+  end;
+
+  if length(Monthnames) = (12 * 3) then
+    for n := 1 to 12 do
+      CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
+  if ThreeMonth <> '' then
+  begin
+    x := GetMonthNumber(ThreeMonth);
+    if (x = 0) then
+      Exit;
+  end;
+  if YearTime <> '' then
+  begin
+    YearTime := ReplaceString(YearTime, '-', ':');
+    if pos(':', YearTime) > 0 then
+    begin
+      if (GetTimeFromstr(YearTime) = -1) then
+        Exit;
+    end
+    else
+    begin
+      YearTime := TrimSP(YearTime);
+      x := StrToIntDef(YearTime, -1);
+      if (x = -1) then
+        Exit;
+      if (x < 1900) or (x > 2100) then
+        Exit;
+    end;
+  end;
+  if Year <> '' then
+  begin
+    Year := TrimSP(Year);
+    x := StrToIntDef(Year, -1);
+    if (x = -1) then
+      Exit;
+    if Length(Year) = 4 then
+    begin
+      if not((x > 1900) and (x < 2100)) then
+        Exit;
+    end
+    else
+      if Length(Year) = 2 then
+      begin
+        if not((x >= 0) and (x <= 99)) then
+          Exit;
+      end
+      else
+        if Length(Year) = 3 then
+        begin
+          if not((x >= 100) and (x <= 110)) then
+            Exit;
+        end
+        else
+          Exit;
+  end;
+  Result := True;
+end;
+
+procedure TFTPList.FillRecord(const Value: TFTPListRec);
+var
+  s: string;
+  x: integer;
+  myear: Word;
+  mmonth: Word;
+  mday: Word;
+  mhours, mminutes, mseconds: word;
+  n: integer;
+begin
+  s := DirFlagValue;
+  if s = '' then
+    s := 'D';
+  s := Uppercase(s);
+  Value.Directory :=  s = Uppercase(DirFlag);
+  if FileName <> '' then
+    Value.FileName := SeparateLeft(Filename, ' -> ');
+  if VMSFileName <> '' then
+  begin
+    Value.FileName := VMSFilename;
+    Value.Directory := Pos('.DIR;',VMSFilename) > 0;
+  end;
+  Value.FileName := TrimSPRight(Value.FileName);
+  Value.Readable := not Value.Directory;
+  if BlockSize <> '' then
+    x := StrToIntDef(BlockSize, 1)
+  else
+    x := 1;
+  {$IFDEF VER100}
+  Value.FileSize := x * StrToIntDef(Size, 0);
+  {$ELSE}
+  Value.FileSize := x * StrToInt64Def(Size, 0);
+  {$ENDIF}
+
+  DecodeDate(Date,myear,mmonth,mday);
+  mhours := 0;
+  mminutes := 0;
+  mseconds := 0;
+
+  if Day <> '' then
+    mday := StrToIntDef(day, 1);
+  if Month <> '' then
+    mmonth := StrToIntDef(Month, 1);
+  if length(Monthnames) = (12 * 3) then
+    for n := 1 to 12 do
+      CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
+  if ThreeMonth <> '' then
+    mmonth := GetMonthNumber(ThreeMonth);
+  if Year <> '' then
+  begin
+    myear := StrToIntDef(Year, 0);
+    if (myear <= 99) and (myear > 50) then
+      myear := myear + 1900;
+    if myear <= 50 then
+      myear := myear + 2000;
+  end;
+  if YearTime <> '' then
+  begin
+    if pos(':', YearTime) > 0 then
+    begin
+      YearTime := TrimSP(YearTime);
+      mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
+      mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0);
+      if (Encodedate(myear, mmonth, mday)
+        + EncodeTime(mHours, mminutes, 0, 0)) > now then
+        Dec(mYear);
+    end
+    else
+      myear := StrToIntDef(YearTime, 0);
+  end;
+  if Minutes <> '' then
+    mminutes := StrToIntDef(Minutes, 0);
+  if Seconds <> '' then
+    mseconds := StrToIntDef(Seconds, 0);
+  if Hours <> '' then
+  begin
+    mHours := StrToIntDef(Hours, 0);
+    if HoursModif <> '' then
+      if Uppercase(HoursModif[1]) = 'P' then
+        if mHours <> 12 then
+          mHours := MHours + 12;
+  end;
+  Value.FileTime := Encodedate(myear, mmonth, mday)
+    + EncodeTime(mHours, mminutes, mseconds, 0);
+  if Permissions <> '' then
+  begin
+    Value.Permission := Permissions;
+    Value.Readable := Uppercase(permissions)[2] = 'R';
+    if Uppercase(permissions)[1] = 'D' then
+    begin
+      Value.Directory := True;
+      Value.Readable := false;
+    end
+    else
+      if Uppercase(permissions)[1] = 'L' then
+        Value.Directory := True;
+  end;
+end;
+
+function TFTPList.ParseEPLF(Value: string): Boolean;
+var
+  s, os: string;
+  flr: TFTPListRec;
+begin
+  Result := False;
+  if Value <> '' then
+    if Value[1] = '+' then
+    begin
+      os := Value;
+      Delete(Value, 1, 1);
+      flr := TFTPListRec.create;
+      flr.FileName := SeparateRight(Value, #9);
+      s := Fetch(Value, ',');
+      while s <> '' do
+      begin
+        if s[1] = #9 then
+          Break;
+        case s[1] of
+          '/':
+            flr.Directory := true;
+          'r':
+            flr.Readable := true;
+          's':
+            {$IFDEF VER100}
+            flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0);
+            {$ELSE}
+            flr.FileSize := StrToInt64Def(Copy(s, 2, Length(s) - 1), 0);
+            {$ENDIF}
+          'm':
+            flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400)
+              + 25569;
+        end;
+        s := Fetch(Value, ',');
+      end;
+      if flr.FileName <> '' then
+      if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')))
+        or (flr.FileName = '') then
+        flr.free
+      else
+      begin
+        flr.OriginalLine := os;
+        flr.Mask := 'EPLF';
+        Flist.Add(flr);
+        Result := True;
+      end;
+    end;
+end;
+
+procedure TFTPList.ParseLines;
+var
+  flr: TFTPListRec;
+  n, m: Integer;
+  S: string;
+  x: integer;
+  b: Boolean;
+begin
+  n := 0;
+  while n < Lines.Count do
+  begin
+    if n = Lines.Count - 1 then
+      s := ''
+    else
+      s := Lines[n + 1];
+    b := False;
+    x := 0;
+    if ParseEPLF(Lines[n]) then
+    begin
+      b := True;
+      x := 1;
+    end
+    else
+      for m := 0 to Masks.Count - 1 do
+      begin
+        x := ParseByMask(Lines[n], s, Masks[m]);
+        if x > 0 then
+          if CheckValues then
+          begin
+            flr := TFTPListRec.create;
+            FillRecord(flr);
+            flr.OriginalLine := Lines[n];
+            flr.Mask := Masks[m];
+            if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then
+              flr.free
+            else
+              Flist.Add(flr);
+            b := True;
+            Break;
+          end;
+      end;
+    if not b then
+      FUnparsedLines.Add(Lines[n]);
+    Inc(n);
+    if x > 1 then
+      Inc(n, x - 1);
+  end;
+end;
+
+{==============================================================================}
+
+function FtpGetFile(const IP, Port, FileName, LocalFile,
+  User, Pass: string): Boolean;
+begin
+  Result := False;
+  with TFTPSend.Create do
+  try
+    if User <> '' then
+    begin
+      Username := User;
+      Password := Pass;
+    end;
+    TargetHost := IP;
+    TargetPort := Port;
+    if not Login then
+      Exit;
+    DirectFileName := LocalFile;
+    DirectFile:=True;
+    Result := RetrieveFile(FileName, False);
+    Logout;
+  finally
+    Free;
+  end;
+end;
+
+function FtpPutFile(const IP, Port, FileName, LocalFile,
+  User, Pass: string): Boolean;
+begin
+  Result := False;
+  with TFTPSend.Create do
+  try
+    if User <> '' then
+    begin
+      Username := User;
+      Password := Pass;
+    end;
+    TargetHost := IP;
+    TargetPort := Port;
+    if not Login then
+      Exit;
+    DirectFileName := LocalFile;
+    DirectFile:=True;
+    Result := StoreFile(FileName, False);
+    Logout;
+  finally
+    Free;
+  end;
+end;
+
+function FtpInterServerTransfer(
+  const FromIP, FromPort, FromFile, FromUser, FromPass: string;
+  const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
+var
+  FromFTP, ToFTP: TFTPSend;
+  s: string;
+  x: integer;
+begin
+  Result := False;
+  FromFTP := TFTPSend.Create;
+  toFTP := TFTPSend.Create;
+  try
+    if FromUser <> '' then
+    begin
+      FromFTP.Username := FromUser;
+      FromFTP.Password := FromPass;
+    end;
+    if ToUser <> '' then
+    begin
+      ToFTP.Username := ToUser;
+      ToFTP.Password := ToPass;
+    end;
+    FromFTP.TargetHost := FromIP;
+    FromFTP.TargetPort := FromPort;
+    ToFTP.TargetHost := ToIP;
+    ToFTP.TargetPort := ToPort;
+    if not FromFTP.Login then
+      Exit;
+    if not ToFTP.Login then
+      Exit;
+    if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
+      Exit;
+    FromFTP.ParseRemote(FromFTP.ResultString);
+    s := ReplaceString(FromFTP.DataIP, '.', ',');
+    s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
+      + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
+    if (ToFTP.FTPCommand(s) div 100) <> 2 then
+      Exit;
+    x := ToFTP.FTPCommand('RETR ' + FromFile);
+    if (x div 100) <> 1 then
+      Exit;
+    x := FromFTP.FTPCommand('STOR ' + ToFile);
+    if (x div 100) <> 1 then
+      Exit;
+    FromFTP.Timeout := 21600000;
+    x := FromFTP.ReadResult;
+    if (x  div 100) <> 2 then
+      Exit;
+    ToFTP.Timeout := 21600000;
+    x := ToFTP.ReadResult;
+    if (x div 100) <> 2 then
+      Exit;
+    Result := True;
+  finally
+    ToFTP.Free;
+    FromFTP.Free;
+  end;
+end;
+
+end.

ftptsend.pas

@@ -0,0 +1,418 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.001 |
+|==============================================================================|
+| Content: Trivial FTP (TFTP) client and server                                |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(TFTP client and server protocol)
+
+Used RFC: RFC-1350
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit ftptsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cTFTPProtocol = '69';
+
+  cTFTP_RRQ = word(1);
+  cTFTP_WRQ = word(2);
+  cTFTP_DTA = word(3);
+  cTFTP_ACK = word(4);
+  cTFTP_ERR = word(5);
+
+type
+  {:@abstract(Implementation of TFTP client and server)
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TTFTPSend = class(TSynaClient)
+  private
+    FSock: TUDPBlockSocket;
+    FErrorCode: integer;
+    FErrorString: string;
+    FData: TMemoryStream;
+    FRequestIP: string;
+    FRequestPort: string;
+    function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
+    function RecvPacket(Serial: word; var Value: string): Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Upload @link(data) as file to TFTP server.}
+    function SendFile(const Filename: string): Boolean;
+
+    {:Download file from TFTP server to @link(data).}
+    function RecvFile(const Filename: string): Boolean;
+
+    {:Acts as TFTP server and wait for client request. When some request
+     incoming within Timeout, result is @true and parametres is filled with
+     information from request. You must handle this request, validate it, and
+     call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
+     to TFTP Client.}
+    function WaitForRequest(var Req: word; var filename: string): Boolean;
+
+    {:send error to TFTP client, when you acts as TFTP server.}
+    procedure ReplyError(Error: word; Description: string);
+
+    {:Accept uploaded file from TFTP client to @link(data), when you acts as
+     TFTP server.}
+    function ReplyRecv: Boolean;
+
+    {:Accept download request file from TFTP client and send content of
+     @link(data), when you acts as TFTP server.}
+    function ReplySend: Boolean;
+  published
+    {:Code of TFTP error.}
+    property ErrorCode: integer read FErrorCode;
+
+    {:Human readable decription of TFTP error. (if is sended by remote side)}
+    property ErrorString: string read FErrorString;
+
+    {:MemoryStream with datas for sending or receiving}
+    property Data: TMemoryStream read FData;
+
+    {:Address of TFTP remote side.}
+    property RequestIP: string read FRequestIP write FRequestIP;
+
+    {:Port of TFTP remote side.}
+    property RequestPort: string read FRequestPort write FRequestPort;
+  end;
+
+implementation
+
+constructor TTFTPSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FSock.Owner := self;
+  FTargetPort := cTFTPProtocol;
+  FData := TMemoryStream.Create;
+  FErrorCode := 0;
+  FErrorString := '';
+end;
+
+destructor TTFTPSend.Destroy;
+begin
+  FSock.Free;
+  FData.Free;
+  inherited Destroy;
+end;
+
+function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
+var
+  s, sh: string;
+begin
+  FErrorCode := 0;
+  FErrorString := '';
+  Result := false;
+  if Cmd <> 2 then
+    s := CodeInt(Cmd) + CodeInt(Serial) + Value
+  else
+    s := CodeInt(Cmd) + Value;
+  FSock.SendString(s);
+  s := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+    if length(s) >= 4 then
+    begin
+      sh := CodeInt(4) + CodeInt(Serial);
+      if Pos(sh, s) = 1 then
+        Result := True
+      else
+        if s[1] = #5 then
+        begin
+          FErrorCode := DecodeInt(s, 3);
+          Delete(s, 1, 4);
+          FErrorString := SeparateLeft(s, #0);
+        end;
+    end;
+end;
+
+function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
+var
+  s: string;
+  ser: word;
+begin
+  FErrorCode := 0;
+  FErrorString := '';
+  Result := False;
+  Value := '';
+  s := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+    if length(s) >= 4 then
+      if DecodeInt(s, 1) = 3 then
+      begin
+        ser := DecodeInt(s, 3);
+        if ser = Serial then
+        begin
+          Delete(s, 1, 4);
+          Value := s;
+          S := CodeInt(4) + CodeInt(ser);
+          FSock.SendString(s);
+          Result := FSock.LastError = 0;
+        end
+        else
+        begin
+          S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
+          FSock.SendString(s);
+        end;
+      end;
+      if DecodeInt(s, 1) = 5 then
+      begin
+        FErrorCode := DecodeInt(s, 3);
+        Delete(s, 1, 4);
+        FErrorString := SeparateLeft(s, #0);
+      end;
+end;
+
+function TTFTPSend.SendFile(const Filename: string): Boolean;
+var
+  s: string;
+  ser: word;
+  n, n1, n2: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FTargetHost, FTargetPort);
+  try
+    if FSock.LastError = 0 then
+    begin
+      s := Filename + #0 + 'octet' + #0;
+      if not Sendpacket(2, 0, s) then
+        Exit;
+      ser := 1;
+      FData.Position := 0;
+      n1 := FData.Size div 512;
+      n2 := FData.Size mod 512;
+      for n := 1 to n1 do
+      begin
+        s := ReadStrFromStream(FData, 512);
+//        SetLength(s, 512);
+//        FData.Read(pointer(s)^, 512);
+        if not Sendpacket(3, ser, s) then
+          Exit;
+        inc(ser);
+      end;
+      s := ReadStrFromStream(FData, n2);
+//      SetLength(s, n2);
+//      FData.Read(pointer(s)^, n2);
+      if not Sendpacket(3, ser, s) then
+        Exit;
+      Result := True;
+    end;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.RecvFile(const Filename: string): Boolean;
+var
+  s: string;
+  ser: word;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  FSock.Connect(FTargetHost, FTargetPort);
+  try
+    if FSock.LastError = 0 then
+    begin
+      s := CodeInt(1) + Filename + #0 + 'octet' + #0;
+      FSock.SendString(s);
+      if FSock.LastError <> 0 then
+        Exit;
+      FData.Clear;
+      ser := 1;
+      repeat
+        if not RecvPacket(ser, s) then
+          Exit;
+        inc(ser);
+        WriteStrToStream(FData, s);
+//        FData.Write(pointer(s)^, length(s));
+      until length(s) <> 512;
+      FData.Position := 0;
+      Result := true;
+    end;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
+var
+  s: string;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  {$IFDEF ULTIBO}
+  FSock.EnableReuse(True); //Closed socket is not destroyed immediately, need to allow port reuse
+  {$ENDIF}
+  FSock.Bind('0.0.0.0', FTargetPort);
+  if FSock.LastError = 0 then
+  begin
+    s := FSock.RecvPacket(FTimeout);
+    if FSock.LastError = 0 then
+      if Length(s) >= 4 then
+      begin
+        FRequestIP := FSock.GetRemoteSinIP;
+        FRequestPort := IntToStr(FSock.GetRemoteSinPort);
+        Req := DecodeInt(s, 1);
+        delete(s, 1, 2);
+        filename := Trim(SeparateLeft(s, #0));
+        s := SeparateRight(s, #0);
+        s := SeparateLeft(s, #0);
+        Result := lowercase(trim(s)) = 'octet';
+      end;
+  end;
+end;
+
+procedure TTFTPSend.ReplyError(Error: word; Description: string);
+var
+  s: string;
+begin
+  FSock.CloseSocket;
+  {$IFDEF ULTIBO}
+  FSock.EnableReuse(True);            //Closed socket is not destroyed immediately, need to allow port reuse
+  FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to
+  {$ENDIF}
+  FSock.Connect(FRequestIP, FRequestPort);
+  s := CodeInt(5) + CodeInt(Error) + Description + #0;
+  FSock.SendString(s);
+  FSock.CloseSocket;
+end;
+
+function TTFTPSend.ReplyRecv: Boolean;
+var
+  s: string;
+  ser: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  {$IFDEF ULTIBO}
+  FSock.EnableReuse(True);            //Closed socket is not destroyed immediately, need to allow port reuse
+  FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to
+  {$ENDIF}
+  FSock.Connect(FRequestIP, FRequestPort);
+  try
+    s := CodeInt(4) + CodeInt(0);
+    FSock.SendString(s);
+    FData.Clear;
+    ser := 1;
+    repeat
+      if not RecvPacket(ser, s) then
+        Exit;
+      inc(ser);
+      WriteStrToStream(FData, s);
+//      FData.Write(pointer(s)^, length(s));
+    until length(s) <> 512;
+    FData.Position := 0;
+    Result := true;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+function TTFTPSend.ReplySend: Boolean;
+var
+  s: string;
+  ser: word;
+  n, n1, n2: integer;
+begin
+  Result := False;
+  FErrorCode := 0;
+  FErrorString := '';
+  FSock.CloseSocket;
+  {$IFDEF ULTIBO}
+  FSock.EnableReuse(True);            //Closed socket is not destroyed immediately, need to allow port reuse
+  FSock.Bind('0.0.0.0', FTargetPort); //Some clients (eg Windows) only accept replies from the port they sent to
+  {$ENDIF}
+  FSock.Connect(FRequestIP, FRequestPort);
+  try
+    ser := 1;
+    FData.Position := 0;
+    n1 := FData.Size div 512;
+    n2 := FData.Size mod 512;
+    for n := 1 to n1 do
+    begin
+      s := ReadStrFromStream(FData, 512);
+//      SetLength(s, 512);
+//      FData.Read(pointer(s)^, 512);
+      if not Sendpacket(3, ser, s) then
+        Exit;
+      inc(ser);
+    end;
+    s := ReadStrFromStream(FData, n2);
+//    SetLength(s, n2);
+//    FData.Read(pointer(s)^, n2);
+    if not Sendpacket(3, ser, s) then
+      Exit;
+    Result := True;
+  finally
+    FSock.CloseSocket;
+  end;
+end;
+
+{==============================================================================}
+
+end.

httpsend.pas

@@ -0,0 +1,866 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.012.009 |
+|==============================================================================|
+| Content: HTTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2015, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2015.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(HTTP protocol client)
+
+Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit httpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synabyte, synaip, synacode, synsock;
+
+const
+  cHttpProtocol = '80';
+
+type
+  {:These encoding types are used internally by the THTTPSend object to identify
+   the transfer data types.}
+  TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
+
+  {:abstract(Implementation of HTTP protocol.)}
+  THTTPSend = class(TSynaClient)
+  private
+    FConnectionTimeOut: Integer;
+    FIgnoreBody: Boolean;
+  protected
+    FSock: TTCPBlockSocket;
+    FTransferEncoding: TTransferEncoding;
+    FAliveHost: string;
+    FAlivePort: string;
+    FHeaders: TStringList;
+    FDocument: TMemoryStream;
+    FMimeType: string;
+    FProtocol: string;
+    FKeepAlive: Boolean;
+    FKeepAliveTimeout: integer;
+    FStatus100: Boolean;
+    FProxyHost: string;
+    FProxyPort: string;
+    FProxyUser: string;
+    FProxyPass: string;
+    FResultCode: Integer;
+    FResultString: string;
+    FUserAgent: string;
+    FCookies: TStringList;
+    FDownloadSize: integer;
+    FUploadSize: integer;
+    FRangeStart: integer;
+    FRangeEnd: integer;
+    FAddPortNumberToHost: Boolean;
+    function ReadUnknown: Boolean; virtual;
+    function ReadIdentity(Size: Integer): Boolean; virtual;
+    function ReadChunked: Boolean; virtual;
+    procedure ParseCookies;
+    function PrepareHeaders: String;
+    function InternalDoConnect(needssl: Boolean): Boolean;
+    function InternalConnect(needssl: Boolean): Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Reset headers, document and Mimetype.}
+    procedure Clear;
+
+    {:Decode ResultCode and ResultString from Value.}
+    procedure DecodeStatus(const Value: string);
+
+    {:Connects to host defined in URL and accesses resource defined in URL by
+     method. If Document is not empty, send it to the server as part of the HTTP
+     request. Server response is in Document and headers. Connection may be
+     authorised by username and password in URL. If you define proxy properties,
+     connection is made by this proxy.
+     If all OK, result is @true, else result is @false.
+
+     If you use 'https:' instead of 'http:' in the URL, your request is made
+     by SSL/TLS connection (if you do not specify port, then port 443 is used
+     instead of standard port 80). If you use SSL/TLS request and you have
+     defined HTTP proxy, then HTTP-tunnel mode is automatically used .}
+    function HTTPMethod(const Method, URL: string): Boolean;
+
+    {:You can call this method from OnStatus event to break current data
+     transfer. (or from another thread.)}
+    procedure Abort;
+  published
+    {:Before HTTP operation you may define any non-standard headers for HTTP
+     request, except: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
+     'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
+     After HTTP operation, it contains full headers of the returned document.}
+    property Headers: TStringList read FHeaders;
+
+    {:Stringlist with name-value stringlist pairs. Each pair is one cookie.
+     After the HTTP request is returned, cookies are parsed to this stringlist.
+     You can leave these cookies untouched for next HTTP requests. You can also
+     save this stringlist for later use.}
+    property Cookies: TStringList read FCookies;
+
+    {:Stream with document to send (before request), or with document received
+     from HTTP server (after request).}
+    property Document: TMemoryStream read FDocument;
+
+    {:If you need to download only part of a requested document, specify here
+     the position of subpart begin. If 0, the full document is requested.}
+    property RangeStart: integer read FRangeStart Write FRangeStart;
+
+    {:If you need to download only part of a requested document, specify here
+     the position of subpart end. If 0, the document from rangeStart to end of
+     document is requested.
+     (Useful for resuming broken downloads, for example.)}
+    property RangeEnd: integer read FRangeEnd Write FRangeEnd;
+
+    {:Mime type of sending data. Default is: 'text/html'.}
+    property MimeType: string read FMimeType Write FMimeType;
+
+    {:Define protocol version. Possible values are: '1.1', '1.0' (default)
+     and '0.9'.}
+    property Protocol: string read FProtocol Write FProtocol;
+
+    {:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
+    property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
+
+    {:Define timeout for keepalives in seconds!}
+    property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
+
+    {:if @true, then the server is requested for 100status capability when
+     uploading data. Default is @false (off).}
+    property Status100: Boolean read FStatus100 Write FStatus100;
+
+    {:Address of proxy server (IP address or domain name) where you want to
+     connect in @link(HTTPMethod) method.}
+    property ProxyHost: string read FProxyHost Write FProxyHost;
+
+    {:Port number for proxy connection. Default value is 8080.}
+    property ProxyPort: string read FProxyPort Write FProxyPort;
+
+    {:Username for connection to proxy server used in HTTPMethod method.}
+    property ProxyUser: string read FProxyUser Write FProxyUser;
+
+    {:Password for connection to proxy server used in HTTPMethod method.}
+    property ProxyPass: string read FProxyPass Write FProxyPass;
+
+    {:Here you can specify custom User-Agent identification.
+     Default: 'Mozilla/4.0 (compatible; Synapse)'}
+    property UserAgent: string read FUserAgent Write FUserAgent;
+
+    {:Operation result code after successful @link(HTTPMethod) method.}
+    property ResultCode: Integer read FResultCode;
+
+    {:Operation result string after successful @link(HTTPMethod) method.}
+    property ResultString: string read FResultString;
+
+    {:if this value is not 0, then data download is pending. In this case you
+     have here the total size of downloaded data. Useful for drawing download
+     progressbar from OnStatus event.}
+    property DownloadSize: integer read FDownloadSize;
+
+    {:if this value is not 0, then data upload is pending. In this case you have
+     here the total size of uploaded data. Useful for drawing upload progressbar
+     from OnStatus event.}
+    property UploadSize: integer read FUploadSize;
+
+    {:Socket object used for TCP/IP operation.
+     Good for setting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:Allows to switch off port number in 'Host:' HTTP header. By default @TRUE.
+     Some buggy servers do not like port informations in this header.}
+    property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
+
+    property ConnectionTimeOut: Integer read FConnectionTimeOut
+      write FConnectionTimeOut;
+
+    property IgnoreBody: Boolean read FIgnoreBody write FIgnoreBody;
+  end;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the GET method of the HTTP protocol. This function sends
+ the GET method for URL document to an HTTP server. Returned document is in the
+ "Response" stringlist (without any headers). Returns boolean TRUE if all went
+ well.}
+function HttpGetText(const URL: string; const Response: TStrings): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the GET method of the HTTP protocol. This function sends
+ the GET method for URL document to an HTTP server. Returned document is in the
+ "Response" stream. Returns boolean TRUE if all went well.}
+function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function sends
+ the SEND method for a URL document to an HTTP server. The document to be sent
+ is located in the "Data" stream. The returned document is in the "Data" stream.
+ Returns boolean TRUE if all went well.}
+function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function is
+ good for POSTing form data. It sends the POST method for a URL document to
+ an HTTP server. You must prepare the form data in the same manner as you would
+ the URL data, and pass this prepared data to "URLdata". The following is
+ a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
+ The information in the field must be encoded by the EncodeURLElement function.
+ The returned document is in the "Data" stream. Returns boolean TRUE if all
+ went well.}
+function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
+
+{:A very useful function, and example of use can be found in the THTTPSend
+ object. It implements the POST method of the HTTP protocol. This function sends
+ the POST method for a URL document to an HTTP server. This function simulates
+ posting of file by HTML form using the 'multipart/form-data' method. The posted
+ file is in the DATA stream. Its name is Filename string. Fieldname is for the
+ name of the form field with the file. (simulates HTML INPUT FILE) The returned
+ document is in the ResultData Stringlist. Returns boolean TRUE if all
+ went well.}
+function HttpPostFile(const URL, FieldName, FileName: string;
+  const Data: TStream; const ResultData: TStrings): Boolean;
+
+implementation
+
+constructor THTTPSend.Create;
+begin
+  inherited Create;
+  FHeaders := TStringList.Create;
+  FCookies := TStringList.Create;
+  FDocument := TMemoryStream.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.ConvertLineEnd := True;
+  FSock.SizeRecvBuffer := c64k;
+  FSock.SizeSendBuffer := c64k;
+  FTimeout := 90000;
+  FTargetPort := cHttpProtocol;
+  FProxyHost := '';
+  FProxyPort := '8080';
+  FProxyUser := '';
+  FProxyPass := '';
+  FAliveHost := '';
+  FAlivePort := '';
+  FProtocol := '1.0';
+  FKeepAlive := True;
+  FStatus100 := False;
+  FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
+  FDownloadSize := 0;
+  FUploadSize := 0;
+  FAddPortNumberToHost := true;
+  FKeepAliveTimeout := 300;
+
+  FConnectionTimeOut := 0;
+  Clear;
+end;
+
+destructor THTTPSend.Destroy;
+begin
+  FSock.Free;
+  FDocument.Free;
+  FCookies.Free;
+  FHeaders.Free;
+  inherited Destroy;
+end;
+
+procedure THTTPSend.Clear;
+begin
+  FRangeStart := 0;
+  FRangeEnd := 0;
+  FDocument.Clear;
+  FHeaders.Clear;
+  FMimeType := 'text/html';
+end;
+
+procedure THTTPSend.DecodeStatus(const Value: string);
+var
+  s, su: string;
+begin
+  s := Trim(SeparateRight(Value, ' '));
+  su := Trim(SeparateLeft(s, ' '));
+  FResultCode := StrToIntDef(su, 0);
+  FResultString := Trim(SeparateRight(s, ' '));
+  if FResultString = s then
+    FResultString := '';
+end;
+
+function THTTPSend.PrepareHeaders: String;
+begin
+  if FProtocol = '0.9' then
+    Result := FHeaders[0] + CRLF
+  else
+{$IFNDEF MSWINDOWS}
+    Result := {$IFDEF UNICODE}TMarshal.AsAnsi{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
+{$ELSE}
+    Result := FHeaders.Text;
+{$ENDIF}
+end;
+
+function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.ConnectionTimeOut := FConnectionTimeOut;
+
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError <> 0 then
+    Exit;
+  if needssl then
+  begin
+    if (FSock.SSL.SNIHost='') then
+      FSock.SSL.SNIHost:=FTargetHost;
+    FSock.SSLDoConnect;
+    FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
+    if FSock.LastError <> 0 then
+      Exit;
+  end;
+  FAliveHost := FTargetHost;
+  FAlivePort := FTargetPort;
+  Result := True;
+end;
+
+function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
+begin
+  if FSock.Socket = INVALID_SOCKET then
+    Result := InternalDoConnect(needssl)
+  else
+    if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
+      or FSock.CanRead(0) then
+      Result := InternalDoConnect(needssl)
+    else
+      Result := True;
+end;
+
+function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
+var
+  Sending, Receiving: Boolean;
+  status100: Boolean;
+  status100error: string;
+  ToClose: Boolean;
+  Size: Integer;
+  Prot, User, Pass, Host, Port, Path, Para, URI: string;
+  s, su: String;
+  HttpTunnel: Boolean;
+  n: integer;
+  pp: string;
+  UsingProxy: boolean;
+  l: TStringList;
+  x: integer;
+begin
+  {initial values}
+  Result := False;
+  FResultCode := 500;
+  FResultString := '';
+  FDownloadSize := 0;
+  FUploadSize := 0;
+
+  URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
+  User := DecodeURL(user);
+  Pass := DecodeURL(pass);
+  if User = '' then
+  begin
+    User := FUsername;
+    Pass := FPassword;
+  end;
+  if UpperCase(Prot) = 'HTTPS' then
+  begin
+    HttpTunnel := FProxyHost <> '';
+    FSock.HTTPTunnelIP := FProxyHost;
+    FSock.HTTPTunnelPort := FProxyPort;
+    FSock.HTTPTunnelUser := FProxyUser;
+    FSock.HTTPTunnelPass := FProxyPass;
+  end
+  else
+  begin
+    HttpTunnel := False;
+    FSock.HTTPTunnelIP := '';
+    FSock.HTTPTunnelPort := '';
+    FSock.HTTPTunnelUser := '';
+    FSock.HTTPTunnelPass := '';
+  end;
+  UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
+  Sending := FDocument.Size > 0;
+  {Headers for Sending data}
+  status100 := FStatus100 and Sending and (FProtocol = '1.1');
+  if status100 then
+    FHeaders.Insert(0, 'Expect: 100-continue');
+  if Sending then
+  begin
+    FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
+    if FMimeType <> '' then
+      FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
+  end;
+  { setting User-agent }
+  if FUserAgent <> '' then
+    FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
+  { setting Ranges }
+  if (FRangeStart > 0) or (FRangeEnd > 0) then
+  begin
+    if FRangeEnd >= FRangeStart then
+      FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
+    else
+      FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
+  end;
+  { setting Cookies }
+  s := '';
+  for n := 0 to FCookies.Count - 1 do
+  begin
+    if s <> '' then
+      s := s + '; ';
+    s := s + FCookies[n];
+  end;
+  if s <> '' then
+    FHeaders.Insert(0, 'Cookie: ' + s);
+  { setting KeepAlives }
+  pp := '';
+  if UsingProxy then
+    pp := 'Proxy-';
+  if FKeepAlive then
+  begin
+    FHeaders.Insert(0, pp + 'Connection: keep-alive');
+    FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
+  end
+  else
+    FHeaders.Insert(0, pp + 'Connection: close');
+  { set target servers/proxy, authorizations, etc... }
+  if (User <> '') or (Pass <> '') then
+    FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
+  if UsingProxy and (FProxyUser <> '') then
+    FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
+      EncodeBase64(FProxyUser + ':' + FProxyPass));
+  if isIP6(Host) then
+    s := '[' + Host + ']'
+  else
+    s := Host;
+  if FAddPortNumberToHost
+    and (((Port <> '80') and (UpperCase(Prot) = 'HTTP'))
+    or ((Port <> '443') and (UpperCase(Prot) = 'HTTPS'))) then
+    FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
+  else
+    FHeaders.Insert(0, 'Host: ' + s);
+  if UsingProxy then
+    URI := Prot + '://' + s + ':' + Port + URI;
+  if URI = '/*' then
+    URI := '*';
+  if FProtocol = '0.9' then
+    FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
+  else
+    FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
+  if UsingProxy then
+  begin
+    FTargetHost := FProxyHost;
+    FTargetPort := FProxyPort;
+  end
+  else
+  begin
+    FTargetHost := Host;
+    FTargetPort := Port;
+  end;
+  if FHeaders[FHeaders.Count - 1] <> '' then
+    FHeaders.Add('');
+
+  { connect }
+  if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
+  begin
+    FAliveHost := '';
+    FAlivePort := '';
+    Exit;
+  end;
+
+  { reading Status }
+  FDocument.Position := 0;
+  Status100Error := '';
+  if status100 then
+  begin
+    { send Headers }
+    FSock.SendString(PrepareHeaders);
+    if FSock.LastError <> 0 then
+      Exit;
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s <> '' then
+        Break;
+    until FSock.LastError <> 0;
+    DecodeStatus(s);
+    Status100Error := s;
+    repeat
+      s := FSock.recvstring(FTimeout);
+      if s = '' then
+        Break;
+    until FSock.LastError <> 0;
+    if (FResultCode >= 100) and (FResultCode < 200) then
+    begin
+      { we can upload content }
+      Status100Error := '';
+      FUploadSize := FDocument.Size;
+      FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+    end;
+  end
+  else
+    { upload content }
+    if sending then
+    begin
+      if FDocument.Size >= c64k then
+      begin
+        FSock.SendString(PrepareHeaders);
+        FUploadSize := FDocument.Size;
+        FSock.SendBuffer(FDocument.Memory, FDocument.Size);
+      end
+      else
+      begin
+        s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
+        FUploadSize := Length(s);
+        FSock.SendString(s);
+      end;
+    end
+    else
+    begin
+      { we not need to upload document, send headers only }
+      FSock.SendString(PrepareHeaders);
+    end;
+
+  if FSock.LastError <> 0 then
+    Exit;
+
+  Clear;
+  Size := -1;
+  FTransferEncoding := TE_UNKNOWN;
+
+  { read status }
+  if Status100Error = '' then
+  begin
+    repeat
+      repeat
+        s := FSock.RecvString(FTimeout);
+        if s <> '' then
+          Break;
+      until FSock.LastError <> 0;
+      if Pos('HTTP/', UpperCase(s)) = 1 then
+      begin
+        FHeaders.Add(s);
+        DecodeStatus(s);
+      end
+      else
+      begin
+        { old HTTP 0.9 and some buggy servers not send result }
+        s := s + CRLF;
+        WriteStrToStream(FDocument, s);
+        FResultCode := 0;
+      end;
+    until (FSock.LastError <> 0) or (FResultCode <> 100);
+  end
+  else
+    FHeaders.Add(Status100Error);
+
+  { if need receive headers, receive and parse it }
+  ToClose := FProtocol <> '1.1';
+  if FHeaders.Count > 0 then
+  begin
+    l := TStringList.Create;
+    try
+      repeat
+        s := FSock.RecvString(FTimeout);
+        l.Add(s);
+        if s = '' then
+          Break;
+      until FSock.LastError <> 0;
+      x := 0;
+      while l.Count > x do
+      begin
+        s := NormalizeHeader(l, x);
+        FHeaders.Add(s);
+        su := UpperCase(s);
+        if Pos('CONTENT-LENGTH:', su) = 1 then
+        begin
+          Size := StrToIntDef(Trim(SeparateRight(s, ':')), -1);
+          if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
+            FTransferEncoding := TE_IDENTITY;
+        end;
+        if Pos('CONTENT-TYPE:', su) = 1 then
+          FMimeType := Trim(SeparateRight(s, ':'));
+        if Pos('TRANSFER-ENCODING:', su) = 1 then
+        begin
+          s := Trim(SeparateRight(su, ':'));
+          if Pos('CHUNKED', s) > 0 then
+            FTransferEncoding := TE_CHUNKED;
+        end;
+        if UsingProxy then
+        begin
+          if Pos('PROXY-CONNECTION:', su) = 1 then
+            if Pos('CLOSE', su) > 0 then
+              ToClose := True;
+        end
+        else
+        begin
+          if Pos('CONNECTION:', su) = 1 then
+            if Pos('CLOSE', su) > 0 then
+              ToClose := True;
+        end;
+      end;
+    finally
+      l.free;
+    end;
+  end;
+
+  Result := FSock.LastError = 0;
+  if not Result then
+  begin
+    FSock.CloseSocket;
+    FAliveHost := '';
+    FAlivePort := '';
+    Exit;
+  end;
+
+  {if need receive response body, read it}
+  Receiving := Method <> 'HEAD';
+  Receiving := Receiving and (FResultCode <> 204);
+  Receiving := Receiving and (FResultCode <> 304);
+  if Receiving then
+    case FTransferEncoding of
+      TE_UNKNOWN:
+        Result := ReadUnknown;
+      TE_IDENTITY:
+        Result := ReadIdentity(Size);
+      TE_CHUNKED:
+        Result := ReadChunked;
+    end;
+
+  FDocument.Position := 0;
+  if ToClose then
+  begin
+    FSock.CloseSocket;
+    FAliveHost := '';
+    FAlivePort := '';
+  end;
+  ParseCookies;
+end;
+
+function THTTPSend.ReadUnknown: Boolean;
+var
+  s: TSynaBytes;
+begin
+  Result := false;
+  repeat
+    s := FSock.RecvPacket(FTimeout);
+    if FSock.LastError = 0 then
+      WriteStrToStream(FDocument, s);
+  until FSock.LastError <> 0;
+  if FSock.LastError = WSAECONNRESET then
+  begin
+    Result := true;
+    FSock.ResetLastError;
+  end;
+end;
+
+function THTTPSend.ReadIdentity(Size: Integer): Boolean;
+begin
+  if Size > 0 then
+  begin
+    FDownloadSize := Size;
+    FSock.RecvStreamSize(FDocument, FTimeout, Size);
+    FDocument.Position := FDocument.Size;
+    Result := FSock.LastError = 0;
+  end
+  else
+    Result := true;
+end;
+
+function THTTPSend.ReadChunked: Boolean;
+var
+  s: string;
+  Size: Integer;
+begin
+  repeat
+    repeat
+      s := FSock.RecvString(FTimeout);
+    until (s <> '') or (FSock.LastError <> 0);
+    if FSock.LastError <> 0 then
+      Break;
+    s := Trim(SeparateLeft(s, ' '));
+    s := Trim(SeparateLeft(s, ';'));
+    Size := StrToIntDef('$' + s, 0);
+    if Size = 0 then
+      Break;
+    if not ReadIdentity(Size) then
+      break;
+  until False;
+  Result := FSock.LastError = 0;
+end;
+
+procedure THTTPSend.ParseCookies;
+var
+  n: integer;
+  s: string;
+  sn, sv: string;
+begin
+  for n := 0 to FHeaders.Count - 1 do
+    if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
+    begin
+      s := SeparateRight(FHeaders[n], ':');
+      s := trim(SeparateLeft(s, ';'));
+      sn := trim(SeparateLeft(s, '='));
+      sv := trim(SeparateRight(s, '='));
+      FCookies.Values[sn] := sv;
+    end;
+end;
+
+procedure THTTPSend.Abort;
+begin
+  FSock.StopFlag := True;
+end;
+
+{==============================================================================}
+
+function HttpGetText(const URL: string; const Response: TStrings): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    Result := HTTP.HTTPMethod('GET', URL);
+    if Result then
+      Response.LoadFromStream(HTTP.Document
+       {$IFDEF UNICODE}, TEncoding.ANSI{$ENDIF});
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    Result := HTTP.HTTPMethod('GET', URL);
+    if Result then
+    begin
+      Response.Position := 0;
+      Response.CopyFrom(HTTP.Document, 0);
+    end;
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    HTTP.Document.CopyFrom(Data, 0);
+    HTTP.MimeType := 'Application/octet-stream';
+    Result := HTTP.HTTPMethod('POST', URL);
+    Data.Size := 0;
+    if Result then
+    begin
+      Data.Position := 0;
+      Data.CopyFrom(HTTP.Document, 0);
+    end;
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
+var
+  HTTP: THTTPSend;
+begin
+  HTTP := THTTPSend.Create;
+  try
+    WriteStrToStream(HTTP.Document, URLData);
+    HTTP.MimeType := 'application/x-www-form-urlencoded';
+    Result := HTTP.HTTPMethod('POST', URL);
+    if Result then
+      Data.CopyFrom(HTTP.Document, 0);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+function HttpPostFile(const URL, FieldName, FileName: string;
+  const Data: TStream; const ResultData: TStrings): Boolean;
+var
+  HTTP: THTTPSend;
+  Bound, s: string;
+begin
+  Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
+  HTTP := THTTPSend.Create;
+  try
+    s := '--' + Bound + CRLF;
+    s := s + 'content-disposition: form-data; name="' + FieldName + '";';
+    s := s + ' filename="' + FileName +'"' + CRLF;
+    s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
+    WriteStrToStream(HTTP.Document, s);
+    HTTP.Document.CopyFrom(Data, 0);
+    s := CRLF + '--' + Bound + '--' + CRLF;
+    WriteStrToStream(HTTP.Document, s);
+    HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
+    Result := HTTP.HTTPMethod('POST', URL);
+    if Result then
+      ResultData.LoadFromStream(HTTP.Document);
+  finally
+    HTTP.Free;
+  end;
+end;
+
+end.

imapsend.pas

@@ -0,0 +1,871 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.005.004 |
+|==============================================================================|
+| Content: IMAP4rev1 client                                                    |
+|==============================================================================|
+| Copyright (c)1999-2015, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2015.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(IMAP4 rev1 protocol client)
+
+Used RFC: RFC-2060, RFC-2595
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit imapsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cIMAPProtocol = '143';
+
+type
+  {:@abstract(Implementation of IMAP4 protocol.)
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TIMAPSend = class(TSynaClient)
+  protected
+    FSock: TTCPBlockSocket;
+    FTagCommand: integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FIMAPcap: TStringList;
+    FAuthDone: Boolean;
+    FSelectedFolder: string;
+    FSelectedCount: integer;
+    FSelectedRecent: integer;
+    FSelectedUIDvalidity: integer;
+    FUID: Boolean;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    function ReadResult: string;
+    function AuthLogin: Boolean;
+    function Connect: Boolean;
+    procedure ParseMess(Value:TStrings);
+    procedure ParseFolderList(Value:TStrings);
+    procedure ParseSelect;
+    procedure ParseSearch(Value:TStrings);
+    procedure ProcessLiterals;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:By this function you can call any IMAP command. Result of this command is
+     in adequate properties.}
+    function IMAPcommand(Value: string): string;
+
+    {:By this function you can call any IMAP command what need upload any data.
+     Result of this command is in adequate properties.}
+    function IMAPuploadCommand(Value: string; const Data:TStrings): string;
+
+    {:Call CAPABILITY command and fill IMAPcap property by new values.}
+    function Capability: Boolean;
+
+    {:Connect to IMAP server and do login to this server. This command begin
+     session.}
+    function Login: Boolean;
+
+    {:Disconnect from IMAP server and terminate session session. If exists some
+     deleted and non-purged messages, these messages are not deleted!}
+    function Logout: Boolean;
+
+    {:Do NOOP. It is for prevent disconnect by timeout.}
+    function NoOp: Boolean;
+
+    {:Lists folder names. You may specify level of listing. If you specify
+     FromFolder as empty string, return is all folders in system.}
+    function List(FromFolder: string; const FolderList: TStrings): Boolean;
+
+    {:Lists folder names what match search criteria. You may specify level of
+     listing. If you specify FromFolder as empty string, return is all folders
+     in system.}
+    function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+
+    {:Lists subscribed folder names. You may specify level of listing. If you
+     specify FromFolder as empty string, return is all subscribed folders in
+     system.}
+    function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
+
+    {:Lists subscribed folder names what matching search criteria. You may
+     specify level of listing. If you specify FromFolder as empty string, return
+     is all subscribed folders in system.}
+    function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+
+    {:Create a new folder.}
+    function CreateFolder(FolderName: string): Boolean;
+
+    {:Delete a folder.}
+    function DeleteFolder(FolderName: string): Boolean;
+
+    {:Rename folder names.}
+    function RenameFolder(FolderName, NewFolderName: string): Boolean;
+
+    {:Subscribe folder.}
+    function SubscribeFolder(FolderName: string): Boolean;
+
+    {:Unsubscribe folder.}
+    function UnsubscribeFolder(FolderName: string): Boolean;
+
+    {:Select folder.}
+    function SelectFolder(FolderName: string): Boolean;
+
+    {:Select folder, but only for reading. Any changes are not allowed!}
+    function SelectROFolder(FolderName: string): Boolean;
+
+    {:Close a folder. (end of Selected state)}
+    function CloseFolder: Boolean;
+
+    {:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
+     result is number of unseen messages in folder. For another status
+     indentificator check IMAP documentation and documentation of your IMAP
+     server (each IMAP server can have their own statuses.)}
+    function StatusFolder(FolderName, Value: string): integer;
+
+    {:Hardly delete all messages marked as 'deleted' in current selected folder.}
+    function ExpungeFolder: Boolean;
+
+    {:Touch to folder. (use as update status of folder, etc.)}
+    function CheckFolder: Boolean;
+
+    {:Append given message to specified folder.}
+    function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
+
+    {:'Delete' message from current selected folder. It mark message as Deleted.
+     Real deleting will be done after sucessfull @link(CloseFolder) or
+     @link(ExpungeFolder)}
+    function DeleteMess(MessID: integer): boolean;
+
+    {:Get full message from specified message in selected folder.}
+    function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
+
+    {:Get message headers only from specified message in selected folder.}
+    function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
+
+    {:Return message size of specified message from current selected folder.}
+    function MessageSize(MessID: integer): integer;
+
+    {:Copy message from current selected folder to another folder.}
+    function CopyMess(MessID: integer; ToFolder: string): Boolean;
+
+    {:Return message numbers from currently selected folder as result
+     of searching. Search criteria is very complex language (see to IMAP
+     specification) similar to SQL (but not same syntax!).}
+    function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
+
+    {:Sets flags of message from current selected folder.}
+    function SetFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Gets flags of message from current selected folder.}
+    function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
+
+    {:Add flags to message's flags.}
+    function AddFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Remove flags from message's flags.}
+    function DelFlagsMess(MessID: integer; Flags: string): Boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:return UID of requested message ID.}
+    function GetUID(MessID: integer; var UID : Integer): Boolean;
+
+    {:Try to find given capabily in capabilty string returned from IMAP server.}
+    function FindCap(const Value: string): string;
+  published
+    {:Status line with result of last operation.}
+    property ResultString: string read FResultString;
+
+    {:Full result of last IMAP operation.}
+    property FullResult: TStringList read FFullResult;
+
+    {:List of server capabilites.}
+    property IMAPcap: TStringList read FIMAPcap;
+
+    {:Authorization is successful done.}
+    property AuthDone: Boolean read FAuthDone;
+
+    {:Turn on or off usage of UID (unicate identificator) of messages instead
+     only sequence numbers.}
+    property UID: Boolean read FUID Write FUID;
+
+    {:Name of currently selected folder.}
+    property SelectedFolder: string read FSelectedFolder;
+
+    {:Count of messages in currently selected folder.}
+    property SelectedCount: integer read FSelectedCount;
+
+    {:Count of not-visited messages in currently selected folder.}
+    property SelectedRecent: integer read FSelectedRecent;
+
+    {:This number with name of folder is unique indentificator of folder.
+     (If someone delete folder and next create new folder with exactly same name
+     of folder, this number is must be different!)}
+    property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
+
+    {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TIMAPSend.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FIMAPcap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.ConvertLineEnd := True;
+  FSock.SizeRecvBuffer := 32768;
+  FSock.SizeSendBuffer := 32768;
+  FTimeout := 60000;
+  FTargetPort := cIMAPProtocol;
+  FTagCommand := 0;
+  FSelectedFolder := '';
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  FUID := False;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TIMAPSend.Destroy;
+begin
+  FSock.Free;
+  FIMAPcap.Free;
+  FFullResult.Free;
+  inherited Destroy;
+end;
+
+
+function TIMAPSend.ReadResult: string;
+var
+  s: string;
+  x, l: integer;
+begin
+  Result := '';
+  FFullResult.Clear;
+  FResultString := '';
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
+    begin
+      FResultString := s;
+      break;
+    end
+    else
+      FFullResult.Add(s);
+    if (s <> '') and (s[Length(s)]='}') then
+    begin
+      s := Copy(s, 1, Length(s) - 1);
+      x := RPos('{', s);
+      s := Copy(s, x + 1, Length(s) - x);
+      l := StrToIntDef(s, -1);
+      if l <> -1 then
+      begin
+        s := FSock.RecvBufferStr(l, FTimeout);
+        FFullResult.Add(s);
+      end;
+    end;
+  until FSock.LastError <> 0;
+  s := Trim(separateright(FResultString, ' '));
+  Result:=uppercase(Trim(separateleft(s, ' ')));
+end;
+
+procedure TIMAPSend.ProcessLiterals;
+var
+  l: TStringList;
+  n, x: integer;
+  b: integer;
+  s: string;
+begin
+  l := TStringList.Create;
+  try
+    l.Assign(FFullResult);
+    FFullResult.Clear;
+    b := 0;
+    for n := 0 to l.Count - 1 do
+    begin
+      s := l[n];
+      if b > 0 then
+      begin
+        FFullResult[FFullresult.Count - 1] :=
+          FFullResult[FFullresult.Count - 1] + s;
+        inc(b);
+        if b > 2 then
+          b := 0;
+      end
+      else
+      begin
+        if (s <> '') and (s[Length(s)]='}') then
+        begin
+          x := RPos('{', s);
+          Delete(s, x, Length(s) - x + 1);
+          b := 1;
+        end
+        else
+          b := 0;
+        FFullResult.Add(s);
+      end;
+    end;
+  finally
+    l.Free;
+  end;
+end;
+
+function TIMAPSend.IMAPcommand(Value: string): string;
+begin
+  Inc(FTagCommand);
+  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
+  Result := ReadResult;
+end;
+
+function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
+var
+  l: integer;
+begin
+  Inc(FTagCommand);
+  l := Length(Data.Text);
+  FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
+  FSock.RecvString(FTimeout);
+  FSock.SendString(Data.Text + CRLF);
+  Result := ReadResult;
+end;
+
+procedure TIMAPSend.ParseMess(Value:TStrings);
+var
+  n: integer;
+begin
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 2 do
+    if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then
+    begin
+      Value.Text := FFullResult[n + 1];
+      Break;
+    end;
+end;
+
+procedure TIMAPSend.ParseFolderList(Value:TStrings);
+var
+  n, x: integer;
+  s: string;
+begin
+  ProcessLiterals;
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := FFullResult[n];
+    if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
+    begin
+      if s[Length(s)] = '"' then
+      begin
+        Delete(s, Length(s), 1);
+        x := RPos('"', s);
+      end
+      else
+        x := RPos(' ', s);
+      if (x > 0) then
+        Value.Add(Copy(s, x + 1, Length(s) - x));
+    end;
+  end;
+end;
+
+procedure TIMAPSend.ParseSelect;
+var
+  n: integer;
+  s, t: string;
+begin
+  ProcessLiterals;
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos(' EXISTS', s) > 0 then
+    begin
+      t := Trim(separateleft(s, ' EXISTS'));
+      t := Trim(separateright(t, '* '));
+      FSelectedCount := StrToIntDef(t, 0);
+    end;
+    if Pos(' RECENT', s) > 0 then
+    begin
+      t := Trim(separateleft(s, ' RECENT'));
+      t := Trim(separateright(t, '* '));
+      FSelectedRecent := StrToIntDef(t, 0);
+    end;
+    if Pos('UIDVALIDITY', s) > 0 then
+    begin
+      t := Trim(separateright(s, 'UIDVALIDITY '));
+      t := Trim(separateleft(t, ']'));
+      FSelectedUIDvalidity := StrToIntDef(t, 0);
+    end;
+  end;
+end;
+
+procedure TIMAPSend.ParseSearch(Value:TStrings);
+var
+  n: integer;
+  s: string;
+begin
+  ProcessLiterals;
+  Value.Clear;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos('* SEARCH', s) = 1 then
+    begin
+      s := Trim(SeparateRight(s, '* SEARCH'));
+      while s <> '' do
+        Value.Add(Fetch(s, ' '));
+    end;
+  end;
+end;
+
+function TIMAPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FIMAPcap.Count - 1 do
+    if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
+    begin
+      Result := FIMAPcap[n];
+      Break;
+    end;
+end;
+
+function TIMAPSend.AuthLogin: Boolean;
+begin
+  Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
+  if Result then
+    FAuthDone := True;
+end;
+
+function TIMAPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TIMAPSend.Capability: Boolean;
+var
+  n: Integer;
+  s, t: string;
+begin
+  Result := False;
+  FIMAPcap.Clear;
+  s := IMAPcommand('CAPABILITY');
+  if s = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+      if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
+      begin
+        s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
+        while not (s = '') do
+        begin
+          t := Trim(separateleft(s, ' '));
+          s := Trim(separateright(s, ' '));
+          if s = t then
+            s := '';
+          FIMAPcap.Add(t);
+        end;
+      end;
+    Result := True;
+  end;
+end;
+
+function TIMAPSend.Login: Boolean;
+var
+  s: string;
+begin
+  FSelectedFolder := '';
+  FSelectedCount := 0;
+  FSelectedRecent := 0;
+  FSelectedUIDvalidity := 0;
+  Result := False;
+  FAuthDone := False;
+  if not Connect then
+    Exit;
+  s := FSock.RecvString(FTimeout);
+  if Pos('* PREAUTH', s) = 1 then
+    FAuthDone := True
+  else
+    if Pos('* OK', s) = 1 then
+      FAuthDone := False
+    else
+      Exit;
+  if Capability then
+  begin
+    if Findcap('IMAP4rev1') = '' then
+      Exit;
+    if FAutoTLS and (Findcap('STARTTLS') <> '') then
+      if StartTLS then
+        Capability;
+  end;
+  Result := AuthLogin;
+end;
+
+function TIMAPSend.Logout: Boolean;
+begin
+  Result := IMAPcommand('LOGOUT') = 'OK';
+  FSelectedFolder := '';
+  FSock.CloseSocket;
+end;
+
+function TIMAPSend.NoOp: Boolean;
+begin
+  Result := IMAPcommand('NOOP') = 'OK';
+end;
+
+function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
+begin
+  Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
+  ParseFolderList(FolderList);
+end;
+
+function TIMAPSend.CreateFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
+begin
+  Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
+end;
+
+function TIMAPSend.SelectFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
+  FSelectedFolder := FolderName;
+  ParseSelect;
+end;
+
+function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
+begin
+  Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
+  FSelectedFolder := FolderName;
+  ParseSelect;
+end;
+
+function TIMAPSend.CloseFolder: Boolean;
+begin
+  Result := IMAPcommand('CLOSE') = 'OK';
+  FSelectedFolder := '';
+end;
+
+function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
+var
+  n: integer;
+  s, t: string;
+begin
+  Result := -1;
+  Value := Uppercase(Value);
+  if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+    begin
+      s := FFullResult[n];
+//      s := UpperCase(FFullResult[n]);
+      if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
+      begin
+        t := SeparateRight(s, Value);
+        t := SeparateLeft(t, ')');
+        t := trim(t);
+        Result := StrToIntDef(t, -1);
+        Break;
+      end;
+    end;
+  end;
+end;
+
+function TIMAPSend.ExpungeFolder: Boolean;
+begin
+  Result := IMAPcommand('EXPUNGE') = 'OK';
+end;
+
+function TIMAPSend.CheckFolder: Boolean;
+begin
+  Result := IMAPcommand('CHECK') = 'OK';
+end;
+
+function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
+begin
+  Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
+end;
+
+function TIMAPSend.DeleteMess(MessID: integer): boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseMess(Mess);
+end;
+
+function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseMess(Headers);
+end;
+
+function TIMAPSend.MessageSize(MessID: integer): integer;
+var
+  n: integer;
+  s, t: string;
+begin
+  Result := -1;
+  s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
+  if FUID then
+    s := 'UID ' + s;
+  if IMAPcommand(s) = 'OK' then
+  begin
+    ProcessLiterals;
+    for n := 0 to FFullResult.Count - 1 do
+    begin
+      s := UpperCase(FFullResult[n]);
+      if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
+      begin
+        t := SeparateRight(s, 'RFC822.SIZE ');
+        t := Trim(SeparateLeft(t, ')'));
+        t := Trim(SeparateLeft(t, ' '));
+        Result := StrToIntDef(t, -1);
+        Break;
+      end;
+    end;
+  end;
+end;
+
+function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
+var
+  s: string;
+begin
+  s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
+var
+  s: string;
+begin
+  s := 'SEARCH ' + Criteria;
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ParseSearch(FoundMess);
+end;
+
+function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+end;
+
+function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
+var
+  s: string;
+  n: integer;
+begin
+  Flags := '';
+  s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
+  if FUID then
+    s := 'UID ' + s;
+  Result := IMAPcommand(s) = 'OK';
+  ProcessLiterals;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
+    begin
+      s := SeparateRight(s, 'FLAGS');
+      s := Separateright(s, '(');
+      Flags := Trim(SeparateLeft(s, ')'));
+    end;
+  end;
+end;
+
+function TIMAPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    if IMAPcommand('STARTTLS') = 'OK' then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+//Paul Buskermolen <[email protected]>
+function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
+var
+  s, sUid: string;
+  n: integer;
+begin
+  sUID := '';
+  s := 'FETCH ' + IntToStr(MessID) + ' UID';
+  Result := IMAPcommand(s) = 'OK';
+  ProcessLiterals;
+  for n := 0 to FFullResult.Count - 1 do
+  begin
+    s := uppercase(FFullResult[n]);
+    if Pos('FETCH (UID', s) >= 1 then
+    begin
+      s := Separateright(s, '(UID ');
+      sUID := Trim(SeparateLeft(s, ')'));
+    end;
+  end;
+  UID := StrToIntDef(sUID, 0);
+end;
+
+{==============================================================================}
+
+end.

laz_synapse.pas

@@ -0,0 +1,18 @@
+{ This file was automatically created by Lazarus. Do not edit!
+  This source is only used to compile and install the package.
+ }
+
+unit laz_synapse;
+
+interface
+
+uses
+  asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend, 
+  imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend, 
+  pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode, 
+  synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil, 
+  synsock, tlntsend;
+
+implementation
+
+end.

ldapsend.pas

@@ -0,0 +1,1268 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.007.001 |
+|==============================================================================|
+| Content: LDAP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2014.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(LDAP client)
+
+Used RFC: RFC-2251, RFC-2254, RFC-2696, RFC-2829, RFC-2830
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit ldapsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, asn1util, synacode;
+
+const
+  cLDAPProtocol = '389';
+
+  LDAP_ASN1_BIND_REQUEST = $60;
+  LDAP_ASN1_BIND_RESPONSE = $61;
+  LDAP_ASN1_UNBIND_REQUEST = $42;
+  LDAP_ASN1_SEARCH_REQUEST = $63;
+  LDAP_ASN1_SEARCH_ENTRY = $64;
+  LDAP_ASN1_SEARCH_DONE = $65;
+  LDAP_ASN1_SEARCH_REFERENCE = $73;
+  LDAP_ASN1_MODIFY_REQUEST = $66;
+  LDAP_ASN1_MODIFY_RESPONSE = $67;
+  LDAP_ASN1_ADD_REQUEST = $68;
+  LDAP_ASN1_ADD_RESPONSE = $69;
+  LDAP_ASN1_DEL_REQUEST = $4A;
+  LDAP_ASN1_DEL_RESPONSE = $6B;
+  LDAP_ASN1_MODIFYDN_REQUEST = $6C;
+  LDAP_ASN1_MODIFYDN_RESPONSE = $6D;
+  LDAP_ASN1_COMPARE_REQUEST = $6E;
+  LDAP_ASN1_COMPARE_RESPONSE = $6F;
+  LDAP_ASN1_ABANDON_REQUEST = $70;
+  LDAP_ASN1_EXT_REQUEST = $77;
+  LDAP_ASN1_EXT_RESPONSE = $78;
+  LDAP_ASN1_CONTROLS = $A0;
+
+
+type
+
+  {:@abstract(LDAP attribute with list of their values)
+   This class holding name of LDAP attribute and list of their values. This is
+   descendant of TStringList class enhanced by some new properties.}
+  TLDAPAttribute = class(TStringList)
+  private
+    FAttributeName: AnsiString;
+    FIsBinary: Boolean;
+  protected
+    function Get(Index: integer): string; override;
+    procedure Put(Index: integer; const Value: string); override;
+    procedure SetAttributeName(Value: AnsiString);
+  public
+    function Add(const S: string): Integer; override;
+  published
+    {:Name of LDAP attribute.}
+    property AttributeName: AnsiString read FAttributeName Write SetAttributeName;
+    {:Return @true when attribute contains binary data.}
+    property IsBinary: Boolean read FIsBinary;
+  end;
+
+  {:@abstract(List of @link(TLDAPAttribute))
+   This object can hold list of TLDAPAttribute objects.}
+  TLDAPAttributeList = class(TObject)
+  private
+    FAttributeList: TList;
+    function GetAttribute(Index: integer): TLDAPAttribute;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    {:Clear list.}
+    procedure Clear;
+    {:Return count of TLDAPAttribute objects in list.}
+    function Count: integer;
+    {:Add new TLDAPAttribute object to list.}
+    function Add: TLDAPAttribute;
+    {:Delete one TLDAPAttribute object from list.}
+    procedure Del(Index: integer);
+    {:Find and return attribute with requested name. Returns nil if not found.}
+    function Find(AttributeName: AnsiString): TLDAPAttribute;
+    {:Find and return attribute value with requested name. Returns empty string if not found.}
+    function Get(AttributeName: AnsiString): string;
+    {:List of TLDAPAttribute objects.}
+    property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default;
+  end;
+
+  {:@abstract(LDAP result object)
+   This object can hold LDAP object. (their name and all their attributes with
+   values)}
+  TLDAPResult = class(TObject)
+  private
+    FObjectName: AnsiString;
+    FAttributes: TLDAPAttributeList;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    {:Name of this LDAP object.}
+    property ObjectName: AnsiString read FObjectName write FObjectName;
+    {:Here is list of object attributes.}
+    property Attributes: TLDAPAttributeList read FAttributes;
+  end;
+
+  {:@abstract(List of LDAP result objects)
+   This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)}
+  TLDAPResultList = class(TObject)
+  private
+    FResultList: TList;
+    function GetResult(Index: integer): TLDAPResult;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    {:Clear all TLDAPResult objects in list.}
+    procedure Clear;
+    {:Return count of TLDAPResult objects in list.}
+    function Count: integer;
+    {:Create and add new TLDAPResult object to list.}
+    function Add: TLDAPResult;
+    {:List of TLDAPResult objects.}
+    property Items[Index: Integer]: TLDAPResult read GetResult; default;
+  end;
+
+  {:Define possible operations for LDAP MODIFY operations.}
+  TLDAPModifyOp = (
+    MO_Add,
+    MO_Delete,
+    MO_Replace
+  );
+
+  {:Specify possible values for search scope.}
+  TLDAPSearchScope = (
+    SS_BaseObject,
+    SS_SingleLevel,
+    SS_WholeSubtree
+  );
+
+  {:Specify possible values about alias dereferencing.}
+  TLDAPSearchAliases = (
+    SA_NeverDeref,
+    SA_InSearching,
+    SA_FindingBaseObj,
+    SA_Always
+  );
+
+  {:@abstract(Implementation of LDAP client)
+   (version 2 and 3)
+
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TLDAPSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: AnsiString;
+    FFullResult: AnsiString;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    FSeq: integer;
+    FResponseCode: integer;
+    FResponseDN: AnsiString;
+    FReferals: TStringList;
+    FVersion: integer;
+    FSearchScope: TLDAPSearchScope;
+    FSearchAliases: TLDAPSearchAliases;
+    FSearchSizeLimit: integer;
+    FSearchTimeLimit: integer;
+    FSearchPageSize: integer;
+    FSearchCookie: AnsiString;
+    FSearchResult: TLDAPResultList;
+    FExtName: AnsiString;
+    FExtValue: AnsiString;
+    function Connect: Boolean;
+    function BuildPacket(const Value: AnsiString): AnsiString;
+    function ReceiveResponse: AnsiString;
+    function DecodeResponse(const Value: AnsiString): AnsiString;
+    function LdapSasl(Value: AnsiString): AnsiString;
+    function TranslateFilter(Value: AnsiString): AnsiString;
+    function GetErrorString(Value: integer): AnsiString;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Try to connect to LDAP server and start secure channel, when it is required.}
+    function Login: Boolean;
+
+    {:Try to bind to LDAP server with @link(TSynaClient.Username) and
+     @link(TSynaClient.Password). If this is empty strings, then it do annonymous
+     Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
+     mode.
+
+     This method using plaintext transport of password! It is not secure!}
+    function Bind: Boolean;
+
+    {:Try to bind to LDAP server with @link(TSynaClient.Username) and
+     @link(TSynaClient.Password). If this is empty strings, then it do annonymous
+     Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
+     mode.
+
+     This method using SASL with DIGEST-MD5 method for secure transfer of your
+     password.}
+    function BindSasl: Boolean;
+
+    {:Close connection to LDAP server.}
+    function Logout: Boolean;
+
+    {:Modify content of LDAP attribute on this object.}
+    function Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
+
+    {:Add list of attributes to specified object.}
+    function Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
+
+    {:Delete this LDAP object from server.}
+    function Delete(obj: AnsiString): Boolean;
+
+    {:Modify object name of this LDAP object.}
+    function ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteoldRDN: Boolean): Boolean;
+
+    {:Try to compare Attribute value with this LDAP object.}
+    function Compare(obj, AttributeValue: AnsiString): Boolean;
+
+    {:Search LDAP base for LDAP objects by Filter.}
+    function Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
+      const Attributes: TStrings): Boolean;
+
+    {:Call any LDAPv3 extended command.}
+    function Extended(const Name, Value: AnsiString): Boolean;
+
+    {:Try to start SSL/TLS connection to LDAP server.}
+    function StartTLS: Boolean;
+  published
+    {:Specify version of used LDAP protocol. Default value is 3.}
+    property Version: integer read FVersion Write FVersion;
+
+    {:Result code of last LDAP operation.}
+    property ResultCode: Integer read FResultCode;
+
+    {:Human readable description of result code of last LDAP operation.}
+    property ResultString: AnsiString read FResultString;
+
+    {:Binary string with full last response of LDAP server. This string is
+     encoded by ASN.1 BER encoding! You need this only for debugging.}
+    property FullResult: AnsiString read FFullResult;
+
+    {:If @true, then try to start TSL mode in Login procedure.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:If @true, then use connection to LDAP server through SSL/TLS tunnel.}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Sequence number of last LDAp command. It is incremented by any LDAP command.}
+    property Seq: integer read FSeq;
+
+    {:Specify what search scope is used in search command.}
+    property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope;
+
+    {:Specify how to handle aliases in search command.}
+    property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases;
+
+    {:Specify result size limit in search command. Value 0 means without limit.}
+    property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit;
+
+    {:Specify search time limit in search command (seconds). Value 0 means
+     without limit.}
+    property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit;
+
+    {:Specify number of results to return per search request. Value 0 means
+     no paging.}
+    property SearchPageSize: integer read FSearchPageSize Write FSearchPageSize;
+
+    {:Cookie returned by paged search results. Use an empty string for the first
+     search request.}
+    property SearchCookie: AnsiString read FSearchCookie Write FSearchCookie;
+
+    {:Here is result of search command.}
+    property SearchResult: TLDAPResultList read FSearchResult;
+
+    {:On each LDAP operation can LDAP server return some referals URLs. Here is
+     their list.}
+    property Referals: TStringList read FReferals;
+
+    {:When you call @link(Extended) operation, then here is result Name returned
+     by server.}
+    property ExtName: AnsiString read FExtName;
+
+    {:When you call @link(Extended) operation, then here is result Value returned
+     by server.}
+    property ExtValue: AnsiString read FExtValue;
+
+    {:TCP socket used by all LDAP operations.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+{:Dump result of LDAP SEARCH into human readable form. Good for debugging.}
+function LDAPResultDump(const Value: TLDAPResultList): string;
+
+implementation
+
+{==============================================================================}
+function TLDAPAttribute.Add(const S: string): Integer;
+begin
+  Result := inherited Add('');
+  Put(Result,S);
+end;
+
+function StrToHex(const s: string):string;
+var
+  i: Integer;
+begin
+  for i := Low(s) to High(s) do
+   Result := Result + Ord(s[i]).ToHexString + ' ';
+end;
+
+function TLDAPAttribute.Get(Index: integer): string;
+begin
+  Result := inherited Get(Index);
+  if FIsbinary then
+    Result := StrToHex(Result);
+end;
+
+procedure TLDAPAttribute.Put(Index: integer; const Value: string);
+var
+  s: AnsiString;
+begin
+  s := Value;
+  if FIsbinary then
+    s := EncodeBase64(Value)
+  else
+    s :=UnquoteStr(s, '"');
+  inherited Put(Index, s);
+end;
+
+procedure TLDAPAttribute.SetAttributeName(Value: AnsiString);
+begin
+  FAttributeName := Value;
+  FIsBinary := (Pos(';binary', Lowercase(value)) > 0) or (FAttributeName = 'objectGUID')  or (FAttributeName = 'objectSid');
+end;
+
+{==============================================================================}
+constructor TLDAPAttributeList.Create;
+begin
+  inherited Create;
+  FAttributeList := TList.Create;
+end;
+
+destructor TLDAPAttributeList.Destroy;
+begin
+  Clear;
+  FAttributeList.Free;
+  inherited Destroy;
+end;
+
+procedure TLDAPAttributeList.Clear;
+var
+  n: integer;
+  x: TLDAPAttribute;
+begin
+  for n := Count - 1 downto 0 do
+  begin
+    x := GetAttribute(n);
+    if Assigned(x) then
+      x.Free;
+  end;
+  FAttributeList.Clear;
+end;
+
+function TLDAPAttributeList.Count: integer;
+begin
+  Result := FAttributeList.Count;
+end;
+
+function TLDAPAttributeList.Get(AttributeName: AnsiString): string;
+var
+  x: TLDAPAttribute;
+begin
+  Result := '';
+  x := self.Find(AttributeName);
+  if x <> nil then
+    if x.Count > 0 then
+      Result := x[0];
+end;
+
+function TLDAPAttributeList.GetAttribute(Index: integer): TLDAPAttribute;
+begin
+  Result := nil;
+  if Index < Count then
+    Result := TLDAPAttribute(FAttributeList[Index]);
+end;
+
+function TLDAPAttributeList.Add: TLDAPAttribute;
+begin
+  Result := TLDAPAttribute.Create;
+  FAttributeList.Add(Result);
+end;
+
+procedure TLDAPAttributeList.Del(Index: integer);
+var
+  x: TLDAPAttribute;
+begin
+  x := GetAttribute(Index);
+  if Assigned(x) then
+    x.free;
+  FAttributeList.Delete(Index);
+end;
+
+function TLDAPAttributeList.Find(AttributeName: AnsiString): TLDAPAttribute;
+var
+  n: integer;
+  x: TLDAPAttribute;
+begin
+  Result := nil;
+  AttributeName := lowercase(AttributeName);
+  for n := 0 to Count - 1 do
+  begin
+    x := GetAttribute(n);
+    if Assigned(x) then
+      if lowercase(x.AttributeName) = Attributename then
+      begin
+        result := x;
+        break;
+      end;
+  end;
+end;
+
+{==============================================================================}
+constructor TLDAPResult.Create;
+begin
+  inherited Create;
+  FAttributes := TLDAPAttributeList.Create;
+end;
+
+destructor TLDAPResult.Destroy;
+begin
+  FAttributes.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+constructor TLDAPResultList.Create;
+begin
+  inherited Create;
+  FResultList := TList.Create;
+end;
+
+destructor TLDAPResultList.Destroy;
+begin
+  Clear;
+  FResultList.Free;
+  inherited Destroy;
+end;
+
+procedure TLDAPResultList.Clear;
+var
+  n: integer;
+  x: TLDAPResult;
+begin
+  for n := Count - 1 downto 0 do
+  begin
+    x := GetResult(n);
+    if Assigned(x) then
+      x.Free;
+  end;
+  FResultList.Clear;
+end;
+
+function TLDAPResultList.Count: integer;
+begin
+  Result := FResultList.Count;
+end;
+
+function TLDAPResultList.GetResult(Index: integer): TLDAPResult;
+begin
+  Result := nil;
+  if Index < Count then
+    Result := TLDAPResult(FResultList[Index]);
+end;
+
+function TLDAPResultList.Add: TLDAPResult;
+begin
+  Result := TLDAPResult.Create;
+  FResultList.Add(Result);
+end;
+
+{==============================================================================}
+constructor TLDAPSend.Create;
+begin
+  inherited Create;
+  FReferals := TStringList.Create;
+  FFullResult := '';
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FTimeout := 60000;
+  FTargetPort := cLDAPProtocol;
+  FAutoTLS := False;
+  FFullSSL := False;
+  FSeq := 0;
+  FVersion := 3;
+  FSearchScope := SS_WholeSubtree;
+  FSearchAliases := SA_Always;
+  FSearchSizeLimit := 0;
+  FSearchTimeLimit := 0;
+  FSearchPageSize := 0;
+  FSearchCookie := '';
+  FSearchResult := TLDAPResultList.Create;
+end;
+
+destructor TLDAPSend.Destroy;
+begin
+  FSock.Free;
+  FSearchResult.Free;
+  FReferals.Free;
+  inherited Destroy;
+end;
+
+function TLDAPSend.GetErrorString(Value: integer): AnsiString;
+begin
+  case Value of
+    0:
+      Result := 'Success';
+    1:
+      Result := 'Operations error';
+    2:
+      Result := 'Protocol error';
+    3:
+      Result := 'Time limit Exceeded';
+    4:
+      Result := 'Size limit Exceeded';
+    5:
+      Result := 'Compare FALSE';
+    6:
+      Result := 'Compare TRUE';
+    7:
+      Result := 'Auth method not supported';
+    8:
+      Result := 'Strong auth required';
+    9:
+      Result := '-- reserved --';
+    10:
+      Result := 'Referal';
+    11:
+      Result := 'Admin limit exceeded';
+    12:
+      Result := 'Unavailable critical extension';
+    13:
+      Result := 'Confidentality required';
+    14:
+      Result := 'Sasl bind in progress';
+    16:
+      Result := 'No such attribute';
+    17:
+      Result := 'Undefined attribute type';
+    18:
+      Result := 'Inappropriate matching';
+    19:
+      Result := 'Constraint violation';
+    20:
+      Result := 'Attribute or value exists';
+    21:
+      Result := 'Invalid attribute syntax';
+    32:
+      Result := 'No such object';
+    33:
+      Result := 'Alias problem';
+    34:
+      Result := 'Invalid DN syntax';
+    36:
+      Result := 'Alias dereferencing problem';
+    48:
+      Result := 'Inappropriate authentication';
+    49:
+      Result := 'Invalid credentials';
+    50:
+      Result := 'Insufficient access rights';
+    51:
+      Result := 'Busy';
+    52:
+      Result := 'Unavailable';
+    53:
+      Result := 'Unwilling to perform';
+    54:
+      Result := 'Loop detect';
+    64:
+      Result := 'Naming violation';
+    65:
+      Result := 'Object class violation';
+    66:
+      Result := 'Not allowed on non leaf';
+    67:
+      Result := 'Not allowed on RDN';
+    68:
+      Result := 'Entry already exists';
+    69:
+      Result := 'Object class mods prohibited';
+    71:
+      Result := 'Affects multiple DSAs';
+    80:
+      Result := 'Other';
+  else
+    Result := '--unknown--';
+  end;
+end;
+
+function TLDAPSend.Connect: Boolean;
+begin
+  // Do not call this function! It is calling by LOGIN method!
+  FSock.CloseSocket;
+  FSock.LineBuffer := '';
+  FSeq := 0;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TLDAPSend.BuildPacket(const Value: AnsiString): AnsiString;
+begin
+  Inc(FSeq);
+  Result := ASNObject(ASNObject(ASNEncInt(FSeq), ASN1_INT) + Value,  ASN1_SEQ);
+end;
+
+function TLDAPSend.ReceiveResponse: AnsiString;
+var
+  x: Byte;
+  i,j: integer;
+begin
+  Result := '';
+  FFullResult := '';
+  x := FSock.RecvByte(FTimeout);
+  if x <> ASN1_SEQ then
+    Exit;
+  Result := AnsiChar(x);
+  x := FSock.RecvByte(FTimeout);
+  Result := Result + AnsiChar(x);
+  if x < $80 then
+    i := 0
+  else
+    i := x and $7F;
+  if i > 0 then
+    Result := Result + FSock.RecvBufferStr(i, Ftimeout);
+  if FSock.LastError <> 0 then
+  begin
+    Result := '';
+    Exit;
+  end;
+  //get length of LDAP packet
+  j := 2;
+  i := ASNDecLen(j, Result);
+  //retreive rest of LDAP packet
+  if i > 0 then
+    Result := Result + FSock.RecvBufferStr(i, Ftimeout);
+  if FSock.LastError <> 0 then
+  begin
+    Result := '';
+    Exit;
+  end;
+  FFullResult := Result;
+end;
+
+function TLDAPSend.DecodeResponse(const Value: AnsiString): AnsiString;
+var
+  i, x: integer;
+  Svt: Integer;
+  s, t: AnsiString;
+begin
+  Result := '';
+  FResultCode := -1;
+  FResultstring := '';
+  FResponseCode := -1;
+  FResponseDN := '';
+  FReferals.Clear;
+  i := 1;
+  ASNItem(i, Value, Svt);
+  x := StrToIntDef(ASNItem(i, Value, Svt), 0);
+  if (svt <> ASN1_INT) or (x <> FSeq) then
+    Exit;
+  s := ASNItem(i, Value, Svt);
+  FResponseCode := svt;
+  if FResponseCode in [LDAP_ASN1_BIND_RESPONSE, LDAP_ASN1_SEARCH_DONE,
+    LDAP_ASN1_MODIFY_RESPONSE, LDAP_ASN1_ADD_RESPONSE, LDAP_ASN1_DEL_RESPONSE,
+    LDAP_ASN1_MODIFYDN_RESPONSE, LDAP_ASN1_COMPARE_RESPONSE,
+    LDAP_ASN1_EXT_RESPONSE] then
+  begin
+    FResultCode := StrToIntDef(ASNItem(i, Value, Svt), -1);
+    FResponseDN := ASNItem(i, Value, Svt);
+    FResultString := ASNItem(i, Value, Svt);
+    if FResultString = '' then
+      FResultString := GetErrorString(FResultCode);
+    if FResultCode = 10 then
+    begin
+      s := ASNItem(i, Value, Svt);
+      if svt = $A3 then
+      begin
+        x := 1;
+        while x < Length(s) do
+        begin
+          t := ASNItem(x, s, Svt);
+          FReferals.Add(t);
+        end;
+      end;
+    end;
+  end;
+  Result := Copy(Value, i, Length(Value) - i + 1);
+end;
+
+function TLDAPSend.LdapSasl(Value: AnsiString): AnsiString;
+var
+  nonce, cnonce, nc, realm, qop, uri, response: AnsiString;
+  s: AnsiString;
+  a1, a2: AnsiString;
+  l: TStringList;
+  n: integer;
+begin
+  l := TStringList.Create;
+  try
+    nonce := '';
+    realm := '';
+    l.CommaText := Value;
+    n := IndexByBegin('nonce=', l);
+    if n >= 0 then
+      nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"');
+    n := IndexByBegin('realm=', l);
+    if n >= 0 then
+      realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"');
+    cnonce := IntToHex(GetTick, 8);
+    nc := '00000001';
+    qop := 'auth';
+    uri := 'ldap/' + FSock.ResolveIpToName(FSock.GetRemoteSinIP);
+    a1 := md5(FUsername + ':' + realm + ':' + FPassword)
+      + ':' + nonce + ':' + cnonce;
+    a2 := 'AUTHENTICATE:' + uri;
+    s := strtohex(md5(a1))+':' + nonce + ':' + nc + ':' + cnonce + ':'
+      + qop +':'+strtohex(md5(a2));
+    response := strtohex(md5(s));
+
+    Result := 'username="' + Fusername + '",realm="' + realm + '",nonce="';
+    Result := Result + nonce + '",cnonce="' + cnonce + '",nc=' + nc + ',qop=';
+    Result := Result + qop + ',digest-uri="' + uri + '",response=' + response;
+  finally
+    l.Free;
+  end;
+end;
+
+function TLDAPSend.TranslateFilter(Value: AnsiString): AnsiString;
+var
+  x: integer;
+  s, t, l: AnsiString;
+  r: string;
+  c: Ansichar;
+  attr, rule: AnsiString;
+  dn: Boolean;
+begin
+  Result := '';
+  if Value = '' then
+    Exit;
+  s := Value;
+  if Value[1] = '(' then
+  begin
+    x := RPos(')', Value);
+    s := Copy(Value, 2, x - 2);
+  end;
+  if s = '' then
+    Exit;
+  case s[1] of
+    '!':
+      // NOT rule (recursive call)
+      begin
+        Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2);
+      end;
+    '&':
+      // AND rule (recursive call)
+      begin
+        repeat
+          t := GetBetween('(', ')', s);
+          s := Trim(SeparateRight(s, t));
+          if s <> '' then
+            if s[1] = ')' then
+              {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
+          Result := Result + TranslateFilter(t);
+        until s = '';
+        Result := ASNOBject(Result, $A0);
+      end;
+    '|':
+      // OR rule (recursive call)
+      begin
+        repeat
+          t := GetBetween('(', ')', s);
+          s := Trim(SeparateRight(s, t));
+          if s <> '' then
+            if s[1] = ')' then
+              {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
+          Result := Result + TranslateFilter(t);
+        until s = '';
+        Result := ASNOBject(Result, $A1);
+      end;
+    else
+      begin
+        l := Trim(SeparateLeft(s, '='));
+        r := Trim(SeparateRight(s, '='));
+        if l <> '' then
+        begin
+          c := l[Length(l)];
+          case c of
+            ':':
+              // Extensible match
+              begin
+                {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
+                dn := False;
+                attr := '';
+                rule := '';
+                if Pos(':dn', l) > 0 then
+                begin
+                  dn := True;
+                  l := ReplaceString(l, ':dn', '');
+                end;
+                attr := Trim(SeparateLeft(l, ':'));
+                rule := Trim(SeparateRight(l, ':'));
+                if rule = l then
+                  rule := '';
+                if rule <> '' then
+                  Result := ASNObject(rule, $81);
+                if attr <> '' then
+                  Result := Result + ASNObject(attr, $82);
+                Result := Result + ASNObject(DecodeTriplet(r, '\'), $83);
+                if dn then
+                  Result := Result + ASNObject(AsnEncInt($ff), $84)
+                else
+                  Result := Result + ASNObject(AsnEncInt(0), $84);
+                Result := ASNOBject(Result, $a9);
+              end;
+            '~':
+              // Approx match
+              begin
+                {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
+                Result := ASNOBject(l, ASN1_OCTSTR)
+                  + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
+                Result := ASNOBject(Result, $a8);
+              end;
+            '>':
+              // Greater or equal match
+              begin
+                {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
+                Result := ASNOBject(l, ASN1_OCTSTR)
+                  + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
+                Result := ASNOBject(Result, $a5);
+              end;
+            '<':
+              // Less or equal match
+              begin
+                {$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
+                Result := ASNOBject(l, ASN1_OCTSTR)
+                  + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
+                Result := ASNOBject(Result, $a6);
+              end;
+          else
+            // present
+            if r = '*' then
+              Result := ASNOBject(l, $87)
+            else
+              if Pos('*', r) > 0 then
+              // substrings
+              begin
+                s := Fetch(r, '*');
+                if s <> '' then
+                  Result := ASNOBject(DecodeTriplet(s, '\'), $80);
+                while r <> '' do
+                begin
+                  if Pos('*', r) <= 0 then
+                    break;
+                  s := Fetch(r, '*');
+                  Result := Result + ASNOBject(DecodeTriplet(s, '\'), $81);
+                end;
+                if r <> '' then
+                  Result := Result + ASNOBject(DecodeTriplet(r, '\'), $82);
+                Result := ASNOBject(l, ASN1_OCTSTR)
+                  + ASNOBject(Result, ASN1_SEQ);
+                Result := ASNOBject(Result, $a4);
+              end
+              else
+              begin
+                // Equality match
+                Result := ASNOBject(l, ASN1_OCTSTR)
+                  + ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
+                Result := ASNOBject(Result, $a3);
+              end;
+          end;
+        end;
+      end;
+  end;
+end;
+
+function TLDAPSend.Login: Boolean;
+begin
+  Result := False;
+  if not Connect then
+    Exit;
+  Result := True;
+  if FAutoTLS then
+    Result := StartTLS;
+end;
+
+function TLDAPSend.Bind: Boolean;
+var
+  s: AnsiString;
+begin
+  s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+    + ASNObject(FUsername, ASN1_OCTSTR)
+    + ASNObject(FPassword, $80);
+  s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.BindSasl: Boolean;
+var
+  s, t: AnsiString;
+  x, xt: integer;
+  digreq: AnsiString;
+begin
+  Result := False;
+  if FPassword = '' then
+    Result := Bind
+  else
+  begin
+    digreq := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+      + ASNObject('', ASN1_OCTSTR)
+      + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR), $A3);
+    digreq := ASNObject(digreq, LDAP_ASN1_BIND_REQUEST);
+    Fsock.SendString(BuildPacket(digreq));
+    s := ReceiveResponse;
+    t := DecodeResponse(s);
+    if FResultCode = 14 then
+    begin
+      s := t;
+      x := 1;
+      t := ASNItem(x, s, xt);
+      s := ASNObject(ASNEncInt(FVersion), ASN1_INT)
+        + ASNObject('', ASN1_OCTSTR)
+        + ASNObject(ASNObject('DIGEST-MD5', ASN1_OCTSTR)
+          + ASNObject(LdapSasl(t), ASN1_OCTSTR), $A3);
+      s := ASNObject(s, LDAP_ASN1_BIND_REQUEST);
+      Fsock.SendString(BuildPacket(s));
+      s := ReceiveResponse;
+      DecodeResponse(s);
+      if FResultCode = 14 then
+      begin
+        Fsock.SendString(BuildPacket(digreq));
+        s := ReceiveResponse;
+        DecodeResponse(s);
+      end;
+      Result := FResultCode = 0;
+    end;
+  end;
+end;
+
+function TLDAPSend.Logout: Boolean;
+begin
+  Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST)));
+  FSock.CloseSocket;
+  Result := True;
+end;
+
+function TLDAPSend.Modify(obj: AnsiString; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
+var
+  s: AnsiString;
+  n: integer;
+begin
+  s := '';
+  for n := 0 to Value.Count -1 do
+    s := s + ASNObject(Value[n], ASN1_OCTSTR);
+  s := ASNObject(Value.AttributeName, ASN1_OCTSTR) + ASNObject(s, ASN1_SETOF);
+  s := ASNObject(ASNEncInt(Ord(Op)), ASN1_ENUM) + ASNObject(s, ASN1_SEQ);
+  s := ASNObject(s, ASN1_SEQ);
+  s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
+  s := ASNObject(s, LDAP_ASN1_MODIFY_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.Add(obj: AnsiString; const Value: TLDAPAttributeList): Boolean;
+var
+  s, t: AnsiString;
+  n, m: integer;
+begin
+  s := '';
+  for n := 0 to Value.Count - 1 do
+  begin
+    t := '';
+    for m := 0 to Value[n].Count - 1 do
+      t := t + ASNObject(Value[n][m], ASN1_OCTSTR);
+    t := ASNObject(Value[n].AttributeName, ASN1_OCTSTR)
+      + ASNObject(t, ASN1_SETOF);
+    s := s + ASNObject(t, ASN1_SEQ);
+  end;
+  s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
+  s := ASNObject(s, LDAP_ASN1_ADD_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.Delete(obj: AnsiString): Boolean;
+var
+  s: AnsiString;
+begin
+  s := ASNObject(obj, LDAP_ASN1_DEL_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.ModifyDN(obj, newRDN, newSuperior: AnsiString; DeleteOldRDN: Boolean): Boolean;
+var
+  s: AnsiString;
+begin
+  s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(newRDN, ASN1_OCTSTR);
+  if DeleteOldRDN then
+    s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
+  else
+    s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
+  if newSuperior <> '' then
+    s := s + ASNObject(newSuperior, $80);
+  s := ASNObject(s, LDAP_ASN1_MODIFYDN_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.Compare(obj, AttributeValue: AnsiString): Boolean;
+var
+  s: AnsiString;
+begin
+  s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR)
+    + ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR);
+  s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
+  s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  DecodeResponse(s);
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.Search(obj: AnsiString; TypesOnly: Boolean; Filter: AnsiString;
+  const Attributes: TStrings): Boolean;
+var
+  s, t, u, c: AnsiString;
+  n, i, x: integer;
+  r: TLDAPResult;
+  a: TLDAPAttribute;
+begin
+  FSearchResult.Clear;
+  FReferals.Clear;
+  s := ASNObject(obj, ASN1_OCTSTR);
+  s := s + ASNObject(ASNEncInt(Ord(FSearchScope)), ASN1_ENUM);
+  s := s + ASNObject(ASNEncInt(Ord(FSearchAliases)), ASN1_ENUM);
+  s := s + ASNObject(ASNEncInt(FSearchSizeLimit), ASN1_INT);
+  s := s + ASNObject(ASNEncInt(FSearchTimeLimit), ASN1_INT);
+  if TypesOnly then
+    s := s + ASNObject(ASNEncInt($ff), ASN1_BOOL)
+  else
+    s := s + ASNObject(ASNEncInt(0), ASN1_BOOL);
+  if Filter = '' then
+    Filter := '(objectclass=*)';
+  t := TranslateFilter(Filter);
+  if t = '' then
+    s := s + ASNObject('', ASN1_NULL)
+  else
+    s := s + t;
+  t := '';
+  for n := 0 to Attributes.Count - 1 do
+    t := t + ASNObject(Attributes[n], ASN1_OCTSTR);
+  s := s + ASNObject(t, ASN1_SEQ);
+  s := ASNObject(s, LDAP_ASN1_SEARCH_REQUEST);
+  if FSearchPageSize > 0 then
+  begin
+    c := ASNObject('1.2.840.113556.1.4.319', ASN1_OCTSTR); // controlType: pagedResultsControl
+    c := c + ASNObject(ASNEncInt(0), ASN1_BOOL); // criticality: FALSE
+    t := ASNObject(ASNEncInt(FSearchPageSize), ASN1_INT); // page size
+    t := t + ASNObject(FSearchCookie, ASN1_OCTSTR); // search cookie
+    t := ASNObject(t, ASN1_SEQ); // wrap with SEQUENCE
+    c := c + ASNObject(t, ASN1_OCTSTR); // add searchControlValue as OCTET STRING
+    c := ASNObject(c, ASN1_SEQ); // wrap with SEQUENCE
+    s := s + ASNObject(c, LDAP_ASN1_CONTROLS); // append Controls to SearchRequest
+  end;
+  Fsock.SendString(BuildPacket(s));
+  repeat
+    s := ReceiveResponse;
+    t := DecodeResponse(s);
+    if FResponseCode = LDAP_ASN1_SEARCH_ENTRY then
+    begin
+      //dekoduj zaznam
+      r := FSearchResult.Add;
+      n := 1;
+      r.ObjectName := ASNItem(n, t, x);
+      ASNItem(n, t, x);
+      if x = ASN1_SEQ then
+      begin
+        while n < Length(t) do
+        begin
+          s := ASNItem(n, t, x);
+          if x = ASN1_SEQ then
+          begin
+            i := n + Length(s);
+            a := r.Attributes.Add;
+            u := ASNItem(n, t, x);
+            a.AttributeName := u;
+            ASNItem(n, t, x);
+            if x = ASN1_SETOF then
+              while n < i do
+              begin
+                u := ASNItem(n, t, x);
+                a.Add(u);
+              end;
+          end;
+        end;
+      end;
+    end;
+    if FResponseCode = LDAP_ASN1_SEARCH_REFERENCE then
+    begin
+      n := 1;
+      while n < Length(t) do
+        FReferals.Add(ASNItem(n, t, x));
+    end;
+  until FResponseCode = LDAP_ASN1_SEARCH_DONE;
+  n := 1;
+  ASNItem(n, t, x);
+  if x = LDAP_ASN1_CONTROLS then
+  begin
+    ASNItem(n, t, x);
+    if x = ASN1_SEQ then
+    begin
+      s := ASNItem(n, t, x);
+      if s = '1.2.840.113556.1.4.319' then
+      begin
+        s := ASNItem(n, t, x); // searchControlValue
+        n := 1;
+        ASNItem(n, s, x);
+        if x = ASN1_SEQ then
+        begin
+          ASNItem(n, s, x); // total number of result records, if known, otherwise 0
+          FSearchCookie := ASNItem(n, s, x); // active search cookie, empty when done
+        end;
+      end;
+    end;
+  end;
+  Result := FResultCode = 0;
+end;
+
+function TLDAPSend.Extended(const Name, Value: AnsiString): Boolean;
+var
+  s, t: AnsiString;
+  x, xt: integer;
+begin
+  s := ASNObject(Name, $80);
+  if Value <> '' then
+    s := s + ASNObject(Value, $81);
+  s := ASNObject(s, LDAP_ASN1_EXT_REQUEST);
+  Fsock.SendString(BuildPacket(s));
+  s := ReceiveResponse;
+  t := DecodeResponse(s);
+  Result := FResultCode = 0;
+  if Result then
+  begin
+    x := 1;
+    FExtName := ASNItem(x, t, xt);
+    FExtValue := ASNItem(x, t, xt);
+  end;
+end;
+
+
+function TLDAPSend.StartTLS: Boolean;
+begin
+  Result := Extended('1.3.6.1.4.1.1466.20037', '');
+  if Result then
+  begin
+    Fsock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+{==============================================================================}
+function LDAPResultDump(const Value: TLDAPResultList): string;
+var
+  n, m, o: integer;
+  r: TLDAPResult;
+  a: TLDAPAttribute;
+begin
+  Result := 'Results: ' + IntToStr(Value.Count) + CRLF +CRLF;
+  for n := 0 to Value.Count - 1 do
+  begin
+    Result := Result + 'Result: ' + IntToStr(n) + CRLF;
+    r := Value[n];
+    Result := Result + '  Object: ' + r.ObjectName + CRLF;
+    for m := 0 to r.Attributes.Count - 1 do
+    begin
+      a := r.Attributes[m];
+      Result := Result + '  Attribute: ' + a.AttributeName + CRLF;
+      for o := 0 to a.Count - 1 do
+        Result := Result + '    ' + a[o] + CRLF;
+    end;
+  end;
+end;
+
+end.

mimeinln.pas

@@ -0,0 +1,263 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.011 |
+|==============================================================================|
+| Content: Inline MIME support procedures and functions                        |
+|==============================================================================|
+| Copyright (c)1999-2006, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2006.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Utilities for inline MIME)
+Support for Inline MIME encoding and decoding.
+
+Used RFC: RFC-2047, RFC-2231
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit mimeinln;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synachar, synacode, synautil;
+
+{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
+function InlineDecode(const Value: string; CP: TMimeChar): string;
+
+{:Encodes string to MIME inline encoding. The source characterset is "CP", and
+ the target charset is "MimeP".}
+function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
+
+{:Returns @true, if "Value" contains characters needed for inline coding.}
+function NeedInline(const Value: AnsiString): boolean;
+
+{:Inline mime encoding similar to @link(InlineEncode), but you can specify
+ source charset, and the target characterset is automatically assigned.}
+function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
+
+{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
+ is automatically set to the system default charset, and the target charset is
+ automatically assigned from set of allowed encoding for MIME.}
+function InlineCode(const Value: string): string;
+
+{:Converts e-mail address to canonical mime form. You can specify source charset.}
+function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
+
+{:Converts e-mail address to canonical mime form. Source charser it system
+ default charset.}
+function InlineEmail(const Value: string): string;
+
+implementation
+
+{==============================================================================}
+
+function InlineDecode(const Value: string; CP: TMimeChar): string;
+var
+  s, su, v: string;
+  x, y, z, n: Integer;
+  ichar: TMimeChar;
+  c: Char;
+
+  function SearchEndInline(const Value: string; be: Integer): Integer;
+  var
+    n, q: Integer;
+  begin
+    q := 0;
+    Result := 0;
+    for n := be + 2 to Length(Value) - 1 do
+      if Value[n] = '?' then
+      begin
+        Inc(q);
+        if (q > 2) and (Value[n + 1] = '=') then
+        begin
+          Result := n;
+          Break;
+        end;
+      end;
+  end;
+
+begin
+  Result := '';
+  v := Value;
+  x := Pos('=?', v);
+  y := SearchEndInline(v, x);
+  //fix for broken coding with begin, but not with end.
+  if (x > 0) and (y <= 0) then
+    y := Length(Result);
+  while (y > x) and (x > 0) do
+  begin
+    s := Copy(v, 1, x - 1);
+    if Trim(s) <> '' then
+      Result := Result + s;
+    s := Copy(v, x, y - x + 2);
+    Delete(v, 1, y + 1);
+    su := Copy(s, 3, Length(s) - 4);
+    z := Pos('?', su);
+    if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
+    begin
+      ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
+      c := UpperCase(su)[z + 1];
+      su := Copy(su, z + 3, Length(su) - z - 2);
+      if c = 'B' then
+      begin
+        s := DecodeBase64(su);
+        s := CharsetConversion(s, ichar, CP);
+      end;
+      if c = 'Q' then
+      begin
+        s := '';
+        for n := 1 to Length(su) do
+          if su[n] = '_' then
+            s := s + ' '
+          else
+            s := s + su[n];
+        s := DecodeQuotedPrintable(s);
+        s := CharsetConversion(s, ichar, CP);
+      end;
+    end;
+    Result := Result + s;
+    x := Pos('=?', v);
+    y := SearchEndInline(v, x);
+  end;
+  Result := Result + v;
+end;
+
+{==============================================================================}
+
+function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
+var
+  s, s1, e: string;
+  n: Integer;
+begin
+  s := CharsetConversion(Value, CP, MimeP);
+  s := EncodeSafeQuotedPrintable(s);
+  e := GetIdFromCP(MimeP);
+  s1 := '';
+  Result := '';
+  for n := 1 to Length(s) do
+    if s[n] = ' ' then
+    begin
+//      s1 := s1 + '=20';
+      s1 := s1 + '_';
+      if Length(s1) > 32 then
+      begin
+        if Result <> '' then
+          Result := Result + ' ';
+        Result := Result + '=?' + e + '?Q?' + s1 + '?=';
+        s1 := '';
+      end;
+    end
+    else
+      s1 := s1 + s[n];
+  if s1 <> '' then
+  begin
+    if Result <> '' then
+      Result := Result + ' ';
+    Result := Result + '=?' + e + '?Q?' + s1 + '?=';
+  end;
+end;
+
+{==============================================================================}
+
+function NeedInline(const Value: AnsiString): boolean;
+var
+  n: Integer;
+begin
+  Result := False;
+  for n := 1 to Length(Value) do
+    if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
+    begin
+      Result := True;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
+var
+  c: TMimeChar;
+begin
+  if NeedInline(Value) then
+  begin
+    c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
+    Result := InlineEncode(Value, FromCP, c);
+  end
+  else
+    Result := Value;
+end;
+
+{==============================================================================}
+
+function InlineCode(const Value: string): string;
+begin
+  Result := InlineCodeEx(Value, GetCurCP);
+end;
+
+{==============================================================================}
+
+function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
+var
+  sd, se: string;
+begin
+  sd := GetEmailDesc(Value);
+  se := GetEmailAddr(Value);
+  if sd = '' then
+    Result := se
+  else
+    Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
+end;
+
+{==============================================================================}
+
+function InlineEmail(const Value: string): string;
+begin
+  Result := InlineEmailEx(Value, GetCurCP);
+end;
+
+end.

mimemess.pas

@@ -0,0 +1,851 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.006.000 |
+|==============================================================================|
+| Content: MIME message object                                                 |
+|==============================================================================|
+| Copyright (c)1999-2012, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2012.                |
+| Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM From distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(MIME message handling)
+Classes for easy handling with e-mail message.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$M+}
+
+unit mimemess;
+
+interface
+
+uses
+  Classes, SysUtils,
+  mimepart, synachar, synautil, mimeinln;
+
+type
+
+  {:Possible values for message priority}
+  TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
+
+  {:@abstract(Object for basic e-mail header fields.)}
+  TMessHeader = class(TObject)
+  private
+    FFrom: string;
+    FToList: TStringList;
+    FCCList: TStringList;
+    FSubject: string;
+    FOrganization: string;
+    FCustomHeaders: TStringList;
+    FDate: TDateTime;
+    FXMailer: string;
+    FCharsetCode: TMimeChar;
+    FReplyTo: string;
+    FMessageID: string;
+    FPriority: TMessPriority;
+    Fpri: TMessPriority;
+    Fxpri: TMessPriority;
+    Fxmspri: TMessPriority;
+  protected
+    function ParsePriority(value: string): TMessPriority;
+    function DecodeHeader(value: string): boolean; virtual;
+  public
+    constructor Create; virtual;
+    destructor Destroy; override;
+
+    {:Clears all data fields.}
+    procedure Clear; virtual;
+
+    {Add headers from from this object to Value.}
+    procedure EncodeHeaders(const Value: TStrings); virtual;
+
+    {:Parse header from Value to this object.}
+    procedure DecodeHeaders(const Value: TStrings);
+
+    {:Try find specific header in CustomHeader. Search is case insensitive.
+     This is good for reading any non-parsed header.}
+    function FindHeader(Value: string): string;
+
+    {:Try find specific headers in CustomHeader. This metod is for repeatly used
+     headers like 'received' header, etc. Search is case insensitive.
+     This is good for reading ano non-parsed header.}
+    procedure FindHeaderList(Value: string; const HeaderList: TStrings);
+  published
+    {:Sender of message.}
+    property From: string read FFrom Write FFrom;
+
+    {:Stringlist with receivers of message. (one per line)}
+    property ToList: TStringList read FToList;
+
+    {:Stringlist with Carbon Copy receivers of message. (one per line)}
+    property CCList: TStringList read FCCList;
+
+    {:Subject of message.}
+    property Subject: string read FSubject Write FSubject;
+
+    {:Organization string.}
+    property Organization: string read FOrganization Write FOrganization;
+
+    {:After decoding contains all headers lines witch not have parsed to any
+     other structures in this object. It mean: this conatins all other headers
+     except:
+
+     X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
+     CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
+     CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
+     X-PRIORITY, PRIORITY
+
+     When you encode headers, all this lines is added as headers. Be carefull
+     for duplicites!}
+    property CustomHeaders: TStringList read FCustomHeaders;
+
+    {:Date and time of message.}
+    property Date: TDateTime read FDate Write FDate;
+
+    {:Mailer identification.}
+    property XMailer: string read FXMailer Write FXMailer;
+
+    {:Address for replies}
+    property ReplyTo: string read FReplyTo Write FReplyTo;
+
+    {:message indetifier}
+    property MessageID: string read FMessageID Write FMessageID;
+
+    {:message priority}
+    property Priority: TMessPriority read FPriority Write FPriority;
+
+    {:Specify base charset. By default is used system charset.}
+    property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
+  end;
+
+  TMessHeaderClass = class of TMessHeader;
+
+  {:@abstract(Object for handling of e-mail message.)}
+  TMimeMess = class(TObject)
+  private
+    FMessagePart: TMimePart;
+    FLines: TStringList;
+    FHeader: TMessHeader;
+  public
+    constructor Create;
+    {:create this object and assign your own descendant of @link(TMessHeader)
+     object to @link(header) property. So, you can create your own message
+     headers parser and use it by this object.}
+    constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
+    destructor Destroy; override;
+
+    {:Reset component to default state.}
+    procedure Clear; virtual;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then one subpart,
+     you must have PartParent of multipart type!}
+    function AddPart(const PartParent: TMimePart): TMimePart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     This part is marked as multipart with secondary MIME type specified by
+     MultipartType parameter. (typical value is 'mixed')
+
+     This part can be used as PartParent for another parts (include next
+     multipart). If you need only one part, then you not need Multipart part.}
+    function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part and set all necessary
+     properties. Content of part is readed from value stringlist.}
+    function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part and set all necessary
+     properties. Content of part is readed from value stringlist. You can select
+     your charset and your encoding type. If Raw is @true, then it not doing
+     charset conversion!}
+    function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+      PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to text part to HTML type and set all
+     necessary properties. Content of HTML part is readed from Value stringlist.}
+    function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartText), but content is readed from file}
+    function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartHTML), but content is readed from file}
+    function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart,
+     you must have PartParent of multipart type!
+
+     After creation of part set type to binary and set all necessary properties.
+     MIME primary and secondary types defined automaticly by filename extension.
+     Content of binary part is readed from Stream. This binary part is encoded
+     as file attachment.}
+    function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartBinary), but content is readed from file}
+    function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to binary and set all necessary properties.
+     MIME primary and secondary types defined automaticly by filename extension.
+     Content of binary part is readed from Stream.
+
+     This binary part is encoded as inline data with given Conten ID (cid).
+     Content ID can be used as reference ID in HTML source in HTML part.}
+    function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartHTMLBinary), but content is readed from file}
+    function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+
+    {:Add MIME part as subpart of PartParent. If you need set root MIME part,
+     then set as PartParent @NIL value. If you need set more then 1 subpart, you
+     must have PartParent of multipart type!
+
+     After creation of part set type to message and set all necessary properties.
+     MIME primary and secondary types are setted to 'message/rfc822'.
+     Content of raw RFC-822 message is readed from Stream.}
+    function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+
+    {:Same as @link(AddPartMess), but content is readed from file}
+    function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+
+    {:Compose message from @link(MessagePart) to @link(Lines). Headers from
+     @link(Header) object is added also.}
+    procedure EncodeMessage; virtual;
+
+    {:Decode message from @link(Lines) to @link(MessagePart). Massage headers
+     are parsed into @link(Header) object.}
+    procedure DecodeMessage; virtual;
+
+    {pf}
+    {: HTTP message is received by @link(THTTPSend) component in two parts:
+     headers are stored in @link(THTTPSend.Headers) and a body in memory stream
+     @link(THTTPSend.Document).
+
+     On the top of it, HTTP connections are always 8-bit, hence data are
+     transferred in native format i.e. no transfer encoding is applied.
+
+     This method operates the similiar way and produces the same
+     result as @link(DecodeMessage).
+    }
+    procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
+    {/pf}
+  published
+    {:@link(TMimePart) object with decoded MIME message. This object can handle
+     any number of nested @link(TMimePart) objects itself. It is used for handle
+     any tree of MIME subparts.}
+    property MessagePart: TMimePart read FMessagePart;
+
+    {:Raw MIME encoded message.}
+    property Lines: TStringList read FLines;
+
+    {:Object for e-mail header fields. This object is created automaticly.
+     Do not free this object!}
+    property Header: TMessHeader read FHeader;
+  end;
+
+implementation
+
+{==============================================================================}
+
+constructor TMessHeader.Create;
+begin
+  inherited Create;
+  FToList := TStringList.Create;
+  FCCList := TStringList.Create;
+  FCustomHeaders := TStringList.Create;
+  FCharsetCode := GetCurCP;
+end;
+
+destructor TMessHeader.Destroy;
+begin
+  FCustomHeaders.Free;
+  FCCList.Free;
+  FToList.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+
+procedure TMessHeader.Clear;
+begin
+  FFrom := '';
+  FToList.Clear;
+  FCCList.Clear;
+  FSubject := '';
+  FOrganization := '';
+  FCustomHeaders.Clear;
+  FDate := 0;
+  FXMailer := '';
+  FReplyTo := '';
+  FMessageID := '';
+  FPriority := MP_unknown;
+end;
+
+procedure TMessHeader.EncodeHeaders(const Value: TStrings);
+var
+  n: Integer;
+  s: string;
+begin
+  if FDate = 0 then
+    FDate := Now;
+  for n := FCustomHeaders.Count - 1 downto 0 do
+    if FCustomHeaders[n] <> '' then
+      Value.Insert(0, FCustomHeaders[n]);
+  if FPriority <> MP_unknown then
+    case FPriority of
+      MP_high:
+        begin
+          Value.Insert(0, 'X-MSMAIL-Priority: High');
+          Value.Insert(0, 'X-Priority: 1');
+          Value.Insert(0, 'Priority: urgent');
+        end;
+      MP_low:
+        begin
+          Value.Insert(0, 'X-MSMAIL-Priority: low');
+          Value.Insert(0, 'X-Priority: 5');
+          Value.Insert(0, 'Priority: non-urgent');
+        end;
+    end;
+  if FReplyTo <> '' then
+    Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
+  if FMessageID <> '' then
+    Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
+  if FXMailer = '' then
+    Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
+  else
+    Value.Insert(0, 'X-mailer: ' + FXMailer);
+  Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
+  if FOrganization <> '' then
+    Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
+  s := '';
+  for n := 0 to FCCList.Count - 1 do
+    if s = '' then
+      s := InlineEmailEx(FCCList[n], FCharsetCode)
+    else
+      s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
+  if s <> '' then
+    Value.Insert(0, 'CC: ' + s);
+  Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
+  if FSubject <> '' then
+    Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
+  s := '';
+  for n := 0 to FToList.Count - 1 do
+    if s = '' then
+      s := InlineEmailEx(FToList[n], FCharsetCode)
+    else
+      s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
+  if s <> '' then
+    Value.Insert(0, 'To: ' + s);
+  Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
+end;
+
+function TMessHeader.ParsePriority(value: string): TMessPriority;
+var
+  s: string;
+  x: integer;
+begin
+  Result := MP_unknown;
+  s := Trim(separateright(value, ':'));
+  s := Separateleft(s, ' ');
+  x := StrToIntDef(s, -1);
+  if x >= 0 then
+    case x of
+      1, 2:
+        Result := MP_High;
+      3:
+        Result := MP_Normal;
+      4, 5:
+        Result := MP_Low;
+    end
+  else
+  begin
+    s := lowercase(s);
+    if (s = 'urgent') or (s = 'high') or (s = 'highest') then
+      Result := MP_High;
+    if (s = 'normal') or (s = 'medium') then
+      Result := MP_Normal;
+    if (s = 'low') or (s = 'lowest')
+      or (s = 'no-priority')  or (s = 'non-urgent') then
+      Result := MP_Low;
+  end;
+end;
+
+function TMessHeader.DecodeHeader(value: string): boolean;
+var
+  s, t: string;
+  cp: TMimeChar;
+begin
+  Result := True;
+  cp := FCharsetCode;
+  s := uppercase(value);
+  if Pos('X-MAILER:', s) = 1 then
+  begin
+    FXMailer := Trim(SeparateRight(Value, ':'));
+    Exit;
+  end;
+  if Pos('FROM:', s) = 1 then
+  begin
+    FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('SUBJECT:', s) = 1 then
+  begin
+    FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('ORGANIZATION:', s) = 1 then
+  begin
+    FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('TO:', s) = 1 then
+  begin
+    s := Trim(SeparateRight(Value, ':'));
+    repeat
+      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
+      if t <> '' then
+        FToList.Add(t);
+    until s = '';
+    Exit;
+  end;
+  if Pos('CC:', s) = 1 then
+  begin
+    s := Trim(SeparateRight(Value, ':'));
+    repeat
+      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
+      if t <> '' then
+        FCCList.Add(t);
+    until s = '';
+    Exit;
+  end;
+  if Pos('DATE:', s) = 1 then
+  begin
+    FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
+    Exit;
+  end;
+  if Pos('REPLY-TO:', s) = 1 then
+  begin
+    FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
+    Exit;
+  end;
+  if Pos('MESSAGE-ID:', s) = 1 then
+  begin
+    FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
+    Exit;
+  end;
+  if Pos('PRIORITY:', s) = 1 then
+  begin
+    FPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('X-PRIORITY:', s) = 1 then
+  begin
+    FXPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
+  begin
+    FXmsPri := ParsePriority(value);
+    Exit;
+  end;
+  if Pos('MIME-VERSION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-TYPE:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-DESCRIPTION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-DISPOSITION:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-ID:', s) = 1 then
+    Exit;
+  if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
+    Exit;
+  Result := False;
+end;
+
+procedure TMessHeader.DecodeHeaders(const Value: TStrings);
+var
+  s: string;
+  x: Integer;
+begin
+  Clear;
+  Fpri := MP_unknown;
+  Fxpri := MP_unknown;
+  Fxmspri := MP_unknown;
+  x := 0;
+  while Value.Count > x do
+  begin
+    s := NormalizeHeader(Value, x);
+    if s = '' then
+      Break;
+    if not DecodeHeader(s) then
+      FCustomHeaders.Add(s);
+  end;
+  if Fpri <> MP_unknown then
+    FPriority := Fpri
+  else
+    if Fxpri <> MP_unknown then
+      FPriority := Fxpri
+    else
+      if Fxmspri <> MP_unknown then
+        FPriority := Fxmspri
+end;
+
+function TMessHeader.FindHeader(Value: string): string;
+var
+  n: integer;
+begin
+  Result := '';
+  for n := 0 to FCustomHeaders.Count - 1 do
+    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
+    begin
+      Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
+      break;
+    end;
+end;
+
+procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
+var
+  n: integer;
+begin
+  HeaderList.Clear;
+  for n := 0 to FCustomHeaders.Count - 1 do
+    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
+    begin
+      HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
+    end;
+end;
+
+{==============================================================================}
+
+constructor TMimeMess.Create;
+begin
+  CreateAltHeaders(TMessHeader);
+end;
+
+constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
+begin
+  inherited Create;
+  FMessagePart := TMimePart.Create;
+  FLines := TStringList.Create;
+  FHeader := HeadClass.Create;
+end;
+
+destructor TMimeMess.Destroy;
+begin
+  FMessagePart.Free;
+  FHeader.Free;
+  FLines.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.Clear;
+begin
+  FMessagePart.Clear;
+  FLines.Clear;
+  FHeader.Clear;
+end;
+
+{==============================================================================}
+
+function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
+begin
+  if PartParent = nil then
+    Result := FMessagePart
+  else
+    Result := PartParent.AddSubPart;
+  Result.Clear;
+end;
+
+{==============================================================================}
+
+function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Primary := 'Multipart';
+    Secondary := MultipartType;
+    Description := 'Multipart message';
+    Boundary := GenerateBoundary;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'plain';
+    Description := 'Message text';
+    Disposition := 'inline';
+    CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
+    EncodingCode := ME_QUOTED_PRINTABLE;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
+  PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'plain';
+    Description := 'Message text';
+    Disposition := 'inline';
+    CharsetCode := PartCharset;
+    EncodingCode := PartEncoding;
+    ConvertCharset := not Raw;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  with Result do
+  begin
+    Value.SaveToStream(DecodedLines);
+    Primary := 'text';
+    Secondary := 'html';
+    Description := 'HTML text';
+    Disposition := 'inline';
+    CharsetCode := UTF_8;
+    EncodingCode := ME_QUOTED_PRINTABLE;
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartText(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartHTML(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  Result.DecodedLines.LoadFromStream(Stream);
+  Result.MimeTypeFromExt(FileName);
+  Result.Description := 'Attached file: ' + FileName;
+  Result.Disposition := 'attachment';
+  Result.FileName := FileName;
+  Result.EncodingCode := ME_BASE64;
+  Result.EncodePart;
+  Result.EncodePartHeader;
+end;
+
+function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TMemoryStream;
+begin
+  tmp := TMemoryStream.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
+  finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+begin
+  Result := AddPart(PartParent);
+  Result.DecodedLines.LoadFromStream(Stream);
+  Result.MimeTypeFromExt(FileName);
+  Result.Description := 'Included file: ' + FileName;
+  Result.Disposition := 'inline';
+  Result.ContentID := Cid;
+  Result.FileName := FileName;
+  Result.EncodingCode := ME_BASE64;
+  Result.EncodePart;
+  Result.EncodePartHeader;
+end;
+
+function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TMemoryStream;
+begin
+  tmp := TMemoryStream.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
+  finally
+    tmp.Free;
+  end;
+end;
+
+function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
+var
+  part: Tmimepart;
+begin
+  Result := AddPart(PartParent);
+  part := AddPart(result);
+  part.lines.addstrings(Value);
+  part.DecomposeParts;
+  with Result do
+  begin
+    Primary := 'message';
+    Secondary := 'rfc822';
+    Description := 'E-mail Message';
+    EncodePart;
+    EncodePartHeader;
+  end;
+end;
+
+function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
+var
+  tmp: TStrings;
+begin
+  tmp := TStringList.Create;
+  try
+    tmp.LoadFromFile(FileName);
+    Result := AddPartMess(tmp, PartParent);
+  Finally
+    tmp.Free;
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.EncodeMessage;
+var
+  l: TStringList;
+  x: integer;
+begin
+  //merge headers from THeaders and header field from MessagePart
+  l := TStringList.Create;
+  try
+    FHeader.EncodeHeaders(l);
+    x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
+    if x >= 0 then
+      l.add(FMessagePart.Headers[x]);
+    FMessagePart.Headers.Assign(l);
+  finally
+    l.Free;
+  end;
+  FMessagePart.ComposeParts;
+  FLines.Assign(FMessagePart.Lines);
+end;
+
+{==============================================================================}
+
+procedure TMimeMess.DecodeMessage;
+begin
+  FHeader.Clear;
+  FHeader.DecodeHeaders(FLines);
+  FMessagePart.Lines.Assign(FLines);
+  FMessagePart.DecomposeParts;
+end;
+
+{pf}
+procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
+begin
+  FHeader.Clear;
+  FLines.Clear;
+  FLines.Assign(AHeader);
+  FHeader.DecodeHeaders(FLines);
+  FMessagePart.DecomposePartsBinary(AHeader,PChar(AData.Memory),PChar(AData.Memory)+AData.Size);
+end;
+{/pf}
+
+end.

mimepart.pas

@@ -0,0 +1,1227 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.009.000 |
+|==============================================================================|
+| Content: MIME support procedures and functions                               |
+|==============================================================================|
+| Copyright (c)1999-200812                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2012.                |
+| Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(MIME part handling)
+Handling with MIME parts.
+
+Used RFC: RFC-2045
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$Q-}
+{$R-}
+{$M+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit mimepart;
+
+interface
+
+uses
+  SysUtils, Classes,
+  synafpc,
+  synachar, synacode, synautil, mimeinln;
+
+type
+
+  TMimePart = class;
+
+  {:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for
+   easy walking through MIME subparts.}
+  THookWalkPart = procedure(const Sender: TMimePart) of object;
+
+  {:The four types of MIME parts. (textual, multipart, message or any other
+   binary data.)}
+  TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY);
+
+  {:The various types of possible part encodings.}
+  TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
+    ME_BASE64, ME_UU, ME_XX);
+
+  {:@abstract(Object for working with parts of MIME e-mail.)
+   Each TMimePart object can handle any number of nested subparts as new
+   TMimepart objects. It can handle any tree hierarchy structure of nested MIME
+   subparts itself.
+
+   Basic tasks are:
+
+   Decoding of MIME message:
+   - store message into Lines property
+   - call DecomposeParts. Now you have decomposed MIME parts in all nested levels!
+   - now you can explore all properties and subparts. (You can use WalkPart method)
+   - if you need decode part, call DecodePart.
+
+   Encoding of MIME message:
+
+   - if you need multipart message, you must create subpart by AddSubPart.
+   - set all properties of all parts.
+   - set content of part into DecodedLines stream
+   - encode this stream by EncodePart.
+   - compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!)
+   - encoded MIME message is stored in Lines property.
+  }
+  TMimePart = class(TObject)
+  private
+    FPrimary: string;
+    FPrimaryCode: TMimePrimary;
+    FSecondary: string;
+    FEncoding: string;
+    FEncodingCode: TMimeEncoding;
+    FDefaultCharset: string;
+    FCharset: string;
+    FCharsetCode: TMimeChar;
+    FTargetCharset: TMimeChar;
+    FDescription: string;
+    FDisposition: string;
+    FContentID: string;
+    FBoundary: string;
+    FFileName: string;
+    FLines: TStringList;
+    FPartBody: TStringList;
+    FHeaders: TStringList;
+    FPrePart: TStringList;
+    FPostPart: TStringList;
+    FDecodedLines: TMemoryStream;
+    FSubParts: TList;
+    FOnWalkPart: THookWalkPart;
+    FMaxLineLength: integer;
+    FSubLevel: integer;
+    FMaxSubLevel: integer;
+    FAttachInside: boolean;
+    FConvertCharset: Boolean;
+    FForcedHTMLConvert: Boolean;
+    FBinaryDecomposer: boolean;
+    procedure SetPrimary(Value: string);
+    procedure SetEncoding(Value: string);
+    procedure SetCharset(Value: string);
+    function IsUUcode(Value: string): boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Assign content of another object to this object. (Only this part,
+     not subparts!)}
+    procedure Assign(Value: TMimePart);
+
+    {:Assign content of another object to this object. (With all subparts!)}
+    procedure AssignSubParts(Value: TMimePart);
+
+    {:Clear all data values to default values. It also call @link(ClearSubparts).}
+    procedure Clear;
+
+    {:Decode Mime part from @link(Lines) to @link(DecodedLines).}
+    procedure DecodePart;
+
+    {:Parse header lines from Headers property into another properties.}
+    procedure DecodePartHeader;
+
+    {:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime
+     headers.}
+    procedure EncodePart;
+
+    {:Build header lines in Headers property from another properties.}
+    procedure EncodePartHeader;
+
+    {:generate primary and secondary mime type from filename extension in value.
+     If type not recognised, it return 'Application/octet-string' type.}
+    procedure MimeTypeFromExt(Value: string);
+
+    {:Return number of decomposed subparts. (On this level! Each of this
+     subparts can hold any number of their own nested subparts!)}
+    function GetSubPartCount: integer;
+
+    {:Get nested subpart object as new TMimePart. For getting maximum possible
+     index you can use @link(GetSubPartCount) method.}
+    function GetSubPart(index: integer): TMimePart;
+
+    {:delete subpart on given index.}
+    procedure DeleteSubPart(index: integer);
+
+    {:Clear and destroy all subpart TMimePart objects.}
+    procedure ClearSubParts;
+
+    {:Add and create new subpart.}
+    function AddSubPart: TMimePart;
+
+    {:E-mail message in @link(Lines) property is parsed into this object.
+     E-mail headers are stored in @link(Headers) property and is parsed into
+     another properties automaticly. Not need call @link(DecodePartHeader)!
+     Content of message (part) is stored into @link(PartBody) property. This
+     part is in undecoded form! If you need decode it, then you must call
+     @link(DecodePart) method by your hands. Lot of another properties is filled
+     also.
+
+     Decoding of parts you must call separately due performance reasons. (Not
+     needed to decode all parts in all reasons.)
+
+     For each MIME subpart is created new TMimepart object (accessible via
+     method @link(GetSubPart)).}
+    procedure DecomposeParts;
+
+    {pf}
+    {: HTTP message is received by @link(THTTPSend) component in two parts:
+     headers are stored in @link(THTTPSend.Headers) and a body in memory stream
+     @link(THTTPSend.Document).
+
+     On the top of it, HTTP connections are always 8-bit, hence data are
+     transferred in native format i.e. no transfer encoding is applied.
+
+     This method operates the similiar way and produces the same
+     result as @link(DecomposeParts).
+    }
+    procedure DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PChar);
+    {/pf}
+
+    {:This part and all subparts is composed into one MIME message stored in
+     @link(Lines) property.}
+    procedure ComposeParts;
+
+    {:By calling this method is called @link(OnWalkPart) event for each part
+     and their subparts. It is very good for calling some code for each part in
+     MIME message}
+    procedure WalkPart;
+
+    {:Return @true when is possible create next subpart. (@link(maxSublevel)
+     is still not reached)}
+    function CanSubPart: boolean;
+  published
+    {:Primary Mime type of part. (i.e. 'application') Writing to this property
+     automaticly generate value of @link(PrimaryCode).}
+    property Primary: string read FPrimary write SetPrimary;
+
+    {:String representation of used Mime encoding in part. (i.e. 'base64')
+     Writing to this property automaticly generate value of @link(EncodingCode).}
+    property Encoding: string read FEncoding write SetEncoding;
+
+    {:String representation of used Mime charset in part. (i.e. 'iso-8859-1')
+     Writing to this property automaticly generate value of @link(CharsetCode).
+     Charset is used only for text parts.}
+    property Charset: string read FCharset write SetCharset;
+
+    {:Define default charset for decoding text MIME parts without charset
+     specification. Default value is 'ISO-8859-1' by RCF documents.
+     But Microsoft Outlook use windows codings as default. This property allows
+     properly decode textual parts from some broken versions of Microsoft
+     Outlook. (this is bad software!)}
+    property DefaultCharset: string read FDefaultCharset write FDefaultCharset;
+
+    {:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART,
+     MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.}
+    property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
+
+    {:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT,
+     ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is
+     ME_7BIT.}
+    property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
+
+    {:Decoded charset type. Possible values are defined in @link(SynaChar) unit.}
+    property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
+
+    {:System charset type. Default value is charset used by default in your
+     operating system.}
+    property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
+
+    {:If @true, then do internal charset translation of part content between @link(CharsetCode)
+     and @link(TargetCharset)}
+    property ConvertCharset: Boolean read FConvertCharset Write FConvertCharset;
+
+    {:If @true, then allways do internal charset translation of HTML parts
+     by MIME even it have their own charset in META tag. Default is @false.}
+    property ForcedHTMLConvert: Boolean read FForcedHTMLConvert Write FForcedHTMLConvert;
+
+    {:Secondary Mime type of part. (i.e. 'mixed')}
+    property Secondary: string read FSecondary Write FSecondary;
+
+    {:Description of Mime part.}
+    property Description: string read FDescription Write FDescription;
+
+    {:Value of content disposition field. (i.e. 'inline' or 'attachment')}
+    property Disposition: string read FDisposition Write FDisposition;
+
+    {:Content ID.}
+    property ContentID: string read FContentID Write FContentID;
+
+    {:Boundary delimiter of multipart Mime part. Used only in multipart part.}
+    property Boundary: string read FBoundary Write FBoundary;
+
+    {:Filename of file in binary part.}
+    property FileName: string read FFileName Write FFileName;
+
+    {:String list with lines contains mime part (It can be a full message).}
+    property Lines: TStringList read FLines;
+
+    {:Encoded form of MIME part data.}
+    property PartBody: TStringList read FPartBody;
+
+    {:All header lines of MIME part.}
+    property Headers: TStringList read FHeaders;
+
+    {:On multipart this contains part of message between first line of message
+     and first boundary.}
+    property PrePart: TStringList read FPrePart;
+
+    {:On multipart this contains part of message between last boundary and end
+     of message.}
+    property PostPart: TStringList read FPostPart;
+
+    {:Stream with decoded form of budy part.}
+    property DecodedLines: TMemoryStream read FDecodedLines;
+
+    {:Show nested level in subpart tree. Value 0 means root part. 1 means
+     subpart from this root. etc.}
+    property SubLevel: integer read FSubLevel write FSubLevel;
+
+    {:Specify maximum sublevel value for decomposing.}
+    property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
+
+    {:When is @true, then this part maybe(!) have included some uuencoded binary
+    data.}
+    property AttachInside: boolean read FAttachInside;
+
+    {:Here you can assign hook procedure for walking through all part and their
+     subparts.}
+    property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
+
+    {:Here you can specify maximum line length for encoding of MIME part.
+     If line is longer, then is splitted by standard of MIME. Correct MIME
+     mailers can de-split this line into original length.}
+    property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
+  end;
+
+const
+  MaxMimeType = 25;
+  MimeType: array[0..MaxMimeType, 0..2] of string =
+  (
+    ('AU', 'audio', 'basic'),
+    ('AVI', 'video', 'x-msvideo'),
+    ('BMP', 'image', 'BMP'),
+    ('DOC', 'application', 'MSWord'),
+    ('EPS', 'application', 'Postscript'),
+    ('GIF', 'image', 'GIF'),
+    ('JPEG', 'image', 'JPEG'),
+    ('JPG', 'image', 'JPEG'),
+    ('MID', 'audio', 'midi'),
+    ('MOV', 'video', 'quicktime'),
+    ('MPEG', 'video', 'MPEG'),
+    ('MPG', 'video', 'MPEG'),
+    ('MP2', 'audio', 'mpeg'),
+    ('MP3', 'audio', 'mpeg'),
+    ('PDF', 'application', 'PDF'),
+    ('PNG', 'image', 'PNG'),
+    ('PS', 'application', 'Postscript'),
+    ('QT', 'video', 'quicktime'),
+    ('RA', 'audio', 'x-realaudio'),
+    ('RTF', 'application', 'RTF'),
+    ('SND', 'audio', 'basic'),
+    ('TIF', 'image', 'TIFF'),
+    ('TIFF', 'image', 'TIFF'),
+    ('WAV', 'audio', 'x-wav'),
+    ('WPD', 'application', 'Wordperfect5.1'),
+    ('ZIP', 'application', 'ZIP')
+    );
+
+{:Generates a unique boundary string.}
+function GenerateBoundary: string;
+
+implementation
+
+{==============================================================================}
+
+constructor TMIMEPart.Create;
+begin
+  inherited Create;
+  FOnWalkPart := nil;
+  FLines := TStringList.Create;
+  FPartBody := TStringList.Create;
+  FHeaders := TStringList.Create;
+  FPrePart := TStringList.Create;
+  FPostPart := TStringList.Create;
+  FDecodedLines := TMemoryStream.Create;
+  FSubParts := TList.Create;
+  FTargetCharset := GetCurCP;
+  //was 'US-ASCII' before, but RFC-ignorant Outlook sometimes using default
+  //system charset instead.
+  FDefaultCharset := GetIDFromCP(GetCurCP);
+  FMaxLineLength := 78;
+  FSubLevel := 0;
+  FMaxSubLevel := -1;
+  FAttachInside := false;
+  FConvertCharset := true;
+  FForcedHTMLConvert := false;
+end;
+
+destructor TMIMEPart.Destroy;
+begin
+  ClearSubParts;
+  FSubParts.Free;
+  FDecodedLines.Free;
+  FPartBody.Free;
+  FLines.Free;
+  FHeaders.Free;
+  FPrePart.Free;
+  FPostPart.Free;
+  inherited Destroy;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.Clear;
+begin
+  FPrimary := '';
+  FEncoding := '';
+  FCharset := '';
+  FPrimaryCode := MP_TEXT;
+  FEncodingCode := ME_7BIT;
+  FCharsetCode := ISO_8859_1;
+  FTargetCharset := GetCurCP;
+  FSecondary := '';
+  FDisposition := '';
+  FContentID := '';
+  FDescription := '';
+  FBoundary := '';
+  FFileName := '';
+  FAttachInside := False;
+  FPartBody.Clear;
+  FHeaders.Clear;
+  FPrePart.Clear;
+  FPostPart.Clear;
+  FDecodedLines.Clear;
+  FConvertCharset := true;
+  FForcedHTMLConvert := false;
+  ClearSubParts;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.Assign(Value: TMimePart);
+begin
+  Primary := Value.Primary;
+  Encoding := Value.Encoding;
+  Charset := Value.Charset;
+  DefaultCharset := Value.DefaultCharset;
+  PrimaryCode := Value.PrimaryCode;
+  EncodingCode := Value.EncodingCode;
+  CharsetCode := Value.CharsetCode;
+  TargetCharset := Value.TargetCharset;
+  Secondary := Value.Secondary;
+  Description := Value.Description;
+  Disposition := Value.Disposition;
+  ContentID := Value.ContentID;
+  Boundary := Value.Boundary;
+  FileName := Value.FileName;
+  Lines.Assign(Value.Lines);
+  PartBody.Assign(Value.PartBody);
+  Headers.Assign(Value.Headers);
+  PrePart.Assign(Value.PrePart);
+  PostPart.Assign(Value.PostPart);
+  MaxLineLength := Value.MaxLineLength;
+  FAttachInside := Value.AttachInside;
+  FConvertCharset := Value.ConvertCharset;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.AssignSubParts(Value: TMimePart);
+var
+  n: integer;
+  p: TMimePart;
+begin
+  Assign(Value);
+  for n := 0 to Value.GetSubPartCount - 1 do
+  begin
+    p := AddSubPart;
+    p.AssignSubParts(Value.GetSubPart(n));
+  end;
+end;
+
+{==============================================================================}
+
+function TMIMEPart.GetSubPartCount: integer;
+begin
+  Result :=  FSubParts.Count;
+end;
+
+{==============================================================================}
+
+function TMIMEPart.GetSubPart(index: integer): TMimePart;
+begin
+  Result := nil;
+  if Index < GetSubPartCount then
+    Result := TMimePart(FSubParts[Index]);
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.DeleteSubPart(index: integer);
+begin
+  if Index < GetSubPartCount then
+  begin
+    GetSubPart(Index).Free;
+    FSubParts.Delete(Index);
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.ClearSubParts;
+var
+  n: integer;
+begin
+  for n := 0 to GetSubPartCount - 1 do
+    TMimePart(FSubParts[n]).Free;
+  FSubParts.Clear;
+end;
+
+{==============================================================================}
+
+function TMIMEPart.AddSubPart: TMimePart;
+begin
+  Result := TMimePart.Create;
+  Result.DefaultCharset := FDefaultCharset;
+  FSubParts.Add(Result);
+  Result.SubLevel := FSubLevel + 1;
+  Result.MaxSubLevel := FMaxSubLevel;  
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.DecomposeParts;
+var
+  x: integer;
+  s: string;
+  Mime: TMimePart;
+
+  procedure SkipEmpty;
+  begin
+    while FLines.Count > x do
+    begin
+      s := TrimRight(FLines[x]);
+      if s <> '' then
+        Break;
+      Inc(x);
+    end;
+  end;
+
+begin
+  FBinaryDecomposer := false;
+  x := 0;
+  Clear;
+  //extract headers
+  while FLines.Count > x do
+  begin
+    s := NormalizeHeader(FLines, x);
+    if s = '' then
+      Break;
+    FHeaders.Add(s);
+  end;
+  DecodePartHeader;
+  //extract prepart
+  if FPrimaryCode = MP_MULTIPART then
+  begin
+    while FLines.Count > x do
+    begin
+      s := FLines[x];
+      Inc(x);
+      if TrimRight(s) = '--' + FBoundary then
+        Break;
+      FPrePart.Add(s);
+      if not FAttachInside then
+        FAttachInside := IsUUcode(s);
+    end;
+  end;
+  //extract body part
+  if FPrimaryCode = MP_MULTIPART then
+  begin
+    repeat
+      if CanSubPart then
+      begin
+        Mime := AddSubPart;
+        while FLines.Count > x do
+        begin
+          s := FLines[x];
+          Inc(x);
+          if Pos('--' + FBoundary, s) = 1 then
+            Break;
+          Mime.Lines.Add(s);
+        end;
+        Mime.DecomposeParts;
+      end
+      else
+      begin
+        s := FLines[x];
+        Inc(x);
+        FPartBody.Add(s);
+      end;
+      if x >= FLines.Count then
+        break;
+    until s = '--' + FBoundary + '--';
+  end;
+  if (FPrimaryCode = MP_MESSAGE) and CanSubPart then
+  begin
+    Mime := AddSubPart;
+    SkipEmpty;
+    while FLines.Count > x do
+    begin
+      s := TrimRight(FLines[x]);
+      Inc(x);
+      Mime.Lines.Add(s);
+    end;
+    Mime.DecomposeParts;
+  end
+  else
+  begin
+    while FLines.Count > x do
+    begin
+      s := FLines[x];
+      Inc(x);
+      FPartBody.Add(s);
+      if not FAttachInside then
+        FAttachInside := IsUUcode(s);
+    end;
+  end;
+  //extract postpart
+  if FPrimaryCode = MP_MULTIPART then
+  begin
+    while FLines.Count > x do
+    begin
+      s := TrimRight(FLines[x]);
+      Inc(x);
+      FPostPart.Add(s);
+      if not FAttachInside then
+        FAttachInside := IsUUcode(s);
+    end;
+  end;
+end;
+
+procedure TMIMEPart.DecomposePartsBinary(AHeader:TStrings; AStx,AEtx:PChar);
+var
+  x:    integer;
+  s:    ANSIString;
+  Mime: TMimePart;
+  BOP:  PChar; // Beginning of Part
+  EOP:  PChar; // End of Part
+
+  function ___HasUUCode(ALines:TStrings): boolean;
+  var
+    x: integer;
+  begin
+    Result := FALSE;
+    for x:=0 to ALines.Count-1 do
+      if IsUUcode(ALInes[x]) then
+      begin
+        Result := TRUE;
+        exit;
+      end;
+  end;
+
+begin
+  FBinaryDecomposer := true;
+  Clear;
+  // Parse passed headers (THTTPSend returns HTTP headers and body separately)
+  x := 0;
+  while x<AHeader.Count do
+    begin
+      s := NormalizeHeader(AHeader,x);
+      if s = '' then
+        Break;
+      FHeaders.Add(s);
+    end;
+  DecodePartHeader;
+  // Extract prepart
+  if FPrimaryCode=MP_MULTIPART then
+    begin
+      CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPrePart,FBoundary);
+      FAttachInside := FAttachInside or ___HasUUCode(FPrePart);
+    end;
+  // Extract body part
+  if FPrimaryCode=MP_MULTIPART then
+    begin
+      repeat
+        if CanSubPart then
+          begin
+            Mime := AddSubPart;
+            BOP  := AStx;
+            EOP  := SearchForBoundary(AStx,AEtx,FBoundary);
+            CopyLinesFromStreamUntilNullLine(BOP,EOP,Mime.Lines);
+            Mime.DecomposePartsBinary(Mime.Lines,BOP,EOP);
+          end
+        else
+          begin
+            EOP := SearchForBoundary(AStx,AEtx,FBoundary);
+            FPartBody.Add(BuildStringFromBuffer(AStx,EOP));
+          end;
+        //
+        BOP := MatchLastBoundary(EOP,AEtx,FBoundary);
+        if Assigned(BOP) then
+          begin
+            AStx := BOP;
+            Break;
+          end;
+      until FALSE;
+    end;
+  // Extract nested MIME message
+  if (FPrimaryCode=MP_MESSAGE) and CanSubPart then
+    begin
+      Mime := AddSubPart;
+      SkipNullLines(AStx,AEtx);
+      CopyLinesFromStreamUntilNullLine(AStx,AEtx,Mime.Lines);
+      Mime.DecomposePartsBinary(Mime.Lines,AStx,AEtx);
+    end
+  // Extract body of single part
+  else
+    begin
+      FPartBody.Add(BuildStringFromBuffer(AStx,AEtx));
+      FAttachInside := FAttachInside or ___HasUUCode(FPartBody);
+    end;
+  // Extract postpart
+  if FPrimaryCode=MP_MULTIPART then
+    begin
+      CopyLinesFromStreamUntilBoundary(AStx,AEtx,FPostPart,'');
+      FAttachInside := FAttachInside or ___HasUUCode(FPostPart);
+    end;
+end;
+{/pf}
+
+{==============================================================================}
+
+procedure TMIMEPart.ComposeParts;
+var
+  n: integer;
+  mime: TMimePart;
+  s, t: string;
+  d1, d2, d3: integer;
+  x: integer;
+begin
+  FLines.Clear;
+  //add headers
+  for n := 0 to FHeaders.Count -1 do
+  begin
+    s := FHeaders[n];
+    repeat
+      if Length(s) < FMaxLineLength then
+      begin
+        t := s;
+        s := '';
+      end
+      else
+      begin
+        d1 := RPosEx('; ', s, FMaxLineLength);
+        d2 := RPosEx(' ', s, FMaxLineLength);
+        d3 := RPosEx(', ', s, FMaxLineLength);
+        if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
+        begin
+          x := Pos(' ', Copy(s, 2, Length(s) - 1));
+          if x < 1 then
+            x := Length(s);
+        end
+        else
+          if d1 > 0 then
+            x := d1
+          else
+            if d3 > 0 then
+              x := d3
+            else
+              x := d2 - 1;
+        t := Copy(s, 1, x);
+        Delete(s, 1, x);
+      end;
+      Flines.Add(t);
+    until s = '';
+  end;
+
+  Flines.Add('');
+  //add body
+  //if multipart
+  if FPrimaryCode = MP_MULTIPART then
+  begin
+    Flines.AddStrings(FPrePart);
+    for n := 0 to GetSubPartCount - 1 do
+    begin
+      Flines.Add('--' + FBoundary);
+      mime := GetSubPart(n);
+      mime.ComposeParts;
+      FLines.AddStrings(mime.Lines);
+    end;
+    Flines.Add('--' + FBoundary + '--');
+    Flines.AddStrings(FPostPart);
+  end;
+  //if message
+  if FPrimaryCode = MP_MESSAGE then
+  begin
+    if GetSubPartCount > 0 then
+    begin
+      mime := GetSubPart(0);
+      mime.ComposeParts;
+      FLines.AddStrings(mime.Lines);
+    end;
+  end
+  else
+  //if normal part
+  begin
+    FLines.AddStrings(FPartBody);
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.DecodePart;
+var
+  n: Integer;
+  s, t, t2: string;
+  b: Boolean;
+begin
+  FDecodedLines.Clear;
+  {pf}
+  // The part decomposer passes data via TStringList which appends trailing line
+  // break inherently. But in a case of native 8-bit data transferred withouth
+  // encoding (default e.g. for HTTP protocol), the redundant line terminators
+  // has to be removed
+  if FBinaryDecomposer and (FPartBody.Count=1) then
+    begin
+      case FEncodingCode of
+          ME_QUOTED_PRINTABLE:
+            s := DecodeQuotedPrintable(FPartBody[0]);
+          ME_BASE64:
+            s := DecodeBase64(FPartBody[0]);
+          ME_UU, ME_XX:
+            begin
+              s := '';
+              for n := 0 to FPartBody.Count - 1 do
+                if FEncodingCode = ME_UU then
+                  s := s + DecodeUU(FPartBody[n])
+                else
+                  s := s + DecodeXX(FPartBody[n]);
+            end;
+        else
+          s := FPartBody[0];
+        end;
+    end
+  else
+  {/pf}
+  case FEncodingCode of
+    ME_QUOTED_PRINTABLE:
+      s := DecodeQuotedPrintable(FPartBody.Text);
+    ME_BASE64:
+      s := DecodeBase64(FPartBody.Text);
+    ME_UU, ME_XX:
+      begin
+        s := '';
+        for n := 0 to FPartBody.Count - 1 do
+          if FEncodingCode = ME_UU then
+            s := s + DecodeUU(FPartBody[n])
+          else
+            s := s + DecodeXX(FPartBody[n]);
+      end;
+  else
+    s := FPartBody.Text;
+  end;
+  if FConvertCharset and (FPrimaryCode = MP_TEXT) then
+    if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then
+    begin
+      b := false;
+      t2 := uppercase(s);
+      t := SeparateLeft(t2, '</HEAD>');
+      if length(t) <> length(s) then
+      begin
+        t := SeparateRight(t, '<HEAD>');
+        t := ReplaceString(t, '"', '');
+        t := ReplaceString(t, ' ', '');
+        b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
+      end;
+      //workaround for shitty M$ Outlook 11 which is placing this information
+      //outside <head> section
+      if not b then
+      begin
+        t := Copy(t2, 1, 2048);
+        t := ReplaceString(t, '"', '');
+        t := ReplaceString(t, ' ', '');
+        b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
+      end;
+      if not b then
+        s := CharsetConversion(s, FCharsetCode, FTargetCharset);
+    end
+    else
+      s := CharsetConversion(s, FCharsetCode, FTargetCharset);
+  WriteStrToStream(FDecodedLines, s);
+  FDecodedLines.Seek(0, soFromBeginning);
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.DecodePartHeader;
+var
+  n: integer;
+  s, su, fn: string;
+  st, st2: string;
+begin
+  Primary := 'text';
+  FSecondary := 'plain';
+  FDescription := '';
+  Charset := FDefaultCharset;
+  FFileName := '';
+  //was 7bit before, but this is more compatible with RFC-ignorant outlook
+  Encoding := '8BIT';
+  FDisposition := '';
+  FContentID := '';
+  fn := '';
+  for n := 0 to FHeaders.Count - 1 do
+    if FHeaders[n] <> '' then
+    begin
+      s := FHeaders[n];
+      su := UpperCase(s);
+      if Pos('CONTENT-TYPE:', su) = 1 then
+      begin
+        st := Trim(SeparateRight(su, ':'));
+        st2 := Trim(SeparateLeft(st, ';'));
+        Primary := Trim(SeparateLeft(st2, '/'));
+        FSecondary := Trim(SeparateRight(st2, '/'));
+        if (FSecondary = Primary) and (Pos('/', st2) < 1) then
+          FSecondary := '';
+        case FPrimaryCode of
+          MP_TEXT:
+            begin
+              Charset := UpperCase(GetParameter(s, 'charset'));
+              FFileName := GetParameter(s, 'name');
+            end;
+          MP_MULTIPART:
+            FBoundary := GetParameter(s, 'Boundary');
+          MP_MESSAGE:
+            begin
+            end;
+          MP_BINARY:
+            FFileName := GetParameter(s, 'name');
+        end;
+      end;
+      if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
+        Encoding := Trim(SeparateRight(su, ':'));
+      if Pos('CONTENT-DESCRIPTION:', su) = 1 then
+        FDescription := Trim(SeparateRight(s, ':'));
+      if Pos('CONTENT-DISPOSITION:', su) = 1 then
+      begin
+        FDisposition := SeparateRight(su, ':');
+        FDisposition := Trim(SeparateLeft(FDisposition, ';'));
+        fn := GetParameter(s, 'FileName');
+      end;
+      if Pos('CONTENT-ID:', su) = 1 then
+        FContentID := Trim(SeparateRight(s, ':'));
+    end;
+  if fn <> '' then
+    FFileName := fn;
+  FFileName := InlineDecode(FFileName, FTargetCharset);
+  FFileName := ExtractFileName(FFileName);
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.EncodePart;
+var
+  l: TStringList;
+  s, t: string;
+  n, x: Integer;
+  d1, d2: integer;
+begin
+  if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
+    Encoding := 'base64';
+  l := TStringList.Create;
+  FPartBody.Clear;
+  FDecodedLines.Seek(0, soFromBeginning);
+  try
+    case FPrimaryCode of
+      MP_MULTIPART, MP_MESSAGE:
+        FPartBody.LoadFromStream(FDecodedLines);
+      MP_TEXT, MP_BINARY:
+        begin
+          s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
+          if FConvertCharset and (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
+            s := GetBOM(FCharSetCode) + CharsetConversion(s, FTargetCharset, FCharsetCode);
+          if FEncodingCode = ME_BASE64 then
+          begin
+            x := 1;
+            while x <= length(s) do
+            begin
+              t := copy(s, x, 54);
+              x := x + length(t);
+              t := EncodeBase64(t);
+              FPartBody.Add(t);
+            end;
+          end
+          else
+          begin
+            if FPrimaryCode = MP_BINARY then
+              l.Add(s)
+            else
+              l.Text := s;
+            for n := 0 to l.Count - 1 do
+            begin
+              s := l[n];
+              if FEncodingCode = ME_QUOTED_PRINTABLE then
+              begin
+                s := EncodeQuotedPrintable(s);
+                repeat
+                  if Length(s) < FMaxLineLength then
+                  begin
+                    t := s;
+                    s := '';
+                  end
+                  else
+                  begin
+                    d1 := RPosEx('=', s, FMaxLineLength);
+                    d2 := RPosEx(' ', s, FMaxLineLength);
+                    if (d1 = 0) and (d2 = 0) then
+                      x := FMaxLineLength
+                    else
+                      if d1 > d2 then
+                        x := d1 - 1
+                      else
+                        x := d2 - 1;
+                    if x = 0 then
+                      x := FMaxLineLength;
+                    t := Copy(s, 1, x);
+                    Delete(s, 1, x);
+                    if s <> '' then
+                      t := t + '=';
+                  end;
+                  FPartBody.Add(t);
+                until s = '';
+              end
+              else
+                FPartBody.Add(s);
+            end;
+            if (FPrimaryCode = MP_BINARY)
+              and (FEncodingCode = ME_QUOTED_PRINTABLE) then
+              FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
+          end;
+        end;
+    end;
+  finally
+    l.Free;
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.EncodePartHeader;
+var
+  s: string;
+begin
+  FHeaders.Clear;
+  if FSecondary = '' then
+    case FPrimaryCode of
+      MP_TEXT:
+        FSecondary := 'plain';
+      MP_MULTIPART:
+        FSecondary := 'mixed';
+      MP_MESSAGE:
+        FSecondary := 'rfc822';
+      MP_BINARY:
+        FSecondary := 'octet-stream';
+    end;
+  if FDescription <> '' then
+    FHeaders.Insert(0, 'Content-Description: ' + FDescription);
+  if FDisposition <> '' then
+  begin
+    s := '';
+    if FFileName <> '' then
+      s := '; FileName=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
+    FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
+  end;
+  if FContentID <> '' then
+    FHeaders.Insert(0, 'Content-ID: ' + FContentID);
+
+  case FEncodingCode of
+    ME_7BIT:
+      s := '7bit';
+    ME_8BIT:
+      s := '8bit';
+    ME_QUOTED_PRINTABLE:
+      s := 'Quoted-printable';
+    ME_BASE64:
+      s := 'Base64';
+  end;
+  case FPrimaryCode of
+    MP_TEXT,
+      MP_BINARY: FHeaders.Insert(0, 'Content-Transfer-Encoding: ' + s);
+  end;
+  case FPrimaryCode of
+    MP_TEXT:
+      s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
+    MP_MULTIPART:
+      s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
+    MP_MESSAGE, MP_BINARY:
+      s := FPrimary + '/' + FSecondary;
+  end;
+  if FFileName <> '' then
+    s := s + '; name=' + QuoteStr(InlineCodeEx(FileName, FTargetCharset), '"');
+  FHeaders.Insert(0, 'Content-type: ' + s);
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.MimeTypeFromExt(Value: string);
+var
+  s: string;
+  n: Integer;
+begin
+  Primary := '';
+  FSecondary := '';
+  s := UpperCase(ExtractFileExt(Value));
+  if s = '' then
+    s := UpperCase(Value);
+  s := SeparateRight(s, '.');
+  for n := 0 to MaxMimeType do
+    if MimeType[n, 0] = s then
+    begin
+      Primary := MimeType[n, 1];
+      FSecondary := MimeType[n, 2];
+      Break;
+    end;
+  if Primary = '' then
+    Primary := 'application';
+  if FSecondary = '' then
+    FSecondary := 'octet-stream';
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.WalkPart;
+var
+  n: integer;
+  m: TMimepart;
+begin
+  if assigned(OnWalkPart) then
+  begin
+    OnWalkPart(self);
+    for n := 0 to GetSubPartCount - 1 do
+    begin
+      m := GetSubPart(n);
+      m.OnWalkPart := OnWalkPart;
+      m.WalkPart;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+procedure TMIMEPart.SetPrimary(Value: string);
+var
+  s: string;
+begin
+  FPrimary := Value;
+  s := UpperCase(Value);
+  FPrimaryCode := MP_BINARY;
+  if Pos('TEXT', s) = 1 then
+    FPrimaryCode := MP_TEXT;
+  if Pos('MULTIPART', s) = 1 then
+    FPrimaryCode := MP_MULTIPART;
+  if Pos('MESSAGE', s) = 1 then
+    FPrimaryCode := MP_MESSAGE;
+end;
+
+procedure TMIMEPart.SetEncoding(Value: string);
+var
+  s: string;
+begin
+  FEncoding := Value;
+  s := UpperCase(Value);
+  FEncodingCode := ME_7BIT;
+  if Pos('8BIT', s) = 1 then
+    FEncodingCode := ME_8BIT;
+  if Pos('QUOTED-PRINTABLE', s) = 1 then
+    FEncodingCode := ME_QUOTED_PRINTABLE;
+  if Pos('BASE64', s) = 1 then
+    FEncodingCode := ME_BASE64;
+  if Pos('X-UU', s) = 1 then
+    FEncodingCode := ME_UU;
+  if Pos('X-XX', s) = 1 then
+    FEncodingCode := ME_XX;
+end;
+
+procedure TMIMEPart.SetCharset(Value: string);
+begin
+  if value <> '' then
+  begin
+    FCharset := Value;
+    FCharsetCode := GetCPFromID(Value);
+  end;
+end;
+
+function TMIMEPart.CanSubPart: boolean;
+begin
+  Result := True;
+  if FMaxSubLevel <> -1 then
+    Result := FMaxSubLevel > FSubLevel;
+end;
+
+function TMIMEPart.IsUUcode(Value: string): boolean;
+begin
+  Value := UpperCase(Value);
+  Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> '');
+end;
+
+{==============================================================================}
+
+function GenerateBoundary: string;
+var
+  x, y: Integer;
+begin
+  y := GetTick;
+  x := y;
+  while TickDelta(y, x) = 0 do
+  begin
+    Sleep(1);
+    x := GetTick;
+  end;
+  Randomize;
+  y := Random(MaxInt);
+  Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
+end;
+
+end.

nntpsend.pas

@@ -0,0 +1,483 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.005.003 |
+|==============================================================================|
+| Content: NNTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2011, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2011.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(NNTP client)
+NNTP (network news transfer protocol)
+
+Used RFC: RFC-977, RFC-2980
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+  {$WARN SUSPICIOUS_TYPECAST OFF}
+{$ENDIF}
+
+unit nntpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cNNTPProtocol = '119';
+
+type
+
+  {:abstract(Implementation of Network News Transfer Protocol.
+
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TNNTPSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FData: TStringList;
+    FDataToSend: TStringList;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    FNNTPcap: TStringList;
+    function ReadResult: Integer;
+    function ReadData: boolean;
+    function SendData: boolean;
+    function Connect: Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to NNTP server and begin session.}
+    function Login: Boolean;
+
+    {:Logout from NNTP server and terminate session.}
+    function Logout: Boolean;
+
+    {:By this you can call any NNTP command.}
+    function DoCommand(const Command: string): boolean;
+
+    {:by this you can call any NNTP command. This variant is used for commands
+     for download information from server.}
+    function DoCommandRead(const Command: string): boolean;
+
+    {:by this you can call any NNTP command. This variant is used for commands
+     for upload information to server.}
+    function DoCommandWrite(const Command: string): boolean;
+
+    {:Download full message to @link(data) property. Value can be number of
+     message or message-id (in brackets).}
+    function GetArticle(const Value: string): Boolean;
+
+    {:Download only body of message to @link(data) property. Value can be number
+     of message or message-id (in brackets).}
+    function GetBody(const Value: string): Boolean;
+
+    {:Download only headers of message to @link(data) property. Value can be
+     number of message or message-id (in brackets).}
+    function GetHead(const Value: string): Boolean;
+
+    {:Get message status. Value can be number of message or message-id
+     (in brackets).}
+    function GetStat(const Value: string): Boolean;
+
+    {:Select given group.}
+    function SelectGroup(const Value: string): Boolean;
+
+    {:Tell to server 'I have mesage with given message-ID.' If server need this
+     message, message is uploaded to server.}
+    function IHave(const MessID: string): Boolean;
+
+    {:Move message pointer to last item in group.}
+    function GotoLast: Boolean;
+
+    {:Move message pointer to next item in group.}
+    function GotoNext: Boolean;
+
+    {:Download to @link(data) property list of all groups on NNTP server.}
+    function ListGroups: Boolean;
+
+    {:Download to @link(data) property list of all groups created after given time.}
+    function ListNewGroups(Since: TDateTime): Boolean;
+
+    {:Download to @link(data) property list of message-ids in given group since
+     given time.}
+    function NewArticles(const Group: string; Since: TDateTime): Boolean;
+
+    {:Upload new article to server. (for new messages by you)}
+    function PostArticle: Boolean;
+
+    {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
+     server'.}
+    function SwitchToSlave: Boolean;
+
+    {:Call NNTP XOVER command.}
+    function Xover(xoStart, xoEnd: string): boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Try to find given capability in extension list. This list is getted after
+     successful login to NNTP server. If extension capability is not found,
+     then return is empty string.}
+    function FindCap(const Value: string): string;
+
+    {:Try get list of server extensions. List is returned in @link(data) property.}
+    function ListExtensions: Boolean;
+  published
+    {:Result code number of last operation.}
+    property ResultCode: Integer read FResultCode;
+
+    {:String description of last result code from NNTP server.}
+    property ResultString: string read FResultString;
+
+    {:Readed data. (message, etc.)}
+    property Data: TStringList read FData;
+
+    {:If is set to @true, then upgrade to SSL/TLS mode after login if remote
+     server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TNNTPSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FData := TStringList.Create;
+  FDataToSend := TStringList.Create;
+  FNNTPcap := TStringList.Create;
+  FSock.ConvertLineEnd := True;
+  FTimeout := 60000;
+  FTargetPort := cNNTPProtocol;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TNNTPSend.Destroy;
+begin
+  FSock.Free;
+  FDataToSend.Free;
+  FData.Free;
+  FNNTPcap.Free;
+  inherited Destroy;
+end;
+
+function TNNTPSend.ReadResult: Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  FData.Clear;
+  s := FSock.RecvString(FTimeout);
+  FResultString := Copy(s, 5, Length(s) - 4);
+  if FSock.LastError <> 0 then
+    Exit;
+  if Length(s) >= 3 then
+    Result := StrToIntDef(Copy(s, 1, 3), 0);
+  FResultCode := Result;
+end;
+
+function TNNTPSend.ReadData: boolean;
+var
+  s: string;
+begin
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if s = '.' then
+      break;
+    if (s <> '') and (s[1] = '.') then
+      s := Copy(s, 2, Length(s) - 1);
+    FData.Add(s);
+  until FSock.LastError <> 0;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.SendData: boolean;
+var
+  s: string;
+  n: integer;
+begin
+  for n := 0 to FDataToSend.Count - 1 do
+  begin
+    s := FDataToSend[n];
+    if (s <> '') and (s[1] = '.') then
+      s := s + '.';
+    FSock.SendString(s + CRLF);
+    if FSock.LastError <> 0 then
+      break;
+  end;
+  if FDataToSend.Count = 0 then
+    FSock.SendString(CRLF);
+  if FSock.LastError = 0 then
+    FSock.SendString('.' + CRLF);
+  FDataToSend.Clear;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TNNTPSend.Login: Boolean;
+begin
+  Result := False;
+  FNNTPcap.Clear;
+  if not Connect then
+    Exit;
+  Result := (ReadResult div 100) = 2;
+  if Result then
+  begin
+    ListExtensions;
+    FNNTPcap.Assign(Fdata);
+    if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
+      Result := StartTLS;
+  end;
+  if (FUsername <> '') and Result then
+  begin
+    FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
+    if (ReadResult div 100) = 3 then
+    begin
+      FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
+      Result := (ReadResult div 100) = 2;
+    end;
+  end;
+end;
+
+function TNNTPSend.Logout: Boolean;
+begin
+  FSock.SendString('QUIT' + CRLF);
+  Result := (ReadResult div 100) = 2;
+  FSock.CloseSocket;
+end;
+
+function TNNTPSend.DoCommand(const Command: string): Boolean;
+begin
+  FSock.SendString(Command + CRLF);
+  Result := (ReadResult div 100) = 2;
+  Result := Result and (FSock.LastError = 0);
+end;
+
+function TNNTPSend.DoCommandRead(const Command: string): Boolean;
+begin
+  Result := DoCommand(Command);
+  if Result then
+  begin
+    Result := ReadData;
+    Result := Result and (FSock.LastError = 0);
+  end;
+end;
+
+function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
+var
+  x: integer;
+begin
+  FDataToSend.Assign(FData);
+  FSock.SendString(Command + CRLF);
+  x := (ReadResult div 100);
+  if x = 3 then
+  begin
+    SendData;
+    x := (ReadResult div 100);
+  end;
+  Result := x = 2;
+  Result := Result and (FSock.LastError = 0);
+end;
+
+function TNNTPSend.GetArticle(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'ARTICLE';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetBody(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'BODY';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetHead(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'HEAD';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.GetStat(const Value: string): Boolean;
+var
+  s: string;
+begin
+  s := 'STAT';
+  if Value <> '' then
+    s := s + ' ' + Value;
+  Result := DoCommand(s);
+end;
+
+function TNNTPSend.SelectGroup(const Value: string): Boolean;
+begin
+  Result := DoCommand('GROUP ' + Value);
+end;
+
+function TNNTPSend.IHave(const MessID: string): Boolean;
+begin
+  Result := DoCommandWrite('IHAVE ' + MessID);
+end;
+
+function TNNTPSend.GotoLast: Boolean;
+begin
+  Result := DoCommand('LAST');
+end;
+
+function TNNTPSend.GotoNext: Boolean;
+begin
+  Result := DoCommand('NEXT');
+end;
+
+function TNNTPSend.ListGroups: Boolean;
+begin
+  Result := DoCommandRead('LIST');
+end;
+
+function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
+begin
+  Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
+end;
+
+function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
+begin
+  Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
+end;
+
+function TNNTPSend.PostArticle: Boolean;
+begin
+  Result := DoCommandWrite('POST');
+end;
+
+function TNNTPSend.SwitchToSlave: Boolean;
+begin
+  Result := DoCommand('SLAVE');
+end;
+
+function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
+var
+  s: string;
+begin
+  s := 'XOVER ' + xoStart;
+  if xoEnd <> xoStart then
+    s := s + '-' + xoEnd;
+  Result := DoCommandRead(s);
+end;
+
+function TNNTPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    if DoCommand('STARTTLS') then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+function TNNTPSend.ListExtensions: Boolean;
+begin
+  Result := DoCommandRead('LIST EXTENSIONS');
+end;
+
+function TNNTPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FNNTPcap.Count - 1 do
+    if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
+    begin
+      Result := FNNTPcap[n];
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+end.

pingsend.pas

@@ -0,0 +1,728 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 004.000.002 |
+|==============================================================================|
+| Content: PING sender                                                         |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(ICMP PING implementation.)
+Allows create PING and TRACEROUTE. Or you can diagnose your network.
+
+This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
+ to use RAW sockets.
+
+Warning: For use of RAW sockets you must have some special rights on some
+ systems. So, it working allways when you have administator/root rights.
+ Otherwise you can have problems!
+
+Note: This unit is NOT portable to .NET!
+  Use native .NET classes for Ping instead.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+
+{$IFDEF CIL}
+  Sorry, this unit is not for .NET!
+{$ENDIF}
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit pingsend;
+
+interface
+
+uses
+  SysUtils,
+  synsock, blcksock, synautil, synafpc, synaip
+{$IFDEF MSWINDOWS}
+  , windows
+{$ENDIF}
+  ;
+
+const
+  ICMP_ECHO = 8;
+  ICMP_ECHOREPLY = 0;
+  ICMP_UNREACH = 3;
+  ICMP_TIME_EXCEEDED = 11;
+//rfc-2292
+  ICMP6_ECHO = 128;
+  ICMP6_ECHOREPLY = 129;
+  ICMP6_UNREACH = 1;
+  ICMP6_TIME_EXCEEDED = 3;
+
+type
+  {:List of possible ICMP reply packet types.}
+  TICMPError = (
+    IE_NoError,
+    IE_Other,
+    IE_TTLExceed,
+    IE_UnreachOther,
+    IE_UnreachRoute,
+    IE_UnreachAdmin,
+    IE_UnreachAddr,
+    IE_UnreachPort
+    );
+
+  {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
+  TPINGSend = class(TSynaClient)
+  private
+    FSock: TICMPBlockSocket;
+    FBuffer: Ansistring;
+    FSeq: Integer;
+    FId: Integer;
+    FPacketSize: Integer;
+    FPingTime: Integer;
+    FIcmpEcho: Byte;
+    FIcmpEchoReply: Byte;
+    FIcmpUnreach: Byte;
+    FReplyFrom: string;
+    FReplyType: byte;
+    FReplyCode: byte;
+    FReplyError: TICMPError;
+    FReplyErrorDesc: string;
+    FTTL: Byte;
+    Fsin: TVarSin;
+    function Checksum(Value: AnsiString): Word;
+    function Checksum6(Value: AnsiString): Word;
+    function ReadPacket: Boolean;
+    procedure TranslateError;
+    procedure TranslateErrorIpHlp(value: integer);
+    function InternalPing(const Host: string): Boolean;
+    function InternalPingIpHlp(const Host: string): Boolean;
+    function IsHostIP6(const Host: string): Boolean;
+    procedure GenErrorDesc;
+  public
+    {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
+     @true.}
+    function Ping(const Host: string): Boolean;
+    constructor Create;
+    destructor Destroy; override;
+  published
+    {:Size of PING packet. Default size is 32 bytes.}
+    property PacketSize: Integer read FPacketSize Write FPacketSize;
+
+    {:Time between request and reply.}
+    property PingTime: Integer read FPingTime;
+
+    {:From this address is sended reply for your PING request. It maybe not your
+     requested destination, when some error occured!}
+    property ReplyFrom: string read FReplyFrom;
+
+    {:ICMP type of PING reply. Each protocol using another values! For IPv4 and
+     IPv6 are used different values!}
+    property ReplyType: byte read FReplyType;
+
+    {:ICMP code of PING reply. Each protocol using another values! For IPv4 and
+     IPv6 are used different values! For protocol independent value look to
+     @link(ReplyError)}
+    property ReplyCode: byte read FReplyCode;
+
+    {:Return type of returned ICMP message. This value is independent on used
+     protocol!}
+    property ReplyError: TICMPError read FReplyError;
+
+    {:Return human readable description of returned packet type.}
+    property ReplyErrorDesc: string read FReplyErrorDesc;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TICMPBlockSocket read FSock;
+
+    {:TTL value for ICMP query}
+    property TTL: byte read FTTL write FTTL;
+  end;
+
+{:A very useful function and example of its use would be found in the TPINGSend
+ object. Use it to ping to any host. If successful, returns the ping time in
+ milliseconds.  Returns -1 if an error occurred.}
+function PingHost(const Host: string): Integer;
+
+{:A very useful function and example of its use would be found in the TPINGSend
+ object. Use it to TraceRoute to any host.}
+function TraceRouteHost(const Host: string): string;
+
+implementation
+
+type
+  {:Record for ICMP ECHO packet header.}
+  TIcmpEchoHeader = packed record
+    i_type: Byte;
+    i_code: Byte;
+    i_checkSum: Word;
+    i_Id: Word;
+    i_seq: Word;
+    TimeStamp: integer;
+  end;
+
+  {:record used internally by TPingSend for compute checksum of ICMPv6 packet
+   pseudoheader.}
+  TICMP6Packet = packed record
+    in_source: TInAddr6;
+    in_dest: TInAddr6;
+    Length: integer;
+    free0: Byte;
+    free1: Byte;
+    free2: Byte;
+    proto: Byte;
+  end;
+
+{$IFDEF MSWINDOWS}
+const
+  DLLIcmpName = 'iphlpapi.dll';
+type
+  TIP_OPTION_INFORMATION = record
+    TTL: Byte;
+    TOS: Byte;
+    Flags: Byte;
+    OptionsSize: Byte;
+    OptionsData: PAnsiChar;
+  end;
+  PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
+
+  TICMP_ECHO_REPLY = record
+    Address: TInAddr;
+    Status: integer;
+    RoundTripTime: integer;
+    DataSize: Word;
+    Reserved: Word;
+    Data: pointer;
+    Options: TIP_OPTION_INFORMATION;
+  end;
+  PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
+
+  TICMPV6_ECHO_REPLY = record
+    Address: TSockAddrIn6;
+    Status: integer;
+    RoundTripTime: integer;
+  end;
+  PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
+
+  TIcmpCreateFile = function: integer; stdcall;
+  TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
+  TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+    ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
+    RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
+    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
+  TIcmp6CreateFile = function: integer; stdcall;
+  TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
+    ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
+    RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
+    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
+
+var
+  IcmpDllHandle: TLibHandle = 0;
+  IcmpHelper4: boolean = false;
+  IcmpHelper6: boolean = false;
+  IcmpCreateFile: TIcmpCreateFile = nil;
+  IcmpCloseHandle: TIcmpCloseHandle = nil;
+  IcmpSendEcho2: TIcmpSendEcho2 = nil;
+  Icmp6CreateFile: TIcmp6CreateFile = nil;
+  Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
+{$ENDIF}
+{==============================================================================}
+
+constructor TPINGSend.Create;
+begin
+  inherited Create;
+  FSock := TICMPBlockSocket.Create;
+  FSock.Owner := self;
+  {$IFDEF ULTIBO}
+  FSock.UseConnect := True; //Connect is needed for the ICMP handler to find the matching
+  {$ENDIF}                  //socket on receive if multiple pings occur are sent at once.
+  FTimeout := 5000;
+  FPacketSize := 32;
+  FSeq := 0;
+  Randomize;
+  FTTL := 128;
+end;
+
+destructor TPINGSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TPINGSend.ReadPacket: Boolean;
+begin
+  FBuffer := FSock.RecvPacket(Ftimeout);
+  Result := FSock.LastError = 0;
+end;
+
+procedure TPINGSend.GenErrorDesc;
+begin
+  case FReplyError of
+    IE_NoError:
+      FReplyErrorDesc := '';
+    IE_Other:
+      FReplyErrorDesc := 'Unknown error';
+    IE_TTLExceed:
+      FReplyErrorDesc := 'TTL Exceeded';
+    IE_UnreachOther:
+      FReplyErrorDesc := 'Unknown unreachable';
+    IE_UnreachRoute:
+      FReplyErrorDesc := 'No route to destination';
+    IE_UnreachAdmin:
+      FReplyErrorDesc := 'Administratively prohibited';
+    IE_UnreachAddr:
+      FReplyErrorDesc := 'Address unreachable';
+    IE_UnreachPort:
+      FReplyErrorDesc := 'Port unreachable';
+  end;
+end;
+
+function TPINGSend.IsHostIP6(const Host: string): Boolean;
+var
+  f: integer;
+begin
+  f := AF_UNSPEC;
+  if IsIp(Host) then
+    f := AF_INET
+  else
+    if IsIp6(Host) then
+      f := AF_INET6;
+  synsock.SetVarSin(Fsin, host, '0', f,
+    IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
+  result := Fsin.sin_family = AF_INET6;
+end;
+
+function TPINGSend.Ping(const Host: string): Boolean;
+{$IFDEF MSWINDOWS}
+var
+  b: boolean;
+{$ENDIF}
+begin
+  FPingTime := -1;
+  FReplyFrom := '';
+  FReplyType := 0;
+  FReplyCode := 0;
+  FReplyError := IE_Other;
+  GenErrorDesc;
+  FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
+{$IFDEF MSWINDOWS}
+  b := IsHostIP6(host);
+  if not(b) and IcmpHelper4 then
+    result := InternalPingIpHlp(host)
+  else
+    if b and IcmpHelper6 then
+      result := InternalPingIpHlp(host)
+    else
+      result := InternalPing(host);
+{$ELSE}
+   result := InternalPing(host);
+{$ENDIF}
+end;
+
+function TPINGSend.InternalPing(const Host: string): Boolean;
+var
+  IPHeadPtr: ^TIPHeader;
+  IpHdrLen: Integer;
+  IcmpEchoHeaderPtr: ^TICMPEchoHeader;
+  t: Boolean;
+  x: cardinal;
+  IcmpReqHead: string;
+begin
+  Result := False;
+  FSock.TTL := FTTL;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(Host, '0');
+  if FSock.LastError <> 0 then
+    Exit;
+  FSock.SizeRecvBuffer := 60 * 1024;
+  if FSock.IP6used then
+  begin
+    FIcmpEcho := ICMP6_ECHO;
+    FIcmpEchoReply := ICMP6_ECHOREPLY;
+    FIcmpUnreach := ICMP6_UNREACH;
+  end
+  else
+  begin
+    FIcmpEcho := ICMP_ECHO;
+    FIcmpEchoReply := ICMP_ECHOREPLY;
+    FIcmpUnreach := ICMP_UNREACH;
+  end;
+  IcmpEchoHeaderPtr := Pointer(FBuffer);
+  with IcmpEchoHeaderPtr^ do
+  begin
+    i_type := FIcmpEcho;
+    i_code := 0;
+    i_CheckSum := 0;
+    FId := System.Random(32767);
+    i_Id := FId;
+    TimeStamp := GetTick;
+    Inc(FSeq);
+    i_Seq := FSeq;
+    if fSock.IP6used then
+      i_CheckSum := CheckSum6(FBuffer)
+    else
+      i_CheckSum := CheckSum(FBuffer);
+  end;
+  FSock.SendString(FBuffer);
+  // remember first 8 bytes of ICMP packet
+  IcmpReqHead := Copy(FBuffer, 1, 8);
+  x := GetTick;
+  repeat
+    t := ReadPacket;
+    if not t then
+      break;
+    if fSock.IP6used then
+    begin
+{$IFNDEF MSWINDOWS}
+      IcmpEchoHeaderPtr := Pointer(FBuffer);
+{$ELSE}
+//WinXP SP1 with networking update doing this think by another way ;-O
+//      FBuffer := StringOfChar(#0, 4) + FBuffer;
+      IcmpEchoHeaderPtr := Pointer(FBuffer);
+//      IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
+{$ENDIF}
+    end
+    else
+    begin
+      IPHeadPtr := Pointer(FBuffer);
+      IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
+      IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
+    end;
+  //check for timeout
+    if TickDelta(x, GetTick) > Cardinal(FTimeout) then
+    begin
+      t := false;
+      Break;
+    end;
+  //it discard sometimes possible 'echoes' of previosly sended packet
+  //or other unwanted ICMP packets...
+  until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
+    and ((IcmpEchoHeaderPtr^.i_id = FId)
+    or (Pos(IcmpReqHead, FBuffer) > 0));
+  if t then
+    begin
+      FPingTime := TickDelta(x, GetTick);
+      FReplyFrom := FSock.GetRemoteSinIP;
+      FReplyType := IcmpEchoHeaderPtr^.i_type;
+      FReplyCode := IcmpEchoHeaderPtr^.i_code;
+      TranslateError;
+      Result := True;
+    end;
+end;
+
+function TPINGSend.Checksum(Value: AnsiString): Word;
+var
+  CkSum: integer;
+  Num, Remain: Integer;
+  n, i: Integer;
+begin
+  Num := Length(Value) div 2;
+  Remain := Length(Value) mod 2;
+  CkSum := 0;
+  i := 1;
+  for n := 0 to Num - 1 do
+  begin
+    CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
+    inc(i, 2);
+  end;
+  if Remain <> 0 then
+    CkSum := CkSum + Ord(Value[Length(Value)]);
+  CkSum := (CkSum shr 16) + (CkSum and $FFFF);
+  CkSum := CkSum + (CkSum shr 16);
+  Result := Word(not CkSum);
+end;
+
+function TPINGSend.Checksum6(Value: AnsiString): Word;
+const
+  IOC_OUT = $40000000;
+  IOC_IN = $80000000;
+  IOC_INOUT = (IOC_IN or IOC_OUT);
+  IOC_WS2 = $08000000;
+  SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
+{$IFDEF MSWINDOWS}
+var
+  ICMP6Ptr: ^TICMP6Packet;
+  s: AnsiString;
+  b: integer;
+  ip6: TSockAddrIn6;
+  x: integer;
+{$ENDIF}  
+begin
+{$IFDEF MSWINDOWS}
+  s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
+  ICMP6Ptr := Pointer(s);
+  x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
+    @FSock.RemoteSin, SizeOf(FSock.RemoteSin),
+    @ip6, SizeOf(ip6), @b, nil, nil);
+  if x <> -1 then
+    ICMP6Ptr^.in_dest := ip6.sin6_addr
+  else
+    ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
+  ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
+  ICMP6Ptr^.Length := synsock.htonl(Length(Value));
+  ICMP6Ptr^.proto := IPPROTO_ICMPV6;
+  Result := Checksum(s);
+{$ELSE}
+  Result := 0;
+{$ENDIF}
+end;
+
+procedure TPINGSend.TranslateError;
+begin
+  if fSock.IP6used then
+  begin
+    case FReplyType of
+      ICMP6_ECHOREPLY:
+        FReplyError := IE_NoError;
+      ICMP6_TIME_EXCEEDED:
+        FReplyError := IE_TTLExceed;
+      ICMP6_UNREACH:
+        case FReplyCode of
+          0:
+            FReplyError := IE_UnreachRoute;
+          3:
+            FReplyError := IE_UnreachAddr;
+          4:
+            FReplyError := IE_UnreachPort;
+          1:
+            FReplyError := IE_UnreachAdmin;
+        else
+          FReplyError := IE_UnreachOther;
+        end;
+    else
+      FReplyError := IE_Other;
+    end;
+  end
+  else
+  begin
+    case FReplyType of
+      ICMP_ECHOREPLY:
+        FReplyError := IE_NoError;
+      ICMP_TIME_EXCEEDED:
+        FReplyError := IE_TTLExceed;
+      ICMP_UNREACH:
+        case FReplyCode of
+          0:
+            FReplyError := IE_UnreachRoute;
+          1:
+            FReplyError := IE_UnreachAddr;
+          3:
+            FReplyError := IE_UnreachPort;
+          13:
+            FReplyError := IE_UnreachAdmin;
+        else
+          FReplyError := IE_UnreachOther;
+        end;
+    else
+      FReplyError := IE_Other;
+    end;
+  end;
+  GenErrorDesc;
+end;
+
+procedure TPINGSend.TranslateErrorIpHlp(value: integer);
+begin
+  case value of
+    11000, 0:
+      FReplyError := IE_NoError;
+    11013:
+      FReplyError := IE_TTLExceed;
+    11002:
+      FReplyError := IE_UnreachRoute;
+    11003:
+      FReplyError := IE_UnreachAddr;
+    11005:
+      FReplyError := IE_UnreachPort;
+    11004:
+      FReplyError := IE_UnreachAdmin;
+  else
+    FReplyError := IE_Other;
+  end;
+  GenErrorDesc;
+end;
+
+function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
+{$IFDEF MSWINDOWS}
+var
+  PingIp6: boolean;
+  PingHandle: integer;
+  r: integer;
+  ipo: TIP_OPTION_INFORMATION;
+  RBuff: Ansistring;
+  ip4reply: PICMP_ECHO_REPLY;
+  ip6reply: PICMPV6_ECHO_REPLY;
+  ip6: TSockAddrIn6;
+begin
+  Result := False;
+  PingIp6 := Fsin.sin_family = AF_INET6;
+  if pingIp6 then
+    PingHandle := Icmp6CreateFile
+  else
+    PingHandle := IcmpCreateFile;
+  if PingHandle <> -1 then
+  begin
+    try
+      ipo.TTL := FTTL;
+      ipo.TOS := 0;
+      ipo.Flags := 0;
+      ipo.OptionsSize := 0;
+      ipo.OptionsData := nil;
+      setlength(RBuff, 4096);
+      if pingIp6 then
+      begin
+        FillChar(ip6, sizeof(ip6), 0);
+        r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
+          PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
+        if r > 0 then
+        begin
+          RBuff := #0 + #0 + RBuff;
+          ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
+          FPingTime := ip6reply^.RoundTripTime;
+          ip6reply^.Address.sin6_family := AF_INET6;
+          FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
+          TranslateErrorIpHlp(ip6reply^.Status);
+          Result := True;
+        end;
+      end
+      else
+      begin
+        r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
+          PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
+        if r > 0 then
+        begin
+          ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
+          FPingTime := ip4reply^.RoundTripTime;
+          FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
+          TranslateErrorIpHlp(ip4reply^.Status);
+          Result := True;
+        end;
+      end
+    finally
+      IcmpCloseHandle(PingHandle);
+    end;
+  end;
+end;
+{$ELSE}
+begin
+  result := false;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function PingHost(const Host: string): Integer;
+begin
+  with TPINGSend.Create do
+  try
+    Result := -1;
+    if Ping(Host) then
+      if ReplyError = IE_NoError then
+        Result := PingTime;
+  finally
+    Free;
+  end;
+end;
+
+function TraceRouteHost(const Host: string): string;
+var
+  Ping: TPingSend;
+  ttl : byte;
+begin
+  Result := '';
+  Ping := TPINGSend.Create;
+  try
+    ttl := 1;
+    repeat
+      ping.TTL := ttl;
+      inc(ttl);
+      if ttl > 30 then
+        Break;
+      if not ping.Ping(Host) then
+      begin
+        Result := Result + cAnyHost+ ' Timeout' + CRLF;
+        continue;
+      end;
+      if (ping.ReplyError <> IE_NoError)
+        and (ping.ReplyError <> IE_TTLExceed) then
+      begin
+        Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
+        break;
+      end;
+      Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
+    until ping.ReplyError = IE_NoError;
+  finally
+    Ping.Free;
+  end;
+end;
+
+{$IFDEF MSWINDOWS}
+initialization
+begin
+  IcmpHelper4 := false;
+  IcmpHelper6 := false;
+  IcmpDllHandle := LoadLibrary(DLLIcmpName);
+  if IcmpDllHandle <> 0 then
+  begin
+    IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
+    IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
+    IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
+    Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
+    Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
+    IcmpHelper4 := assigned(IcmpCreateFile)
+      and assigned(IcmpCloseHandle)
+      and assigned(IcmpSendEcho2);
+    IcmpHelper6 := assigned(Icmp6CreateFile)
+      and assigned(Icmp6SendEcho2);
+  end;
+end;
+
+finalization
+begin
+  FreeLibrary(IcmpDllHandle);
+end;
+{$ENDIF}
+
+end.

pop3send.pas

@@ -0,0 +1,483 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.006.002 |
+|==============================================================================|
+| Content: POP3 client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(POP3 protocol client)
+
+Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$M+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit pop3send;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synacode;
+
+const
+  cPop3Protocol = '110';
+
+type
+
+  {:The three types of possible authorization methods for "logging in" to a POP3
+   server.}
+  TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
+
+  {:@abstract(Implementation of POP3 client protocol.)
+
+   Note: Are you missing properties for setting Username and Password? Look to
+   parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TPOP3Send = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FResultCode: Integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FStatCount: Integer;
+    FStatSize: Integer;
+    FListSize: Integer;
+    FTimeStamp: string;
+    FAuthType: TPOP3AuthType;
+    FPOP3cap: TStringList;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    function ReadResult(Full: Boolean): Integer;
+    function Connect: Boolean;
+    function AuthLogin: Boolean;
+    function AuthApop: Boolean;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:You can call any custom by this method. Call Command without trailing CRLF.
+      If MultiLine parameter is @true, multilined response are expected.
+      Result is @true on sucess.}
+    function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
+
+    {:Call CAPA command for get POP3 server capabilites.
+     note: not all servers support this command!}
+    function Capability: Boolean;
+
+    {:Connect to remote POP3 host. If all OK, result is @true.}
+    function Login: Boolean;
+
+    {:Disconnects from POP3 server.}
+    function Logout: Boolean;
+
+    {:Send RSET command. If all OK, result is @true.}
+    function Reset: Boolean;
+
+    {:Send NOOP command. If all OK, result is @true.}
+    function NoOp: Boolean;
+
+    {:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
+     If all OK, result is @true.}
+    function Stat: Boolean;
+
+    {:Send LIST command. If Value is 0, LIST is for all messages. After
+     successful operation is listing in FullResult. If all OK, result is @True.}
+    function List(Value: Integer): Boolean;
+
+    {:Send RETR command. After successful operation dowloaded message in
+     @link(FullResult). If all OK, result is @true.}
+    function Retr(Value: Integer): Boolean;
+
+    {:Send RETR command. After successful operation dowloaded message in
+     @link(Stream). If all OK, result is @true.}
+    function RetrStream(Value: Integer; Stream: TStream): Boolean;
+
+    {:Send DELE command for delete specified message. If all OK, result is @true.}
+    function Dele(Value: Integer): Boolean;
+
+    {:Send TOP command. After successful operation dowloaded headers of message
+     and maxlines count of message in @link(FullResult). If all OK, result is
+     @true.}
+    function Top(Value, Maxlines: Integer): Boolean;
+
+    {:Send UIDL command. If Value is 0, UIDL is for all messages. After
+     successful operation is listing in FullResult. If all OK, result is @True.}
+    function Uidl(Value: Integer): Boolean;
+
+    {:Call STLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Try to find given capabily in capabilty string returned from POP3 server
+     by CAPA command.}
+    function FindCap(const Value: string): string;
+  published
+    {:Result code of last POP3 operation. 0 - error, 1 - OK.}
+    property ResultCode: Integer read FResultCode;
+
+    {:Result string of last POP3 operation.}
+    property ResultString: string read FResultString;
+
+    {:Stringlist with full lines returned as result of POP3 operation. I.e. if
+     operation is LIST, this property is filled by list of messages. If
+     operation is RETR, this property have downloaded message.}
+    property FullResult: TStringList read FFullResult;
+
+    {:After STAT command is there count of messages in inbox.}
+    property StatCount: Integer read FStatCount;
+
+    {:After STAT command is there size of all messages in inbox.}
+    property StatSize: Integer read  FStatSize;
+
+    {:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
+    property ListSize: Integer read  FListSize;
+
+    {:If server support this, after comnnect is in this property timestamp of
+     remote server.}
+    property TimeStamp: string read FTimeStamp;
+
+    {:Type of authorisation for login to POP3 server. Dafault is autodetect one
+     of possible authorisation. Autodetect do this:
+
+     If remote POP3 server support APOP, try login by APOP method. If APOP is
+     not supported, or if APOP login failed, try classic USER+PASS login method.}
+    property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
+
+    {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TPOP3Send.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FPOP3cap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.ConvertLineEnd := true;
+  FTimeout := 60000;
+  FTargetPort := cPop3Protocol;
+  FStatCount := 0;
+  FStatSize := 0;
+  FListSize := 0;
+  FAuthType := POP3AuthAll;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TPOP3Send.Destroy;
+begin
+  FSock.Free;
+  FPOP3cap.Free;
+  FullResult.Free;
+  inherited Destroy;
+end;
+
+function TPOP3Send.ReadResult(Full: Boolean): Integer;
+var
+  s: string;
+begin
+  Result := 0;
+  FFullResult.Clear;
+  s := FSock.RecvString(FTimeout);
+  if Pos('+OK', s) = 1 then
+    Result := 1;
+  FResultString := s;
+  if Full and (Result = 1) then
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s = '.' then
+        Break;
+      if s <> '' then
+        if s[1] = '.' then
+          Delete(s, 1, 1);
+      FFullResult.Add(s);
+    until FSock.LastError <> 0;
+  if not Full and (Result = 1) then
+    FFullResult.Add(SeparateRight(FResultString, ' '));
+  if FSock.LastError <> 0 then
+    Result := 0;
+  FResultCode := Result;
+end;
+
+function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
+begin
+  FSock.SendString(Command + CRLF);
+  Result := ReadResult(MultiLine) <> 0;
+end;
+
+function TPOP3Send.AuthLogin: Boolean;
+begin
+  Result := False;
+  if not CustomCommand('USER ' + FUserName, False) then
+    exit;
+  Result := CustomCommand('PASS ' + FPassword, False)
+end;
+
+function TPOP3Send.AuthAPOP: Boolean;
+var
+  s: string;
+begin
+  s := StrToHex(MD5(FTimeStamp + FPassWord));
+  Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
+end;
+
+function TPOP3Send.Connect: Boolean;
+begin
+  // Do not call this function! It is calling by LOGIN method!
+  FStatCount := 0;
+  FStatSize := 0;
+  FSock.CloseSocket;
+  FSock.LineBuffer := '';
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TPOP3Send.Capability: Boolean;
+begin
+  FPOP3cap.Clear;
+  Result := CustomCommand('CAPA', True);
+  if Result then
+    FPOP3cap.AddStrings(FFullResult);
+end;
+
+function TPOP3Send.Login: Boolean;
+var
+  s, s1: string;
+begin
+  Result := False;
+  FTimeStamp := '';
+  if not Connect then
+    Exit;
+  if ReadResult(False) <> 1 then
+    Exit;
+  s := SeparateRight(FResultString, '<');
+  if s <> FResultString then
+  begin
+    s1 := Trim(SeparateLeft(s, '>'));
+    if s1 <> s then
+      FTimeStamp := '<' + s1 + '>';
+  end;
+  Result := False;
+  if Capability then
+    if FAutoTLS and (Findcap('STLS') <> '') then
+      if StartTLS then
+        Capability
+      else
+      begin
+        Result := False;
+        Exit;
+      end;
+  if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
+  begin
+    Result := AuthApop;
+    if not Result then
+    begin
+      if not Connect then
+        Exit;
+      if ReadResult(False) <> 1 then
+        Exit;
+    end;
+  end;
+  if not Result and not (FAuthType = POP3AuthAPOP) then
+    Result := AuthLogin;
+end;
+
+function TPOP3Send.Logout: Boolean;
+begin
+  Result := CustomCommand('QUIT', False);
+  FSock.CloseSocket;
+end;
+
+function TPOP3Send.Reset: Boolean;
+begin
+  Result := CustomCommand('RSET', False);
+end;
+
+function TPOP3Send.NoOp: Boolean;
+begin
+  Result := CustomCommand('NOOP', False);
+end;
+
+function TPOP3Send.Stat: Boolean;
+var
+  s: string;
+begin
+  Result := CustomCommand('STAT', False);
+  if Result then
+  begin
+    s := SeparateRight(ResultString, '+OK ');
+    FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
+    FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
+  end;
+end;
+
+function TPOP3Send.List(Value: Integer): Boolean;
+var
+  s: string;
+  n: integer;
+begin
+  if Value = 0 then
+    s := 'LIST'
+  else
+    s := 'LIST ' + IntToStr(Value);
+  Result := CustomCommand(s, Value = 0);
+  FListSize := 0;
+  if Result then
+    if Value <> 0 then
+    begin
+      s := SeparateRight(ResultString, '+OK ');
+      FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
+    end
+    else
+      for n := 0 to FFullResult.Count - 1 do
+        FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
+end;
+
+function TPOP3Send.Retr(Value: Integer): Boolean;
+begin
+  Result := CustomCommand('RETR ' + IntToStr(Value), True);
+end;
+
+//based on code by Miha Vrhovnik
+function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
+var
+  s: string;
+begin
+  Result := False;
+  FFullResult.Clear;
+  Stream.Size := 0;
+  FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
+
+  s := FSock.RecvString(FTimeout);
+  if Pos('+OK', s) = 1 then
+    Result := True;
+  FResultString := s;
+  if Result then begin
+    repeat
+      s := FSock.RecvString(FTimeout);
+      if s = '.' then
+        Break;
+      if s <> '' then begin
+        if s[1] = '.' then
+          Delete(s, 1, 1);
+      end;
+      WriteStrToStream(Stream, s);
+      WriteStrToStream(Stream, CRLF);
+    until FSock.LastError <> 0;
+  end;
+
+  if Result then
+    FResultCode := 1
+  else
+    FResultCode := 0;
+end;
+
+function TPOP3Send.Dele(Value: Integer): Boolean;
+begin
+  Result := CustomCommand('DELE ' + IntToStr(Value), False);
+end;
+
+function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
+begin
+  Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
+end;
+
+function TPOP3Send.Uidl(Value: Integer): Boolean;
+var
+  s: string;
+begin
+  if Value = 0 then
+    s := 'UIDL'
+  else
+    s := 'UIDL ' + IntToStr(Value);
+  Result := CustomCommand(s, Value = 0);
+end;
+
+function TPOP3Send.StartTLS: Boolean;
+begin
+  Result := False;
+  if CustomCommand('STLS', False) then
+  begin
+    Fsock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+function TPOP3Send.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FPOP3cap.Count - 1 do
+    if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
+    begin
+      Result := FPOP3cap[n];
+      Break;
+    end;
+end;
+
+end.

slogsend.pas

@@ -0,0 +1,320 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.002.003 |
+|==============================================================================|
+| Content: SysLog client                                                       |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|    Christian Brosius                                                         |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(BSD SYSLOG protocol)
+
+Used RFC: RFC-3164
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit slogsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cSysLogProtocol = '514';
+
+  FCL_Kernel = 0;
+  FCL_UserLevel = 1;
+  FCL_MailSystem = 2;
+  FCL_System = 3;
+  FCL_Security = 4;
+  FCL_Syslogd = 5;
+  FCL_Printer = 6;
+  FCL_News = 7;
+  FCL_UUCP = 8;
+  FCL_Clock = 9;
+  FCL_Authorization = 10;
+  FCL_FTP = 11;
+  FCL_NTP = 12;
+  FCL_LogAudit = 13;
+  FCL_LogAlert = 14;
+  FCL_Time = 15;
+  FCL_Local0 = 16;
+  FCL_Local1 = 17;
+  FCL_Local2 = 18;
+  FCL_Local3 = 19;
+  FCL_Local4 = 20;
+  FCL_Local5 = 21;
+  FCL_Local6 = 22;
+  FCL_Local7 = 23;
+
+type
+  {:@abstract(Define possible priority of Syslog message)}
+  TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
+    Debug);
+
+  {:@abstract(encoding or decoding of SYSLOG message)}
+  TSyslogMessage = class(TObject)
+  private
+    FFacility:Byte;
+    FSeverity:TSyslogSeverity;
+    FDateTime:TDateTime;
+    FTag:String;
+    FMessage:String;
+    FLocalIP:String;
+    function GetPacketBuf:String;
+    procedure SetPacketBuf(Value:String);
+  public
+    {:Reset values to defaults}
+    procedure Clear;
+  published
+    {:Define facilicity of Syslog message. For specify you may use predefined
+     FCL_* constants. Default is "FCL_Local0".}
+    property Facility:Byte read FFacility write FFacility;
+
+    {:Define possible priority of Syslog message. Default is "Debug".}
+    property Severity:TSyslogSeverity read FSeverity write FSeverity;
+
+    {:date and time of Syslog message}
+    property DateTime:TDateTime read FDateTime write FDateTime;
+
+    {:This is used for identify process of this message. Default is filename
+     of your executable file.}
+    property Tag:String read FTag write FTag;
+
+    {:Text of your message for log.}
+    property LogMessage:String read FMessage write FMessage;
+
+    {:IP address of message sender.}
+    property LocalIP:String read FLocalIP write FLocalIP;
+
+    {:This property holds encoded binary SYSLOG packet}
+    property PacketBuf:String read GetPacketBuf write SetPacketBuf;
+  end;
+
+  {:@abstract(This object implement BSD SysLog client)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSyslogSend = class(TSynaClient)
+  private
+    FSock: TUDPBlockSocket;
+    FSysLogMessage: TSysLogMessage;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    {:Send Syslog UDP packet defined by @link(SysLogMessage).}
+    function DoIt: Boolean;
+  published
+    {:Syslog message for send}
+    property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
+  end;
+
+{:Simply send packet to specified Syslog server.}
+function ToSysLog(const SyslogServer: string; Facil: Byte;
+  Sever: TSyslogSeverity; const Content: string): Boolean;
+
+implementation
+
+function TSyslogMessage.GetPacketBuf:String;
+begin
+  Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
+  Result := Result + CDateTime(FDateTime) + ' ';
+  Result := Result + FLocalIP + ' ';
+  Result := Result + FTag + ': ' + FMessage;
+end;
+
+procedure TSyslogMessage.SetPacketBuf(Value:String);
+var StrBuf:String;
+    IntBuf,Pos:Integer;
+begin
+  if Length(Value) < 1 then exit;
+  Pos := 1;
+  if Value[Pos] <> '<' then exit;
+  Inc(Pos);
+  // Facility and Severity
+  StrBuf := '';
+  while (Value[Pos] <> '>')do
+  begin
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+  end;
+  IntBuf := StrToInt(StrBuf);
+  FFacility := IntBuf div 8;
+  case (IntBuf mod 8)of
+    0:FSeverity := Emergency;
+    1:FSeverity := Alert;
+    2:FSeverity := Critical;
+    3:FSeverity := Error;
+    4:FSeverity := Warning;
+    5:FSeverity := Notice;
+    6:FSeverity := Info;
+    7:FSeverity := Debug;
+  end;
+  // DateTime
+  Inc(Pos);
+  StrBuf := '';
+    // Month
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+    // Day
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+    StrBuf := StrBuf + Value[Pos];
+    Inc(Pos);
+    // Time
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FDateTime := DecodeRFCDateTime(StrBuf);
+  Inc(Pos);
+
+  // LocalIP
+  StrBuf := '';
+  while (Value[Pos] <> ' ')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FLocalIP := StrBuf;
+  Inc(Pos);
+  // Tag
+  StrBuf := '';
+  while (Value[Pos] <> ':')do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FTag := StrBuf;
+  // LogMessage
+  Inc(Pos);
+  StrBuf := '';
+  while (Pos <= Length(Value))do
+    begin
+      StrBuf := StrBuf + Value[Pos];
+      Inc(Pos);
+    end;
+  FMessage := TrimSP(StrBuf);
+end;
+
+procedure TSysLogMessage.Clear;
+begin
+  FFacility := FCL_Local0;
+  FSeverity := Debug;
+  FTag := ExtractFileName(ParamStr(0));
+  FMessage := '';
+  FLocalIP  := '0.0.0.0';
+end;
+
+//------------------------------------------------------------------------------
+
+constructor TSyslogSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FSock.Owner := self;
+  FSysLogMessage := TSysLogMessage.Create;
+  FTargetPort := cSysLogProtocol;
+end;
+
+destructor TSyslogSend.Destroy;
+begin
+  FSock.Free;
+  FSysLogMessage.Free;
+  inherited Destroy;
+end;
+
+function TSyslogSend.DoIt: Boolean;
+var
+  L: TStringList;
+begin
+  Result := False;
+  L := TStringList.Create;
+  try
+    FSock.ResolveNameToIP(FSock.Localname, L);
+    if L.Count < 1 then
+      FSysLogMessage.LocalIP := '0.0.0.0'
+    else
+      FSysLogMessage.LocalIP := L[0];
+  finally
+    L.Free;
+  end;
+  FSysLogMessage.DateTime := Now;
+  if Length(FSysLogMessage.PacketBuf) <= 1024 then
+  begin
+    FSock.Connect(FTargetHost, FTargetPort);
+    FSock.SendString(FSysLogMessage.PacketBuf);
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+{==============================================================================}
+
+function ToSysLog(const SyslogServer: string; Facil: Byte;
+  Sever: TSyslogSeverity; const Content: string): Boolean;
+begin
+  with TSyslogSend.Create do
+    try
+      TargetHost :=SyslogServer;
+      SysLogMessage.Facility := Facil;
+      SysLogMessage.Severity := Sever;
+      SysLogMessage.LogMessage := Content;
+      Result := DoIt;
+    finally
+      Free;
+    end;
+end;
+
+end.

smtpsend.pas

@@ -0,0 +1,987 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.005.001 |
+|==============================================================================|
+| Content: SMTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2010.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SMTP client)
+
+Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
+ RFC-2554, RFC-2821
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit smtpsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil, synacode;
+
+const
+  cSmtpProtocol = '25';
+
+type
+  TOnAnswerEvent = TNotifyEvent;
+
+  {:@abstract(Implementation of SMTP and ESMTP procotol),
+   include some ESMTP extensions, include SSL/TLS too.
+
+   Note: Are you missing properties for setting Username and Password for ESMTP?
+   Look to parent @link(TSynaClient) object!
+
+   Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSMTPSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    //---
+    FOnAnswerEvent: TOnAnswerEvent;
+    FLastCmd: string;
+    FLastCmdData: string;
+    //---
+    FResultCode: Integer;
+    FResultString: string;
+    FFullResult: TStringList;
+    FESMTPcap: TStringList;
+    FESMTP: Boolean;
+    FAuthDone: Boolean;
+    FESMTPSize: Boolean;
+    FMaxSize: Integer;
+    FEnhCode1: Integer;
+    FEnhCode2: Integer;
+    FEnhCode3: Integer;
+    FSystemName: string;
+    FAutoTLS: Boolean;
+    FFullSSL: Boolean;
+    procedure EnhancedCode(const Value: string);
+    function ReadResult: Integer;
+    function AuthLogin: Boolean;
+    function AuthCram: Boolean;
+    function AuthPlain: Boolean;
+    function Helo: Boolean;
+    function Ehlo: Boolean;
+    function Connect: Boolean;
+    procedure DoAnswerEvent;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    function SendCmd(const AOut: string; const AResponse: SmallInt = -1): SmallInt; overload;
+    function SendCmd(const AOut: string; const AResponse: array of SmallInt): SmallInt; overload;
+
+    //---
+    procedure ClearResult;
+    procedure ParseESmtp;
+    procedure RaiseProtocolExcept;
+    function SmtpSendCmd(const ACmd: string; const ACmdData: string = ''): Integer;
+    function SmtpSendCmdHelo: Boolean;
+    function SmtpSendCmdEhlo: Boolean;
+    function SmtpSendCmdFrom(const AFromMail: string; const ADop: string = ''): Boolean;
+    function SmtpSendCmdRcpt(const ARcptMail: string; const ADop: string = ''): Boolean;
+    function SmtpSendCmdData: Boolean;
+    function SmtpSendMailData(AEml: TStrings): Boolean;
+    function SmtpSendQuit: Boolean;
+    {Ðàçäåëåíèå Login() íà îòäåëüíûå øàãè}
+    function SmtpConnect: Boolean;
+    function SmtpHelo: Boolean;
+    function SmtpLogin: Boolean;
+    function SmtpStartTLS: Boolean;
+    function SmtpAfterHelo: Boolean;
+    //---
+
+    {:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
+     begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
+     ESMTP capabilites and if you specified Username and password and remote
+     server can handle AUTH command, try login by AUTH command. Preffered login
+     method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
+     @false.}
+    function Login: Boolean;
+
+    {:Close SMTP session (QUIT command) and disconnect from SMTP server.}
+    function Logout: Boolean;
+
+    {:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
+     else result is @false.}
+    function Reset: Boolean;
+
+    {:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
+     else result is @false.}
+    function NoOp: Boolean;
+
+    {:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
+     e-mail address is empty string, transmited message is error message.
+
+     If size not 0 and remote server can handle SIZE parameter, append SIZE
+     parameter to request. If all OK, result is @true, else result is @false.}
+    function MailFrom(const Value, ADop: string; Size: Integer = 0): Boolean;
+
+    {:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
+     empty string. If all OK, result is @true, else result is @false.}
+    function MailTo(const Value: string): Boolean;
+
+    {:Send DATA SMTP command and transmit message data. If all OK, result is
+     @true, else result is @false.}
+    function MailData(const Value: Tstrings): Boolean;
+
+    {:Send ETRN SMTP command for start sending of remote queue for domain in
+     Value. If all OK, result is @true, else result is @false.}
+    function Etrn(const Value: string): Boolean;
+
+    {:Send VRFY SMTP command for check receiver e-mail address. It cannot be
+     an empty string. If all OK, result is @true, else result is @false.}
+    function Verify(const Value: string): Boolean;
+
+    {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
+    function StartTLS: Boolean;
+
+    {:Return string descriptive text for enhanced result codes stored in
+     @link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
+    function EnhCodeString: string;
+
+    {:Try to find specified capability in ESMTP response.}
+    function FindCap(const Value: string): string;
+
+    //---
+    property LastCmd: string read FLastCmd;
+    property LastCmdData: string read FLastCmdData;
+    property OnAnswer: TOnAnswerEvent read FOnAnswerEvent write FOnAnswerEvent;
+    //---
+
+  published
+    {:result code of last SMTP command.}
+    property ResultCode: Integer read FResultCode;
+
+    {:result string of last SMTP command (begin with string representation of
+     result code).}
+    property ResultString: string read FResultString;
+
+    {:All result strings of last SMTP command (result is maybe multiline!).}
+    property FullResult: TStringList read FFullResult;
+
+    {:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
+     server only!).}
+    property ESMTPcap: TStringList read FESMTPcap;
+
+    {:@TRUE if you successfuly logged to ESMTP server.}
+    property ESMTP: Boolean read FESMTP;
+
+    {:@TRUE if you successfuly pass authorisation to remote server.}
+    property AuthDone: Boolean read FAuthDone;
+
+    {:@TRUE if remote server can handle SIZE parameter.}
+    property ESMTPSize: Boolean read FESMTPSize;
+
+    {:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
+     server can handle.}
+    property MaxSize: Integer read FMaxSize;
+
+    {:First digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode1: Integer read FEnhCode1;
+
+    {:Second digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode2: Integer read FEnhCode2;
+
+    {:Third digit of Enhanced result code. If last operation does not have
+     enhanced result code, values is 0.}
+    property EnhCode3: Integer read FEnhCode3;
+
+    {:name of our system used in HELO and EHLO command. Implicit value is
+     internet address of your machine.}
+    property SystemName: string read FSystemName Write FSystemName;
+
+    {:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
+    property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
+
+    {:SSL/TLS mode is used from first contact to server. Servers with full
+     SSL/TLS mode usualy using non-standard TCP port!}
+    property FullSSL: Boolean read FFullSSL Write FFullSSL;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+  end;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Send maildata (text of e-mail with all SMTP headers! For example when
+ text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
+ address to "MailTo" e-mail address (If you need more then one receiver, then
+ separate their addresses by comma).
+
+ Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
+ Username and password are used for authorization to the "SMTPhost". If you
+ don't want authorization, set "Username" and "Password" to empty strings. If
+ e-mail message is successfully sent, the result returns @true.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Send "Maildata" (text of e-mail without any SMTP headers!) from
+ "MailFrom" e-mail address to "MailTo" e-mail address with "Subject".  (If you
+ need more then one receiver, then separate their addresses by comma).
+
+ This function constructs all needed SMTP headers (with DATE header) and sends
+ the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
+ e-mail message is successfully sent, the result will be @TRUE.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings): Boolean;
+
+{:A very useful function and example of its use would be found in the TSMTPsend
+ object. Sends "MailData" (text of e-mail without any SMTP headers!) from
+ "MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
+ receiver, then separate their addresses by comma).
+
+ This function sends the e-mail to the SMTP server defined in the "SMTPhost"
+ parameter. Username and password are used for authorization to the "SMTPhost".
+ If you dont want authorization, set "Username" and "Password" to empty Strings.
+ If the e-mail message is successfully sent, the result will be @TRUE.
+
+ If you need use different port number then standard, then add this port number
+ to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
+function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+
+implementation
+
+constructor TSMTPSend.Create;
+begin
+  inherited Create;
+  FFullResult := TStringList.Create;
+  FESMTPcap := TStringList.Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.ConvertLineEnd := true;
+  FTimeout := 60000;
+  FTargetPort := cSmtpProtocol;
+  FSystemName := FSock.LocalName;
+  FAutoTLS := False;
+  FFullSSL := False;
+end;
+
+destructor TSMTPSend.Destroy;
+begin
+  FSock.Free;
+  FESMTPcap.Free;
+  FFullResult.Free;
+  inherited Destroy;
+end;
+
+procedure TSMTPSend.DoAnswerEvent;
+begin
+  if Assigned(FOnAnswerEvent) then
+    FOnAnswerEvent(Self)
+end;
+
+procedure TSMTPSend.EnhancedCode(const Value: string);
+var
+  s, t: string;
+  e1, e2, e3: Integer;
+begin
+  FEnhCode1 := 0;
+  FEnhCode2 := 0;
+  FEnhCode3 := 0;
+  s := Copy(Value, 5, Length(Value) - 4);
+  t := Trim(SeparateLeft(s, '.'));
+  s := Trim(SeparateRight(s, '.'));
+  if t = '' then
+    Exit;
+  if Length(t) > 1 then
+    Exit;
+  e1 := StrToIntDef(t, 0);
+  if e1 = 0 then
+    Exit;
+  t := Trim(SeparateLeft(s, '.'));
+  s := Trim(SeparateRight(s, '.'));
+  if t = '' then
+    Exit;
+  if Length(t) > 3 then
+    Exit;
+  e2 := StrToIntDef(t, 0);
+  t := Trim(SeparateLeft(s, ' '));
+  if t = '' then
+    Exit;
+  if Length(t) > 3 then
+    Exit;
+  e3 := StrToIntDef(t, 0);
+  FEnhCode1 := e1;
+  FEnhCode2 := e2;
+  FEnhCode3 := e3;
+end;
+
+procedure TSMTPSend.RaiseProtocolExcept;
+begin
+  raise ESynProtocolError.CreateErrorCode(FResultCode, FFullResult.Text);
+end;
+
+function TSMTPSend.ReadResult: Integer;
+var
+  s: String;
+begin
+  Result := 0;
+  FFullResult.Clear;
+  repeat
+    s := FSock.RecvString(FTimeout);
+    if FResultString = '' then    
+      FResultString := s
+    else
+      FResultString := FResultString + #13#10 + s;
+    FFullResult.Add(s);
+    if FSock.LastError <> 0 then
+      Break;
+  until Pos('-', s) <> 4;
+  s := FFullResult[0];
+  if Length(s) >= 3 then
+    Result := StrToIntDef(Copy(s, 1, 3), 0);
+  FResultCode := Result;
+  EnhancedCode(s);
+  DoAnswerEvent;
+end;
+
+function TSMTPSend.AuthLogin: Boolean;
+begin
+  Result := False;
+  FSock.SendString('AUTH LOGIN' + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  FSock.SendString(EncodeBase64(FUsername) + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  FSock.SendString(EncodeBase64(FPassword) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+function TSMTPSend.AuthCram: Boolean;
+var
+  s: ansistring;
+begin
+  Result := False;
+  FSock.SendString('AUTH CRAM-MD5' + CRLF);
+  if ReadResult <> 334 then
+    Exit;
+  s := Copy(FResultString, 5, Length(FResultString) - 4);
+  s := DecodeBase64(s);
+  s := HMAC_MD5(s, FPassword);
+  s := FUsername + ' ' + StrToHex(s);
+  FSock.SendString(EncodeBase64(s) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+function TSMTPSend.AuthPlain: Boolean;
+var
+  s: ansistring;
+begin
+  s := ansichar(0) + FUsername + ansichar(0) + FPassword;
+  FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
+  Result := ReadResult = 235;
+end;
+
+procedure TSMTPSend.ClearResult;
+begin
+  FResultCode := -1;
+  FResultString := '';
+  FFullResult.Clear;
+  //---
+  FLastCmd := '';
+  FLastCmdData := '';
+end;
+
+function TSMTPSend.Connect: Boolean;
+begin
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  if FSock.LastError = 0 then
+    FSock.Connect(FTargetHost, FTargetPort);
+  if FSock.LastError = 0 then
+    if FFullSSL then
+      FSock.SSLDoConnect;
+  Result := FSock.LastError = 0;
+end;
+
+function TSMTPSend.Helo: Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('HELO ' + FSystemName + CRLF);
+  x := ReadResult;
+  Result := ((x >= 250) and (x <= 259)) or (x = 220);
+end;
+
+function TSMTPSend.Ehlo: Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('EHLO ' + FSystemName + CRLF);
+  x := ReadResult;
+  Result := ((x >= 250) and (x <= 259)) or (x = 220);
+end;
+
+function TSMTPSend.Login: Boolean;
+var
+  n: Integer;
+  auths: string;
+  s: string;
+begin
+  Result := False;
+//-------------------------------
+  FResultCode := -1;
+  FResultString := '';
+  FFullResult.Clear;
+//-------------------------------
+  FESMTP := True;
+  FAuthDone := False;
+  FESMTPcap.clear;
+  FESMTPSize := False;
+  FMaxSize := 0;
+  if not Connect then
+    Exit;
+  if ReadResult <> 220 then
+    Exit;
+  if not Ehlo then
+  begin
+    FESMTP := False;
+    if not Helo then
+      Exit;
+  end;
+  Result := True;
+  if FESMTP then
+  begin
+    for n := 1 to FFullResult.Count - 1 do
+      FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
+    if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
+      if StartTLS then
+      begin
+        Ehlo;
+        FESMTPcap.Clear;
+        for n := 1 to FFullResult.Count - 1 do
+          FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
+      end
+      else
+      begin
+        Result := False;
+        Exit;
+      end;
+    if not ((FUsername = '') and (FPassword = '')) then
+    begin
+      s := FindCap('AUTH ');
+      if s = '' then
+        s := FindCap('AUTH=');
+      auths := UpperCase(s);
+      if s <> '' then
+      begin
+        if Pos('CRAM-MD5', auths) > 0 then
+          FAuthDone := AuthCram;
+        if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
+          FAuthDone := AuthPlain;
+        if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
+          FAuthDone := AuthLogin;
+      end;
+    end;
+    s := FindCap('SIZE');
+    if s <> '' then
+    begin
+      FESMTPsize := True;
+      FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
+    end;
+  end;
+end;
+
+function TSMTPSend.Logout: Boolean;
+begin
+  FSock.SendString('QUIT' + CRLF);
+  Result := ReadResult = 221;
+  FSock.CloseSocket;
+end;
+
+function TSMTPSend.Reset: Boolean;
+begin
+  FSock.SendString('RSET' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.NoOp: Boolean;
+begin
+  FSock.SendString('NOOP' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+procedure TSMTPSend.ParseESmtp;
+var
+  n: Integer;
+  z: string;
+begin
+  FESMTPcap.Clear;
+  if ESMTP then
+    for n := 1 to FFullResult.Count - 1 do
+    begin
+      z := FFullResult[n];
+      FESMTPcap.Add(Copy(z, 5, MaxInt));
+    end;
+end;
+
+function TSMTPSend.MailFrom(const Value, ADop: string; Size: Integer): Boolean;
+var
+  s: string;
+begin
+  s := 'MAIL FROM: <' + Value + '>';
+  if FESMTPsize and (Size > 0) then
+    s := s + ' SIZE=' + IntToStr(Size);
+  if ADop <> '' then
+    s := s + ' ' + ADop;
+  FSock.SendString(s + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.MailTo(const Value: string): Boolean;
+begin
+  FSock.SendString('RCPT TO: <' + Value + '>' + CRLF);
+  Result := ReadResult = 250;
+end;
+
+function TSMTPSend.MailData(const Value: TStrings): Boolean;
+var
+  n: Integer;
+  s: string;
+  t: string;
+  x: integer;
+begin
+  Result := False;
+  FSock.SendString('DATA' + CRLF);
+  if ReadResult <> 354 then
+    Exit;
+  t := '';
+  x := 1500;
+  for n := 0 to Value.Count - 1 do
+  begin
+    s := Value[n];
+    if Length(s) >= 1 then
+      if s[1] = '.' then
+        s := '.' + s;
+    if Length(t) + Length(s) >= x then
+    begin
+      FSock.SendString(t);
+      t := '';
+    end;
+    t := t + s + CRLF;
+  end;
+  if t <> '' then
+    FSock.SendString(t);
+  FSock.SendString('.' + CRLF);
+  Result := ReadResult div 100 = 2;
+end;
+
+function TSMTPSend.Etrn(const Value: string): Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('ETRN ' + Value + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.Verify(const Value: string): Boolean;
+var
+  x: Integer;
+begin
+  FSock.SendString('VRFY ' + Value + CRLF);
+  x := ReadResult;
+  Result := (x >= 250) and (x <= 259);
+end;
+
+function TSMTPSend.SendCmd(const AOut: string;
+  const AResponse: SmallInt): SmallInt;
+begin
+  if AResponse = -1 then begin
+    Result := SendCmd(AOut, []);
+  end else begin
+    Result := SendCmd(AOut, [AResponse]);
+  end;
+end;
+
+function TSMTPSend.SendCmd(const AOut: string;
+  const AResponse: array of SmallInt): SmallInt;
+var
+  j : Integer;
+begin
+  FSock.SendString(AOut + CRLF);
+  Result := ReadResult;
+  if Length(AResponse)>0 then
+  begin
+    for j:=Low(AResponse) to High(AResponse) do
+    begin
+      if AResponse[j]=ResultCode then
+        Exit;
+    end;
+    RaiseProtocolExcept;
+  end;
+end;
+
+function TSMTPSend.SmtpConnect: Boolean;
+begin
+  Result := False;
+  ClearResult;
+  FESMTP := False;
+  FAuthDone := False;
+  FESMTPcap.Clear;
+  FESMTPSize := False;
+  FMaxSize := 0;
+  if not Connect then
+    Exit;
+  if ReadResult <> 220 then
+    Exit;
+  Result := True;
+end;
+
+function TSMTPSend.SmtpHelo: Boolean;
+begin
+  ClearResult;
+  Result := False;
+  if SmtpSendCmdEhlo then
+  begin
+    FESMTP := True;
+    Result := True;
+  end
+  else
+  begin
+    if SmtpSendCmdHelo then
+      Result := True;
+  end;
+end;
+
+function TSMTPSend.SmtpLogin: Boolean;
+var s, auths: AnsiString;
+begin
+  ClearResult;
+  s := FindCap('AUTH ');
+  if s = '' then
+    s := FindCap('AUTH=');
+  auths := UpperCase(s);
+  if s <> '' then
+  begin
+    if Pos('CRAM-MD5', auths) > 0 then
+      FAuthDone := AuthCram;
+    if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
+      FAuthDone := AuthPlain;
+    if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
+      FAuthDone := AuthLogin;
+  end;
+  Result := FAuthDone;
+end;
+
+function TSMTPSend.SmtpSendCmd(const ACmd, ACmdData: string): Integer;
+var lCmd: AnsiString;
+begin
+  ClearResult;
+  FLastCmd := ACmd;
+  FLastCmdData:= ACmdData;
+  if ACmdData='' then
+    lCmd := ACmd
+  else
+    lCmd := ACmd + ' ' + ACmdData;
+  Result := SendCmd(lCmd, []);
+end;
+
+function TSMTPSend.SmtpSendCmdEhlo: Boolean;
+var x: Integer;
+begin
+  x := SmtpSendCmd('EHLO', FSystemName);
+  Result := ((x >= 250) and (x <= 259)) or (x = 220);
+end;
+
+function TSMTPSend.SmtpSendCmdHelo: Boolean;
+var x: Integer;
+begin
+  x := SmtpSendCmd('HELO', FSystemName);
+  Result := ((x >= 250) and (x <= 259)) or (x = 220);
+end;
+
+function TSMTPSend.SmtpSendCmdFrom(const AFromMail, ADop: string): Boolean;
+var z: AnsiString;
+begin
+  if ADop='' then z := '<' + AFromMail + '>'
+             else z := '<' + AFromMail + '> ' + ADop;
+  Result := SmtpSendCmd('MAIL FROM:', z) = 250
+end;
+
+function TSMTPSend.SmtpSendCmdRcpt(const ARcptMail, ADop: string): Boolean;
+var z: AnsiString;
+begin
+  if ADop='' then z := '<' + ARcptMail + '>'
+             else z := '<' + ARcptMail + '> ' + ADop;
+  Result := SmtpSendCmd('RCPT TO:', z) = 250
+end;
+
+function TSMTPSend.SmtpSendCmdData: Boolean;
+begin
+  Result := SmtpSendCmd('DATA') = 354;
+end;
+
+function TSMTPSend.SmtpSendMailData(AEml: TStrings): Boolean;
+var
+  j: Integer;
+  z: AnsiString;
+begin
+  for j:=0 to (AEml.Count-1) do
+  begin
+    z := AnsiString(AEml[j]);
+    if z='.' then
+      z := '..';
+    Sock.SendString(z+CRLF);
+  end;
+  Result := SmtpSendCmd('.') = 250
+end;
+
+function TSMTPSend.SmtpSendQuit: Boolean;
+begin
+  Result := SmtpSendCmd('QUIT') = 221
+end;
+
+function TSMTPSend.SmtpStartTLS: Boolean;
+var lres: Integer;
+begin
+  lres := SmtpSendCmd('STARTTLS');
+  if (lres = 220) and (FSock.LastError = 0) then
+  begin
+    Fsock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end
+  else
+  begin
+    Result := False  
+  end;
+end;
+
+function TSMTPSend.SmtpAfterHelo: Boolean;
+var s: AnsiString;
+begin
+  Result := True;
+  if FESMTP then
+  begin
+    s := FindCap('SIZE');
+    if s <> '' then
+    begin
+      FESMTPsize := True;
+      FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
+    end;
+  end;
+end;
+
+
+function TSMTPSend.StartTLS: Boolean;
+begin
+  Result := False;
+  if FindCap('STARTTLS') <> '' then
+  begin
+    FSock.SendString('STARTTLS' + CRLF);
+    if (ReadResult = 220) and (FSock.LastError = 0) then
+    begin
+      Fsock.SSLDoConnect;
+      Result := FSock.LastError = 0;
+    end;
+  end;
+end;
+
+function TSMTPSend.EnhCodeString: string;
+var
+  s, t: string;
+begin
+  s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
+  t := '';
+  if s = '0.0' then t := 'Other undefined Status';
+  if s = '1.0' then t := 'Other address status';
+  if s = '1.1' then t := 'Bad destination mailbox address';
+  if s = '1.2' then t := 'Bad destination system address';
+  if s = '1.3' then t := 'Bad destination mailbox address syntax';
+  if s = '1.4' then t := 'Destination mailbox address ambiguous';
+  if s = '1.5' then t := 'Destination mailbox address valid';
+  if s = '1.6' then t := 'Mailbox has moved';
+  if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
+  if s = '1.8' then t := 'Bad sender''s system address';
+  if s = '2.0' then t := 'Other or undefined mailbox status';
+  if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
+  if s = '2.2' then t := 'Mailbox full';
+  if s = '2.3' then t := 'Message Length exceeds administrative limit';
+  if s = '2.4' then t := 'Mailing list expansion problem';
+  if s = '3.0' then t := 'Other or undefined mail system status';
+  if s = '3.1' then t := 'Mail system full';
+  if s = '3.2' then t := 'System not accepting network messages';
+  if s = '3.3' then t := 'System not capable of selected features';
+  if s = '3.4' then t := 'Message too big for system';
+  if s = '3.5' then t := 'System incorrectly configured';
+  if s = '4.0' then t := 'Other or undefined network or routing status';
+  if s = '4.1' then t := 'No answer from host';
+  if s = '4.2' then t := 'Bad connection';
+  if s = '4.3' then t := 'Routing server failure';
+  if s = '4.4' then t := 'Unable to route';
+  if s = '4.5' then t := 'Network congestion';
+  if s = '4.6' then t := 'Routing loop detected';
+  if s = '4.7' then t := 'Delivery time expired';
+  if s = '5.0' then t := 'Other or undefined protocol status';
+  if s = '5.1' then t := 'Invalid command';
+  if s = '5.2' then t := 'Syntax error';
+  if s = '5.3' then t := 'Too many recipients';
+  if s = '5.4' then t := 'Invalid command arguments';
+  if s = '5.5' then t := 'Wrong protocol version';
+  if s = '6.0' then t := 'Other or undefined media error';
+  if s = '6.1' then t := 'Media not supported';
+  if s = '6.2' then t := 'Conversion required and prohibited';
+  if s = '6.3' then t := 'Conversion required but not supported';
+  if s = '6.4' then t := 'Conversion with loss performed';
+  if s = '6.5' then t := 'Conversion failed';
+  if s = '7.0' then t := 'Other or undefined security status';
+  if s = '7.1' then t := 'Delivery not authorized, message refused';
+  if s = '7.2' then t := 'Mailing list expansion prohibited';
+  if s = '7.3' then t := 'Security conversion required but not possible';
+  if s = '7.4' then t := 'Security features not supported';
+  if s = '7.5' then t := 'Cryptographic failure';
+  if s = '7.6' then t := 'Cryptographic algorithm not supported';
+  if s = '7.7' then t := 'Message integrity failure';
+  s := '???-';
+  if FEnhCode1 = 2 then s := 'Success-';
+  if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
+  if FEnhCode1 = 5 then s := 'Permanent Failure-';
+  Result := s + t;
+end;
+
+function TSMTPSend.FindCap(const Value: string): string;
+var
+  n: Integer;
+  s: string;
+begin
+  s := UpperCase(Value);
+  Result := '';
+  for n := 0 to FESMTPcap.Count - 1 do
+    if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
+    begin
+      Result := FESMTPcap[n];
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+var
+  SMTP: TSMTPSend;
+  s, t: string;
+begin
+  Result := False;
+  SMTP := TSMTPSend.Create;
+  try
+// if you need SOCKS5 support, uncomment next lines:
+    // SMTP.Sock.SocksIP := '127.0.0.1';
+    // SMTP.Sock.SocksPort := '1080';
+// if you need support for upgrade session to TSL/SSL, uncomment next lines:
+     SMTP.AutoTLS := True;
+// if you need support for TSL/SSL tunnel, uncomment next lines:
+     SMTP.FullSSL := True;
+    SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
+    s := Trim(SeparateRight(SMTPHost, ':'));
+    if (s <> '') and (s <> SMTPHost) then
+      SMTP.TargetPort := s;
+    SMTP.Username := Username;
+    SMTP.Password := Password;
+    if SMTP.Login then
+    begin
+      if SMTP.MailFrom(GetEmailAddr(MailFrom), '', Length(MailData.Text)) then
+      begin
+        s := MailTo;
+        repeat
+          t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
+          if t <> '' then
+            Result := SMTP.MailTo(t);
+          if not Result then
+            Break;
+        until s = '';
+        if Result then
+          Result := SMTP.MailData(MailData);
+      end;
+      SMTP.Logout;
+    end;
+  finally
+    SMTP.Free;
+  end;
+end;
+
+function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings; const Username, Password: string): Boolean;
+var
+  t: TStrings;
+begin
+  t := TStringList.Create;
+  try
+    t.Assign(MailData);
+    t.Insert(0, '');
+    t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
+    t.Insert(0, 'Subject: ' + Subject);
+    t.Insert(0, 'Date: ' + Rfc822DateTime(now));
+    t.Insert(0, 'To: ' + MailTo);
+    t.Insert(0, 'From: ' + MailFrom);
+    Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
+  finally
+    t.Free;
+  end;
+end;
+
+function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
+  const MailData: TStrings): Boolean;
+begin
+  Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
+end;
+
+end.

snmpsend.pas

@@ -0,0 +1,1269 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 004.000.000 |
+|==============================================================================|
+| Content: SNMP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2011, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2011.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Jean-Fabien Connault ([email protected])                                |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SNMP client)
+Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization
+and privacy encryption.
+
+Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416, RFC-3826
+
+Supported Authorization hashes: MD5, SHA1
+Supported Privacy encryptions: DES, 3DES, AES
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit snmpsend;
+
+interface
+
+uses
+  Classes, SysUtils,
+  blcksock, synautil, asn1util, synaip, synacode, synacrypt;
+
+const
+  cSnmpProtocol = '161';
+  cSnmpTrapProtocol = '162';
+
+  SNMP_V1 = 0;
+  SNMP_V2C = 1;
+  SNMP_V3 = 3;
+
+  //PDU type
+  PDUGetRequest = $A0;
+  PDUGetNextRequest = $A1;
+  PDUGetResponse = $A2;
+  PDUSetRequest = $A3;
+  PDUTrap = $A4; //Obsolete
+  //for SNMPv2
+  PDUGetBulkRequest = $A5;
+  PDUInformRequest = $A6;
+  PDUTrapV2 = $A7;
+  PDUReport = $A8;
+
+  //errors
+  ENoError = 0;
+  ETooBig = 1;
+  ENoSuchName = 2;
+  EBadValue = 3;
+  EReadOnly = 4;
+  EGenErr = 5;
+  //errors SNMPv2
+  ENoAccess = 6;
+  EWrongType = 7;
+  EWrongLength = 8;
+  EWrongEncoding = 9;
+  EWrongValue = 10;
+  ENoCreation = 11;
+  EInconsistentValue = 12;
+  EResourceUnavailable = 13;
+  ECommitFailed = 14;
+  EUndoFailed = 15;
+  EAuthorizationError = 16;
+  ENotWritable = 17;
+  EInconsistentName = 18;
+
+type
+
+  {:@abstract(Possible values for SNMPv3 flags.)
+   This flags specify level of authorization and encryption.}
+  TV3Flags = (
+    NoAuthNoPriv,
+    AuthNoPriv,
+    AuthPriv);
+
+  {:@abstract(Type of SNMPv3 authorization)}
+  TV3Auth = (
+    AuthMD5,
+    AuthSHA1);
+
+  {:@abstract(Type of SNMPv3 privacy)}
+  TV3Priv = (
+    PrivDES,
+    Priv3DES,
+    PrivAES);
+
+  {:@abstract(Data object with one record of MIB OID and corresponding values.)}
+  TSNMPMib = class(TObject)
+  protected
+    FOID: AnsiString;
+    FValue: AnsiString;
+    FValueType: Integer;
+  published
+    {:OID number in string format.}
+    property OID: AnsiString read FOID write FOID;
+
+    {:Value of OID object in string format.}
+    property Value: AnsiString read FValue write FValue;
+
+    {:Define type of Value. Supported values are defined in @link(asn1util).
+     For queries use ASN1_NULL, becouse you don't know type in response!}
+    property ValueType: Integer read FValueType write FValueType;
+  end;
+
+  {:@abstract(It holding all information for SNMPv3 agent synchronization)
+   Used internally.}
+  TV3Sync = record
+    EngineID: AnsiString;
+    EngineBoots: integer;
+    EngineTime: integer;
+    EngineStamp: Cardinal;
+  end;
+
+  {:@abstract(Data object abstracts SNMP data packet)}
+  TSNMPRec = class(TObject)
+  protected
+    FVersion: Integer;
+    FPDUType: Integer;
+    FID: Integer;
+    FErrorStatus: Integer;
+    FErrorIndex: Integer;
+    FCommunity: AnsiString;
+    FSNMPMibList: TList;
+    FMaxSize: Integer;
+    FFlags: TV3Flags;
+    FFlagReportable: Boolean;
+    FContextEngineID: AnsiString;
+    FContextName: AnsiString;
+    FAuthMode: TV3Auth;
+    FAuthEngineID: AnsiString;
+    FAuthEngineBoots: integer;
+    FAuthEngineTime: integer;
+    FAuthEngineTimeStamp: cardinal;
+    FUserName: AnsiString;
+    FPassword: AnsiString;
+    FAuthKey: AnsiString;
+    FPrivMode: TV3Priv;
+    FPrivPassword: AnsiString;
+    FPrivKey: AnsiString;
+    FPrivSalt: AnsiString;
+    FPrivSaltCounter: integer;
+    FOldTrapEnterprise: AnsiString;
+    FOldTrapHost: AnsiString;
+    FOldTrapGen: Integer;
+    FOldTrapSpec: Integer;
+    FOldTrapTimeTicks: Integer;
+    function Pass2Key(const Value: AnsiString): AnsiString;
+    function EncryptPDU(const value: AnsiString): AnsiString;
+    function DecryptPDU(const value: AnsiString): AnsiString;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Decode SNMP packet in buffer to object properties.}
+    function DecodeBuf(Buffer: AnsiString): Boolean;
+
+    {:Encode obeject properties to SNMP packet.}
+    function EncodeBuf: AnsiString;
+
+    {:Clears all object properties to default values.}
+    procedure Clear;
+
+    {:Add entry to @link(SNMPMibList). For queries use value as empty string,
+     and ValueType as ASN1_NULL.}
+    procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
+
+    {:Delete entry from @link(SNMPMibList).}
+    procedure MIBDelete(Index: Integer);
+
+    {:Search @link(SNMPMibList) list for MIB and return correspond value.}
+    function MIBGet(const MIB: AnsiString): AnsiString;
+
+    {:return number of entries in MIB array.}
+    function MIBCount: integer;
+
+    {:Return MIB information from given row of MIB array.}
+    function MIBByIndex(Index: Integer): TSNMPMib;
+
+    {:List of @link(TSNMPMib) objects.}
+    property SNMPMibList: TList read FSNMPMibList;
+  published
+    {:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use
+     value 1 for SNMPv2c or value 3 for SNMPv3.}
+    property Version: Integer read FVersion write FVersion;
+
+    {:Community string for autorize access to SNMP server. (Case sensitive!)
+     Community string is not used in SNMPv3! Use @link(Username) and
+     @link(password) instead!}
+    property Community: AnsiString read FCommunity write FCommunity;
+
+    {:Define type of SNMP operation.}
+    property PDUType: Integer read FPDUType write FPDUType;
+
+    {:Contains ID number. Not need to use.}
+    property ID: Integer read FID write FID;
+
+    {:When packet is reply, contains error code. Supported values are defined by
+     E* constants.}
+    property ErrorStatus: Integer read FErrorStatus write FErrorStatus;
+
+    {:Point to error position in reply packet. Not usefull for users. It only
+     good for debugging!}
+    property ErrorIndex: Integer read FErrorIndex write FErrorIndex;
+
+    {:special value for GetBulkRequest of SNMPv2 and v3.}
+    property NonRepeaters: Integer read FErrorStatus write FErrorStatus;
+
+    {:special value for GetBulkRequest of SNMPv2 and v3.}
+    property MaxRepetitions: Integer read FErrorIndex write FErrorIndex;
+
+    {:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.}
+    property MaxSize: Integer read FMaxSize write FMaxSize;
+
+    {:Specify if message is authorised or encrypted. Used only in SNMPv3.}
+    property Flags: TV3Flags read FFlags write FFlags;
+
+    {:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some
+     error).}
+    property FlagReportable: Boolean read FFlagReportable write FFlagReportable;
+
+    {:For SNMPv3. If not specified, is used value from @link(AuthEngineID)}
+    property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID;
+
+    {:For SNMPv3.}
+    property ContextName: AnsiString read FContextName write FContextName;
+
+    {:For SNMPv3. Specify Authorization mode. (specify used hash for
+     authorization)}
+    property AuthMode: TV3Auth read FAuthMode write FAuthMode;
+
+    {:For SNMPv3. Specify Privacy mode.}
+    property PrivMode: TV3Priv read FPrivMode write FPrivMode;
+
+    {:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
+    property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID;
+
+    {:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
+    property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots;
+
+    {:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
+    property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime;
+
+    {:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
+    property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp;
+
+    {:SNMPv3 authorization username}
+    property UserName: AnsiString read FUserName write FUserName;
+
+    {:SNMPv3 authorization password}
+    property Password: AnsiString read FPassword write FPassword;
+
+    {:For SNMPv3. Computed Athorization key from @link(password).}
+    property AuthKey: AnsiString read FAuthKey write FAuthKey;
+
+    {:SNMPv3 privacy password}
+    property PrivPassword: AnsiString read FPrivPassword write FPrivPassword;
+
+    {:For SNMPv3. Computed Privacy key from @link(PrivPassword).}
+    property PrivKey: AnsiString read FPrivKey write FPrivKey;
+
+    {:MIB value to identify the object that sent the TRAPv1.}
+    property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise;
+
+    {:Address of TRAPv1 sender (IP address).}
+    property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost;
+
+    {:Generic TRAPv1 identification.}
+    property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen;
+
+    {:Specific TRAPv1 identification.}
+    property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec;
+
+    {:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)}
+    property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks;
+  end;
+
+  {:@abstract(Implementation of SNMP protocol.)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSNMPSend = class(TSynaClient)
+  protected
+    FSock: TUDPBlockSocket;
+    FBuffer: AnsiString;
+    FHostIP: AnsiString;
+    FQuery: TSNMPRec;
+    FReply: TSNMPRec;
+    function InternalSendSnmp(const Value: TSNMPRec): Boolean;
+    function InternalRecvSnmp(const Value: TSNMPRec): Boolean;
+    function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
+    function GetV3EngineID: AnsiString;
+    function GetV3Sync: TV3Sync;
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to a Host and send there query. If in timeout SNMP server send
+     back query, result is @true. If is used SNMPv3, then it synchronize self
+     with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)}
+    function SendRequest: Boolean;
+
+    {:Send SNMP packet only, but not waits for reply. Good for sending traps.}
+    function SendTrap: Boolean;
+
+    {:Receive SNMP packet only. Good for receiving traps.}
+    function RecvTrap: Boolean;
+
+    {:Mapped to @link(SendRequest) internally. This function is only for
+     backward compatibility.}
+    function DoIt: Boolean;
+  published
+    {:contains raw binary form of SNMP packet. Good for debugging.}
+    property Buffer: AnsiString read FBuffer write FBuffer;
+
+    {:After SNMP operation hold IP address of remote side.}
+    property HostIP: AnsiString read FHostIP;
+
+    {:Data object contains SNMP query.}
+    property Query: TSNMPRec read FQuery;
+
+    {:Data object contains SNMP reply.}
+    property Reply: TSNMPRec read FReply;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TUDPBlockSocket read FSock;
+  end;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It implements basic GET method of the SNMP protocol. The MIB value is
+ located in the "OID" variable, and is sent to the requested "SNMPHost" with
+ the proper "Community" access identifier. Upon a successful retrieval, "Value"
+ will contain the information requested. If the SNMP operation is successful,
+ the result returns @true.}
+function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+
+{:This is useful function and example of use TSNMPSend object. It implements
+ the basic SET method of the SNMP protocol. If the SNMP operation is successful,
+ the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community"
+ access identifier. You must specify "ValueType" too.}
+function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It implements basic GETNEXT method of the SNMP protocol. The MIB value
+ is located in the "OID" variable, and is sent to the requested "SNMPHost" with
+ the proper "Community" access identifier. Upon a successful retrieval, "Value"
+ will contain the information requested. If the SNMP operation is successful,
+ the result returns @true.}
+function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It implements basic read of SNMP MIB tables. As BaseOID you must
+ specify basic MIB OID of requested table (base IOD is OID without row and
+ column specificator!)
+ Table is readed into stringlist, where each string is comma delimited string.
+
+ Warning: this function is not have best performance. For better performance
+ you must write your own function. best performace you can get by knowledge
+ of structuture of table and by more then one MIB on one query. }
+function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It implements basic read of SNMP MIB table element. As BaseOID you must
+ specify basic MIB OID of requested table (base IOD is OID without row and
+ column specificator!)
+ As next you must specify identificator of row and column for specify of needed
+ field of table.}
+function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It implements a TRAPv1 to send with all data in the parameters.}
+function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
+  Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
+  MIBtype: Integer): Integer;
+
+{:A very useful function and example of its use would be found in the TSNMPSend
+ object. It receives a TRAPv1 and returns all the data that comes with it.}
+function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
+  var Generic, Specific, Seconds: Integer; const MIBName,
+  MIBValue: TStringList): Integer;
+
+implementation
+
+{==============================================================================}
+
+constructor TSNMPRec.Create;
+begin
+  inherited Create;
+  FSNMPMibList := TList.Create;
+  Clear;
+  FAuthMode := AuthMD5;
+  FPassword := '';
+  FPrivMode := PrivDES;
+  FPrivPassword := '';
+  FID := 1;
+  FMaxSize := 1472;
+end;
+
+destructor TSNMPRec.Destroy;
+var
+  i: Integer;
+begin
+  for i := 0 to FSNMPMibList.Count - 1 do
+    TSNMPMib(FSNMPMibList[i]).Free;
+  FSNMPMibList.Clear;
+  FSNMPMibList.Free;
+  inherited Destroy;
+end;
+
+function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString;
+var
+  key: AnsiString;
+begin
+  case FAuthMode of
+    AuthMD5:
+      begin
+        key := MD5LongHash(Value, 1048576);
+        Result := MD5(key + FAuthEngineID + key);
+      end;
+    AuthSHA1:
+      begin
+        key := SHA1LongHash(Value, 1048576);
+        Result := SHA1(key + FAuthEngineID + key);
+      end;
+  else
+    Result := '';
+  end;
+end;
+
+function TSNMPRec.DecryptPDU(const value: AnsiString): AnsiString;
+var
+  des: TSynaDes;
+  des3: TSyna3Des;
+  aes: TSynaAes;
+  s: string;
+begin
+  FPrivKey := '';
+  if FFlags <> AuthPriv then
+    Result := value
+  else
+  begin
+    case FPrivMode of
+      Priv3DES:
+        begin
+          FPrivKey := Pass2Key(FPrivPassword);
+          FPrivKey := FPrivKey + Pass2Key(FPrivKey);
+          des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0));
+          try
+            s := PadString(FPrivKey, 32, #0);
+            delete(s, 1, 24);
+            des3.SetIV(xorstring(s, FPrivSalt));
+            s := des3.DecryptCBC(value);
+            Result := s;
+          finally
+            des3.free;
+          end;
+        end;
+      PrivAES:
+        begin
+          FPrivKey := Pass2Key(FPrivPassword);
+          aes := TSynaAes.Create(PadString(FPrivKey, 16, #0));
+          try
+            s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt;
+            aes.SetIV(s);
+            s := aes.DecryptCFBblock(value);
+            Result := s;
+          finally
+            aes.free;
+          end;
+        end;
+    else //PrivDES as default
+      begin
+        FPrivKey := Pass2Key(FPrivPassword);
+        des := TSynaDes.Create(PadString(FPrivKey, 8, #0));
+        try
+          s := PadString(FPrivKey, 16, #0);
+          delete(s, 1, 8);
+          des.SetIV(xorstring(s, FPrivSalt));
+          s := des.DecryptCBC(value);
+          Result := s;
+        finally
+          des.free;
+        end;
+      end;
+    end;
+  end;
+end;
+
+function TSNMPRec.DecodeBuf(Buffer: AnsiString): Boolean;
+var
+  Pos: Integer;
+  EndPos: Integer;
+  sm, sv: AnsiString;
+  Svt: Integer;
+  s: AnsiString;
+  Spos: integer;
+  x: Byte;
+begin
+  Clear;
+  Result := False;
+  if Length(Buffer) < 2 then
+    Exit;
+  if (Ord(Buffer[1]) and $20) = 0 then
+    Exit;
+  Pos := 2;
+  EndPos := ASNDecLen(Pos, Buffer);
+  if Length(Buffer) < (EndPos + 2) then
+    Exit;
+  Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+
+  if FVersion = 3 then
+  begin
+    ASNItem(Pos, Buffer, Svt);  //header data seq
+    ASNItem(Pos, Buffer, Svt);  //ID
+    FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    s := ASNItem(Pos, Buffer, Svt);
+    x := 0;
+    if s <> '' then
+      x := Ord(s[1]);
+    FFlagReportable := (x and 4) > 0;
+    x := x and 3;
+    case x of
+      1:
+        FFlags := AuthNoPriv;
+      3:
+        FFlags := AuthPriv;
+    else
+      FFlags := NoAuthNoPriv;
+    end;
+
+    x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    s := ASNItem(Pos, Buffer, Svt); //SecurityParameters
+    //if SecurityModel is USM, then try to decode SecurityParameters
+    if (x = 3) and (s <> '') then
+    begin
+      spos := 1;
+      ASNItem(SPos, s, Svt);
+      FAuthEngineID := ASNItem(SPos, s, Svt);
+      FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0);
+      FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0);
+      FAuthEngineTimeStamp := GetTick;
+      FUserName := ASNItem(SPos, s, Svt);
+      FAuthKey := ASNItem(SPos, s, Svt);
+      FPrivSalt := ASNItem(SPos, s, Svt);
+    end;
+    //scopedPDU
+    if FFlags = AuthPriv then
+    begin
+      x := Pos;
+      s := ASNItem(Pos, Buffer, Svt);
+      if Svt <> ASN1_OCTSTR then
+        exit;
+      s := DecryptPDU(s);
+      //replace encoded content by decoded version and continue
+      Buffer := copy(Buffer, 1, x - 1);
+      Buffer := Buffer + s;
+      Pos := x;
+      if length(Buffer) < EndPos then
+        EndPos := length(buffer);
+    end;
+    ASNItem(Pos, Buffer, Svt); //skip sequence mark
+    FContextEngineID := ASNItem(Pos, Buffer, Svt);
+    FContextName := ASNItem(Pos, Buffer, Svt);
+  end
+  else
+  begin
+    //old packet
+    Self.FCommunity := ASNItem(Pos, Buffer, Svt);
+  end;
+
+  ASNItem(Pos, Buffer, Svt);
+  Self.FPDUType := Svt;
+  if Self.FPDUType = PDUTrap then
+  begin
+    FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt);
+    FOldTrapHost := ASNItem(Pos, Buffer, Svt);
+    FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+  end
+  else
+  begin
+    Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+    Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
+  end;
+  ASNItem(Pos, Buffer, Svt);
+  while Pos < EndPos do
+  begin
+    ASNItem(Pos, Buffer, Svt);
+    Sm := ASNItem(Pos, Buffer, Svt);
+    Sv := ASNItem(Pos, Buffer, Svt);
+    if sm <> '' then
+      Self.MIBAdd(sm, sv, Svt);
+  end;
+  Result := True;
+end;
+
+function TSNMPRec.EncryptPDU(const value: AnsiString): AnsiString;
+var
+  des: TSynaDes;
+  des3: TSyna3Des;
+  aes: TSynaAes;
+  s: string;
+  x: integer;
+begin
+  FPrivKey := '';
+  if FFlags <> AuthPriv then
+    Result := Value
+  else
+  begin
+    case FPrivMode of
+      Priv3DES:
+        begin
+          FPrivKey := Pass2Key(FPrivPassword);
+          FPrivKey := FPrivKey + Pass2Key(FPrivKey);
+          des3 := TSyna3Des.Create(PadString(FPrivKey, 24, #0));
+          try
+            s := PadString(FPrivKey, 32, #0);
+            delete(s, 1, 24);
+            FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter);
+            inc(FPrivSaltCounter);
+            s := xorstring(s, FPrivSalt);
+            des3.SetIV(s);
+            x := length(value) mod 8;
+            x := 8 - x;
+            if x = 8 then
+              x := 0;
+            s := des3.EncryptCBC(value + Stringofchar(#0, x));
+            Result := ASNObject(s, ASN1_OCTSTR);
+          finally
+            des3.free;
+          end;
+        end;
+      PrivAES:
+        begin
+          FPrivKey := Pass2Key(FPrivPassword);
+          aes := TSynaAes.Create(PadString(FPrivKey, 16, #0));
+          try
+            FPrivSalt := CodeLongInt(0) + CodeLongInt(FPrivSaltCounter);
+            inc(FPrivSaltCounter);
+            s := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FAuthEngineTime) + FPrivSalt;
+            aes.SetIV(s);
+            s := aes.EncryptCFBblock(value);
+            Result := ASNObject(s, ASN1_OCTSTR);
+          finally
+            aes.free;
+          end;
+        end;
+    else //PrivDES as default
+      begin
+        FPrivKey := Pass2Key(FPrivPassword);
+        des := TSynaDes.Create(PadString(FPrivKey, 8, #0));
+        try
+          s := PadString(FPrivKey, 16, #0);
+          delete(s, 1, 8);
+          FPrivSalt := CodeLongInt(FAuthEngineBoots) + CodeLongInt(FPrivSaltCounter);
+          inc(FPrivSaltCounter);
+          s := xorstring(s, FPrivSalt);
+          des.SetIV(s);
+          x := length(value) mod 8;
+          x := 8 - x;
+          if x = 8 then
+            x := 0;
+          s := des.EncryptCBC(value + Stringofchar(#0, x));
+          Result := ASNObject(s, ASN1_OCTSTR);
+        finally
+          des.free;
+        end;
+      end;
+    end;
+  end;
+end;
+
+function TSNMPRec.EncodeBuf: AnsiString;
+var
+  s: AnsiString;
+  SNMPMib: TSNMPMib;
+  n: Integer;
+  pdu, head, auth, authbeg: AnsiString;
+  x: Byte;
+begin
+  pdu := '';
+  for n := 0 to FSNMPMibList.Count - 1 do
+  begin
+    SNMPMib := TSNMPMib(FSNMPMibList[n]);
+    case SNMPMib.ValueType of
+      ASN1_INT:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+      ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+      ASN1_OBJID:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
+      ASN1_IPADDR:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
+      ASN1_NULL:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject('', ASN1_NULL);
+      ASN1_COUNTER64:
+        s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+          ASNObject(ASNEncInt(StrToInt64Def(SNMPMib.Value, 0)), SNMPMib.ValueType);
+    else
+      s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
+        ASNObject(SNMPMib.Value, SNMPMib.ValueType);
+    end;
+    pdu := pdu + ASNObject(s, ASN1_SEQ);
+  end;
+  pdu := ASNObject(pdu, ASN1_SEQ);
+
+  if Self.FPDUType = PDUTrap then
+    pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) +
+      ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) +
+      ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) +
+      ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) +
+      ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) +
+      pdu
+  else
+    pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
+      ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
+      ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
+      pdu;
+  pdu := ASNObject(pdu, Self.FPDUType);
+
+  if FVersion = 3 then
+  begin
+    if FContextEngineID = '' then
+      FContextEngineID := FAuthEngineID;
+    //complete PDUv3...
+    pdu := ASNObject(FContextEngineID, ASN1_OCTSTR)
+      + ASNObject(FContextName, ASN1_OCTSTR)
+      + pdu;
+    pdu := ASNObject(pdu, ASN1_SEQ);
+    //encrypt PDU if Priv mode is enabled
+    pdu := EncryptPDU(pdu);
+
+    //prepare flags
+    case FFlags of
+      AuthNoPriv:
+        x := 1;
+      AuthPriv:
+        x := 3;
+    else
+      x := 0;
+    end;
+    if FFlagReportable then
+      x := x or 4;
+    head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT);
+    s := ASNObject(ASNEncInt(FID), ASN1_INT)
+      + ASNObject(ASNEncInt(FMaxSize), ASN1_INT)
+      + ASNObject(AnsiChar(x), ASN1_OCTSTR)
+    //encode security model USM
+      + ASNObject(ASNEncInt(3), ASN1_INT);
+    head := head + ASNObject(s, ASN1_SEQ);
+
+    //compute engine time difference
+    if FAuthEngineTimeStamp = 0 then //out of sync
+      x := 0
+    else
+      x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000;
+
+    authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR)
+      + ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT)
+      + ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT)
+      + ASNObject(FUserName, ASN1_OCTSTR);
+
+
+    case FFlags of
+      AuthNoPriv,
+      AuthPriv:
+        begin
+          s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR)
+             + ASNObject(FPrivSalt, ASN1_OCTSTR);
+          s := ASNObject(s, ASN1_SEQ);
+          s := head + ASNObject(s, ASN1_OCTSTR);
+          s := ASNObject(s + pdu, ASN1_SEQ);
+          //in s is entire packet without auth info...
+          case FAuthMode of
+            AuthMD5:
+              begin
+                s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48));
+                //strip to HMAC-MD5-96
+                delete(s, 13, 4);
+              end;
+            AuthSHA1:
+              begin
+                s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44));
+                //strip to HMAC-SHA-96
+                delete(s, 13, 8);
+              end;
+          else
+            s := '';
+          end;
+          FAuthKey := s;
+        end;
+    end;
+
+    auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR)
+     + ASNObject(FPrivSalt, ASN1_OCTSTR);
+    auth := ASNObject(auth, ASN1_SEQ);
+
+    head := head + ASNObject(auth, ASN1_OCTSTR);
+    Result := ASNObject(head + pdu, ASN1_SEQ);
+  end
+  else
+  begin
+    head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
+      ASNObject(Self.FCommunity, ASN1_OCTSTR);
+    Result := ASNObject(head + pdu, ASN1_SEQ);
+  end;
+  inc(self.FID);
+end;
+
+procedure TSNMPRec.Clear;
+var
+  i: Integer;
+begin
+  FVersion := SNMP_V1;
+  FCommunity := 'public';
+  FUserName := '';
+  FPDUType := 0;
+  FErrorStatus := 0;
+  FErrorIndex := 0;
+  for i := 0 to FSNMPMibList.Count - 1 do
+    TSNMPMib(FSNMPMibList[i]).Free;
+  FSNMPMibList.Clear;
+  FOldTrapEnterprise := '';
+  FOldTrapHost := '';
+  FOldTrapGen := 0;
+  FOldTrapSpec := 0;
+  FOldTrapTimeTicks := 0;
+  FFlags := NoAuthNoPriv;
+  FFlagReportable := false;
+  FContextEngineID := '';
+  FContextName := '';
+  FAuthEngineID := '';
+  FAuthEngineBoots := 0;
+  FAuthEngineTime := 0;
+  FAuthEngineTimeStamp := 0;
+  FAuthKey := '';
+  FPrivKey := '';
+  FPrivSalt := '';
+  FPrivSaltCounter := random(maxint);
+end;
+
+procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
+var
+  SNMPMib: TSNMPMib;
+begin
+  SNMPMib := TSNMPMib.Create;
+  SNMPMib.OID := MIB;
+  SNMPMib.Value := Value;
+  SNMPMib.ValueType := ValueType;
+  FSNMPMibList.Add(SNMPMib);
+end;
+
+procedure TSNMPRec.MIBDelete(Index: Integer);
+begin
+  if (Index >= 0) and (Index < MIBCount) then
+  begin
+    TSNMPMib(FSNMPMibList[Index]).Free;
+    FSNMPMibList.Delete(Index);
+  end;
+end;
+
+function TSNMPRec.MIBCount: integer;
+begin
+  Result := FSNMPMibList.Count;
+end;
+
+function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib;
+begin
+  Result := nil;
+  if (Index >= 0) and (Index < MIBCount) then
+    Result := TSNMPMib(FSNMPMibList[Index]);
+end;
+
+function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString;
+var
+  i: Integer;
+begin
+  Result := '';
+  for i := 0 to MIBCount - 1 do
+  begin
+    if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
+    begin
+      Result := (TSNMPMib(FSNMPMibList[i])).Value;
+      Break;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+constructor TSNMPSend.Create;
+begin
+  inherited Create;
+  FQuery := TSNMPRec.Create;
+  FReply := TSNMPRec.Create;
+  FQuery.Clear;
+  FReply.Clear;
+  FSock := TUDPBlockSocket.Create;
+  FSock.Owner := self;
+  FTimeout := 5000;
+  FTargetPort := cSnmpProtocol;
+  FHostIP := '';
+end;
+
+destructor TSNMPSend.Destroy;
+begin
+  FSock.Free;
+  FReply.Free;
+  FQuery.Free;
+  inherited Destroy;
+end;
+
+function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean;
+begin
+  FBuffer := Value.EncodeBuf;
+  FSock.SendString(FBuffer);
+  Result := FSock.LastError = 0;
+end;
+
+function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean;
+begin
+  Result := False;
+  FReply.Clear;
+  FHostIP := cAnyHost;
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    FHostIP := FSock.GetRemoteSinIP;
+    Result := Value.DecodeBuf(FBuffer);
+  end;
+end;
+
+function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
+begin
+  Result := False;
+  RValue.AuthMode := QValue.AuthMode;
+  RValue.Password := QValue.Password;
+  RValue.PrivMode := QValue.PrivMode;
+  RValue.PrivPassword := QValue.PrivPassword;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  if InternalSendSnmp(QValue) then
+    Result := InternalRecvSnmp(RValue);
+end;
+
+function TSNMPSend.SendRequest: Boolean;
+var
+  sync: TV3Sync;
+begin
+  Result := False;
+  if FQuery.FVersion = 3 then
+  begin
+    sync := GetV3Sync;
+    FQuery.AuthEngineBoots := Sync.EngineBoots;
+    FQuery.AuthEngineTime := Sync.EngineTime;
+    FQuery.AuthEngineTimeStamp := Sync.EngineStamp;
+    FQuery.AuthEngineID := Sync.EngineID;
+  end;
+  Result := InternalSendRequest(FQuery, FReply);
+end;
+
+function TSNMPSend.SendTrap: Boolean;
+begin
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  Result := InternalSendSnmp(FQuery);
+end;
+
+function TSNMPSend.RecvTrap: Boolean;
+begin
+  FSock.Bind(FIPInterface, FTargetPort);
+  Result := InternalRecvSnmp(FReply);
+end;
+
+function TSNMPSend.DoIt: Boolean;
+begin
+  Result := SendRequest;
+end;
+
+function TSNMPSend.GetV3EngineID: AnsiString;
+var
+  DisQuery: TSNMPRec;
+begin
+  Result := '';
+  DisQuery := TSNMPRec.Create;
+  try
+    DisQuery.Version := 3;
+    DisQuery.UserName := '';
+    DisQuery.FlagReportable := True;
+    DisQuery.PDUType := PDUGetRequest;
+    if InternalSendRequest(DisQuery, FReply) then
+      Result := FReply.FAuthEngineID;
+  finally
+    DisQuery.Free;
+  end;
+end;
+
+function TSNMPSend.GetV3Sync: TV3Sync;
+var
+  SyncQuery: TSNMPRec;
+begin
+  Result.EngineID := GetV3EngineID;
+  Result.EngineBoots := FReply.AuthEngineBoots;
+  Result.EngineTime := FReply.AuthEngineTime;
+  Result.EngineStamp := FReply.AuthEngineTimeStamp;
+  if Result.EngineTime = 0 then
+  begin
+    //still not have sync...
+    SyncQuery := TSNMPRec.Create;
+    try
+      SyncQuery.Version := 3;
+      SyncQuery.UserName := FQuery.UserName;
+      SyncQuery.Password := FQuery.Password;
+      SyncQuery.FlagReportable := True;
+      SyncQuery.Flags := FQuery.Flags;
+      SyncQuery.AuthMode := FQuery.AuthMode;
+      SyncQuery.PrivMode := FQuery.PrivMode;
+      SyncQuery.PrivPassword := FQuery.PrivPassword;
+      SyncQuery.PDUType := PDUGetRequest;
+      SyncQuery.AuthEngineID := FReply.FAuthEngineID;
+      if InternalSendRequest(SyncQuery, FReply) then
+      begin
+        Result.EngineBoots := FReply.AuthEngineBoots;
+        Result.EngineTime := FReply.AuthEngineTime;
+        Result.EngineStamp := FReply.AuthEngineTimeStamp;
+      end;
+    finally
+      SyncQuery.Free;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+var
+  SNMPSend: TSNMPSend;
+begin
+  SNMPSend := TSNMPSend.Create;
+  try
+    SNMPSend.Query.Clear;
+    SNMPSend.Query.Community := Community;
+    SNMPSend.Query.PDUType := PDUGetRequest;
+    SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
+    SNMPSend.TargetHost := SNMPHost;
+    Result := SNMPSend.SendRequest;
+    Value := '';
+    if Result then
+      Value := SNMPSend.Reply.MIBGet(OID);
+  finally
+    SNMPSend.Free;
+  end;
+end;
+
+function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean;
+var
+  SNMPSend: TSNMPSend;
+begin
+  SNMPSend := TSNMPSend.Create;
+  try
+    SNMPSend.Query.Clear;
+    SNMPSend.Query.Community := Community;
+    SNMPSend.Query.PDUType := PDUSetRequest;
+    SNMPSend.Query.MIBAdd(OID, Value, ValueType);
+    SNMPSend.TargetHost := SNMPHost;
+    Result := SNMPSend.Sendrequest = True;
+  finally
+    SNMPSend.Free;
+  end;
+end;
+
+function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString;
+  const Community: AnsiString; var Value: AnsiString): Boolean;
+begin
+  SNMPSend.Query.Clear;
+  SNMPSend.Query.ID := SNMPSend.Query.ID + 1;
+  SNMPSend.Query.Community := Community;
+  SNMPSend.Query.PDUType := PDUGetNextRequest;
+  SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
+  Result := SNMPSend.Sendrequest;
+  Value := '';
+  if Result then
+    if SNMPSend.Reply.SNMPMibList.Count > 0 then
+    begin
+      OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
+      Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
+    end;
+end;
+
+function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+var
+  SNMPSend: TSNMPSend;
+begin
+  SNMPSend := TSNMPSend.Create;
+  try
+    SNMPSend.TargetHost := SNMPHost;
+    Result := InternalGetNext(SNMPSend, OID, Community, Value);
+  finally
+    SNMPSend.Free;
+  end;
+end;
+
+function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
+var
+  OID: AnsiString;
+  s: AnsiString;
+  col,row: String;
+  x: integer;
+  SNMPSend: TSNMPSend;
+  RowList: TStringList;
+begin
+  Value.Clear;
+  SNMPSend := TSNMPSend.Create;
+  RowList := TStringList.Create;
+  try
+    SNMPSend.TargetHost := SNMPHost;
+    OID := BaseOID;
+    repeat
+      Result := InternalGetNext(SNMPSend, OID, Community, s);
+      if Pos(BaseOID, OID) <> 1 then
+          break;
+      row := separateright(oid, baseoid + '.');
+      col := fetch(row, '.');
+
+      if IsBinaryString(s) then
+        s := StrToHex(s);
+      x := RowList.indexOf(Row);
+      if x < 0 then
+      begin
+        x := RowList.add(Row);
+        Value.Add('');
+      end;
+      if (Value[x] <> '') then
+        Value[x] := Value[x] + ',';
+      Value[x] := Value[x] + AnsiQuotedStr(s, '"');
+    until not result;
+  finally
+    SNMPSend.Free;
+    RowList.Free;
+  end;
+end;
+
+function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
+var
+  s: AnsiString;
+begin
+  s := BaseOID + '.' + ColID + '.' + RowID;
+  Result := SnmpGet(s, Community, SNMPHost, Value);
+end;
+
+function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
+  Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
+  MIBtype: Integer): Integer;
+var
+  SNMPSend: TSNMPSend;
+begin
+  SNMPSend := TSNMPSend.Create;
+  try
+    SNMPSend.TargetHost := Dest;
+    SNMPSend.TargetPort := cSnmpTrapProtocol;
+    SNMPSend.Query.Community := Community;
+    SNMPSend.Query.Version := SNMP_V1;
+    SNMPSend.Query.PDUType := PDUTrap;
+    SNMPSend.Query.OldTrapHost := Source;
+    SNMPSend.Query.OldTrapEnterprise := Enterprise;
+    SNMPSend.Query.OldTrapGen := Generic;
+    SNMPSend.Query.OldTrapSpec := Specific;
+    SNMPSend.Query.OldTrapTimeTicks := Seconds;
+    SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType);
+    Result := Ord(SNMPSend.SendTrap);
+  finally
+    SNMPSend.Free;
+  end;
+end;
+
+function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
+  var Generic, Specific, Seconds: Integer;
+  const MIBName, MIBValue: TStringList): Integer;
+var
+  SNMPSend: TSNMPSend;
+  i: Integer;
+begin
+  SNMPSend := TSNMPSend.Create;
+  try
+    Result := 0;
+    SNMPSend.TargetPort := cSnmpTrapProtocol;
+    if SNMPSend.RecvTrap then
+    begin
+      Result := 1;
+      Dest := SNMPSend.HostIP;
+      Community := SNMPSend.Reply.Community;
+      Source := SNMPSend.Reply.OldTrapHost;
+      Enterprise := SNMPSend.Reply.OldTrapEnterprise;
+      Generic := SNMPSend.Reply.OldTrapGen;
+      Specific := SNMPSend.Reply.OldTrapSpec;
+      Seconds := SNMPSend.Reply.OldTrapTimeTicks;
+      MIBName.Clear;
+      MIBValue.Clear;
+      for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do
+      begin
+        MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID);
+        MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value);
+      end;
+    end;
+  finally
+    SNMPSend.Free;
+  end;
+end;
+
+
+end.
+
+

sntpsend.pas

@@ -0,0 +1,382 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.000.003 |
+|==============================================================================|
+| Content: SNTP client                                                         |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Patrick Chevalley                                                          |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract( NTP and SNTP client)
+
+Used RFC: RFC-1305, RFC-2030
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+unit sntpsend;
+
+interface
+
+uses
+  SysUtils, synabyte,
+  synsock, blcksock, synautil;
+
+const
+  cNtpProtocol = '123';
+
+type
+
+  {:@abstract(Record containing the NTP packet.)}
+  TNtp = packed record
+    mode: Byte;
+    stratum: Byte;
+    poll: Byte;
+    Precision: Byte;
+    RootDelay: Longint;
+    RootDisperson: Longint;
+    RefID: Longint;
+    Ref1: Longint;
+    Ref2: Longint;
+    Org1: Longint;
+    Org2: Longint;
+    Rcv1: Longint;
+    Rcv2: Longint;
+    Xmit1: Longint;
+    Xmit2: Longint;
+  end;
+
+  {:@abstract(Implementation of NTP and SNTP client protocol),
+   include time synchronisation. It can send NTP or SNTP time queries, or it
+   can receive NTP broadcasts too.
+   
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TSNTPSend = class(TSynaClient)
+  private
+    FNTPReply: TNtp;
+    FNTPTime: TDateTime;
+    FNTPOffset: double;
+    FNTPDelay: double;
+    FMaxSyncDiff: double;
+    FSyncTime: Boolean;
+    FSock: TUDPBlockSocket;
+    FBuffer: TSynaBytes;
+    FLi, FVn, Fmode : byte;
+    function StrToNTP(const Value: TSynaBytes): TNtp;
+    function NTPtoStr(const Value: Tntp): TSynaBytes;
+    procedure ClearNTP(var Value: Tntp);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
+    function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
+
+    {:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
+    procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
+
+    {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
+     is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
+     valid.}
+    function GetSNTP: Boolean;
+
+    {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
+     is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
+     valid. Result time is after all needed corrections.}
+    function GetNTP: Boolean;
+
+    {:Wait for broadcast NTP packet. If all OK, result is @true and
+     @link(NTPReply) and @link(NTPTime) are valid.}
+    function GetBroadcastNTP: Boolean;
+
+    {:Holds last received NTP packet.}
+    property NTPReply: TNtp read FNTPReply;
+  published
+    {:Date and time of remote NTP or SNTP server. (UTC time!!!)}
+    property NTPTime: TDateTime read FNTPTime;
+
+    {:Offset between your computer and remote NTP or SNTP server.}
+    property NTPOffset: Double read FNTPOffset;
+
+    {:Delay between your computer and remote NTP or SNTP server.}
+    property NTPDelay: Double read FNTPDelay;
+
+    {:Define allowed maximum difference between your time and remote time for
+     synchronising time. If difference is bigger, your system time is not
+     changed!}
+    property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
+
+    {:If @true, after successfull getting time is local computer clock
+     synchronised to given time.
+     For synchronising time you must have proper rights! (Usually Administrator)}
+    property SyncTime: Boolean read FSyncTime write FSyncTime;
+
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TUDPBlockSocket read FSock;
+  end;
+
+implementation
+
+constructor TSNTPSend.Create;
+begin
+  inherited Create;
+  FSock := TUDPBlockSocket.Create;
+  FSock.Owner := self;
+  FTimeout := 5000;
+  FTargetPort := cNtpProtocol;
+  FMaxSyncDiff := 3600;
+  FSyncTime := False;
+end;
+
+destructor TSNTPSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TSNTPSend.StrToNTP(const Value: TSynaBytes): TNtp;
+begin
+  if length(FBuffer) >= SizeOf(Result) then
+  begin
+    Result.mode := ord(Value[1]);
+    Result.stratum := ord(Value[2]);
+    Result.poll := ord(Value[3]);
+    Result.Precision := ord(Value[4]);
+    Result.RootDelay := DecodeLongInt(value, 5);
+    Result.RootDisperson := DecodeLongInt(value, 9);
+    Result.RefID := DecodeLongInt(value, 13);
+    Result.Ref1 := DecodeLongInt(value, 17);
+    Result.Ref2 := DecodeLongInt(value, 21);
+    Result.Org1 := DecodeLongInt(value, 25);
+    Result.Org2 := DecodeLongInt(value, 29);
+    Result.Rcv1 := DecodeLongInt(value, 33);
+    Result.Rcv2 := DecodeLongInt(value, 37);
+    Result.Xmit1 := DecodeLongInt(value, 41);
+    Result.Xmit2 := DecodeLongInt(value, 45);
+  end;
+
+end;
+
+function TSNTPSend.NTPtoStr(const Value: Tntp): TSynaBytes;
+begin
+{$IFDEF UNICODE}
+  Result.Length := 4;
+  Result.Bytes[0] := TSynaByte(Value.mode);
+  Result.Bytes[1] := TSynaByte(Value.stratum);
+  Result.Bytes[2] := TSynaByte(Value.poll);
+  Result.Bytes[3] := TSynaByte(Value.precision);
+{$ELSE}
+  SetLength(Result, 4);
+  Result[1] := TSynaByte(Value.mode);
+  Result[2] := TSynaByte(Value.stratum);
+  Result[3] := TSynaByte(Value.poll);
+  Result[4] := TSynaByte(Value.precision);
+{$ENDIF}
+  Result := Result + CodeLongInt(Value.RootDelay);
+  Result := Result + CodeLongInt(Value.RootDisperson);
+  Result := Result + CodeLongInt(Value.RefID);
+  Result := Result + CodeLongInt(Value.Ref1);
+  Result := Result + CodeLongInt(Value.Ref2);
+  Result := Result + CodeLongInt(Value.Org1);
+  Result := Result + CodeLongInt(Value.Org2);
+  Result := Result + CodeLongInt(Value.Rcv1);
+  Result := Result + CodeLongInt(Value.Rcv2);
+  Result := Result + CodeLongInt(Value.Xmit1);
+  Result := Result + CodeLongInt(Value.Xmit2);
+end;
+
+procedure TSNTPSend.ClearNTP(var Value: Tntp);
+begin
+  Value.mode := 0;
+  Value.stratum := 0;
+  Value.poll := 0;
+  Value.Precision := 0;
+  Value.RootDelay := 0;
+  Value.RootDisperson := 0;
+  Value.RefID := 0;
+  Value.Ref1 := 0;
+  Value.Ref2 := 0;
+  Value.Org1 := 0;
+  Value.Org2 := 0;
+  Value.Rcv1 := 0;
+  Value.Rcv2 := 0;
+  Value.Xmit1 := 0;
+  Value.Xmit2 := 0;
+end;
+
+function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
+const
+  maxi = 4294967295.0;
+var
+  d, d1: Double;
+begin
+  d := Nsec;
+  if d < 0 then
+    d := maxi + d + 1;
+  d1 := Nfrac;
+  if d1 < 0 then
+    d1 := maxi + d1 + 1;
+  d1 := d1 / maxi;
+  d1 := Trunc(d1 * 10000) / 10000;
+  Result := (d + d1) / 86400;
+  Result := Result + 2;
+end;
+
+procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
+const
+  maxi = 4294967295.0;
+  maxilongint = 2147483647;
+var
+  d, d1: Double;
+begin
+  d  := (dt - 2) * 86400;
+  d1 := frac(d);
+  if d > maxilongint then
+     d := d - maxi - 1;
+  d  := trunc(d);
+  d1 := Trunc(d1 * 10000) / 10000;
+  d1 := d1 * maxi;
+  if d1 > maxilongint then
+     d1 := d1 - maxi - 1;
+  Nsec:=trunc(d);
+  Nfrac:=trunc(d1);
+end;
+
+function TSNTPSend.GetBroadcastNTP: Boolean;
+var
+  x: Integer;
+begin
+  Result := False;
+  FSock.Bind(FIPInterface, FTargetPort);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
+      if x >= SizeOf(NTPReply) then
+      begin
+        FNTPReply := StrToNTP(FBuffer);
+        FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+        if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
+          SetUTTime(FNTPTime);
+        Result := True;
+      end;
+  end;
+end;
+
+function TSNTPSend.GetSNTP: Boolean;
+var
+  q: TNtp;
+  x: Integer;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  ClearNtp(q);
+  q.mode := $1B;
+  FBuffer := NTPtoStr(q);
+  FSock.SendString(FBuffer);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    if x >= SizeOf(NTPReply) then
+    begin
+      FNTPReply := StrToNTP(FBuffer);
+      FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+      if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
+        SetUTTime(FNTPTime);
+      Result := True;
+    end;
+  end;
+end;
+
+function TSNTPSend.GetNTP: Boolean;
+var
+  q: TNtp;
+  x: Integer;
+  t1, t2, t3, t4 : TDateTime;
+begin
+  Result := False;
+  FSock.CloseSocket;
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  ClearNtp(q);
+  q.mode := $1B;
+  t1 := GetUTTime;
+  EncodeTs(t1, q.org1, q.org2);
+  FBuffer := NTPtoStr(q);
+  FSock.SendString(FBuffer);
+  FBuffer := FSock.RecvPacket(FTimeout);
+  if FSock.LastError = 0 then
+  begin
+    x := Length(FBuffer);
+    t4 := GetUTTime;
+    if x >= SizeOf(NTPReply) then
+    begin
+      FNTPReply := StrToNTP(FBuffer);
+      FLi := (NTPReply.mode and $C0) shr 6;
+      FVn := (NTPReply.mode and $38) shr 3;
+      Fmode := NTPReply.mode and $07;
+      if (Fli < 3) and (Fmode = 4) and
+         (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
+         (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
+         then begin
+           t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
+           t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
+           FNTPDelay := (T4 - T1) - (T2 - T3);
+           FNTPTime := t3 + FNTPDelay / 2;
+           FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
+           FNTPDelay := FNTPDelay * 86400;
+           if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
+             SetUTTime(FNTPTime);
+           Result := True;
+           end
+         else result:=false;
+    end;
+  end;
+end;
+
+end.

ssdotnet.inc

@@ -0,0 +1,1099 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.002 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - .NET definition include         |
+|==============================================================================|
+| Copyright (c)2004, Lukas Gebauer                                             |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2004.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF CIL}
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+  System.Net,
+  System.Net.Sockets;
+
+const
+  DLLStackName = '';
+  WinsockLevel = $0202;
+
+function InitSocketInterface(stack: string): Boolean;
+function DestroySocketInterface: Boolean;
+
+type
+  u_char = Char;
+  u_short = Word;
+  u_int = Integer;
+  u_long = Longint;
+  pu_long = ^u_long;
+  pu_short = ^u_short;
+  PSockAddr = IPEndPoint;
+  DWORD = integer;
+  ULong = cardinal;
+  TMemory = Array of byte;
+  TLinger = LingerOption;
+  TSocket = socket;
+  TAddrFamily = AddressFamily;
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = packed record
+    wVersion: Word;
+    wHighVersion: Word;
+    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+//    lpVendorInfo: PChar;
+  end;
+
+const
+  MSG_NOSIGNAL = 0;
+  INVALID_SOCKET = nil;
+  AF_UNSPEC = AddressFamily.Unspecified;
+  AF_INET = AddressFamily.InterNetwork;
+  AF_INET6 = AddressFamily.InterNetworkV6;
+  SOCKET_ERROR = integer(-1);
+
+  FIONREAD     = integer($4004667f);
+  FIONBIO      = integer($8004667e);
+  FIOASYNC     = integer($8004667d);
+
+  SOMAXCONN       = integer($7fffffff);
+
+  IPPROTO_IP = ProtocolType.IP;
+  IPPROTO_ICMP = ProtocolType.Icmp;
+  IPPROTO_IGMP = ProtocolType.Igmp;
+  IPPROTO_TCP = ProtocolType.Tcp;
+  IPPROTO_UDP = ProtocolType.Udp;
+  IPPROTO_RAW = ProtocolType.Raw;
+  IPPROTO_IPV6 = ProtocolType.IPV6;
+//
+  IPPROTO_ICMPV6 = ProtocolType.Icmp; //??
+
+  SOCK_STREAM     = SocketType.Stream;
+  SOCK_DGRAM      = SocketType.Dgram;
+  SOCK_RAW        = SocketType.Raw;
+  SOCK_RDM        = SocketType.Rdm;
+  SOCK_SEQPACKET  = SocketType.Seqpacket;
+
+  SOL_SOCKET = SocketOptionLevel.Socket;
+  SOL_IP = SocketOptionLevel.Ip;
+
+
+  IP_OPTIONS          = SocketOptionName.IPOptions;
+  IP_HDRINCL          = SocketOptionName.HeaderIncluded;
+  IP_TOS              = SocketOptionName.TypeOfService;           { set/get IP Type Of Service       }
+  IP_TTL              = SocketOptionName.IpTimeToLive;           { set/get IP Time To Live          }
+  IP_MULTICAST_IF     = SocketOptionName.MulticastInterface;           { set/get IP multicast interface   }
+  IP_MULTICAST_TTL    = SocketOptionName.MulticastTimeToLive;           { set/get IP multicast timetolive  }
+  IP_MULTICAST_LOOP   = SocketOptionName.MulticastLoopback;           { set/get IP multicast loopback    }
+  IP_ADD_MEMBERSHIP   = SocketOptionName.AddMembership;           { add  an IP group membership      }
+  IP_DROP_MEMBERSHIP  = SocketOptionName.DropMembership;           { drop an IP group membership      }
+  IP_DONTFRAGMENT     = SocketOptionName.DontFragment;           { set/get IP Don't Fragment flag   }
+
+  IPV6_UNICAST_HOPS      = 8;  // TTL
+  IPV6_MULTICAST_IF      = 9;  // set/get IP multicast i/f
+  IPV6_MULTICAST_HOPS    = 10; // set/get IP multicast ttl
+  IPV6_MULTICAST_LOOP    = 11; // set/get IP multicast loopback
+  IPV6_JOIN_GROUP        = 12; // add an IP group membership
+  IPV6_LEAVE_GROUP       = 13; // drop an IP group membership
+
+  SO_DEBUG        = SocketOptionName.Debug;          { turn on debugging info recording }
+  SO_ACCEPTCONN   = SocketOptionName.AcceptConnection;          { socket has had listen() }
+  SO_REUSEADDR    = SocketOptionName.ReuseAddress;          { allow local address reuse }
+  SO_KEEPALIVE    = SocketOptionName.KeepAlive;          { keep connections alive }
+  SO_DONTROUTE    = SocketOptionName.DontRoute;          { just use interface addresses }
+  SO_BROADCAST    = SocketOptionName.Broadcast;          { permit sending of broadcast msgs }
+  SO_USELOOPBACK  = SocketOptionName.UseLoopback;          { bypass hardware when possible }
+  SO_LINGER       = SocketOptionName.Linger;          { linger on close if data present }
+  SO_OOBINLINE    = SocketOptionName.OutOfBandInline;          { leave received OOB data in line }
+  SO_DONTLINGER   = SocketOptionName.DontLinger;
+{ Additional options. }
+  SO_SNDBUF       = SocketOptionName.SendBuffer;          { send buffer size }
+  SO_RCVBUF       = SocketOptionName.ReceiveBuffer;          { receive buffer size }
+  SO_SNDLOWAT     = SocketOptionName.SendLowWater;          { send low-water mark }
+  SO_RCVLOWAT     = SocketOptionName.ReceiveLowWater;          { receive low-water mark }
+  SO_SNDTIMEO     = SocketOptionName.SendTimeout;          { send timeout }
+  SO_RCVTIMEO     = SocketOptionName.ReceiveTimeout;          { receive timeout }
+  SO_ERROR        = SocketOptionName.Error;          { get error status and clear }
+  SO_TYPE         = SocketOptionName.Type;          { get socket type }
+
+{ WinSock 2 extension -- new options }
+//  SO_GROUP_ID       = $2001; { ID of a socket group}
+//  SO_GROUP_PRIORITY = $2002; { the relative priority within a group}
+//  SO_MAX_MSG_SIZE   = $2003; { maximum message size }
+//  SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure }
+//  SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure }
+//  SO_PROTOCOL_INFO  = SO_PROTOCOL_INFOA;
+//  PVD_CONFIG        = $3001; {configuration info for service provider }
+{ Option for opening sockets for synchronous access. }
+//  SO_OPENTYPE     = $7008;
+//  SO_SYNCHRONOUS_ALERT    = $10;
+//  SO_SYNCHRONOUS_NONALERT = $20;
+{ Other NT-specific options. }
+//  SO_MAXDG        = $7009;
+//  SO_MAXPATHDG    = $700A;
+//  SO_UPDATE_ACCEPT_CONTEXT     = $700B;
+//  SO_CONNECT_TIME = $700C;
+
+
+  { All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
+  WSABASEERR              = 10000;
+
+{ Windows Sockets definitions of regular Microsoft C error constants }
+
+  WSAEINTR                = (WSABASEERR+4);
+  WSAEBADF                = (WSABASEERR+9);
+  WSAEACCES               = (WSABASEERR+13);
+  WSAEFAULT               = (WSABASEERR+14);
+  WSAEINVAL               = (WSABASEERR+22);
+  WSAEMFILE               = (WSABASEERR+24);
+
+{ Windows Sockets definitions of regular Berkeley error constants }
+
+  WSAEWOULDBLOCK          = (WSABASEERR+35);
+  WSAEINPROGRESS          = (WSABASEERR+36);
+  WSAEALREADY             = (WSABASEERR+37);
+  WSAENOTSOCK             = (WSABASEERR+38);
+  WSAEDESTADDRREQ         = (WSABASEERR+39);
+  WSAEMSGSIZE             = (WSABASEERR+40);
+  WSAEPROTOTYPE           = (WSABASEERR+41);
+  WSAENOPROTOOPT          = (WSABASEERR+42);
+  WSAEPROTONOSUPPORT      = (WSABASEERR+43);
+  WSAESOCKTNOSUPPORT      = (WSABASEERR+44);
+  WSAEOPNOTSUPP           = (WSABASEERR+45);
+  WSAEPFNOSUPPORT         = (WSABASEERR+46);
+  WSAEAFNOSUPPORT         = (WSABASEERR+47);
+  WSAEADDRINUSE           = (WSABASEERR+48);
+  WSAEADDRNOTAVAIL        = (WSABASEERR+49);
+  WSAENETDOWN             = (WSABASEERR+50);
+  WSAENETUNREACH          = (WSABASEERR+51);
+  WSAENETRESET            = (WSABASEERR+52);
+  WSAECONNABORTED         = (WSABASEERR+53);
+  WSAECONNRESET           = (WSABASEERR+54);
+  WSAENOBUFS              = (WSABASEERR+55);
+  WSAEISCONN              = (WSABASEERR+56);
+  WSAENOTCONN             = (WSABASEERR+57);
+  WSAESHUTDOWN            = (WSABASEERR+58);
+  WSAETOOMANYREFS         = (WSABASEERR+59);
+  WSAETIMEDOUT            = (WSABASEERR+60);
+  WSAECONNREFUSED         = (WSABASEERR+61);
+  WSAELOOP                = (WSABASEERR+62);
+  WSAENAMETOOLONG         = (WSABASEERR+63);
+  WSAEHOSTDOWN            = (WSABASEERR+64);
+  WSAEHOSTUNREACH         = (WSABASEERR+65);
+  WSAENOTEMPTY            = (WSABASEERR+66);
+  WSAEPROCLIM             = (WSABASEERR+67);
+  WSAEUSERS               = (WSABASEERR+68);
+  WSAEDQUOT               = (WSABASEERR+69);
+  WSAESTALE               = (WSABASEERR+70);
+  WSAEREMOTE              = (WSABASEERR+71);
+
+{ Extended Windows Sockets error constant definitions }
+
+  WSASYSNOTREADY          = (WSABASEERR+91);
+  WSAVERNOTSUPPORTED      = (WSABASEERR+92);
+  WSANOTINITIALISED       = (WSABASEERR+93);
+  WSAEDISCON              = (WSABASEERR+101);
+  WSAENOMORE              = (WSABASEERR+102);
+  WSAECANCELLED           = (WSABASEERR+103);
+  WSAEEINVALIDPROCTABLE   = (WSABASEERR+104);
+  WSAEINVALIDPROVIDER     = (WSABASEERR+105);
+  WSAEPROVIDERFAILEDINIT  = (WSABASEERR+106);
+  WSASYSCALLFAILURE       = (WSABASEERR+107);
+  WSASERVICE_NOT_FOUND    = (WSABASEERR+108);
+  WSATYPE_NOT_FOUND       = (WSABASEERR+109);
+  WSA_E_NO_MORE           = (WSABASEERR+110);
+  WSA_E_CANCELLED         = (WSABASEERR+111);
+  WSAEREFUSED             = (WSABASEERR+112);
+
+{ Error return codes from gethostbyname() and gethostbyaddr()
+  (when using the resolver). Note that these errors are
+  retrieved via WSAGetLastError() and must therefore follow
+  the rules for avoiding clashes with error numbers from
+  specific implementations or language run-time systems.
+  For this reason the codes are based at WSABASEERR+1001.
+  Note also that [WSA]NO_ADDRESS is defined only for
+  compatibility purposes. }
+
+{ Authoritative Answer: Host not found }
+  WSAHOST_NOT_FOUND       = (WSABASEERR+1001);
+  HOST_NOT_FOUND          = WSAHOST_NOT_FOUND;
+{ Non-Authoritative: Host not found, or SERVERFAIL }
+  WSATRY_AGAIN            = (WSABASEERR+1002);
+  TRY_AGAIN               = WSATRY_AGAIN;
+{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
+  WSANO_RECOVERY          = (WSABASEERR+1003);
+  NO_RECOVERY             = WSANO_RECOVERY;
+{ Valid name, no data record of requested type }
+  WSANO_DATA              = (WSABASEERR+1004);
+  NO_DATA                 = WSANO_DATA;
+{ no address, look for MX record }
+  WSANO_ADDRESS           = WSANO_DATA;
+  NO_ADDRESS              = WSANO_ADDRESS;
+
+  EWOULDBLOCK        =  WSAEWOULDBLOCK;
+  EINPROGRESS        =  WSAEINPROGRESS;
+  EALREADY           =  WSAEALREADY;
+  ENOTSOCK           =  WSAENOTSOCK;
+  EDESTADDRREQ       =  WSAEDESTADDRREQ;
+  EMSGSIZE           =  WSAEMSGSIZE;
+  EPROTOTYPE         =  WSAEPROTOTYPE;
+  ENOPROTOOPT        =  WSAENOPROTOOPT;
+  EPROTONOSUPPORT    =  WSAEPROTONOSUPPORT;
+  ESOCKTNOSUPPORT    =  WSAESOCKTNOSUPPORT;
+  EOPNOTSUPP         =  WSAEOPNOTSUPP;
+  EPFNOSUPPORT       =  WSAEPFNOSUPPORT;
+  EAFNOSUPPORT       =  WSAEAFNOSUPPORT;
+  EADDRINUSE         =  WSAEADDRINUSE;
+  EADDRNOTAVAIL      =  WSAEADDRNOTAVAIL;
+  ENETDOWN           =  WSAENETDOWN;
+  ENETUNREACH        =  WSAENETUNREACH;
+  ENETRESET          =  WSAENETRESET;
+  ECONNABORTED       =  WSAECONNABORTED;
+  ECONNRESET         =  WSAECONNRESET;
+  ENOBUFS            =  WSAENOBUFS;
+  EISCONN            =  WSAEISCONN;
+  ENOTCONN           =  WSAENOTCONN;
+  ESHUTDOWN          =  WSAESHUTDOWN;
+  ETOOMANYREFS       =  WSAETOOMANYREFS;
+  ETIMEDOUT          =  WSAETIMEDOUT;
+  ECONNREFUSED       =  WSAECONNREFUSED;
+  ELOOP              =  WSAELOOP;
+  ENAMETOOLONG       =  WSAENAMETOOLONG;
+  EHOSTDOWN          =  WSAEHOSTDOWN;
+  EHOSTUNREACH       =  WSAEHOSTUNREACH;
+  ENOTEMPTY          =  WSAENOTEMPTY;
+  EPROCLIM           =  WSAEPROCLIM;
+  EUSERS             =  WSAEUSERS;
+  EDQUOT             =  WSAEDQUOT;
+  ESTALE             =  WSAESTALE;
+  EREMOTE            =  WSAEREMOTE;
+
+
+type
+  TVarSin = IPEndpoint;
+
+{  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+}
+
+{procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+}
+{=============================================================================}
+
+  function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+  function WSACleanup: Integer;
+  function WSAGetLastError: Integer;
+  function WSAGetLastErrorDesc: String;
+  function GetHostName: string;
+  function Shutdown(s: TSocket; how: Integer): Integer;
+//  function SetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
+//    optlen: Integer): Integer;
+  function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    optlen: Integer): Integer;
+  function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer;
+  function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    var optlen: Integer): Integer;
+//  function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
+//    tolen: Integer): Integer;
+///  function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer;
+///  function Send(s: TSocket; const Buf; len, flags: Integer): Integer;
+///  function  Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
+//  function  RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
+//    var fromlen: Integer): Integer;
+///  function  RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer;
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+  function  ntohs(netshort: u_short): u_short;
+  function  ntohl(netlong: u_long): u_long;
+  function  Listen(s: TSocket; backlog: Integer): Integer;
+  function  IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+  function  htons(hostshort: u_short): u_short;
+  function  htonl(hostlong: u_long): u_long;
+//  function  GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+  function  GetSockName(s: TSocket; var name: TVarSin): Integer;
+//  function  GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+  function  GetPeerName(s: TSocket; var name: TVarSin): Integer;
+//  function  Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
+  function  Connect(s: TSocket; const name: TVarSin): Integer;
+  function  CloseSocket(s: TSocket): Integer;
+//  function  Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
+  function  Bind(s: TSocket; const addr: TVarSin): Integer;
+//  function  Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
+  function  Accept(s: TSocket; var addr: TVarSin): TSocket;
+  function  Socket(af, Struc, Protocol: Integer): TSocket;
+//  Select = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+//    timeout: PTimeVal): Longint;
+//    {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};
+
+//  TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
+//    cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
+//    lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
+//    lpCompletionRoutine: pointer): u_int;
+//    stdcall;
+
+  function GetPortService(value: string): integer;
+
+function IsNewApi(Family: TAddrFamily): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): string;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string;
+function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word;
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+{==============================================================================}
+implementation
+
+threadvar
+  WSALastError: integer;
+  WSALastErrorDesc: string;
+
+var
+  services: Array [0..139, 0..1] of string =
+  (
+    ('echo', '7'),
+    ('discard', '9'),
+    ('sink', '9'),
+    ('null', '9'),
+    ('systat', '11'),
+    ('users', '11'),
+    ('daytime', '13'),
+    ('qotd', '17'),
+    ('quote', '17'),
+    ('chargen', '19'),
+    ('ttytst', '19'),
+    ('source', '19'),
+    ('ftp-data', '20'),
+    ('ftp', '21'),
+    ('telnet', '23'),
+    ('smtp', '25'),
+    ('mail', '25'),
+    ('time', '37'),
+    ('timeserver', '37'),
+    ('rlp', '39'),
+    ('nameserver', '42'),
+    ('name', '42'),
+    ('nickname', '43'),
+    ('whois', '43'),
+    ('domain', '53'),
+    ('bootps', '67'),
+    ('dhcps', '67'),
+    ('bootpc', '68'),
+    ('dhcpc', '68'),
+    ('tftp', '69'),
+    ('gopher', '70'),
+    ('finger', '79'),
+    ('http', '80'),
+    ('www', '80'),
+    ('www-http', '80'),
+    ('kerberos', '88'),
+    ('hostname', '101'),
+    ('hostnames', '101'),
+    ('iso-tsap', '102'),
+    ('rtelnet', '107'),
+    ('pop2', '109'),
+    ('postoffice', '109'),
+    ('pop3', '110'),
+    ('sunrpc', '111'),
+    ('rpcbind', '111'),
+    ('portmap', '111'),
+    ('auth', '113'),
+    ('ident', '113'),
+    ('tap', '113'),
+    ('uucp-path', '117'),
+    ('nntp', '119'),
+    ('usenet', '119'),
+    ('ntp', '123'),
+    ('epmap', '135'),
+    ('loc-srv', '135'),
+    ('netbios-ns', '137'),
+    ('nbname', '137'),
+    ('netbios-dgm', '138'),
+    ('nbdatagram', '138'),
+    ('netbios-ssn', '139'),
+    ('nbsession', '139'),
+    ('imap', '143'),
+    ('imap4', '143'),
+    ('pcmail-srv', '158'),
+    ('snmp', '161'),
+    ('snmptrap', '162'),
+    ('snmp-trap', '162'),
+    ('print-srv', '170'),
+    ('bgp', '179'),
+    ('irc', '194'),
+    ('ipx', '213'),
+    ('ldap', '389'),
+    ('https', '443'),
+    ('mcom', '443'),
+    ('microsoft-ds', '445'),
+    ('kpasswd', '464'),
+    ('isakmp', '500'),
+    ('ike', '500'),
+    ('exec', '512'),
+    ('biff', '512'),
+    ('comsat', '512'),
+    ('login', '513'),
+    ('who', '513'),
+    ('whod', '513'),
+    ('cmd', '514'),
+    ('shell', '514'),
+    ('syslog', '514'),
+    ('printer', '515'),
+    ('spooler', '515'),
+    ('talk', '517'),
+    ('ntalk', '517'),
+    ('efs', '520'),
+    ('router', '520'),
+    ('route', '520'),
+    ('routed', '520'),
+    ('timed', '525'),
+    ('timeserver', '525'),
+    ('tempo', '526'),
+    ('newdate', '526'),
+    ('courier', '530'),
+    ('rpc', '530'),
+    ('conference', '531'),
+    ('chat', '531'),
+    ('netnews', '532'),
+    ('readnews', '532'),
+    ('netwall', '533'),
+    ('uucp', '540'),
+    ('uucpd', '540'),
+    ('klogin', '543'),
+    ('kshell', '544'),
+    ('krcmd', '544'),
+    ('new-rwho', '550'),
+    ('new-who', '550'),
+    ('remotefs', '556'),
+    ('rfs', '556'),
+    ('rfs_server', '556'),
+    ('rmonitor', '560'),
+    ('rmonitord', '560'),
+    ('monitor', '561'),
+    ('ldaps', '636'),
+    ('sldap', '636'),
+    ('doom', '666'),
+    ('kerberos-adm', '749'),
+    ('kerberos-iv', '750'),
+    ('kpop', '1109'),
+    ('phone', '1167'),
+    ('ms-sql-s', '1433'),
+    ('ms-sql-m', '1434'),
+    ('wins', '1512'),
+    ('ingreslock', '1524'),
+    ('ingres', '1524'),
+    ('l2tp', '1701'),
+    ('pptp', '1723'),
+    ('radius', '1812'),
+    ('radacct', '1813'),
+    ('nfsd', '2049'),
+    ('nfs', '2049'),
+    ('knetd', '2053'),
+    ('gds_db', '3050'),
+    ('man', '9535')
+    );
+
+{function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
+             (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
+             (a^.s_un_dw.s_dw3 = 0) and
+             (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and
+             (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1)));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80)));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0)));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.s_un_b.s_b1 = char($FF));
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.s_un_b.s_b16 := char(1);
+end;
+}
+
+{=============================================================================}
+
+procedure NullErr;
+begin
+  WSALastError := 0;
+  WSALastErrorDesc := '';
+end;
+
+procedure GetErrCode(E: System.Exception);
+var
+  SE: System.Net.Sockets.SocketException;
+begin
+  if E is System.Net.Sockets.SocketException then
+  begin
+    SE := E as System.Net.Sockets.SocketException;
+    WSALastError := SE.ErrorCode;
+    WSALastErrorDesc := SE.Message;
+  end
+end;
+
+function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+begin
+  NullErr;
+  with WSData do
+  begin
+    wVersion := wVersionRequired;
+    wHighVersion := $202;
+    szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
+    szSystemStatus := 'Running on .NET';
+    iMaxSockets := 32768;
+    iMaxUdpDg := 8192;
+  end;
+  Result := 0;
+end;
+
+function WSACleanup: Integer;
+begin
+  NullErr;
+  Result := 0;
+end;
+
+function WSAGetLastError: Integer;
+begin
+  Result := WSALastError;
+end;
+
+function WSAGetLastErrorDesc: String;
+begin
+  Result := WSALastErrorDesc;
+end;
+
+function GetHostName: string;
+begin
+  Result := System.Net.DNS.GetHostName;
+end;
+
+function Shutdown(s: TSocket; how: Integer): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.ShutDown(SocketShutdown(how));
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  optlen: Integer): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function SetSockOptObj(s: TSocket; level, optname: Integer; optval: TObject): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.SetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  var optlen: Integer): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.GetSocketOption(SocketOptionLevel(level), SocketOptionName(optname), optval);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+//function SendTo(s: TSocket; const Buf; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+  NullErr;
+  try
+    result := s.SendTo(Buf, len, SocketFlags(flags), addrto);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+//function Send(s: TSocket; const Buf; len, flags: Integer): Integer;
+begin
+  NullErr;
+  try
+    result := s.Send(Buf, len, SocketFlags(flags));
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+//function  Recv(s: TSocket; var Buf; len, flags: Integer): Integer;
+begin
+  NullErr;
+  try
+    result := s.Receive(Buf, len, SocketFlags(flags));
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+//function  RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
+//  var fromlen: Integer): Integer;
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+//function  RecvFrom(s: TSocket; var Buf; len, flags: Integer; from: TVarSin): Integer;
+var
+  EP: EndPoint;
+begin
+  NullErr;
+  try
+    EP := from;
+    result := s.ReceiveFrom(Buf, len, SocketFlags(flags), EndPoint(EP));
+    from := EP as IPEndPoint;
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function  ntohs(netshort: u_short): u_short;
+begin
+  Result := IPAddress.NetworkToHostOrder(NetShort);
+end;
+
+function  ntohl(netlong: u_long): u_long;
+begin
+  Result := IPAddress.NetworkToHostOrder(NetLong);
+end;
+
+function  Listen(s: TSocket; backlog: Integer): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.Listen(backlog);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function  IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+var
+  inv, outv: TMemory;
+begin
+  Result := 0;
+  NullErr;
+  try
+    if cmd = DWORD(FIONBIO) then
+      s.Blocking := arg = 0
+    else
+    begin
+      inv := BitConverter.GetBytes(arg);
+      outv := BitConverter.GetBytes(integer(0));
+      s.IOControl(cmd, inv, outv);
+      arg := BitConverter.ToInt32(outv, 0);
+    end;
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function  htons(hostshort: u_short): u_short;
+begin
+  Result := IPAddress.HostToNetworkOrder(Hostshort);
+end;
+
+function  htonl(hostlong: u_long): u_long;
+begin
+  Result := IPAddress.HostToNetworkOrder(HostLong);
+end;
+
+//function  GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+function  GetSockName(s: TSocket; var name: TVarSin): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    Name := s.localEndPoint as IPEndpoint;
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+//function  GetPeerName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+function  GetPeerName(s: TSocket; var name: TVarSin): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    Name := s.RemoteEndPoint as IPEndpoint;
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+//function  Connect(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.Connect(name);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+function CloseSocket(s: TSocket): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.Close;
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+//function  Bind(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+  Result := 0;
+  NullErr;
+  try
+    s.Bind(addr);
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := integer(SOCKET_ERROR);
+    end;
+  end;
+end;
+
+//function  Accept(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+begin
+  NullErr;
+  try
+    result := s.Accept();
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := nil;
+    end;
+  end;
+end;
+
+function Socket(af, Struc, Protocol: Integer): TSocket;
+begin
+  NullErr;
+  try
+    result := TSocket.Create(AddressFamily(af), SocketType(Struc), ProtocolType(Protocol));
+  except
+    on e: System.Net.Sockets.SocketException do
+    begin
+      GetErrCode(e);
+      Result := nil;
+    end;
+  end;
+end;
+
+{=============================================================================}
+function GetPortService(value: string): integer;
+var
+  n: integer;
+begin
+  Result := 0;
+  value := Lowercase(value);
+  for n := 0 to High(Services) do
+    if services[n, 0] = value then
+    begin
+      Result := strtointdef(services[n, 1], 0);
+      break;
+    end;
+  if Result = 0 then
+    Result := StrToIntDef(value, 0);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: TAddrFamily): Boolean;
+begin
+  Result := true;
+end;
+
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+var
+  IPs: array of IPAddress;
+  n: integer;
+  ip4, ip6: string;
+  sip: string;
+begin
+  sip := '';
+  ip4 := '';
+  ip6 := '';
+  IPs := Dns.Resolve(IP).AddressList;
+  for n :=low(IPs) to high(IPs) do begin
+    if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then
+      ip4 := IPs[n].toString;
+    if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then
+      ip6 := IPs[n].toString;
+    if (ip4 <> '') and (ip6 <> '') then
+      break;
+  end;
+  case Family of
+    AF_UNSPEC:
+      begin
+        if (ip4 <> '') and (ip6 <> '') then
+        begin
+          if PreferIP4 then
+            sip := ip4
+          else
+            Sip := ip6;
+          end
+        else
+        begin
+          sip := ip4;
+          if (ip6 <> '') then
+            sip := ip6;
+        end;
+      end;
+    AF_INET:
+      sip := ip4;
+    AF_INET6:
+      sip := ip6;
+  end;
+  sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port));
+end;
+
+function GetSinIP(Sin: TVarSin): string;
+begin
+  Result := Sin.Address.ToString;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  Result := Sin.Port;
+end;
+
+procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings);
+var
+  IPs :array of IPAddress;
+  n: integer;
+begin
+  IPList.Clear;
+  IPs := Dns.Resolve(Name).AddressList;
+  for n := low(IPs) to high(IPs) do
+  begin
+    if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET))
+      or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then
+    begin
+      IPList.Add(IPs[n].toString);
+    end;
+  end;
+end;
+
+function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word;
+var
+  n: integer;
+begin
+  Result := StrToIntDef(port, 0);
+  if Result = 0 then
+  begin
+    port := Lowercase(port);
+    for n := 0 to High(Services) do
+      if services[n, 0] = port then
+      begin
+        Result := strtointdef(services[n, 1], 0);
+        break;
+      end;
+  end;
+end;
+
+function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string;
+begin
+  Result := Dns.GetHostByAddress(IP).HostName;
+end;
+
+
+{=============================================================================}
+function InitSocketInterface(stack: string): Boolean;
+begin
+  Result := True;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  NullErr;
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+//  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+//  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  NullErr;
+  SynSockCS.Free;
+end;
+
+{$ENDIF}

ssfpc.inc

@@ -0,0 +1,926 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.005 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - FreePascal definition include   |
+|==============================================================================|
+| Copyright (c)2006-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2006-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF FPC}
+{For FreePascal 2.x.x}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$ifdef FreeBSD}
+{$DEFINE SOCK_HAS_SINLEN}               // BSD definition of scoketaddr
+{$endif}
+{$ifdef darwin}
+{$DEFINE SOCK_HAS_SINLEN}               // BSD definition of scoketaddr
+{$endif}
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+  synafpc, BaseUnix, Unix, termio, sockets, netdb;
+
+function InitSocketInterface(stack: string): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+  DLLStackName = '';
+  WinsockLevel = $0202;
+
+  cLocalHost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  c6AnyHost = '::0';
+  c6Localhost = '::1';
+  cLocalHostStr = 'localhost';
+
+type
+  TSocket = longint;
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+
+type
+  TFDSet = Baseunix.TFDSet;
+  PFDSet = ^TFDSet;
+  Ptimeval = Baseunix.ptimeval;
+  Ttimeval = Baseunix.ttimeval;
+
+const
+  FIONREAD        = termio.FIONREAD;
+  FIONBIO         = termio.FIONBIO;
+  FIOASYNC        = termio.FIOASYNC;
+
+const
+  IPPROTO_IP     =   0;		{ Dummy					}
+  IPPROTO_ICMP   =   1;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   2;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   6;		{ TCP           			}
+  IPPROTO_UDP    =   17;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   41;
+  IPPROTO_ICMPV6 =   58;
+  IPPROTO_RM     =  113;
+
+  IPPROTO_RAW    =   255;
+  IPPROTO_MAX    =   256;
+
+type
+  PInAddr = ^TInAddr;
+  TInAddr = sockets.in_addr;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = sockets.TInetSockAddr;
+
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     // IP multicast address of group
+    imr_interface: TInAddr;     // local IP address of interface
+  end;
+
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = sockets.Tin6_addr;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = sockets.TInetSockAddr6;
+
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  IP_TOS             = sockets.IP_TOS;             { int; IP type of service and precedence.  }
+  IP_TTL             = sockets.IP_TTL;             { int; IP time to live.  }
+  IP_HDRINCL         = sockets.IP_HDRINCL;         { int; Header is included with data.  }
+  IP_OPTIONS         = sockets.IP_OPTIONS;         { ip_opts; IP per-packet options.  }
+//  IP_ROUTER_ALERT    = sockets.IP_ROUTER_ALERT;    { bool }
+  IP_RECVOPTS        = sockets.IP_RECVOPTS;        { bool }
+  IP_RETOPTS         = sockets.IP_RETOPTS;         { bool }
+//  IP_PKTINFO         = sockets.IP_PKTINFO;         { bool }
+//  IP_PKTOPTIONS      = sockets.IP_PKTOPTIONS;
+//  IP_PMTUDISC        = sockets.IP_PMTUDISC;        { obsolete name? }
+//  IP_MTU_DISCOVER    = sockets.IP_MTU_DISCOVER;    { int; see below }
+//  IP_RECVERR         = sockets.IP_RECVERR;         { bool }
+//  IP_RECVTTL         = sockets.IP_RECVTTL;         { bool }
+//  IP_RECVTOS         = sockets.IP_RECVTOS;         { bool }
+  IP_MULTICAST_IF    = sockets.IP_MULTICAST_IF;    { in_addr; set/get IP multicast i/f }
+  IP_MULTICAST_TTL   = sockets.IP_MULTICAST_TTL;   { u_char; set/get IP multicast ttl }
+  IP_MULTICAST_LOOP  = sockets.IP_MULTICAST_LOOP;  { i_char; set/get IP multicast loopback }
+  IP_ADD_MEMBERSHIP  = sockets.IP_ADD_MEMBERSHIP;  { ip_mreq; add an IP group membership }
+  IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership }
+
+  SOL_SOCKET    = sockets.SOL_SOCKET;
+
+  SO_DEBUG      = sockets.SO_DEBUG;
+  SO_REUSEADDR  = sockets.SO_REUSEADDR;
+  SO_TYPE       = sockets.SO_TYPE;
+  SO_ERROR      = sockets.SO_ERROR;
+  SO_DONTROUTE  = sockets.SO_DONTROUTE;
+  SO_BROADCAST  = sockets.SO_BROADCAST;
+  SO_SNDBUF     = sockets.SO_SNDBUF;
+  SO_RCVBUF     = sockets.SO_RCVBUF;
+  SO_KEEPALIVE  = sockets.SO_KEEPALIVE;
+  SO_OOBINLINE  = sockets.SO_OOBINLINE;
+//  SO_NO_CHECK   = sockets.SO_NO_CHECK;
+//  SO_PRIORITY   = sockets.SO_PRIORITY;
+  SO_LINGER     = sockets.SO_LINGER;
+//  SO_BSDCOMPAT  = sockets.SO_BSDCOMPAT;
+//  SO_REUSEPORT  = sockets.SO_REUSEPORT;
+//  SO_PASSCRED   = sockets.SO_PASSCRED;
+//  SO_PEERCRED   = sockets.SO_PEERCRED;
+  SO_RCVLOWAT   = sockets.SO_RCVLOWAT;
+  SO_SNDLOWAT   = sockets.SO_SNDLOWAT;
+  SO_RCVTIMEO   = sockets.SO_RCVTIMEO;
+  SO_SNDTIMEO   = sockets.SO_SNDTIMEO;
+{ Security levels - as per NRL IPv6 - don't actually do anything }
+//  SO_SECURITY_AUTHENTICATION       = sockets.SO_SECURITY_AUTHENTICATION;
+//  SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT;
+//  SO_SECURITY_ENCRYPTION_NETWORK   = sockets.SO_SECURITY_ENCRYPTION_NETWORK;
+//  SO_BINDTODEVICE                  = sockets.SO_BINDTODEVICE;
+{ Socket filtering }
+//  SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER;
+//  SO_DETACH_FILTER = sockets.SO_DETACH_FILTER;
+
+{$IFDEF DARWIN}
+  SO_NOSIGPIPE = $1022;
+{$ENDIF}
+
+  SOMAXCONN       = 1024;
+
+  IPV6_UNICAST_HOPS     = sockets.IPV6_UNICAST_HOPS;
+  IPV6_MULTICAST_IF     = sockets.IPV6_MULTICAST_IF;
+  IPV6_MULTICAST_HOPS   = sockets.IPV6_MULTICAST_HOPS;
+  IPV6_MULTICAST_LOOP   = sockets.IPV6_MULTICAST_LOOP;
+  IPV6_JOIN_GROUP       = sockets.IPV6_JOIN_GROUP;
+  IPV6_LEAVE_GROUP      = sockets.IPV6_LEAVE_GROUP;
+
+const
+  SOCK_STREAM     = 1;               { stream socket }
+  SOCK_DGRAM      = 2;               { datagram socket }
+  SOCK_RAW        = 3;               { raw-protocol interface }
+  SOCK_RDM        = 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001;
+
+{ Address families. }
+
+  AF_UNSPEC       = 0;               { unspecified }
+  AF_INET         = 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = 10;              { Internetwork Version 6 }
+  AF_MAX          = 24;
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = packed record
+    l_onoff: integer;
+    l_linger: integer;
+  end;
+
+const
+
+  MSG_OOB       = sockets.MSG_OOB;      // Process out-of-band data.
+  MSG_PEEK      = sockets.MSG_PEEK;     // Peek at incoming messages.
+  {$ifdef DARWIN}
+  MSG_NOSIGNAL  = $20000;  // Do not generate SIGPIPE.
+                           // Works under MAC OS X, but is undocumented,
+                           // So FPC doesn't include it
+  {$else}
+   MSG_NOSIGNAL  = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
+  {$endif}
+
+const
+  WSAEINTR = ESysEINTR;
+  WSAEBADF = ESysEBADF;
+  WSAEACCES = ESysEACCES;
+  WSAEFAULT = ESysEFAULT;
+  WSAEINVAL = ESysEINVAL;
+  WSAEMFILE = ESysEMFILE;
+  WSAEWOULDBLOCK = ESysEWOULDBLOCK;
+  WSAEINPROGRESS = ESysEINPROGRESS;
+  WSAEALREADY = ESysEALREADY;
+  WSAENOTSOCK = ESysENOTSOCK;
+  WSAEDESTADDRREQ = ESysEDESTADDRREQ;
+  WSAEMSGSIZE = ESysEMSGSIZE;
+  WSAEPROTOTYPE = ESysEPROTOTYPE;
+  WSAENOPROTOOPT = ESysENOPROTOOPT;
+  WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT;
+  WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT;
+  WSAEOPNOTSUPP = ESysEOPNOTSUPP;
+  WSAEPFNOSUPPORT = ESysEPFNOSUPPORT;
+  WSAEAFNOSUPPORT = ESysEAFNOSUPPORT;
+  WSAEADDRINUSE = ESysEADDRINUSE;
+  WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL;
+  WSAENETDOWN = ESysENETDOWN;
+  WSAENETUNREACH = ESysENETUNREACH;
+  WSAENETRESET = ESysENETRESET;
+  WSAECONNABORTED = ESysECONNABORTED;
+  WSAECONNRESET = ESysECONNRESET;
+  WSAENOBUFS = ESysENOBUFS;
+  WSAEISCONN = ESysEISCONN;
+  WSAENOTCONN = ESysENOTCONN;
+  WSAESHUTDOWN = ESysESHUTDOWN;
+  WSAETOOMANYREFS = ESysETOOMANYREFS;
+  WSAETIMEDOUT = ESysETIMEDOUT;
+  WSAECONNREFUSED = ESysECONNREFUSED;
+  WSAELOOP = ESysELOOP;
+  WSAENAMETOOLONG = ESysENAMETOOLONG;
+  WSAEHOSTDOWN = ESysEHOSTDOWN;
+  WSAEHOSTUNREACH = ESysEHOSTUNREACH;
+  WSAENOTEMPTY = ESysENOTEMPTY;
+  WSAEPROCLIM = -1;
+  WSAEUSERS = ESysEUSERS;
+  WSAEDQUOT = ESysEDQUOT;
+  WSAESTALE = ESysESTALE;
+  WSAEREMOTE = ESysEREMOTE;
+  WSASYSNOTREADY = -2;
+  WSAVERNOTSUPPORTED = -3;
+  WSANOTINITIALISED = -4;
+  WSAEDISCON = -5;
+  WSAHOST_NOT_FOUND = 1;
+  WSATRY_AGAIN = 2;
+  WSANO_RECOVERY = 3;
+  WSANO_DATA = -6;
+  WSABASEERR = 10000;
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = packed record
+    wVersion: Word;
+    wHighVersion: Word;
+    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PChar;
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+  {$ifdef SOCK_HAS_SINLEN}
+     sin_len     : cuchar;
+  {$endif}
+    case integer of
+      0: (AddressFamily: sa_family_t);
+      1: (
+        case sin_family: sa_family_t of
+          AF_INET: (sin_port: word;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of Char);
+          AF_INET6: (sin6_port:     word;
+                		sin6_flowinfo: longword;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: longword);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+  function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+  function WSACleanup: Integer;
+  function WSAGetLastError: Integer;
+  function GetHostName: string;
+  function Shutdown(s: TSocket; how: Integer): Integer;
+  function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    optlen: Integer): Integer;
+  function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    var optlen: Integer): Integer;
+  function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+  function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+  function ntohs(netshort: word): word;
+  function ntohl(netlong: longword): longword;
+  function Listen(s: TSocket; backlog: Integer): Integer;
+  function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+  function htons(hostshort: word): word;
+  function htonl(hostlong: longword): longword;
+  function GetSockName(s: TSocket; var name: TVarSin): Integer;
+  function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+  function Connect(s: TSocket; const name: TVarSin): Integer;
+  function CloseSocket(s: TSocket): Integer;
+  function Bind(s: TSocket; const addr: TVarSin): Integer;
+  function Accept(s: TSocket; var addr: TVarSin): TSocket;
+  function Socket(af, Struc, Protocol: Integer): TSocket;
+  function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): string;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: string;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+
+
+{==============================================================================}
+implementation
+
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.u6_addr8[15] := 1;
+end;
+
+{=============================================================================}
+
+function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+begin
+  with WSData do
+  begin
+    wVersion := wVersionRequired;
+    wHighVersion := $202;
+    szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
+    szSystemStatus := 'Running on Unix/Linux by FreePascal';
+    iMaxSockets := 32768;
+    iMaxUdpDg := 8192;
+  end;
+  Result := 0;
+end;
+
+function WSACleanup: Integer;
+begin
+  Result := 0;
+end;
+
+function WSAGetLastError: Integer;
+begin
+  Result := fpGetErrno; 
+end;
+
+function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
+begin
+  Result := fpFD_ISSET(socket, fdset) <> 0;
+end;
+
+procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
+begin
+  fpFD_SET(Socket, fdset);
+end;
+
+procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
+begin
+  fpFD_CLR(Socket, fdset);
+end;
+
+procedure FD_ZERO(var fdset: TFDSet);
+begin
+  fpFD_ZERO(fdset);
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+  if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+  if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := fpGetSockName(s, @name, @Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := fpGetPeerName(s, @name, @Len);
+end;
+
+function GetHostName: string;
+begin
+  Result := unix.GetHostName;
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := fpSend(s, pointer(Buf), len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := fpRecv(s, pointer(Buf), len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+  Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: integer;
+begin
+  x := SizeOf(from);
+  Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: integer;
+begin
+  x := SizeOf(addr);
+  Result := fpAccept(s, @addr, @x);
+end;
+
+function Shutdown(s: TSocket; how: Integer): Integer;
+begin
+  Result := fpShutdown(s, how);
+end;
+
+function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  optlen: Integer): Integer;
+begin
+  Result := fpsetsockopt(s, level, optname, pointer(optval), optlen);
+end;
+
+function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  var optlen: Integer): Integer;
+begin
+  Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen);
+end;
+
+function  ntohs(netshort: word): word;
+begin
+  Result := sockets.ntohs(NetShort);
+end;
+
+function  ntohl(netlong: longword): longword;
+begin
+  Result := sockets.ntohl(NetLong);
+end;
+
+function  Listen(s: TSocket; backlog: Integer): Integer;
+begin
+  if fpListen(s, backlog) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function  IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+begin
+  Result := fpIoctl(s, cmd, @arg);
+end;
+
+function  htons(hostshort: word): word;
+begin
+  Result := sockets.htons(Hostshort);
+end;
+
+function  htonl(hostlong: longword): longword;
+begin
+  Result := sockets.htonl(HostLong);
+end;
+
+function CloseSocket(s: TSocket): Integer;
+begin
+  Result := sockets.CloseSocket(s);
+end;
+
+function Socket(af, Struc, Protocol: Integer): TSocket;
+{$IFDEF DARWIN}
+var
+  on_off: integer;
+{$ENDIF}
+begin
+  Result := fpSocket(af, struc, protocol);
+// ##### Patch for Mac OS to avoid "Project XXX raised exception class 'External: SIGPIPE'" error.
+{$IFDEF DARWIN}
+  if Result <> INVALID_SOCKET then
+  begin
+    on_off := 1;
+    synsock.SetSockOpt(Result, integer(SOL_SOCKET), integer(SO_NOSIGPIPE), @on_off, SizeOf(integer));
+  end;
+{$ENDIF}
+end;
+
+function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+  timeout: PTimeVal): Longint;
+begin
+  Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+var
+  TwoPass: boolean;
+  f1, f2: integer;
+
+  function GetAddr(f:integer): integer;
+  var
+    a4: array [1..1] of in_addr;
+    a6: array [1..1] of Tin6_addr;
+    he: THostEntry;
+  begin
+    Result := WSAEPROTONOSUPPORT;
+    case f of
+      AF_INET:
+        begin
+          if IP = cAnyHost then
+          begin
+            Sin.sin_family := AF_INET;
+            Result := 0;
+          end
+          else
+          begin
+            if lowercase(IP) = cLocalHostStr then
+              a4[1].s_addr := htonl(INADDR_LOOPBACK)
+            else
+            begin
+              a4[1].s_addr := 0;
+              Result := WSAHOST_NOT_FOUND;
+              a4[1] := StrTonetAddr(IP);
+              if a4[1].s_addr = INADDR_ANY then
+                if GetHostByName(ip, he) then
+                  a4[1]:=HostToNet(he.Addr)
+                else
+                  Resolvename(ip, a4);
+            end;
+            if a4[1].s_addr <> INADDR_ANY then
+            begin
+              Sin.sin_family := AF_INET;
+              sin.sin_addr := a4[1];
+              Result := 0;
+            end;
+          end;
+        end;
+      AF_INET6:
+        begin
+          if IP = c6AnyHost then
+          begin
+            Sin.sin_family := AF_INET6;
+            Result := 0;
+          end
+          else
+          begin
+            if lowercase(IP) = cLocalHostStr then
+              SET_LOOPBACK_ADDR6(@a6[1])
+            else
+            begin
+              Result := WSAHOST_NOT_FOUND;
+              SET_IN6_IF_ADDR_ANY(@a6[1]);
+              a6[1] := StrTonetAddr6(IP);
+              if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+                Resolvename6(ip, a6);
+            end;
+            if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+            begin
+              Sin.sin_family := AF_INET6;
+              sin.sin6_addr := a6[1];
+              Result := 0;
+            end;
+          end;
+        end;
+    end;
+  end;
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  Sin.sin_port := Resolveport(port, family, SockProtocol, SockType);
+  TwoPass := False;
+  if Family = AF_UNSPEC then
+  begin
+    if PreferIP4 then
+    begin
+      f1 := AF_INET;
+      f2 := AF_INET6;
+      TwoPass := True;
+    end
+    else
+    begin
+      f2 := AF_INET;
+      f1 := AF_INET6;
+      TwoPass := True;
+    end;
+  end
+  else
+    f1 := Family;
+  Result := GetAddr(f1);
+  if Result <> 0 then
+    if TwoPass then
+      Result := GetAddr(f2);
+end;
+
+function GetSinIP(Sin: TVarSin): string;
+begin
+  Result := '';
+  case sin.AddressFamily of
+    AF_INET:
+      begin
+        result := NetAddrToStr(sin.sin_addr);
+      end;
+    AF_INET6:
+      begin
+        result := NetAddrToStr6(sin.sin6_addr);
+      end;
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
+var
+  x, n: integer;
+  a4: array [1..255] of in_addr;
+  a6: array [1..255] of Tin6_addr;
+  he: THostEntry;
+begin
+  IPList.Clear;
+  if (family = AF_INET) or (family = AF_UNSPEC) then
+  begin
+    if lowercase(name) = cLocalHostStr then
+      IpList.Add(cLocalHost)
+    else
+    begin
+      a4[1] := StrTonetAddr(name);
+      if a4[1].s_addr = INADDR_ANY then
+        if GetHostByName(name, he) then
+        begin
+          a4[1]:=HostToNet(he.Addr);
+          x := 1;
+        end
+        else
+          x := Resolvename(name, a4)
+      else
+        x := 1;
+      for n := 1  to x do
+        IpList.Add(netaddrToStr(a4[n]));
+    end;
+  end;
+
+  if (family = AF_INET6) or (family = AF_UNSPEC) then
+  begin
+    if lowercase(name) = cLocalHostStr then
+      IpList.Add(c6LocalHost)
+    else
+    begin
+      a6[1] := StrTonetAddr6(name);
+      if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
+        x := Resolvename6(name, a6)
+      else
+        x := 1;
+      for n := 1  to x do
+        IpList.Add(netaddrToStr6(a6[n]));
+    end;
+  end;
+
+  if IPList.Count = 0 then
+    IPList.Add(cLocalHost);
+end;
+
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+var
+  ProtoEnt: TProtocolEntry;
+  ServEnt: TServiceEntry;
+begin
+  Result := synsock.htons(StrToIntDef(Port, 0));
+  if Result = 0 then
+  begin
+    ProtoEnt.Name := '';
+    GetProtocolByNumber(SockProtocol, ProtoEnt);
+    ServEnt.port := 0;
+    GetServiceByName(Port, ProtoEnt.Name, ServEnt);
+    Result := ServEnt.port;  
+  end;
+end;
+
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+var
+  n: integer;
+  a4: array [1..1] of in_addr;
+  a6: array [1..1] of Tin6_addr;
+  a: array [1..1] of string;
+begin
+  Result := IP;
+  a4[1] := StrToNetAddr(IP);
+  if a4[1].s_addr <> INADDR_ANY then
+  begin
+//why ResolveAddress need address in HOST order? :-O 
+    n := ResolveAddress(nettohost(a4[1]), a);
+    if n > 0 then
+      Result := a[1];
+  end
+  else
+  begin
+    a6[1] := StrToNetAddr6(IP);
+    n := ResolveAddress6(a6[1], a);
+    if n > 0 then
+      Result := a[1];
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: string): Boolean;
+begin
+  SockEnhancedApi := False;
+  SockWship6Api := False;
+//  Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
+  Result := True;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;
+
+{$ENDIF}
+

ssl_cryptlib.pas

@@ -0,0 +1,681 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.001 |
+|==============================================================================|
+| Content: SSL/SSH support by Peter Gutmann's CryptLib                         |
+|==============================================================================|
+| Copyright (c)1999-2015, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005-2015.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL/SSH plugin for CryptLib)
+
+This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
+and Linux. This library is staticly linked - when you compile your application
+with this plugin, you MUST distribute it with Cryptib library, otherwise you
+cannot run your application!
+
+It can work with keys and certificates stored as PKCS#15 only! It must be stored
+as disk file only, you cannot load them from memory! Each file can hold multiple
+keys and certificates. You must identify it by 'label' stored in
+@link(TSSLCryptLib.PrivateKeyLabel).
+
+If you need to use secure connection and authorize self by certificate
+(each SSL/TLS server or client with client authorization), then use
+@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
+@link(TCustomSSL.KeyPassword) properties.
+
+If you need to use server what verifying client certificates, then use
+@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
+with non-matching certificates will be rejected by cryptLib.
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+
+You can use this plugin for SSHv2 connections too! You must explicitly set
+@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
+and @link(TCustomSSL.password). You can use special SSH channels too, see
+@link(TCustomSSL).
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_cryptlib;
+
+interface
+
+uses
+  Windows,
+  SysUtils,
+  blcksock, synsock, synautil, synacode,
+  cryptlib;
+
+type
+  {:@abstract(class implementing CryptLib SSL/SSH plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLCryptLib = class(TCustomSSL)
+  protected
+    FCryptSession: CRYPT_SESSION;
+    FPrivateKeyLabel: string;
+    FDelCert: Boolean;
+    FReadBuffer: string;
+    FTrustedCAs: array of integer;
+    function SSLCheck(Value: integer): Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+    function PopAll: string;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:Load trusted CA's in PEM format}
+    procedure SetCertCAFile(const Value: string); override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited}
+    procedure Assign(const Value: TCustomSSL); override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetVerifyCert: integer; override;
+  published
+    {:name of certificate/key within PKCS#15 file. It can hold more then one
+     certificate/key and each certificate/key must have unique label within one file.}
+    property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
+  end;
+
+implementation
+
+{==============================================================================}
+
+constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FPrivateKeyLabel := 'synapse';
+  FDelCert := false;
+  FTrustedCAs := nil;
+end;
+
+destructor TSSLCryptLib.Destroy;
+begin
+  SetCertCAFile('');  // destroy certificates
+  DeInit;
+  inherited Destroy;
+end;
+
+procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
+begin
+  inherited Assign(Value);
+  if Value is TSSLCryptLib then
+  begin
+    FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
+  end;
+end;
+
+function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
+var
+  l: integer;
+begin
+  l := 0;
+  cryptGetAttributeString(cryptHandle, attributeType, nil, l);
+  setlength(Result, l);
+  cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
+  setlength(Result, l);
+end;
+
+function TSSLCryptLib.LibVersion: String;
+var
+  x: integer;
+begin
+  Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
+  Result := Result + ' v' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
+  Result := Result + '.' + IntToStr(x);
+  cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
+  Result := Result + '.' + IntToStr(x);
+end;
+
+function TSSLCryptLib.LibName: String;
+begin
+  Result := 'ssl_cryptlib';
+end;
+
+function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  if Value = CRYPT_ERROR_COMPLETE then
+    Value := 0;
+  FLastError := Value;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+{$IF CRYPTLIB_VERSION >= 3400}
+    FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE);
+{$ELSE}
+    FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
+{$IFEND}
+  end;
+end;
+
+function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
+var
+  privateKey: CRYPT_CONTEXT;
+  keyset: CRYPT_KEYSET;
+  cert: CRYPT_CERTIFICATE;
+  publicKey: CRYPT_CONTEXT;
+begin
+  if FPrivatekeyFile = '' then
+    FPrivatekeyFile := GetTempFile('', 'key');
+  cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
+  cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
+    Length(FPrivatekeyLabel));
+  cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
+  cryptGenerateKey(privateKey);
+  cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
+  FDelCert := True;
+  cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
+  cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
+  cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
+  cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
+  cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
+  cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
+  cryptSignCert(cert, privateKey);
+  cryptAddPublicKey(keyset, cert);
+  cryptKeysetClose(keyset);
+  cryptDestroyCert(cert);
+  cryptDestroyContext(privateKey);
+  cryptDestroyContext(publicKey);
+  Result := True;
+end;
+
+function TSSLCryptLib.PopAll: string;
+const
+  BufferMaxSize = 32768;
+var
+  Outbuffer: string;
+  WriteLen: integer;
+begin
+  Result := '';
+  repeat
+    setlength(outbuffer, BufferMaxSize);
+    Writelen := 0;
+    SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
+    if FLastError <> 0 then
+      Break;
+    if WriteLen > 0 then
+    begin
+      setlength(outbuffer, WriteLen);
+      Result := Result + outbuffer;
+    end;
+  until WriteLen = 0;
+end;
+
+function TSSLCryptLib.Init(server:Boolean): Boolean;
+var
+  st: CRYPT_SESSION_TYPE;
+  keysetobj: CRYPT_KEYSET;
+  cryptContext: CRYPT_CONTEXT;
+  x: integer;
+  aUserName : AnsiString;
+  aPassword: AnsiString;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  FDelCert := false;
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  if server then
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL_SERVER;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH_SERVER;
+    else
+      Exit;
+    end
+  else
+    case FSSLType of
+      LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
+        st := CRYPT_SESSION_SSL;
+      LT_SSHv2:
+        st := CRYPT_SESSION_SSH;
+    else
+      Exit;
+    end;
+  if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
+    Exit;
+  x := -1;
+  case FSSLType of
+    LT_SSLv3:
+      x := 0;
+    LT_TLSv1:
+      x := 1;
+    LT_TLSv1_1:
+      x := 2;
+  end;
+  if x >= 0 then
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
+      Exit;
+
+  if (FCertComplianceLevel <> -1) then
+    if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL,
+      FCertComplianceLevel)) then
+      Exit;
+
+  if FUsername <> '' then
+  begin
+    aUserName := fUserName;
+    aPassword := fPassword;
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
+      Pointer(FUsername), Length(FUsername));
+    cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
+      Pointer(FPassword), Length(FPassword));
+  end;
+  if FSSLType = LT_SSHv2 then
+    if FSSHChannelType <> '' then
+    begin
+      cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
+      cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
+        Pointer(FSSHChannelType), Length(FSSHChannelType));
+      if FSSHChannelArg1 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
+          Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
+      if FSSHChannelArg2 <> '' then
+        cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
+          Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
+    end;
+
+
+  if server and (FPrivatekeyFile = '') then
+  begin
+    if FPrivatekeyLabel = '' then
+      FPrivatekeyLabel := 'synapse';
+    if FkeyPassword = '' then
+      FkeyPassword := 'synapse';
+    CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+  end;
+
+  if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
+      PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
+      cryptcontext)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+      cryptDestroyContext(cryptcontext);
+    end;
+  end;
+  if server and FVerifyCert then
+  begin
+    if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
+      PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
+      Exit;
+    try
+    if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
+      keySetObj)) then
+      Exit;
+    finally
+      cryptKeysetClose(keySetObj);
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLCryptLib.DeInit: Boolean;
+begin
+  Result := True;
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    CryptDestroySession(FcryptSession);
+  FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
+  FSSLEnabled := False;
+  if FDelCert then
+    SysUtils.DeleteFile(FPrivatekeyFile);
+end;
+
+function TSSLCryptLib.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLCryptLib.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    if FverifyCert then
+      if (GetVerifyCert <> 0) or (not DoVerifyCert) then
+        Exit;
+    FSSLEnabled := True;
+    Result := True;
+    FReadBuffer := '';
+  end;
+end;
+
+function TSSLCryptLib.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
+      Exit;
+    if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+    FReadBuffer := '';
+  end;
+end;
+
+function TSSLCryptLib.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLCryptLib.BiShutdown: boolean;
+begin
+  if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
+  DeInit;
+  FReadBuffer := '';
+  Result := True;
+end;
+
+function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
+  cryptFlushData(FcryptSession);
+  Result := l;
+end;
+
+function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  if Length(FReadBuffer) = 0 then
+    FReadBuffer := PopAll;
+  if Len > Length(FReadBuffer) then
+    Len := Length(FReadBuffer);
+  Move(Pointer(FReadBuffer)^, buffer^, Len);
+  Delete(FReadBuffer, 1, Len);
+  Result := Len;
+end;
+
+function TSSLCryptLib.WaitingData: Integer;
+begin
+  Result := Length(FReadBuffer);
+end;
+
+function TSSLCryptLib.GetSSLVersion: string;
+var
+  x: integer;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
+  if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
+    case x of
+      0:
+        Result := 'SSLv3';
+      1:
+        Result := 'TLSv1';
+      2:
+        Result := 'TLSv1.1';
+    end;
+  if FSSLType in [LT_SSHv2] then
+    case x of
+      0:
+        Result := 'SSHv1';
+      1:
+        Result := 'SSHv2';
+    end;
+end;
+
+function TSSLCryptLib.GetPeerSubject: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
+  Result := GetString(cert, CRYPT_CERTINFO_DN);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerName: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
+  Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerIssuer: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME);
+  Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
+  cryptDestroyCert(cert);
+end;
+
+function TSSLCryptLib.GetPeerFingerprint: string;
+var
+  cert: CRYPT_CERTIFICATE;
+begin
+  Result := '';
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
+  cryptDestroyCert(cert);
+end;
+
+
+procedure TSSLCryptLib.SetCertCAFile(const Value: string);
+
+var F:textfile;
+  bInCert:boolean;
+  s,sCert:string;
+  cert: CRYPT_CERTIFICATE;
+  idx:integer;
+
+begin
+if assigned(FTrustedCAs) then
+  begin
+  for idx := 0 to High(FTrustedCAs) do
+    cryptDestroyCert(FTrustedCAs[idx]);
+  FTrustedCAs:=nil;
+  end;
+if Value<>'' then
+  begin
+  AssignFile(F,Value);
+  reset(F);
+  bInCert:=false;
+  idx:=0;
+  while not eof(F) do
+    begin
+    readln(F,s);
+    if pos('-----END CERTIFICATE-----',s)>0 then
+      begin
+      bInCert:=false;
+      cert:=0;
+      if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then
+        begin
+        cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 );
+        SetLength(FTrustedCAs,idx+1);
+        FTrustedCAs[idx]:=cert;
+        idx:=idx+1;
+        end;
+      end;
+    if bInCert then
+      sCert:=sCert+s+#13#10;
+    if pos('-----BEGIN CERTIFICATE-----',s)>0 then
+      begin
+      bInCert:=true;
+      sCert:='';
+      end;
+    end;
+  CloseFile(F);
+  end;
+end;
+
+function TSSLCryptLib.GetVerifyCert: integer;
+var
+  cert: CRYPT_CERTIFICATE;
+  itype,ilocus:integer;
+begin
+  Result := -1;
+  if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
+    Exit;
+  cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
+  result:=cryptCheckCert(cert,CRYPT_UNUSED);
+  if result<>CRYPT_OK then
+    begin
+    //get extended error info if available
+    cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype);
+    cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus);
+    cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
+    FLastError := Result;
+    FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.',
+      [GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]);
+    end;
+  cryptDestroyCert(cert);
+end;
+
+{==============================================================================}
+
+var imajor,iminor,iver:integer;
+//    e: ESynapseError;
+
+initialization
+  if cryptInit = CRYPT_OK then
+    SSLImplementation := TSSLCryptLib;
+  cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
+  cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor);
+  cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor);
+// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits
+  if CRYPTLIB_VERSION >1000 then
+    iver:=CRYPTLIB_VERSION div 100
+  else
+    iver:=CRYPTLIB_VERSION div 10;
+  if (iver <> imajor*10+iminor) then
+  begin
+    SSLImplementation :=TSSLNone;
+//    e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ',
+//       [imajor,iminor,iver div 10, iver mod 10]));
+//    e.ErrorCode := 0;
+//    e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)',
+//       [imajor,iminor,iver div 10, iver mod 10]);
+//    raise e;
+  end;
+finalization
+  cryptEnd;
+end.
+
+

ssl_libssh2.pas

@@ -0,0 +1,251 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.000 |
+|==============================================================================|
+| Content: SSH support by LibSSH2                                              |
+|==============================================================================|
+| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Alexey Suhinin.                |
+| Portions created by Alexey Suhinin are Copyright (c)2012-2013.                |
+| Portions created by Lukas Gebauer are Copyright (c)2013-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+//requires LibSSH2 libraries! http://libssh2.org
+
+{:@abstract(SSH plugin for LibSSH2)
+
+Requires libssh2.dll or libssh2.so. 
+You can download binaries as part of the CURL project from 
+http://curl.haxx.se/download.html
+
+You need Pascal bindings for the library too! You can find one at:
+ http://www.lazarus.freepascal.org/index.php/topic,15935.msg86465.html#msg86465
+
+This plugin implements the client part only.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_libssh2;
+
+interface
+ 
+uses
+  SysUtils,
+  blcksock, synsock,
+  libssh2;
+ 
+type
+  {:@abstract(class implementing LibSSH2 SSH plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLLibSSH2 = class(TCustomSSL)
+  protected
+    FSession: PLIBSSH2_SESSION;
+    FChannel: PLIBSSH2_CHANNEL;
+    function SSHCheck(Value: integer): Boolean;
+    function DeInit: Boolean;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited}
+    function Connect: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+  published
+  end;
+ 
+implementation
+ 
+{==============================================================================}
+function TSSLLibSSH2.SSHCheck(Value: integer): Boolean;
+var
+  PLastError: PAnsiChar;
+  ErrMsgLen: Integer;
+begin
+  Result := true;
+  FLastError := 0;
+  FLastErrorDesc := '';
+  if Value<0 then
+  begin
+    FLastError := libssh2_session_last_error(FSession, PLastError, ErrMsglen, 0);
+    FLastErrorDesc := PLastError;
+    Result := false;
+  end;
+end;
+ 
+ 
+function TSSLLibSSH2.DeInit: Boolean;
+begin
+  if Assigned(FChannel) then
+  begin
+    libssh2_channel_free(FChannel);
+    FChannel := nil;
+  end;
+  if Assigned(FSession) then
+  begin
+    libssh2_session_disconnect(FSession,'Goodbye');
+    libssh2_session_free(FSession);
+    FSession := nil;
+  end;
+  FSSLEnabled := False;
+  Result := true;
+end;
+ 
+constructor TSSLLibSSH2.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FSession := nil;
+  FChannel := nil;
+end;
+ 
+destructor TSSLLibSSH2.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+ 
+function TSSLLibSSH2.Connect: boolean;
+begin
+  Result := False;
+  if SSLEnabled then DeInit;
+  if (FSocket.Socket <> INVALID_SOCKET) and (FSocket.SSL.SSLType = LT_SSHv2) then
+    begin
+      FSession := libssh2_session_init();
+      if not Assigned(FSession) then
+      begin
+        FLastError := -999;
+        FLastErrorDesc := 'Cannot initialize SSH session';
+        exit;
+      end;
+      if not SSHCheck(libssh2_session_startup(FSession, FSocket.Socket)) then
+        exit;
+      // Attempt private key authentication, then fall back to username/password but
+      // do not forget original private key auth error. This avoids giving spurious errors like
+      // Authentication failed (username/password)
+      // instead of e.g.
+      // Unable to extract public key from private key file: Method unimplemented in libgcrypt backend
+      if FSocket.SSL.PrivateKeyFile<>'' then
+        if (not SSHCheck(libssh2_userauth_publickey_fromfile(FSession, PChar(FSocket.SSL.Username), nil, PChar(FSocket.SSL.PrivateKeyFile), PChar(FSocket.SSL.KeyPassword))))
+          and (libssh2_userauth_password(FSession, PChar(FSocket.SSL.Username), PChar(FSocket.SSL.Password))<0) then
+            exit;
+      FChannel := libssh2_channel_open_session(FSession);
+      if not assigned(FChannel) then
+      begin
+//        SSHCheck(-1);
+        FLastError:=-999;
+        FLastErrorDesc := 'Cannot open session';
+        exit;
+      end;
+      if not SSHCheck(libssh2_channel_request_pty(FChannel, 'vanilla')) then
+        exit;
+      if not SSHCheck(libssh2_channel_shell(FChannel)) then
+        exit;
+      FSSLEnabled := True;
+      Result := True;
+    end;
+end;
+
+function TSSLLibSSH2.LibName: String;
+begin
+  Result := 'ssl_libssh2';
+end;
+ 
+function TSSLLibSSH2.Shutdown: boolean;
+begin
+  Result := DeInit;
+end;
+ 
+ 
+function TSSLLibSSH2.BiShutdown: boolean;
+begin
+  Result := DeInit;
+end;
+ 
+function TSSLLibSSH2.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  Result:=libssh2_channel_write(FChannel, PAnsiChar(Buffer), Len);
+  SSHCheck(Result);
+end;
+
+function TSSLLibSSH2.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+begin
+  result:=libssh2_channel_read(FChannel, PAnsiChar(Buffer), Len);
+  SSHCheck(Result);
+end;
+ 
+function TSSLLibSSH2.WaitingData: Integer;
+begin
+  if libssh2_poll_channel_read(FChannel, Result) <> 1 then
+    Result := 0;
+end;
+ 
+function TSSLLibSSH2.GetSSLVersion: string;
+begin
+  Result := 'SSH2';
+end;
+
+function TSSLLibSSH2.LibVersion: String;
+begin
+  Result := libssh2_version(0);
+end;
+
+initialization
+  if libssh2_init(0)=0 then
+    SSLImplementation := TSSLLibSSH2;
+ 
+finalization
+  libssh2_exit;
+ 
+end.

ssl_openssl.pas

@@ -0,0 +1,1007 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.000 |
+|==============================================================================|
+| Content: SSL support by OpenSSL                                              |
+|==============================================================================|
+| Copyright (c)1999-2017, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005-2017.                |
+| Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+//requires OpenSSL libraries!
+
+{:@abstract(SSL plugin for OpenSSL)
+
+Compatibility with OpenSSL versions:
+0.9.6 should work, known mysterious crashing on FreePascal and Linux platform.
+0.9.7 - 1.0.0 working fine.
+1.1.0 should work, under testing.
+
+OpenSSL libraries are loaded dynamicly - you not need OpenSSL librares even you
+compile your application with this unit. SSL just not working when you not have
+OpenSSL libraries.
+
+This plugin have limited support for .NET too! Because is not possible to use
+callbacks with CDECL calling convention under .NET, is not supported
+key/certificate passwords and multithread locking. :-(
+
+For handling keys and certificates you can use this properties:
+
+@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
+@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
+@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
+@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
+@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
+@link(TCustomSSL.PFXFile) for PFX format. @br
+@link(TCustomSSL.PFX) for PFX format from binary string. @br
+
+This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
+server without explicitly assigned key and certificate, then this plugin create
+Ad-Hoc key and certificate for each incomming connection by self. It slowdown
+accepting of new connections!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit ssl_openssl;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil,
+  synabyte,
+{$IFDEF CIL}
+  System.Text,
+{$ENDIF}
+  ssl_openssl_lib;
+
+type
+  {:@abstract(class implementing OpenSSL SSL plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLOpenSSL = class(TCustomSSL)
+  protected
+    FSsl: PSSL;
+    Fctx: PSSL_CTX;
+    function SSLCheck: Boolean;
+    function SetSslKeys: boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    function LoadPFX(pfxdata: TSynaBytes): Boolean;
+    function CreateSelfSignedCert(Host: string): Boolean; override;
+  public
+    {:See @inherited}
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_cryptlib) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerSerialNo: integer; override; {pf}
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerNameHash: cardinal; override; {pf}
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    function GetPeerFingerprintDigest(const ADigest: string): string; override;
+    {:See @inherited}
+    function GetCertInfo: string; override;
+    {:See @inherited}
+    function GetCipherName: string; override;
+    {:See @inherited}
+    function GetCipherBits: integer; override;
+    {:See @inherited}
+    function GetCipherAlgBits: integer; override;
+    {:See @inherited}
+    function GetVerifyCert: integer; override;
+  end;
+
+implementation
+
+{==============================================================================}
+
+{$IFNDEF CIL}
+function PasswordCallback(Buf:PByte; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
+var
+  Password: TSynabytes;
+begin
+  Password := '';
+  if TCustomSSL(userdata) is TCustomSSL then
+    Password := TCustomSSL(userdata).KeyPassword;
+  if Length(Password) > (Size - 1) then
+  {$IFDEF UNICODE}
+   Password.Length := Size - 1;
+  {$ELSE}
+    SetLength(Password, Size - 1);
+  {$ENDIF}
+  Result := Length(Password);
+  Password := Password + #0;
+            
+{$IFDEF UNICODE}
+  Move(Password.Data^, buf^, result+1);
+{$ELSE}
+  Move(PAnsiChar(AnsiString(Password))^, buf^, result+1);
+{$ENDIF}
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FCiphers := 'DEFAULT';
+  FSsl := nil;
+  Fctx := nil;
+end;
+
+destructor TSSLOpenSSL.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLOpenSSL.LibVersion: String;
+begin
+  Result := SSLeayversion(0);
+end;
+
+function TSSLOpenSSL.LibName: String;
+begin
+  Result := 'ssl_openssl';
+end;
+
+function TSSLOpenSSL.SSLCheck: Boolean;
+var
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ELSE}
+  se: integer;
+{$ENDIF}
+  s : TSynabytes;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  FLastError := ErrGetError;
+  ErrClearError;
+  if FLastError <> 0 then
+  begin
+    Result := False;
+{$IFDEF CIL}
+    sb := StringBuilder.Create(256);
+    ErrErrorString(FLastError, sb, 256);
+    FLastErrorDesc := Trim(sb.ToString);
+{$ELSE}
+    //{$IFDEF WIN???}
+      if FLastError = SSL_ERROR_SYSCALL then
+      begin
+        se := WSAGetLastError();
+        FLastErrorDesc := '#sslErr:' + SysUtils.IntToStr(FLastError)
+            + ' #sysErr:' + SysUtils.IntToStr(se)
+            + ' ' + string(TBlockSocket.GetErrorDesc(se))  // cast
+      end;
+    //{$ELSE}
+    //{$ENDIF}
+    if FLastErrorDesc = '' then
+    begin
+      s := StringOfChar(AnsiChar(#0), 256);
+      ErrErrorString(FLastError, s, Length(s));
+      FLastErrorDesc := '#sslErr:' + SysUtils.IntToStr(FLastError)
+          + ' ' + string(s); // cast
+    end
+{$ENDIF}
+  end;
+end;
+
+function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
+var
+  pk: EVP_PKEY;
+  x: PX509;
+  rsa: PRSA;
+  t: PASN1_UTCTIME;
+  name: PX509_NAME;
+  b: PBIO;
+  xn, y: integer;
+  s: TBytes;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  Result := True;
+  pk := EvpPkeynew;
+  x := X509New;
+  try
+    rsa := RsaGenerateKey(1024, $10001, nil, nil);
+    EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
+    X509SetVersion(x, 2);
+    Asn1IntegerSet(X509getSerialNumber(x), 0);
+    t := Asn1UtctimeNew;
+    try
+      X509GmtimeAdj(t, -60 * 60 *24);
+      X509SetNotBefore(x, t);
+      X509GmtimeAdj(t, 60 * 60 * 60 *24);
+      X509SetNotAfter(x, t);
+    finally
+      Asn1UtctimeFree(t);
+    end;
+    X509SetPubkey(x, pk);
+    Name := X509GetSubjectName(x);
+    X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
+    X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
+    x509SetIssuerName(x, Name);
+    x509Sign(x, pk, EvpGetDigestByName('SHA1'));
+    b := BioNew(BioSMem);
+    try
+      i2dX509Bio(b, x);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, @s[0], xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FCertificate := StringOf(s);
+    b := BioNew(BioSMem);
+    try
+      i2dPrivatekeyBio(b, pk);
+      xn := bioctrlpending(b);
+{$IFDEF CIL}
+      sb := StringBuilder.Create(xn);
+      y := bioread(b, sb, xn);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+{$ELSE}
+      setlength(s, xn);
+      y := bioread(b, @s[0], xn);
+      if y > 0 then
+        setlength(s, y);
+{$ENDIF}
+    finally
+      BioFreeAll(b);
+    end;
+    FPrivatekey := StringOf(s);
+  finally
+    X509free(x);
+    EvpPkeyFree(pk);
+  end;
+end;
+
+function TSSLOpenSSL.LoadPFX(pfxdata: TSynaBytes): Boolean;
+var
+  cert, pkey, ca: SslPtr;
+  b: PBIO;
+  p12: SslPtr;
+  buf: PByte;
+  len: cardinal;
+begin
+  Result := False;
+  b := BioNew(BioSMem);
+  try
+{$IFDEF UNICODE}
+    buf := pfxdata.Data;
+    len := pfxdata.Length;
+{$ELSE}
+    buf := PByte(pfxData);
+    len := length(pfxData);
+{$ENDIF}
+    BioWrite(b, buf, len);
+    p12 := d2iPKCS12bio(b, nil);
+    if not Assigned(p12) then
+      Exit;
+    try
+      cert := nil;
+      pkey := nil;
+      ca := nil;
+      try {pf}
+        if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
+          if SSLCTXusecertificate(Fctx, cert) > 0 then
+            if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
+              Result := True;
+      {pf}
+      finally
+        EvpPkeyFree(pkey);
+        X509free(cert);
+        SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated...
+      end;
+      {/pf}
+    finally
+      PKCS12free(p12);
+    end;
+  finally
+    BioFreeAll(b);
+  end;
+end;
+
+function TSSLOpenSSL.SetSslKeys: boolean;
+var
+  st: TFileStream;
+  s: string;
+begin
+  Result := False;
+  if not assigned(FCtx) then
+    Exit;
+  try
+    if FCertificateFile <> '' then
+      if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
+        if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
+          if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
+            Exit;
+    if FCertificate <> '' then
+      if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
+        Exit;
+    SSLCheck;
+    if FPrivateKeyFile <> '' then
+      if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
+        if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
+          Exit;
+    if FPrivateKey <> '' then
+      if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
+        Exit;
+    SSLCheck;
+    if FCertCAFile <> '' then
+      if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
+        Exit;
+    if FPFXfile <> '' then
+    begin
+      try
+        st := TFileStream.Create(FPFXfile, fmOpenRead	 or fmShareDenyNone);
+        try
+          s := ReadStrFromStream(st, st.Size);
+        finally
+          st.Free;
+        end;
+        if not LoadPFX(s) then
+          Exit;
+      except
+        on Exception do
+          Exit;
+      end;
+    end;
+    if FPFX <> '' then
+      if not LoadPFX(FPfx) then
+        Exit;
+    SSLCheck;
+    Result := True;
+  finally
+    SSLCheck;
+  end;
+end;
+
+function TSSLOpenSSL.Init(server:Boolean): Boolean;
+var
+  s: TSynabytes;
+  buf: PByte;
+begin
+  Result := False;
+  FLastErrorDesc := '';
+  FLastError := 0;
+  Fctx := nil;
+  case FSSLType of
+    LT_SSLv2:
+      Fctx := SslCtxNew(SslMethodV2);
+    LT_SSLv3:
+      Fctx := SslCtxNew(SslMethodV3);
+    LT_TLSv1:
+      Fctx := SslCtxNew(SslMethodTLSV1);
+    LT_TLSv1_1:
+      Fctx := SslCtxNew(SslMethodTLSV11);
+    LT_TLSv1_2:
+      Fctx := SslCtxNew(SslMethodTLSV12);
+    LT_all:
+      begin
+        //try new call for OpenSSL 1.1.0 first
+        Fctx := SslCtxNew(SslMethodTLS);
+        if Fctx=nil then
+          //callback to previous versions
+          Fctx := SslCtxNew(SslMethodV23);
+      end;
+  else
+    Exit;
+  end;
+  if Fctx = nil then
+  begin
+    SSLCheck;
+    Exit;
+  end
+  else
+  begin
+    s := FCiphers;
+  {$IFDEF UNICODE}
+    buf := s.Data;
+  {$ELSE}
+    buf := PByte(s);
+  {$ENDIF}
+    SslCtxSetCipherList(Fctx, buf);
+    if FVerifyCert then
+      SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
+    else
+      SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
+{$IFNDEF CIL}
+    SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
+    SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
+{$ENDIF}
+
+    if server and (FCertificateFile = '') and (FCertificate = '')
+      and (FPFXfile = '') and (FPFX = '') then
+    begin
+      CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
+    end;
+
+    if not SetSSLKeys then
+      Exit
+    else
+    begin
+      Fssl := nil;
+      Fssl := SslNew(Fctx);
+      if Fssl = nil then
+      begin
+        SSLCheck;
+        exit;
+      end;
+    end;
+  end;
+  Result := true;
+end;
+
+function TSSLOpenSSL.DeInit: Boolean;
+begin
+  Result := True;
+  if assigned (Fssl) then
+    sslfree(Fssl);
+  Fssl := nil;
+  if assigned (Fctx) then
+  begin
+    SslCtxFree(Fctx);
+    Fctx := nil;
+    ErrRemoveState(0);
+  end;
+  FSSLEnabled := False;
+end;
+
+function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLOpenSSL.Connect: boolean;
+var
+  x: integer;
+  b: boolean;
+  err: integer;
+  s: TSynabytes;
+  buf: PByte;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(False) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    if SNIHost<>'' then
+    begin
+      s := sniHost;
+    {$IFDEF  UNICODE}
+      buf := s.Data;
+    {$ELSE}
+      buf := PByte(s);
+    {$ENDIF}
+      SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, buf);
+    end;
+    if FSocket.ConnectionTimeout <= 0 then //do blocking call of SSL_Connect
+    begin
+      x := sslconnect(FSsl);
+      if x < 1 then
+      begin
+        SSLcheck;
+        Exit;
+      end;
+    end
+    else //do non-blocking call of SSL_Connect
+    begin
+      b := Fsocket.NonBlockMode;
+      Fsocket.NonBlockMode := true;
+      repeat
+        x := sslconnect(FSsl);
+        err := SslGetError(FSsl, x);
+        if err = SSL_ERROR_WANT_READ then
+          if not FSocket.CanRead(FSocket.ConnectionTimeout) then
+            break;
+        if err = SSL_ERROR_WANT_WRITE then
+          if not FSocket.CanWrite(FSocket.ConnectionTimeout) then
+            break;
+      until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+      Fsocket.NonBlockMode := b;
+      if err <> SSL_ERROR_NONE then
+      begin
+        SSLcheck;
+        Exit;
+      end;
+    end;
+  if FverifyCert then
+    if (GetVerifyCert <> 0) or (not DoVerifyCert) then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Accept: boolean;
+var
+  x: integer;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(True) then
+  begin
+{$IFDEF CIL}
+    if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
+{$ELSE}
+    if sslsetfd(FSsl, FSocket.Socket) < 1 then
+{$ENDIF}
+    begin
+      SSLCheck;
+      Exit;
+    end;
+    x := sslAccept(FSsl);
+    if x < 1 then
+    begin
+      SSLcheck;
+      Exit;
+    end;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLOpenSSL.Shutdown: boolean;
+begin
+  if assigned(FSsl) then
+    sslshutdown(FSsl);
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.BiShutdown: boolean;
+var
+  x: integer;
+begin
+  if assigned(FSsl) then
+  begin
+    x := sslshutdown(FSsl);
+    if x = 0 then
+    begin
+      Synsock.Shutdown(FSocket.Socket, 1);
+      sslshutdown(FSsl);
+    end;
+  end;
+  DeInit;
+  Result := True;
+end;
+
+function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    s := StringOf(Buffer);
+    Result := SslWrite(FSsl, s, Len);
+{$ELSE}
+    Result := SslWrite(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  else
+    if (err <> 0) then
+      FLastError := err;
+end;
+
+function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  err: integer;
+{$IFDEF CIL}
+  sb: stringbuilder;
+  s: ansistring;
+{$ENDIF}
+begin
+  FLastError := 0;
+  FLastErrorDesc := '';
+  repeat
+{$IFDEF CIL}
+    sb := StringBuilder.Create(Len);
+    Result := SslRead(FSsl, sb, Len);
+    if Result > 0 then
+    begin
+      sb.Length := Result;
+      s := sb.ToString;
+      System.Array.Copy(BytesOf(s), Buffer, length(s));
+    end;
+{$ELSE}
+    Result := SslRead(FSsl, Buffer , Len);
+{$ENDIF}
+    err := SslGetError(FSsl, Result);
+  until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
+  if err = SSL_ERROR_ZERO_RETURN then
+    Result := 0
+  {pf}// Verze 1.1.0 byla s else tak jak to ted mam,
+      // ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN
+      // propagovano jako Chyba.
+  {pf} else {/pf} if (err <> 0) then   
+    FLastError := err;
+end;
+
+function TSSLOpenSSL.WaitingData: Integer;
+begin
+  Result := sslpending(Fssl);
+end;
+
+function TSSLOpenSSL.GetSSLVersion: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SSlGetVersion(FSsl);
+end;
+
+function TSSLOpenSSL.GetPeerSubject: string;
+var
+  cert: PX509;
+  s: TBytes;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetSubjectName(cert), @s[0], Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+
+function TSSLOpenSSL.GetPeerSerialNo: integer; {pf}
+var
+  cert: PX509;
+  SN:   PASN1_INTEGER;
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := -1;
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  try
+    if not assigned(cert) then
+    begin
+      Result := -1;
+      Exit;
+    end;
+    SN := X509GetSerialNumber(cert);
+    Result := Asn1IntegerGet(SN);
+  finally
+    X509Free(cert);
+  end;
+end;
+
+function TSSLOpenSSL.GetPeerName: string;
+var
+  s: string;
+begin
+  s := GetPeerSubject;
+  s := SeparateRight(s, '/CN=');
+  Result := Trim(SeparateLeft(s, '/'));
+end;
+
+function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf}
+var
+  cert: PX509;
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := 0;
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  try
+    if not assigned(cert) then
+    begin
+      Result := 0;
+      Exit;
+    end;
+    Result := X509NameHash(X509GetSubjectName(cert));
+  finally
+    X509Free(cert);
+  end;
+end;
+
+function TSSLOpenSSL.GetPeerIssuer: string;
+var
+  cert: PX509;
+  s: TBytes;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
+{$ELSE}
+  setlength(s, 4096);
+  Result := X509NameOneline(X509GetIssuerName(cert), @s[0], Length(s));
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerFingerprint: string;
+var
+  cert: PX509;
+  x: integer;
+{$IFDEF CIL}
+  sb: StringBuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+{$IFDEF CIL}
+  sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
+  sb.Length := x;
+  Result := sb.ToString;
+{$ELSE}
+  setlength(Result, EVP_MAX_MD_SIZE);
+  X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
+  SetLength(Result, x);
+{$ENDIF}
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetPeerFingerprintDigest(const ADigest: string): string;
+var
+  cert: PX509;
+  x: integer;
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  setlength(Result, 128);
+  X509Digest(cert, EvpGetDigestByName(ADigest), Result, x);
+  SetLength(Result, x);
+  X509Free(cert);
+end;
+
+function TSSLOpenSSL.GetCertInfo: string;
+var
+  cert: PX509;
+  x, y: integer;
+  b: PBIO;
+  s: TBytes;
+{$IFDEF CIL}
+  sb: stringbuilder;
+{$ENDIF}
+begin
+  if not assigned(FSsl) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  cert := SSLGetPeerCertificate(Fssl);
+  if not assigned(cert) then
+  begin
+    Result := '';
+    Exit;
+  end;
+  try {pf}
+    b := BioNew(BioSMem);
+    try
+      X509Print(b, cert);
+      x := bioctrlpending(b);
+  {$IFDEF CIL}
+      sb := StringBuilder.Create(x);
+      y := bioread(b, sb, x);
+      if y > 0 then
+      begin
+        sb.Length := y;
+        s := sb.ToString;
+      end;
+  {$ELSE}
+      setlength(s,x);
+      y := bioread(b,@s[0],x);
+      if y > 0 then
+        setlength(s, y);
+  {$ENDIF}
+      Result := ReplaceString(StringOf(s), LF, CRLF);
+    finally
+      BioFreeAll(b);
+    end;
+  {pf}
+  finally
+    X509Free(cert);
+  end;
+  {/pf}
+end;
+
+function TSSLOpenSSL.GetCipherName: string;
+begin
+  if not assigned(FSsl) then
+    Result := ''
+  else
+    Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
+end;
+
+function TSSLOpenSSL.GetCipherBits: integer;
+var
+  x: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
+end;
+
+function TSSLOpenSSL.GetCipherAlgBits: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 0
+  else
+    SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
+end;
+
+function TSSLOpenSSL.GetVerifyCert: integer;
+begin
+  if not assigned(FSsl) then
+    Result := 1
+  else
+    Result := SslGetVerifyResult(FSsl);
+end;
+
+{==============================================================================}
+
+initialization
+  if InitSSLInterface then
+    SSLImplementation := TSSLOpenSSL;
+
+end.

ssl_openssl_lib.pas

@@ -0,0 +1,2463 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.008.000 |
+|==============================================================================|
+| Content: SSL support by OpenSSL                                              |
+|==============================================================================|
+| Copyright (c)1999-2017, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2002-2017.                |
+| Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Tomas Hajny (OS2 support)                                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{
+Special thanks to Gregor Ibic <[email protected]>
+ (Intelicom d.o.o., http://www.intelicom.si)
+ for good inspiration about begin with SSL programming.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+  (*$HPPEMIT 'namespace ssl_openssl_lib { using System::Shortint; }' *)
+{$ENDIF}
+
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{:@abstract(OpenSSL support)
+
+This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit).
+OpenSSL is loaded dynamicly on-demand. If this library is not found in system,
+requested OpenSSL function just return errorcode.
+}
+unit ssl_openssl_lib;
+
+interface
+
+{$IFDEF IOS}
+{$DEFINE STATIC}
+{$ENDIF}
+
+uses
+{$IFDEF CIL}
+  System.Runtime.InteropServices,
+  System.Text,
+{$ENDIF}
+  Classes,
+  synafpc,
+  synabyte,
+{$IFNDEF MSWINDOWS}
+  {$IFDEF FPC}
+   {$IFDEF UNIX}
+  BaseUnix,
+   {$ENDIF UNIX}
+  {$ELSE}
+   Libc,
+  {$ENDIF}
+  SysUtils;
+{$ELSE}
+  Windows;
+{$ENDIF}
+
+
+{$IFDEF CIL}
+const
+  {$IFDEF LINUX}
+  DLLSSLName = 'libssl.so';
+  DLLUtilName = 'libcrypto.so';
+  {$ELSE}
+  DLLSSLName = 'ssleay32.dll';
+  DLLUtilName = 'libeay32.dll';
+  {$ENDIF}
+{$ELSE}
+var
+  {$IFNDEF MSWINDOWS}
+    {$IFDEF DARWIN}
+    DLLSSLName: string = 'libssl.dylib';
+    DLLUtilName: string = 'libcrypto.dylib';
+    {$ELSE}
+     {$IFDEF OS2}
+      {$IFDEF OS2GCC}
+    DLLSSLName: string = 'kssl.dll';
+    DLLUtilName: string = 'kcrypto.dll';
+      {$ELSE OS2GCC}
+    DLLSSLName: string = 'ssl.dll';
+    DLLUtilName: string = 'crypto.dll';
+      {$ENDIF OS2GCC}
+     {$ELSE OS2}
+    DLLSSLName: string = 'libssl.so';
+    DLLUtilName: string = 'libcrypto.so';
+     {$ENDIF OS2}
+    {$ENDIF}
+  {$ELSE}
+  DLLSSLName: string = 'ssleay32.dll';
+  DLLSSLName2: string = 'libssl32.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}
+
+type
+{$IFDEF CIL}
+  SslPtr = IntPtr;
+{$ELSE}
+  SslPtr = Pointer;
+{$ENDIF}
+  PSslPtr = ^SslPtr;
+  PSSL_CTX = SslPtr;
+  PSSL = SslPtr;
+  PSSL_METHOD = SslPtr;
+  PX509 = SslPtr;
+  PX509_NAME = SslPtr;
+  PEVP_MD	= SslPtr;
+  PInteger = ^Integer;
+  PBIO_METHOD = SslPtr;
+  PBIO = SslPtr;
+  EVP_PKEY = SslPtr;
+  PRSA = SslPtr;
+  PASN1_UTCTIME = SslPtr;
+  PASN1_INTEGER = SslPtr;
+  PPasswdCb = SslPtr;
+  PFunction = procedure;
+  PSTACK = SslPtr; {pf}
+  TSkPopFreeFunc = procedure(p:SslPtr); cdecl; {pf}
+  TX509Free = procedure(x: PX509); cdecl; {pf}
+
+  DES_cblock = array[0..7] of Byte;
+  PDES_cblock = ^DES_cblock;
+  des_ks_struct = packed record
+    ks: DES_cblock;
+    weak_key: Integer;
+  end;
+  des_key_schedule = array[1..16] of des_ks_struct;
+
+const
+  EVP_MAX_MD_SIZE = 16 + 20;
+
+  SSL_ERROR_NONE = 0;
+  SSL_ERROR_SSL = 1;
+  SSL_ERROR_WANT_READ = 2;
+  SSL_ERROR_WANT_WRITE = 3;
+  SSL_ERROR_WANT_X509_LOOKUP = 4;
+  SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno
+  SSL_ERROR_ZERO_RETURN = 6;
+  SSL_ERROR_WANT_CONNECT = 7;
+  SSL_ERROR_WANT_ACCEPT = 8;
+
+  SSL_OP_NO_SSLv2 = $01000000;
+  SSL_OP_NO_SSLv3 = $02000000;
+  SSL_OP_NO_TLSv1 = $04000000;
+  SSL_OP_ALL = $000FFFFF;
+  SSL_VERIFY_NONE = $00;
+  SSL_VERIFY_PEER = $01;
+
+  OPENSSL_DES_DECRYPT = 0;
+  OPENSSL_DES_ENCRYPT = 1;
+
+  X509_V_OK =	0;
+  X509_V_ILLEGAL = 1;
+  X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2;
+  X509_V_ERR_UNABLE_TO_GET_CRL = 3;
+  X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4;
+  X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5;
+  X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6;
+  X509_V_ERR_CERT_SIGNATURE_FAILURE = 7;
+  X509_V_ERR_CRL_SIGNATURE_FAILURE = 8;
+  X509_V_ERR_CERT_NOT_YET_VALID = 9;
+  X509_V_ERR_CERT_HAS_EXPIRED = 10;
+  X509_V_ERR_CRL_NOT_YET_VALID = 11;
+  X509_V_ERR_CRL_HAS_EXPIRED = 12;
+  X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13;
+  X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14;
+  X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15;
+  X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16;
+  X509_V_ERR_OUT_OF_MEM = 17;
+  X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18;
+  X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19;
+  X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20;
+  X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21;
+  X509_V_ERR_CERT_CHAIN_TOO_LONG = 22;
+  X509_V_ERR_CERT_REVOKED = 23;
+  X509_V_ERR_INVALID_CA = 24;
+  X509_V_ERR_PATH_LENGTH_EXCEEDED = 25;
+  X509_V_ERR_INVALID_PURPOSE = 26;
+  X509_V_ERR_CERT_UNTRUSTED = 27;
+  X509_V_ERR_CERT_REJECTED = 28;
+  //These are 'informational' when looking for issuer cert
+  X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29;
+  X509_V_ERR_AKID_SKID_MISMATCH = 30;
+  X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31;
+  X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32;
+  X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33;
+  X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34;
+  //The application is not happy
+  X509_V_ERR_APPLICATION_VERIFICATION = 50;
+
+  SSL_FILETYPE_ASN1	= 2;
+  SSL_FILETYPE_PEM = 1;
+  EVP_PKEY_RSA = 6;
+
+  SSL_CTRL_SET_TLSEXT_HOSTNAME = 55;
+  TLSEXT_NAMETYPE_host_name = 0;
+
+var
+  SSLLibHandle: TLibHandle = 0;
+  SSLUtilHandle: TLibHandle = 0;
+  SSLLibFile: string = '';
+  SSLUtilFile: string = '';
+
+{$IFDEF CIL}
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_get_error')]
+    function SslGetError(s: PSSL; ret_code: Integer): Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_library_init')]
+    function SslLibraryInit: Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_load_error_strings')]
+    procedure SslLoadErrorStrings; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_set_cipher_list')]
+    function SslCtxSetCipherList(arg0: PSSL_CTX; var str: string): Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_new')]
+    function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_free')]
+    procedure SslCtxFree (arg0: PSSL_CTX);   external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_set_fd')]
+    function SslSetFd(s: PSSL; fd: Integer):Integer;    external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSLv2_method')]
+    function SslMethodV2 : PSSL_METHOD; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSLv3_method')]
+    function SslMethodV3 : PSSL_METHOD;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'TLSv1_method')]
+    function SslMethodTLSV1:PSSL_METHOD;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'TLSv1_1_method')]
+    function SslMethodTLSV11:PSSL_METHOD;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'TLSv1_2_method')]
+    function SslMethodTLSV12:PSSL_METHOD;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSLv23_method')]
+    function SslMethodV23 : PSSL_METHOD; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'TLS_method')]
+    function SslMethodTLS : PSSL_METHOD; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_PrivateKey')]
+    function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_PrivateKey_ASN1')]
+    function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: string; len: integer):Integer;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_RSAPrivateKey_file')]
+    function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: string; _type: Integer):Integer;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_certificate')]
+    function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_certificate_ASN1')]
+    function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: string):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_certificate_file')]
+    function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: string; _type: Integer):Integer;external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_use_certificate_chain_file')]
+    function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: string):Integer;external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_check_private_key')]
+    function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_set_default_passwd_cb')]
+    procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb); external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_set_default_passwd_cb_userdata')]
+    procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: IntPtr); external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_load_verify_locations')]
+    function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; CAfile: string; CApath: string):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_ctrl')]
+    function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: IntPtr): integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_new')]
+    function SslNew(ctx: PSSL_CTX):PSSL;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_free')]
+    procedure SslFree(ssl: PSSL); external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_accept')]
+    function SslAccept(ssl: PSSL):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_connect')]
+    function SslConnect(ssl: PSSL):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_shutdown')]
+    function SslShutdown(s: PSSL):Integer;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_read')]
+    function SslRead(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_peek')]
+    function SslPeek(ssl: PSSL; buf: StringBuilder; num: Integer):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_write')]
+    function SslWrite(ssl: PSSL; buf: string; num: Integer):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_pending')]
+    function SslPending(ssl: PSSL):Integer; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_get_version')]
+    function SslGetVersion(ssl: PSSL):string; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_get_peer_certificate')]
+    function SslGetPeerCertificate(s: PSSL):PX509; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CTX_set_verify')]
+    procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction); external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_get_current_cipher')]
+    function SSLGetCurrentCipher(s: PSSL): SslPtr;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CIPHER_get_name')]
+    function SSLCipherGetName(c: SslPtr):string; external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_CIPHER_get_bits')]
+    function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;  external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_get_verify_result')]
+    function SSLGetVerifyResult(ssl: PSSL):Integer;external;
+
+  [DllImport(DLLSSLName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'SSL_ctrl')]
+    function SslCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: IntPtr): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_new')]
+    function X509New: PX509; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_free')]
+    procedure X509Free(x: PX509); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_NAME_oneline')]
+    function X509NameOneline(a: PX509_NAME; buf: StringBuilder; size: Integer): string; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_get_subject_name')]
+    function X509GetSubjectName(a: PX509):PX509_NAME; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_get_issuer_name')]
+    function X509GetIssuerName(a: PX509):PX509_NAME;  external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_NAME_hash')]
+    function X509NameHash(x: PX509_NAME):Cardinal;   external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'X509_digest')]
+    function X509Digest (data: PX509; _type: PEVP_MD; md: StringBuilder; var len: Integer):Integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_set_version')]
+    function X509SetVersion(x: PX509; version: integer): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_set_pubkey')]
+    function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_set_issuer_name')]
+    function X509SetIssuerName(x: PX509; name: PX509_NAME): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_NAME_add_entry_by_txt')]
+    function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer;
+      bytes: string; len, loc, _set: integer): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_sign')]
+    function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_print')]
+    function X509print(b: PBIO; a: PX509): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_gmtime_adj')]
+    function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_set_notBefore')]
+    function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_set_notAfter')]
+    function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'X509_get_serialNumber')]
+    function X509GetSerialNumber(x: PX509): PASN1_INTEGER; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'EVP_PKEY_new')]
+    function EvpPkeyNew: EVP_PKEY; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'EVP_PKEY_free')]
+    procedure EvpPkeyFree(pk: EVP_PKEY); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'EVP_PKEY_assign')]
+    function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'EVP_get_digestbyname')]
+    function EvpGetDigestByName(Name: string): PEVP_MD; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'EVP_cleanup')]
+    procedure EVPcleanup; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'SSLeay_version')]
+    function SSLeayversion(t: integer): string; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ERR_error_string_n')]
+    procedure ErrErrorString(e: integer; buf: StringBuilder; len: integer); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ERR_get_error')]
+    function ErrGetError: integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ERR_clear_error')]
+    procedure ErrClearError; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ERR_free_strings')]
+    procedure ErrFreeStrings; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ERR_remove_state')]
+    procedure ErrRemoveState(pid: integer); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'OPENSSL_add_all_algorithms_noconf')]
+    procedure OPENSSLaddallalgorithms; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'CRYPTO_cleanup_all_ex_data')]
+    procedure CRYPTOcleanupAllExData; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'RAND_screen')]
+    procedure RandScreen; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_new')]
+    function BioNew(b: PBIO_METHOD): PBIO; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_free_all')]
+    procedure BioFreeAll(b: PBIO); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_s_mem')]
+    function BioSMem: PBIO_METHOD; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_ctrl_pending')]
+    function BioCtrlPending(b: PBIO): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_read')]
+    function BioRead(b: PBIO; Buf: StringBuilder; Len: integer): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'BIO_write')]
+    function BioWrite(b: PBIO; var Buf: string; Len: integer): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'd2i_PKCS12_bio')]
+    function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'PKCS12_parse')]
+    function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'PKCS12_free')]
+    procedure PKCS12free(p12: SslPtr); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'RSA_generate_key')]
+    function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ASN1_UTCTIME_new')]
+    function Asn1UtctimeNew: PASN1_UTCTIME; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ASN1_UTCTIME_free')]
+    procedure Asn1UtctimeFree(a: PASN1_UTCTIME); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'ASN1_INTEGER_set')]
+    function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'i2d_X509_bio')]
+    function i2dX509bio(b: PBIO; x: PX509): integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint =  'i2d_PrivateKey_bio')]
+    function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; external;
+
+  // 3DES functions
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'DES_set_odd_parity')]
+    procedure DESsetoddparity(Key: des_cblock); external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'DES_set_key_checked')]
+    function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer; external;
+
+  [DllImport(DLLUtilName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'DES_ecb_encrypt')]
+    procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); external;
+
+{$ELSE}
+// libssl.dll
+  function SslGetError(s: PSSL; ret_code: Integer):Integer;
+  function SslLibraryInit:Integer;
+  procedure SslLoadErrorStrings;
+//  function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer;
+  function SslCtxSetCipherList(arg0: PSSL_CTX; str: PByte):Integer;
+  function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
+  procedure SslCtxFree(arg0: PSSL_CTX);
+  function SslSetFd(s: PSSL; fd: Integer):Integer;
+  function SslMethodV2:PSSL_METHOD;
+  function SslMethodV3:PSSL_METHOD;
+  function SslMethodTLSV1:PSSL_METHOD;
+  function SslMethodTLSV11:PSSL_METHOD;
+  function SslMethodTLSV12:PSSL_METHOD;
+  function SslMethodV23:PSSL_METHOD;
+  function SslMethodTLS:PSSL_METHOD;
+  function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
+  function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: TSynaBytes; len: integer):Integer;
+//  function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
+  function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer;
+  function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
+  function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: TSynaBytes):Integer;
+  function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer;
+//  function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
+  function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: TSynaBytes):Integer;
+  function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
+  procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
+  procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
+//  function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
+  function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: TSynaBytes; const CApath: TSynaBytes):Integer;
+  function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
+  function SslNew(ctx: PSSL_CTX):PSSL;
+  procedure SslFree(ssl: PSSL);
+  function SslAccept(ssl: PSSL):Integer;
+  function SslConnect(ssl: PSSL):Integer;
+  function SslShutdown(ssl: PSSL):Integer;
+  function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+  function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+  function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+  function SslPending(ssl: PSSL):Integer;
+  function SslGetVersion(ssl: PSSL):string;
+  function SslGetPeerCertificate(ssl: PSSL):PX509;
+  procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
+  function SSLGetCurrentCipher(s: PSSL):SslPtr;
+  function SSLCipherGetName(c: SslPtr): string;
+  function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
+  function SSLGetVerifyResult(ssl: PSSL):Integer;
+  function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer;
+
+// libeay.dll
+  function X509New: PX509;
+  procedure X509Free(x: PX509);
+  function X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer): string;
+  function X509GetSubjectName(a: PX509):PX509_NAME;
+  function X509GetIssuerName(a: PX509):PX509_NAME;
+  function X509NameHash(x: PX509_NAME):Cardinal;
+//  function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
+  function X509Digest(data: PX509; _type: PEVP_MD; md: TSynaBytes; var len: Integer):Integer;
+  function X509print(b: PBIO; a: PX509): integer;
+  function X509SetVersion(x: PX509; version: integer): integer;
+  function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
+  function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
+  function X509NameAddEntryByTxt(name: PX509_NAME; field: TSynaBytes; _type: integer;
+    bytes: TSynaBytes; len, loc, _set: integer): integer;
+  function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
+  function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
+  function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
+  function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
+  function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
+  function EvpPkeyNew: EVP_PKEY;
+  procedure EvpPkeyFree(pk: EVP_PKEY);
+  function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
+  function EvpGetDigestByName(Name: TSynaBytes): PEVP_MD;
+  procedure EVPcleanup;
+//  function ErrErrorString(e: integer; buf: PChar): PChar;
+  function SSLeayversion(t: integer): string;
+  function OpenSSLversion(t: integer): string;
+  procedure ErrErrorString(e: integer; var buf: TSynaBytes; len: integer);
+  function ErrGetError: integer;
+  procedure ErrClearError;
+  procedure ErrFreeStrings;
+  procedure ErrRemoveState(pid: integer);
+  procedure OPENSSLaddallalgorithms;
+  procedure CRYPTOcleanupAllExData;
+  procedure RandScreen;
+  function BioNew(b: PBIO_METHOD): PBIO;
+  procedure BioFreeAll(b: PBIO);
+  function BioSMem: PBIO_METHOD;
+  function BioCtrlPending(b: PBIO): integer;
+  function BioRead(b: PBIO; Buf: PByte; Len: integer): integer;
+  function BioWrite(b: PBIO; Buf: PByte; Len: integer): integer;
+  function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
+  function PKCS12parse(p12: SslPtr; pass: TSynaBytes; var pkey, cert, ca: SslPtr): integer;
+  procedure PKCS12free(p12: SslPtr);
+  function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
+  function Asn1UtctimeNew: PASN1_UTCTIME;
+  procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
+  function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
+  function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf}
+  function i2dX509bio(b: PBIO; x: PX509): integer;
+  function d2iX509bio(b:PBIO; x:PX509):  PX509;    {pf}
+  function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr):  PX509;    {pf}
+  procedure SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); {pf}
+
+
+  function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
+
+  // 3DES functions
+  procedure DESsetoddparity(Key: des_cblock);
+  function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
+  procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
+
+{$ENDIF}
+
+function IsSSLloaded: Boolean;
+function InitSSLInterface: Boolean;
+function DestroySSLInterface: Boolean;
+
+var
+  _X509Free: TX509Free = nil; {pf}
+
+implementation
+
+uses
+{$IFDEF OS2}
+  Sockets,
+{$ENDIF OS2}
+  SyncObjs;
+
+{$IFNDEF CIL}
+
+{$IFNDEF STATIC}
+type
+// libssl.dll
+  TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl;
+  TSslLibraryInit = function:Integer; cdecl;
+  TSslLoadErrorStrings = procedure; cdecl;
+  TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PByte):Integer; cdecl;
+  TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl;
+  TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl;
+  TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl;
+  TSslMethodV2 = function:PSSL_METHOD; cdecl;
+  TSslMethodV3 = function:PSSL_METHOD; cdecl;
+  TSslMethodTLSV1 = function:PSSL_METHOD; cdecl;
+  TSslMethodTLSV11 = function:PSSL_METHOD; cdecl;
+  TSslMethodTLSV12 = function:PSSL_METHOD; cdecl;
+  TSslMethodV23 = function:PSSL_METHOD; cdecl;
+  TSslMethodTLS = function:PSSL_METHOD; cdecl;
+  TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl;
+  TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl;
+  TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;
+  TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl;
+  TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl;
+  TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;
+  TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PByte):Integer; cdecl;
+  TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl;
+  TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl;
+  TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl;
+  TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PByte; const CApath: PByte):Integer; cdecl;
+  TSslCtxCtrl = function(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl;
+  TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl;
+  TSslFree = procedure(ssl: PSSL); cdecl;
+  TSslAccept = function(ssl: PSSL):Integer; cdecl;
+  TSslConnect = function(ssl: PSSL):Integer; cdecl;
+  TSslShutdown = function(ssl: PSSL):Integer; cdecl;
+  TSslRead = function(ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;
+  TSslPeek = function(ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;
+  TSslWrite = function(ssl: PSSL; const buf: PByte; num: Integer):Integer; cdecl;
+  TSslPending = function(ssl: PSSL):Integer; cdecl;
+  TSslGetVersion = function(ssl: PSSL):PByte; cdecl;
+  TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl;
+  TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl;
+  TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl;
+  TSSLCipherGetName = function(c: Sslptr):PByte; cdecl;
+  TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl;
+  TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl;
+  TSSLCtrl = function(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl;
+
+  TSSLSetTlsextHostName = function(ssl: PSSL; buf: PAnsiChar):Integer; cdecl;
+
+// libeay.dll
+  TX509New = function: PX509; cdecl;
+  TX509NameOneline = function(a: PX509_NAME; buf: PByte; size: Integer):PByte; cdecl;
+  TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl;
+  TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl;
+  TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl;
+  TX509Digest = function(data: PX509; _type: PEVP_MD; md: PByte; len: PInteger):Integer; cdecl;
+  TX509print = function(b: PBIO; a: PX509): integer; cdecl;
+  TX509SetVersion = function(x: PX509; version: integer): integer; cdecl;
+  TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl;
+  TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl;
+  TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PByte; _type: integer;
+    bytes: PByte; len, loc, _set: integer): integer; cdecl;
+  TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl;
+  TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl;
+  TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
+  TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
+  TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl;
+  TEvpPkeyNew = function: EVP_PKEY; cdecl;
+  TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl;
+  TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl;
+  TEvpGetDigestByName = function(Name: PByte): PEVP_MD; cdecl;
+  TEVPcleanup = procedure; cdecl;
+  TSSLeayversion = function(t: integer): PByte; cdecl;
+  TOpenSSLversion = function(t: integer): PByte; cdecl;
+  TErrErrorString = procedure(e: integer; buf: PByte; len: integer); cdecl;
+  TErrGetError = function: integer; cdecl;
+  TErrClearError = procedure; cdecl;
+  TErrFreeStrings = procedure; cdecl;
+  TErrRemoveState = procedure(pid: integer); cdecl;
+  TOPENSSLaddallalgorithms = procedure; cdecl;
+  TCRYPTOcleanupAllExData = procedure; cdecl;
+  TRandScreen = procedure; cdecl;
+  TBioNew = function(b: PBIO_METHOD): PBIO; cdecl;
+  TBioFreeAll = procedure(b: PBIO); cdecl;
+  TBioSMem = function: PBIO_METHOD; cdecl;
+  TBioCtrlPending = function(b: PBIO): integer; cdecl;
+  TBioRead = function(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;
+  TBioWrite = function(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;
+  Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl;
+  TPKCS12parse = function(p12: SslPtr; pass: PByte; var pkey, cert, ca: SslPtr): integer; cdecl;
+  TPKCS12free = procedure(p12: SslPtr); cdecl;
+  TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl;
+  TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl;
+  TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl;
+  TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl;
+  TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl; {pf}
+  Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl;
+  Td2iX509bio = function(b:PBIO;  x:PX509):   PX509;   cdecl; {pf}
+  TPEMReadBioX509 = function(b:PBIO;  {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509;   cdecl; {pf}
+  TSkX509PopFree = procedure(st: PSTACK; func: TSkPopFreeFunc); cdecl; {pf}
+  Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl;
+
+  // 3DES functions
+  TDESsetoddparity = procedure(Key: des_cblock); cdecl;
+  TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl;
+  TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl;
+  //thread lock functions
+  TCRYPTOnumlocks = function: integer; cdecl;
+  TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl;
+
+var
+// libssl.dll
+  _SslGetError: TSslGetError = nil;
+  _SslLibraryInit: TSslLibraryInit = nil;
+  _SslLoadErrorStrings: TSslLoadErrorStrings = nil;
+  _SslCtxSetCipherList: TSslCtxSetCipherList = nil;
+  _SslCtxNew: TSslCtxNew = nil;
+  _SslCtxFree: TSslCtxFree = nil;
+  _SslSetFd: TSslSetFd = nil;
+  _SslMethodV2: TSslMethodV2 = nil;
+  _SslMethodV3: TSslMethodV3 = nil;
+  _SslMethodTLSV1: TSslMethodTLSV1 = nil;
+  _SslMethodTLSV11: TSslMethodTLSV11 = nil;
+  _SslMethodTLSV12: TSslMethodTLSV12 = nil;
+  _SslMethodV23: TSslMethodV23 = nil;
+  _SslMethodTLS: TSslMethodTLS = nil;
+  _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil;
+  _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil;
+  _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil;
+  _SslCtxUseCertificate: TSslCtxUseCertificate = nil;
+  _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil;
+  _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil;
+  _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil;
+  _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil;
+  _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil;
+  _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil;
+  _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil;
+  _SslCtxCtrl: TSslCtxCtrl = nil;
+  _SslNew: TSslNew = nil;
+  _SslFree: TSslFree = nil;
+  _SslAccept: TSslAccept = nil;
+  _SslConnect: TSslConnect = nil;
+  _SslShutdown: TSslShutdown = nil;
+  _SslRead: TSslRead = nil;
+  _SslPeek: TSslPeek = nil;
+  _SslWrite: TSslWrite = nil;
+  _SslPending: TSslPending = nil;
+  _SslGetVersion: TSslGetVersion = nil;
+  _SslGetPeerCertificate: TSslGetPeerCertificate = nil;
+  _SslCtxSetVerify: TSslCtxSetVerify = nil;
+  _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil;
+  _SSLCipherGetName: TSSLCipherGetName = nil;
+  _SSLCipherGetBits: TSSLCipherGetBits = nil;
+  _SSLGetVerifyResult: TSSLGetVerifyResult = nil;
+  _SSLCtrl: TSSLCtrl = nil;
+
+// libeay.dll
+  _X509New: TX509New = nil;
+  _X509NameOneline: TX509NameOneline = nil;
+  _X509GetSubjectName: TX509GetSubjectName = nil;
+  _X509GetIssuerName: TX509GetIssuerName = nil;
+  _X509NameHash: TX509NameHash = nil;
+  _X509Digest: TX509Digest = nil;
+  _X509print: TX509print = nil;
+  _X509SetVersion: TX509SetVersion = nil;
+  _X509SetPubkey: TX509SetPubkey = nil;
+  _X509SetIssuerName: TX509SetIssuerName = nil;
+  _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil;
+  _X509Sign: TX509Sign = nil;
+  _X509GmtimeAdj: TX509GmtimeAdj = nil;
+  _X509SetNotBefore: TX509SetNotBefore = nil;
+  _X509SetNotAfter: TX509SetNotAfter = nil;
+  _X509GetSerialNumber: TX509GetSerialNumber = nil;
+  _EvpPkeyNew: TEvpPkeyNew = nil;
+  _EvpPkeyFree: TEvpPkeyFree = nil;
+  _EvpPkeyAssign: TEvpPkeyAssign = nil;
+  _EvpGetDigestByName: TEvpGetDigestByName = nil;
+  _EVPcleanup: TEVPcleanup = nil;
+  _SSLeayversion: TSSLeayversion = nil;
+  _OpenSSLversion: TOpenSSLversion = nil;
+  _ErrErrorString: TErrErrorString = nil;
+  _ErrGetError: TErrGetError = nil;
+  _ErrClearError: TErrClearError = nil;
+  _ErrFreeStrings: TErrFreeStrings = nil;
+  _ErrRemoveState: TErrRemoveState = nil;
+  _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil;
+  _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil;
+  _RandScreen: TRandScreen = nil;
+  _BioNew: TBioNew = nil;
+  _BioFreeAll: TBioFreeAll = nil;
+  _BioSMem: TBioSMem = nil;
+  _BioCtrlPending: TBioCtrlPending = nil;
+  _BioRead: TBioRead = nil;
+  _BioWrite: TBioWrite = nil;
+  _d2iPKCS12bio: Td2iPKCS12bio = nil;
+  _PKCS12parse: TPKCS12parse = nil;
+  _PKCS12free: TPKCS12free = nil;
+  _RsaGenerateKey: TRsaGenerateKey = nil;
+  _Asn1UtctimeNew: TAsn1UtctimeNew = nil;
+  _Asn1UtctimeFree: TAsn1UtctimeFree = nil;
+  _Asn1IntegerSet: TAsn1IntegerSet = nil;
+  _Asn1IntegerGet: TAsn1IntegerGet = nil; {pf}
+  _i2dX509bio: Ti2dX509bio = nil;
+  _d2iX509bio: Td2iX509bio = nil; {pf}
+  _PEMReadBioX509: TPEMReadBioX509 = nil; {pf}
+  _SkX509PopFree: TSkX509PopFree = nil; {pf}
+  _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil;
+
+  // 3DES functions
+  _DESsetoddparity: TDESsetoddparity = nil;
+  _DESsetkeychecked: TDESsetkeychecked = nil;
+  _DESecbencrypt: TDESecbencrypt = nil;
+  //thread lock functions
+  _CRYPTOnumlocks: TCRYPTOnumlocks = nil;
+  _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil;
+{$ELSE STATIC} 
+// libssl.dll
+   function _SslGetError(s: PSSL; ret_code: Integer):Integer; cdecl; external DLLSSLName name 'SSL_get_error';
+  function _SslLibraryInit(): integer; cdecl; external DLLSSLName name 'SSL_library_init';
+  procedure _SslLoadErrorStrings(); cdecl;external DLLSSLName name 'SSL_load_error_strings';
+  function _SslCtxSetCipherList (arg0: PSSL_CTX; str: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_set_cipher_list';
+  function _SslCtxNew (meth: PSSL_METHOD):PSSL_CTX; cdecl;external DLLSSLName name 'SSL_CTX_new';
+  procedure _SslCtxFree(arg0: PSSL_CTX); cdecl;external DLLSSLName name 'SSL_CTX_free';
+  function _SslSetFd (s: PSSL; fd: Integer):Integer; cdecl;external DLLSSLName name 'SSL_set_fd';
+  function _SslMethodV2():PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv2_method';
+  function _SslMethodV3():PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv3_method';
+  function _SslMethodTLSV1:PSSL_METHOD; cdecl;external DLLSSLName name 'TLSv1_method';
+  function _SslMethodV23:PSSL_METHOD; cdecl;external DLLSSLName name 'SSLv23_method';
+  function _SslCtxUsePrivateKey (ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_PrivateKey';
+  function _SslCtxUsePrivateKeyASN1 (pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_PrivateKey_ASN1';
+  function _SslCtxUsePrivateKeyFile (ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_RSAPrivateKey_file';
+  function _SslCtxUseCertificate (ctx: PSSL_CTX; x: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate';
+  function _SslCtxUseCertificateASN1 (ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_ASN1';
+  function _SslCtxUseCertificateFile (ctx: PSSL_CTX; const _file: PByte; _type: Integer):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_file';
+  function _SslCtxUseCertificateChainFile (ctx: PSSL_CTX; const _file: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_use_certificate_chain_file';
+  function _SslCtxCheckPrivateKeyFile (ctx: PSSL_CTX):Integer; cdecl;external DLLSSLName name 'SSL_CTX_check_private_key';
+  procedure _SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_default_passwd_cb';
+  procedure _SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_default_passwd_cb_userdata';
+  function _SslCtxLoadVerifyLocations (ctx: PSSL_CTX; const CAfile: PByte; const CApath: PByte):Integer; cdecl;external DLLSSLName name 'SSL_CTX_load_verify_locations';
+  function _SslCtxCtrl (ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer; cdecl;external DLLSSLName name 'SSL_CTX_ctrl';
+  function _SslNew (ctx: PSSL_CTX):PSSL; cdecl;external DLLSSLName name 'SSL_new';
+  procedure _SslFree(ssl: PSSL); cdecl;external DLLSSLName name 'SSL_free';
+  function _SslAccept (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_accept';
+  function _SslConnect (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_connect';
+  function _SslShutdown (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_shutdown';
+  function _SslRead (ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_read';
+  function _SslPeek (ssl: PSSL; buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_peek';
+  function _SslWrite (ssl: PSSL; const buf: PByte; num: Integer):Integer; cdecl;external DLLSSLName name 'SSL_write';
+  function _SslPending (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_pending';
+  function _SslGetVersion (ssl: PSSL):PByte; cdecl;external DLLSSLName name 'SSL_get_version';
+  function _SslGetPeerCertificate (ssl: PSSL):PX509; cdecl;external DLLSSLName name 'SSL_get_peer_certificate';
+  procedure _SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl;external DLLSSLName name 'SSL_CTX_set_verify';
+  function _SslGetCurrentCipher (s: PSSL):SslPtr; cdecl;external DLLSSLName name 'SSL_get_current_cipher';
+  function _SslCipherGetName (c: Sslptr):PByte; cdecl;external DLLSSLName name 'SSL_CIPHER_get_name';
+  function _SslCipherGetBits (c: SslPtr; alg_bits: PInteger):Integer; cdecl;external DLLSSLName name 'SSL_CIPHER_get_bits';
+  function _SslGetVerifyResult (ssl: PSSL):Integer; cdecl;external DLLSSLName name 'SSL_get_verify_result';
+  function _SslCtrl (ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer; cdecl;external DLLSSLName name 'SSL_ctrl';
+
+// libeay.dll
+  function _X509New: PX509; cdecl;external DLLUtilName name 'X509_new';
+  function _X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer):PByte; cdecl;external DLLUtilName name 'X509_NAME_oneline';
+  function _X509GetSubjectName(a: PX509):PX509_NAME; cdecl;external DLLUtilName name 'X509_get_subject_name';
+  function _X509GetIssuerName(a: PX509):PX509_NAME; cdecl;external DLLUtilName name 'X509_get_issuer_name';
+  function _X509NameHash(x: PX509_NAME):Cardinal; cdecl;external DLLUtilName name 'X509_NAME_hash';
+  function _X509Digest(data: PX509; _type: PEVP_MD; md: PByte; len: PInteger):Integer; cdecl;external DLLUtilName name 'X509_digest';
+  function _X509print(b: PBIO; a: PX509): integer; cdecl;external DLLUtilName name 'X509_print';
+  function _X509SetVersion(x: PX509; version: integer): integer; cdecl;external DLLUtilName name 'X509_set_version';
+  function _X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer; cdecl;external DLLUtilName name 'X509_set_pubkey';
+  function _X509SetIssuerName(x: PX509; name: PX509_NAME): integer; cdecl;external DLLUtilName name 'X509_set_issuer_name';
+  function _X509NameAddEntryByTxt(name: PX509_NAME; field: PByte; _type: integer;
+    bytes: PByte; len, loc, _set: integer): integer; cdecl;external DLLUtilName name 'X509_NAME_add_entry_by_txt';
+  function _X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl;external DLLUtilName name 'X509_sign';
+  function _X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl;external DLLUtilName name 'X509_gmtime_adj';
+  function _X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;external DLLUtilName name 'X509_set_notBefore';
+  function _X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;external DLLUtilName name 'X509_set_notAfter';
+  function _X509GetSerialNumber(x: PX509): PASN1_INTEGER; cdecl;external DLLUtilName name 'X509_get_serialNumber';
+  function _EvpPkeyNew: EVP_PKEY; cdecl;external DLLUtilName name 'EVP_PKEY_new';
+  procedure _EvpPkeyFree(pk: EVP_PKEY); cdecl;external DLLUtilName name 'EVP_PKEY_free';
+  function _EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl;external DLLUtilName name 'EVP_PKEY_assign';
+  function _EvpGetDigestByName(Name: PByte): PEVP_MD; cdecl;external DLLUtilName name 'EVP_get_digestbyname';
+  procedure _EVPcleanup; cdecl;external DLLUtilName name 'EVP_cleanup';
+  function _SSLeayversion(t: integer): PByte; cdecl;external DLLUtilName name 'SSLeay_version';
+  procedure _ErrErrorString(e: integer; buf: PByte; len: integer); cdecl;external DLLUtilName name 'ERR_error_string_n';
+  function _ErrGetError: integer; cdecl;external DLLUtilName name 'ERR_get_error';
+  procedure _ErrClearError; cdecl;external DLLUtilName name 'ERR_clear_error';
+  procedure _ErrFreeStrings; cdecl;external DLLUtilName name 'ERR_free_strings';
+  procedure _ErrRemoveState(pid: integer); cdecl;external DLLUtilName name 'ERR_remove_state';
+  procedure _OPENSSLaddallalgorithms; cdecl;external DLLUtilName name 'OPENSSL_add_all_algorithms_noconf';
+  procedure _CRYPTOcleanupAllExData; cdecl;external DLLUtilName name 'CRYPTO_cleanup_all_ex_data';
+  procedure _RandScreen; cdecl;external DLLUtilName name 'RAND_screen';
+  function _BioNew(b: PBIO_METHOD): PBIO; cdecl;external DLLUtilName name 'BIO_new';
+  procedure _BioFreeAll(b: PBIO); cdecl;external DLLUtilName name 'BIO_free_all';
+  function _BioSMem: PBIO_METHOD; cdecl;external DLLUtilName name 'BIO_s_mem';
+  function _BioCtrlPending(b: PBIO): integer; cdecl;external DLLUtilName name 'BIO_ctrl_pending';
+  function _BioRead(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;external DLLUtilName name 'BIO_read';
+  function _BioWrite(b: PBIO; Buf: PByte; Len: integer): integer; cdecl;external DLLUtilName name 'BIO_write';
+  function _d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl;external DLLUtilName name 'd2i_PKCS12_bio';
+  function _PKCS12parse(p12: SslPtr; pass: PByte; var pkey, cert, ca: SslPtr): integer; cdecl;external DLLUtilName name 'PKCS12_parse';
+  procedure _PKCS12free(p12: SslPtr); cdecl;external DLLUtilName name 'PKCS12_free';
+  function _RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl;external DLLUtilName name 'RSA_generate_key';
+  function _Asn1UtctimeNew: PASN1_UTCTIME; cdecl;external DLLUtilName name 'ASN1_UTCTIME_new';
+  procedure _Asn1UtctimeFree(a: PASN1_UTCTIME); cdecl;external DLLUtilName name 'ASN1_UTCTIME_free';
+  function _Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer; cdecl;external DLLUtilName name 'ASN1_INTEGER_set';
+  function _Asn1IntegerGet(a: PASN1_INTEGER): integer; cdecl;external DLLUtilName name 'ASN1_INTEGER_get';
+  function _i2dX509bio(b: PBIO; x: PX509): integer; cdecl;external DLLUtilName name 'i2d_X509_bio';
+  function _d2iX509bio(b:PBIO;  x:PX509):   PX509;   cdecl; external DLLUtilName name 'd2i_X509_bio';
+  function _PEMReadBioX509(b:PBIO;  {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl; external DLLUtilName name 'PEM_read_bio_X509';
+{$IFNDEF MSWINDOWS}
+  procedure _SkX509PopFree(st: PSTACK; func: TSkPopFreeFunc); cdecl; external DLLUtilName name 'sk_X509_pop_free';
+{$ENDIF}
+  function _i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer; cdecl;external DLLUtilName name 'i2d_PrivateKey_bio';
+
+
+  // 3DES functions
+  procedure _DESsetoddparity(Key: des_cblock); cdecl;external DLLUtilName name 'DES_set_odd_parity';
+  function _DESsetkeychecked (key: des_cblock; schedule: des_key_schedule): Integer; cdecl;external DLLUtilName name 'DES_set_key_checked';
+  procedure _DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl;external DLLUtilName name 'DES_ecb_encrypt';
+  //thread lock functions
+  function _CRYPTOnumlocks: integer; cdecl;external DLLUtilName name 'CRYPTO_num_locks';
+  procedure _CRYPTOSetLockingCallback(cb: Sslptr); cdecl; external DLLUtilName name 'CRYPTO_set_locking_callback';
+{$ENDIF}
+{$ENDIF}
+
+
+var
+  SSLCS: TCriticalSection;
+  SSLloaded: boolean = false;
+{$IFNDEF CIL}
+  Locks: Array of TCriticalSection;
+{$ENDIF}
+
+{$IFNDEF CIL}
+// libssl.dll
+function SslGetError(s: PSSL; ret_code: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetError){$ENDIF} then
+    Result := _SslGetError(s, ret_code)
+  else
+    Result := SSL_ERROR_SSL;
+end;
+
+function SslLibraryInit:Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslLibraryInit){$ENDIF} then
+    Result := _SslLibraryInit
+  else
+    Result := 1;
+end;
+
+procedure SslLoadErrorStrings;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslLoadErrorStrings){$ENDIF} then
+    _SslLoadErrorStrings;
+end;
+
+function SslCtxSetCipherList(arg0: PSSL_CTX; str: PByte):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetCipherList){$ENDIF} then
+    Result := _SslCtxSetCipherList(arg0, str)
+  else
+    Result := 0;
+end;
+
+function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxNew){$ENDIF} then
+    Result := _SslCtxNew(meth)
+  else
+    Result := nil;
+end;
+
+procedure SslCtxFree(arg0: PSSL_CTX);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxFree){$ENDIF} then
+    _SslCtxFree(arg0);
+end;
+
+function SslSetFd(s: PSSL; fd: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslSetFd){$ENDIF} then
+    Result := _SslSetFd(s, fd)
+  else
+    Result := 0;
+end;
+
+function SslMethodV2:PSSL_METHOD;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV2){$ENDIF} then
+    Result := _SslMethodV2
+  else
+    Result := nil;
+end;
+
+function SslMethodV3:PSSL_METHOD;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV3){$ENDIF} then
+    Result := _SslMethodV3
+  else
+    Result := nil;
+end;
+
+function SslMethodTLSV1:PSSL_METHOD;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodTLSV1){$ENDIF} then
+    Result := _SslMethodTLSV1
+  else
+    Result := nil;
+end;
+
+function SslMethodTLSV11:PSSL_METHOD;
+begin
+  if InitSSLInterface and Assigned(_SslMethodTLSV11) then
+    Result := _SslMethodTLSV11
+  else
+    Result := nil;
+end;
+
+function SslMethodTLSV12:PSSL_METHOD;
+begin
+  if InitSSLInterface and Assigned(_SslMethodTLSV12) then
+    Result := _SslMethodTLSV12
+  else
+    Result := nil;
+end;
+
+function SslMethodV23:PSSL_METHOD;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslMethodV23){$ENDIF} then
+    Result := _SslMethodV23
+  else
+    Result := nil;
+end;
+
+function SslMethodTLS:PSSL_METHOD;
+begin
+  if InitSSLInterface and Assigned(_SslMethodTLS) then
+    Result := _SslMethodTLS
+  else
+    Result := nil;
+end;
+
+function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKey){$ENDIF} then
+    Result := _SslCtxUsePrivateKey(ctx, pkey)
+  else
+    Result := 0;
+end;
+
+function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: TSynaBytes; len: integer):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKeyASN1){$ENDIF} then
+  begin
+    {$IFDEF UNICODE}
+      buf :=  TSynaBytes(d).Data;
+    {$ELSE}
+      buf := PByte(d);
+    {$ENDIF}
+    Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(buf), len)
+  end
+  else
+    Result := 0;
+end;
+
+//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
+function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUsePrivateKeyFile){$ENDIF} then
+  begin
+  {$IFDEF UNICODE}
+      buf :=  TSynaBytes(_file).Data;
+    {$ELSE}
+      buf := Pointer(_file);
+    {$ENDIF}
+    Result := _SslCtxUsePrivateKeyFile(ctx, buf, _type)
+  end
+  else
+    Result := 0;
+end;
+
+function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificate){$ENDIF} then
+    Result := _SslCtxUseCertificate(ctx, x)
+  else
+    Result := 0;
+end;
+
+function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: TSynaBytes):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateASN1){$ENDIF} then
+  begin
+    {$IFDEF UNICODE}
+      buf :=  TSynaBytes(d).Data;
+    {$ELSE}
+      buf := PByte(d);
+    {$ENDIF}
+    Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(buf))
+  end
+  else
+    Result := 0;
+end;
+
+function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: TSynaBytes; _type: Integer):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateFile){$ENDIF} then
+  begin
+   {$IFDEF UNICODE}
+      buf :=  TSynaBytes(_file).Data;
+    {$ELSE}
+      buf := PByte(_file);
+    {$ENDIF}
+    Result := _SslCtxUseCertificateFile(ctx, buf, _type)
+  end
+   else
+    Result := 0;
+end;
+
+//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
+function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: TSynaBytes):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxUseCertificateChainFile){$ENDIF} then
+  begin
+    {$IFDEF UNICODE}
+      buf :=  TSynaBytes(_file).Data;
+    {$ELSE}
+      buf := Pointer(_file);
+    {$ENDIF}
+    Result := _SslCtxUseCertificateChainFile(ctx, buf)
+  end
+  else
+    Result := 0;
+end;
+
+function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxCheckPrivateKeyFile){$ENDIF} then
+    Result := _SslCtxCheckPrivateKeyFile(ctx)
+  else
+    Result := 0;
+end;
+
+procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetDefaultPasswdCb){$ENDIF} then
+    _SslCtxSetDefaultPasswdCb(ctx, cb);
+end;
+
+procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetDefaultPasswdCbUserdata){$ENDIF} then
+    _SslCtxSetDefaultPasswdCbUserdata(ctx, u);
+end;
+
+//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
+function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: TSynaBytes; const CApath: TSynaBytes):Integer;
+var buf,path: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxLoadVerifyLocations){$ENDIF} then
+  begin
+   {$IFDEF UNICODE}
+      buf :=  TSynaBytes(CAfile).Data;
+      path := TSynaBytes(CApath).Data;
+    {$ELSE}
+      buf := PByte(CAfile);
+      path := PByte(CApath);
+    {$ENDIF}
+    Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(buf), SslPtr(path))
+  end
+  else
+    Result := 0;
+end;
+
+function SslCtxCtrl(ctx: PSSL_CTX; cmd: integer; larg: integer; parg: SslPtr): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxCtrl){$ENDIF} then
+    Result := _SslCtxCtrl(ctx, cmd, larg, parg)
+  else
+    Result := 0;
+end;
+
+function SslNew(ctx: PSSL_CTX):PSSL;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslNew){$ENDIF} then
+    Result := _SslNew(ctx)
+  else
+    Result := nil;
+end;
+
+procedure SslFree(ssl: PSSL);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslFree){$ENDIF} then
+    _SslFree(ssl);
+end;
+
+function SslAccept(ssl: PSSL):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslAccept) {$ENDIF}then
+    Result := _SslAccept(ssl)
+  else
+    Result := -1;
+end;
+
+function SslConnect(ssl: PSSL):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslConnect) {$ENDIF}then
+    Result := _SslConnect(ssl)
+  else
+    Result := -1;
+end;
+
+function SslShutdown(ssl: PSSL):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslShutdown){$ENDIF} then
+    Result := _SslShutdown(ssl)
+  else
+    Result := -1;
+end;
+
+//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer;
+function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslRead) {$ENDIF}then
+    Result := _SslRead(ssl, PByte(buf), num)
+  else
+    Result := -1;
+end;
+
+//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer;
+function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslPeek){$ENDIF} then
+    Result := _SslPeek(ssl, PByte(buf), num)
+  else
+    Result := -1;
+end;
+
+//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer;
+function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslWrite){$ENDIF} then
+    Result := _SslWrite(ssl, PByte(buf), num)
+  else
+    Result := -1;
+end;
+
+function SslPending(ssl: PSSL):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslPending){$ENDIF} then
+    Result := _SslPending(ssl)
+  else
+    Result := 0;
+end;
+
+//function SslGetVersion(ssl: PSSL):PChar;
+function SslGetVersion(ssl: PSSL):string;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetVersion){$ENDIF} then
+    Result := synabyte.StringOf(_SslGetVersion(ssl))
+  else
+    Result := '';
+end;
+
+function SslGetPeerCertificate(ssl: PSSL):PX509;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslGetPeerCertificate){$ENDIF} then
+    Result := _SslGetPeerCertificate(ssl)
+  else
+    Result := nil;
+end;
+
+//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr);
+procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SslCtxSetVerify){$ENDIF} then
+    _SslCtxSetVerify(ctx, mode, @arg2);
+end;
+
+function SSLGetCurrentCipher(s: PSSL):SslPtr;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLGetCurrentCipher){$ENDIF} then
+{$IFDEF CIL}
+{$ELSE}
+    Result := _SSLGetCurrentCipher(s)
+{$ENDIF}
+  else
+    Result := nil;
+end;
+
+//function SSLCipherGetName(c: SslPtr):PChar;
+function SSLCipherGetName(c: SslPtr):string;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCipherGetName){$ENDIF} then
+    Result := synabyte.StringOf(_SSLCipherGetName(c))
+  else
+    Result := '';
+end;
+
+//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer;
+function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCipherGetBits){$ENDIF} then
+    Result := _SSLCipherGetBits(c, @alg_bits)
+  else
+    Result := 0;
+end;
+
+function SSLGetVerifyResult(ssl: PSSL):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLGetVerifyResult){$ENDIF} then
+    Result := _SSLGetVerifyResult(ssl)
+  else
+    Result := X509_V_ERR_APPLICATION_VERIFICATION;
+end;
+
+
+function SSLCtrl(ssl: PSSL; cmd: integer; larg: integer; parg: SslPtr):Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLCtrl){$ENDIF} then
+    Result := _SSLCtrl(ssl, cmd, larg, parg)
+  else
+    Result := X509_V_ERR_APPLICATION_VERIFICATION;
+end;
+
+// libeay.dll
+function X509New: PX509;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509New){$ENDIF} then
+    Result := _X509New
+  else
+    Result := nil;
+end;
+
+procedure X509Free(x: PX509);
+begin
+  if InitSSLInterface and Assigned(_X509Free) then
+    _X509Free(x);
+end;
+
+function X509NameOneline(a: PX509_NAME; buf: PByte; size: Integer): string;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameOneline){$ENDIF} then
+    Result := synabyte.StringOf(_X509NameOneline(a, buf,size))
+  else
+    Result := '';
+end;
+
+function X509GetSubjectName(a: PX509):PX509_NAME;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetSubjectName){$ENDIF} then
+    Result := _X509GetSubjectName(a)
+  else
+    Result := nil;
+end;
+
+function X509GetIssuerName(a: PX509):PX509_NAME;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetIssuerName){$ENDIF} then
+    Result := _X509GetIssuerName(a)
+  else
+    Result := nil;
+end;
+
+function X509NameHash(x: PX509_NAME):Cardinal;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameHash){$ENDIF} then
+    Result := _X509NameHash(x)
+  else
+    Result := 0;
+end;
+
+//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
+function X509Digest(data: PX509; _type: PEVP_MD; md: TSynaBytes; var len: Integer):Integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509Digest){$ENDIF} then
+  begin
+  {$IFDEF UNICODE}
+      buf :=  TSynaBytes(md).Data;
+    {$ELSE}
+      buf := PByte(md);
+    {$ENDIF}
+    Result := _X509Digest(data, _type, buf, @len)
+  end
+  else
+    Result := 0;
+end;
+
+function EvpPkeyNew: EVP_PKEY;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyNew){$ENDIF} then
+    Result := _EvpPkeyNew
+  else
+    Result := nil;
+end;
+
+procedure EvpPkeyFree(pk: EVP_PKEY);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyFree){$ENDIF} then
+    _EvpPkeyFree(pk);
+end;
+
+function SSLeayversion(t: integer): string;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SSLeayversion){$ENDIF} then
+    Result := synabyte.StringOf(_SSLeayversion(t))
+  else
+    Result := '';
+end;
+
+function OpenSSLversion(t: integer): string;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_OpenSSLversion){$ENDIF} then
+    Result := synabyte.StringOf(_OpenSSLversion(t))
+  else
+    Result := '';
+end;
+
+procedure ErrErrorString(e: integer; var buf: TSynaBytes; len: integer);
+var ptr: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrErrorString){$ENDIF} then
+  begin
+    {$IFDEF UNICODE}
+      ptr :=  TSynaBytes(buf).Data;
+    {$ELSE}
+      ptr := PByte(buf);
+    {$ENDIF}
+    _ErrErrorString(e, ptr, len);
+  end;
+end;
+
+function ErrGetError: integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrGetError){$ENDIF} then
+    Result := _ErrGetError
+  else
+    Result := SSL_ERROR_SSL;
+end;
+
+procedure ErrClearError;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrClearError){$ENDIF} then
+    _ErrClearError;
+end;
+
+procedure ErrFreeStrings;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrFreeStrings){$ENDIF} then
+    _ErrFreeStrings;
+end;
+
+procedure ErrRemoveState(pid: integer);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_ErrRemoveState){$ENDIF} then
+    _ErrRemoveState(pid);
+end;
+
+procedure OPENSSLaddallalgorithms;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_OPENSSLaddallalgorithms){$ENDIF} then
+    _OPENSSLaddallalgorithms;
+end;
+
+procedure EVPcleanup;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EVPcleanup){$ENDIF} then
+    _EVPcleanup;
+end;
+
+procedure CRYPTOcleanupAllExData;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_CRYPTOcleanupAllExData){$ENDIF} then
+    _CRYPTOcleanupAllExData;
+end;
+
+procedure RandScreen;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_RandScreen){$ENDIF} then
+    _RandScreen;
+end;
+
+function BioNew(b: PBIO_METHOD): PBIO;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioNew){$ENDIF} then
+    Result := _BioNew(b)
+  else
+    Result := nil;
+end;
+
+procedure BioFreeAll(b: PBIO);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioFreeAll){$ENDIF} then
+    _BioFreeAll(b);
+end;
+
+function BioSMem: PBIO_METHOD;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioSMem){$ENDIF} then
+    Result := _BioSMem
+  else
+    Result := nil;
+end;
+
+function BioCtrlPending(b: PBIO): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioCtrlPending){$ENDIF} then
+    Result := _BioCtrlPending(b)
+  else
+    Result := 0;
+end;
+
+//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer;
+function BioRead(b: PBIO; Buf: PByte; Len: integer): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioRead){$ENDIF} then
+    Result := _BioRead(b, buf, Len)
+  else
+    Result := -2;
+end;
+
+//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer;
+function BioWrite(b: PBIO; Buf: PByte; Len: integer): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_BioWrite){$ENDIF} then
+    Result := _BioWrite(b, Buf, Len)
+  else
+    Result := -2;
+end;
+
+function X509print(b: PBIO; a: PX509): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509print){$ENDIF} then
+    Result := _X509print(b, a)
+  else
+    Result := 0;
+end;
+
+function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iPKCS12bio){$ENDIF} then
+    Result := _d2iPKCS12bio(b, Pkcs12)
+  else
+    Result := nil;
+end;
+
+function PKCS12parse(p12: SslPtr; pass: TSynaBytes; var pkey, cert, ca: SslPtr): integer;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PKCS12parse){$ENDIF} then
+  begin
+     {$IFDEF UNICODE}
+      buf :=  TSynaBytes(pass).Data;
+    {$ELSE}
+      buf := Pointer(pass);
+    {$ENDIF}
+    Result := _PKCS12parse(p12, SslPtr(buf), pkey, cert, ca)
+  end
+  else
+    Result := 0;
+end;
+
+procedure PKCS12free(p12: SslPtr);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PKCS12free){$ENDIF} then
+    _PKCS12free(p12);
+end;
+
+function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_RsaGenerateKey){$ENDIF} then
+    Result := _RsaGenerateKey(bits, e, callback, cb_arg)
+  else
+    Result := nil;
+end;
+
+function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpPkeyAssign){$ENDIF} then
+    Result := _EvpPkeyAssign(pkey, _type, key)
+  else
+    Result := 0;
+end;
+
+function X509SetVersion(x: PX509; version: integer): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetVersion){$ENDIF} then
+    Result := _X509SetVersion(x, version)
+  else
+    Result := 0;
+end;
+
+function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetPubkey){$ENDIF} then
+    Result := _X509SetPubkey(x, pkey)
+  else
+    Result := 0;
+end;
+
+function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetIssuerName){$ENDIF} then
+    Result := _X509SetIssuerName(x, name)
+  else
+    Result := 0;
+end;
+
+function X509NameAddEntryByTxt(name: PX509_NAME; field: TSynaBytes; _type: integer;
+  bytes: TSynaBytes; len, loc, _set: integer): integer;
+var buf: PByte;
+  strb: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509NameAddEntryByTxt){$ENDIF} then
+  begin
+   {$IFDEF UNICODE}
+      buf :=  TSynaBytes(field).Data;
+      strb := TSynaBytes(bytes).Data;
+    {$ELSE}
+      buf := Pointer(field);
+      strb := Pointer(bytes);
+    {$ENDIF}
+    Result := _X509NameAddEntryByTxt(name, buf, _type, strb, len, loc, _set)
+  end
+  else
+    Result := 0;
+end;
+
+function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509Sign){$ENDIF} then
+    Result := _X509Sign(x, pkey, md)
+  else
+    Result := 0;
+end;
+
+function Asn1UtctimeNew: PASN1_UTCTIME;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1UtctimeNew){$ENDIF} then
+    Result := _Asn1UtctimeNew
+  else
+    Result := nil;
+end;
+
+procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1UtctimeFree){$ENDIF} then
+    _Asn1UtctimeFree(a);
+end;
+
+function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GmtimeAdj){$ENDIF} then
+    Result := _X509GmtimeAdj(s, adj)
+  else
+    Result := nil;
+end;
+
+function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetNotBefore){$ENDIF} then
+    Result := _X509SetNotBefore(x, tm)
+  else
+    Result := 0;
+end;
+
+function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509SetNotAfter){$ENDIF} then
+    Result := _X509SetNotAfter(x, tm)
+  else
+    Result := 0;
+end;
+
+function i2dX509bio(b: PBIO; x: PX509): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_i2dX509bio){$ENDIF} then
+    Result := _i2dX509bio(b, x)
+  else
+    Result := 0;
+end;
+
+function d2iX509bio(b: PBIO; x: PX509): PX509; {pf}
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_d2iX509bio){$ENDIF} then
+    Result := _d2iX509bio(x,b)
+  else
+    Result := nil;
+end;
+
+function PEMReadBioX509(b:PBIO; {var x:PX509;}x:PSslPtr; callback:PFunction; cb_arg: SslPtr):  PX509;    {pf}
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_PEMReadBioX509){$ENDIF} then
+    Result := _PEMReadBioX509(b,x,callback,cb_arg)
+  else
+    Result := nil;
+end;
+
+procedure SkX509PopFree(st: PSTACK; func:TSkPopFreeFunc); {pf}
+begin
+{$IFNDEF MSWINDOWS}
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_SkX509PopFree){$ENDIF} then
+    _SkX509PopFree(st,func);
+{$ENDIF}
+end;
+
+function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_i2dPrivateKeyBio){$ENDIF} then
+    Result := _i2dPrivateKeyBio(b, pkey)
+  else
+    Result := 0;
+end;
+
+function EvpGetDigestByName(Name: TSynaBytes): PEVP_MD;
+var buf: PByte;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_EvpGetDigestByName){$ENDIF} then
+  begin
+         {$IFDEF UNICODE}
+      buf :=  TSynaBytes(name).Data;
+    {$ELSE}
+      buf := PByte(name);
+    {$ENDIF}
+    Result := _EvpGetDigestByName(buf)
+  end
+  else
+    Result := nil;
+end;
+
+function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1IntegerSet){$ENDIF} then
+    Result := _Asn1IntegerSet(a, v)
+  else
+    Result := 0;
+end;
+
+function Asn1IntegerGet(a: PASN1_INTEGER): integer; {pf}
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_Asn1IntegerGet){$ENDIF} then
+    Result := _Asn1IntegerGet(a)
+  else
+    Result := 0;
+end;
+
+function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_X509GetSerialNumber){$ENDIF} then
+    Result := _X509GetSerialNumber(x)
+  else
+    Result := nil;
+end;
+
+// 3DES functions
+procedure DESsetoddparity(Key: des_cblock);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESsetoddparity){$ENDIF} then
+    _DESsetoddparity(Key);
+end;
+
+function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESsetkeychecked){$ENDIF} then
+    Result := _DESsetkeychecked(key, schedule)
+  else
+    Result := -1;
+end;
+
+procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
+begin
+  if InitSSLInterface {$IFNDEF STATIC}and Assigned(_DESecbencrypt){$ENDIF} then
+    _DESecbencrypt(Input, output, ks, enc);
+end;
+
+procedure locking_callback(mode, ltype: integer; lfile: PChar; line: integer); cdecl;
+begin
+  if ltype>High(Locks) then exit; //Should never happen?
+  
+  if (mode and 1) > 0 then
+    TCriticalSection(Locks[ltype]).Enter
+  else
+    TCriticalSection(Locks[ltype]).Leave;
+end;
+
+procedure InitLocks;
+var
+  n: integer;
+begin
+  Setlength(Locks, _CRYPTOnumlocks);
+  for n := 0 to high(Locks) do
+    Locks[n] := TCriticalSection.Create;
+  _CRYPTOsetlockingcallback(@locking_callback);
+end;
+
+procedure FreeLocks;
+var
+  n: integer;
+begin
+  _CRYPTOsetlockingcallback(nil);
+  for n := 0 to high(Locks) do
+    Locks[n].Free;
+  Setlength(Locks, 0);
+end;
+
+{$ENDIF}
+
+{$IFNDEF STATIC}
+function LoadLib(const Value: string): HModule;
+begin
+{$IFDEF CIL}
+  Result := LoadLibrary(Value);
+{$ELSE}
+  Result := LoadLibrary(PChar(Value));
+{$ENDIF}
+end;
+
+function GetProcAddr(module: HModule; const ProcName: string): SslPtr;
+begin
+{$IFDEF CIL}
+  Result := GetProcAddress(module, ProcName);
+{$ELSE}
+  Result := GetProcAddress(module, PChar(ProcName));
+{$ENDIF}
+end;
+{$ENDIF}
+
+function InitSSLInterface: Boolean;
+var
+  s: string;
+  x: integer;
+begin
+  {pf}
+  if SSLLoaded then
+    begin
+      Result := TRUE;
+      exit;
+    end;
+  {/pf}
+  Result := False;
+  if SSLCS = nil then
+    Exit;  
+  SSLCS.Enter;
+  try
+    if not IsSSLloaded then
+    begin
+{$IFDEF CIL}
+      SSLLibHandle := 1;
+      SSLUtilHandle := 1;
+{$ELSE}
+
+    {$IFDEF MSWINDOWS}
+      SSLUtilHandle := LoadLib(DLL_LIBCRYPTO_1_1);
+      SSLLibHandle := LoadLib(DLL_LIBSSL_1_1);
+
+      if (SSLUtilHandle = 0) or (SSLLibHandle = 0) then
+      begin
+        FreeLibrary(SSLLibHandle);
+        FreeLibrary(SSLUtilHandle);
+        
+        SSLUtilHandle := LoadLib(DLLUtilName);
+        SSLLibHandle := LoadLib(DLLSSLName);
+        if (SSLLibHandle = 0) then
+          SSLLibHandle := LoadLib(DLLSSLName2);
+      end;
+    {$ELSE}
+      SSLUtilHandle := LoadLib(DLLUtilName);
+      SSLLibHandle := LoadLib(DLLSSLName);
+    {$ENDIF}
+{$ENDIF}
+      if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
+      begin
+{$IFNDEF CIL}
+ {$IFNDEF STATIC}
+        _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error');
+        _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init');
+        _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings');
+        _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list');
+        _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new');
+        _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free');
+        _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd');
+        _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method');
+        _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method');
+        _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method');
+        _SslMethodTLSV11 := GetProcAddr(SSLLibHandle, 'TLSv1_1_method');
+        _SslMethodTLSV12 := GetProcAddr(SSLLibHandle, 'TLSv1_2_method');
+        _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method');
+        _SslMethodTLS := GetProcAddr(SSLLibHandle, 'TLS_method');
+        _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey');
+        _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1');
+        //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file,
+        //because SSL_CTX_use_PrivateKey_file not support DER format. :-O
+        _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file');
+        _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate');
+        _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1');
+        _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file');
+        _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file');
+        _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key');
+        _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb');
+        _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata');
+        _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations');
+        _SslCtxCtrl := GetProcAddr(SSLLibHandle, 'SSL_CTX_ctrl');
+        _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new');
+        _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free');
+        _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept');
+        _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect');
+        _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown');
+        _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read');
+        _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek');
+        _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write');
+        _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending');
+        _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate');
+        _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version');
+        _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify');
+        _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher');
+        _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name');
+        _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits');
+        _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result');
+        _SslCtrl := GetProcAddr(SSLLibHandle, 'SSL_ctrl');
+
+        _X509New := GetProcAddr(SSLUtilHandle, 'X509_new');
+        _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free');
+        _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline');
+        _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name');
+        _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name');
+        _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash');
+        _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest');
+        _X509print := GetProcAddr(SSLUtilHandle, 'X509_print');
+        _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version');
+        _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey');
+        _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name');
+        _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt');
+        _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign');
+        _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj');
+        _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore');
+        _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter');
+        _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber');
+        _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new');
+        _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free');
+        _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign');
+        _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup');
+        _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname');
+        _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version');
+        _OpenSSLversion := GetProcAddr(SSLUtilHandle, 'OpenSSL_version');
+        _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n');
+        _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error');
+        _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error');
+        _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings');
+        _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state');
+        _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf');
+        _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data');
+        _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen');
+        _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new');
+        _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all');
+        _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem');
+        _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending');
+        _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read');
+        _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write');
+        _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio');
+        _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse');
+        _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free');
+        _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key');
+        _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new');
+        _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free');
+        _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set');
+        _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get'); {pf}
+        _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio');
+        _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio'); {pf}
+        _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509'); {pf}
+        _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE'); {pf}
+        _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio');
+
+        // 3DES functions
+        _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity');
+        _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked');
+        _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt');
+        //
+        _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks');
+        _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback');
+ {$ENDIF STATIC} 
+{$ENDIF}
+{$IFDEF CIL}
+        SslLibraryInit;
+        SslLoadErrorStrings;
+        OPENSSLaddallalgorithms;
+        RandScreen;
+{$ELSE}
+        SetLength(s, 1024);
+        x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s));
+        SetLength(s, x);
+        SSLLibFile := s;
+        SetLength(s, 1024);
+        x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s));
+        SetLength(s, x);
+        SSLUtilFile := s;
+        //init library
+        {$IFNDEF STATIC}if assigned(_SslLibraryInit) then{$ENDIF}
+          _SslLibraryInit;
+        {$IFNDEF STATIC}if assigned(_SslLoadErrorStrings) then{$ENDIF}
+          _SslLoadErrorStrings;
+        {$IFNDEF STATIC}if assigned(_OPENSSLaddallalgorithms) then{$ENDIF}
+          _OPENSSLaddallalgorithms;
+        {$IFNDEF STATIC}if assigned(_RandScreen) then{$ENDIF}
+          _RandScreen;
+        {$IFNDEF STATIC}
+        if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
+        {$ENDIF}
+          InitLocks;
+{$ENDIF}
+        SSLloaded := True;
+{$IFDEF OS2}
+        Result := InitEMXHandles;
+{$ELSE OS2}
+        Result := True;
+{$ENDIF OS2}
+      end
+      else
+      begin
+        //load failed!
+        if SSLLibHandle <> 0 then
+        begin
+{$IFNDEF CIL}
+          FreeLibrary(SSLLibHandle);
+{$ENDIF}
+          SSLLibHandle := 0;
+        end;
+        if SSLUtilHandle <> 0 then
+        begin
+{$IFNDEF CIL}
+          FreeLibrary(SSLUtilHandle);
+{$ENDIF}
+          SSLLibHandle := 0;
+        end;
+        Result := False;
+      end;
+    end
+    else
+      //loaded before...
+      Result := true;
+  finally
+    SSLCS.Leave;
+  end;
+end;
+
+function DestroySSLInterface: Boolean;
+begin
+  SSLCS.Enter;
+  try
+    if IsSSLLoaded then
+    begin
+      //deinit library
+{$IFNDEF CIL}
+      {$IFNDEF STATIC}
+      if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
+      {$ENDIF}
+        FreeLocks;
+{$ENDIF}
+      EVPCleanup;
+      CRYPTOcleanupAllExData;
+      ErrRemoveState(0);
+    end;
+    SSLloaded := false;
+    if SSLLibHandle <> 0 then
+    begin
+{$IFNDEF CIL}
+      FreeLibrary(SSLLibHandle);
+{$ENDIF}
+      SSLLibHandle := 0;
+    end;
+    if SSLUtilHandle <> 0 then
+    begin
+{$IFNDEF CIL}
+      FreeLibrary(SSLUtilHandle);
+{$ENDIF}
+      SSLLibHandle := 0;
+    end;
+
+{$IFNDEF CIL}
+{$IFNDEF STATIC}
+    _SslGetError := nil;
+    _SslLibraryInit := nil;
+    _SslLoadErrorStrings := nil;
+    _SslCtxSetCipherList := nil;
+    _SslCtxNew := nil;
+    _SslCtxFree := nil;
+    _SslSetFd := nil;
+    _SslMethodV2 := nil;
+    _SslMethodV3 := nil;
+    _SslMethodTLSV1 := nil;
+    _SslMethodTLSV11 := nil;
+    _SslMethodTLSV12 := nil;
+    _SslMethodV23 := nil;
+    _SslMethodTLS := nil;
+    _SslCtxUsePrivateKey := nil;
+    _SslCtxUsePrivateKeyASN1 := nil;
+    _SslCtxUsePrivateKeyFile := nil;
+    _SslCtxUseCertificate := nil;
+    _SslCtxUseCertificateASN1 := nil;
+    _SslCtxUseCertificateFile := nil;
+    _SslCtxUseCertificateChainFile := nil;
+    _SslCtxCheckPrivateKeyFile := nil;
+    _SslCtxSetDefaultPasswdCb := nil;
+    _SslCtxSetDefaultPasswdCbUserdata := nil;
+    _SslCtxLoadVerifyLocations := nil;
+    _SslCtxCtrl := nil;
+    _SslNew := nil;
+    _SslFree := nil;
+    _SslAccept := nil;
+    _SslConnect := nil;
+    _SslShutdown := nil;
+    _SslRead := nil;
+    _SslPeek := nil;
+    _SslWrite := nil;
+    _SslPending := nil;
+    _SslGetPeerCertificate := nil;
+    _SslGetVersion := nil;
+    _SslCtxSetVerify := nil;
+    _SslGetCurrentCipher := nil;
+    _SslCipherGetName := nil;
+    _SslCipherGetBits := nil;
+    _SslGetVerifyResult := nil;
+    _SslCtrl := nil;
+
+    _X509New := nil;
+    _X509Free := nil;
+    _X509NameOneline := nil;
+    _X509GetSubjectName := nil;
+    _X509GetIssuerName := nil;
+    _X509NameHash := nil;
+    _X509Digest := nil;
+    _X509print := nil;
+    _X509SetVersion := nil;
+    _X509SetPubkey := nil;
+    _X509SetIssuerName := nil;
+    _X509NameAddEntryByTxt := nil;
+    _X509Sign := nil;
+    _X509GmtimeAdj := nil;
+    _X509SetNotBefore := nil;
+    _X509SetNotAfter := nil;
+    _X509GetSerialNumber := nil;
+    _EvpPkeyNew := nil;
+    _EvpPkeyFree := nil;
+    _EvpPkeyAssign := nil;
+    _EVPCleanup := nil;
+    _EvpGetDigestByName := nil;
+    _SSLeayversion := nil;
+    _OpenSSLversion := nil;
+    _ErrErrorString := nil;
+    _ErrGetError := nil;
+    _ErrClearError := nil;
+    _ErrFreeStrings := nil;
+    _ErrRemoveState := nil;
+    _OPENSSLaddallalgorithms := nil;
+    _CRYPTOcleanupAllExData := nil;
+    _RandScreen := nil;
+    _BioNew := nil;
+    _BioFreeAll := nil;
+    _BioSMem := nil;
+    _BioCtrlPending := nil;
+    _BioRead := nil;
+    _BioWrite := nil;
+    _d2iPKCS12bio := nil;
+    _PKCS12parse := nil;
+    _PKCS12free := nil;
+    _RsaGenerateKey := nil;
+    _Asn1UtctimeNew := nil;
+    _Asn1UtctimeFree := nil;
+    _Asn1IntegerSet := nil;
+    _Asn1IntegerGet := nil; {pf}
+    _SkX509PopFree := nil; {pf}
+    _i2dX509bio := nil;
+    _i2dPrivateKeyBio := nil;
+
+    // 3DES functions
+    _DESsetoddparity := nil;
+    _DESsetkeychecked := nil;
+    _DESecbencrypt := nil;
+    //
+    _CRYPTOnumlocks := nil;
+    _CRYPTOsetlockingcallback := nil;
+{$ENDIF}
+{$ENDIF}
+  finally
+    SSLCS.Leave;
+  end;
+  Result := True;
+end;
+
+function IsSSLloaded: Boolean;
+begin
+  Result := SSLLoaded;
+end;
+
+initialization
+begin
+  SSLCS:= TCriticalSection.Create;
+end;
+
+finalization
+begin
+{$IFNDEF CIL}
+  DestroySSLInterface;
+{$ENDIF}
+  SSLCS.Free;
+end;
+
+end.

ssl_streamsec.pas

@@ -0,0 +1,539 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.006 |
+|==============================================================================|
+| Content: SSL support by StreamSecII                                          |
+|==============================================================================|
+| Copyright (c)1999-2005, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2005.                     |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Henrick Hellström <[email protected]>                                   |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
+
+StreamSecII is native pascal library, you not need any external libraries!
+
+You can tune lot of StreamSecII properties by using your GlobalServer. If you not
+using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
+instance for each TCP connection. Formore information about GlobalServer usage
+refer StreamSecII documentation.
+
+If you are not using key and certificate by GlobalServer, then you can use
+properties of this plugin instead, but this have limited features and
+@link(TCustomSSL.KeyPassword) not working properly yet!
+
+For handling keys and certificates you can use this properties:
+@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
+@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
+@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
+@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
+@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
+of keys and certificates refer to StreamSecII documentation.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+unit ssl_streamsec;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synsock, synautil, synacode,
+  TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
+  SecUtils;
+
+type
+  {:@exclude}
+  TMyTLSSynSockSlave = class(TTLSSynSockSlave)
+  protected
+    procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
+    function GetMyTLSServer: TCustomTLSInternalServer;
+  published
+    property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
+  end;
+
+  {:@abstract(class implementing StreamSecII SSL plugin.)
+   Instance of this class will be created for each @link(TTCPBlockSocket).
+   You not need to create instance of this class, all is done by Synapse itself!}
+  TSSLStreamSec = class(TCustomSSL)
+  protected
+    FSlave: TMyTLSSynSockSlave;
+    FIsServer: Boolean;
+    FTLSServer: TCustomTLSInternalServer;
+    FServerCreated: Boolean;
+    function SSLCheck: Boolean;
+    function Init(server:Boolean): Boolean;
+    function DeInit: Boolean;
+    function Prepare(server:Boolean): Boolean;
+    procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+    function X500StrToStr(const Prefix: string; const Value: TX500String): string;
+    function X501NameToStr(const Value: TX501Name): string;
+    function GetCert: PASN1Struct;
+  public
+    constructor Create(const Value: TTCPBlockSocket); override;
+    destructor Destroy; override;
+    {:See @inherited}
+    function LibVersion: String; override;
+    {:See @inherited}
+    function LibName: String; override;
+    {:See @inherited and @link(ssl_streamsec) for more details.}
+    function Connect: boolean; override;
+    {:See @inherited and @link(ssl_streamsec) for more details.}
+    function Accept: boolean; override;
+    {:See @inherited}
+    function Shutdown: boolean; override;
+    {:See @inherited}
+    function BiShutdown: boolean; override;
+    {:See @inherited}
+    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
+    {:See @inherited}
+    function WaitingData: Integer; override;
+    {:See @inherited}
+    function GetSSLVersion: string; override;
+    {:See @inherited}
+    function GetPeerSubject: string; override;
+    {:See @inherited}
+    function GetPeerIssuer: string; override;
+    {:See @inherited}
+    function GetPeerName: string; override;
+    {:See @inherited}
+    function GetPeerFingerprint: string; override;
+    {:See @inherited}
+    function GetCertInfo: string; override;
+  published
+    {:TLS server for tuning of StreamSecII.}
+    property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
+  end;
+
+implementation
+
+{==============================================================================}
+procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
+begin
+  TLSServer := Value;
+end;
+
+function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
+begin
+  Result := TLSServer;
+end;
+
+{==============================================================================}
+
+constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
+begin
+  inherited Create(Value);
+  FSlave := nil;
+  FIsServer := False;
+  FTLSServer := nil;
+end;
+
+destructor TSSLStreamSec.Destroy;
+begin
+  DeInit;
+  inherited Destroy;
+end;
+
+function TSSLStreamSec.LibVersion: String;
+begin
+  Result := 'StreamSecII';
+end;
+
+function TSSLStreamSec.LibName: String;
+begin
+  Result := 'ssl_streamsec';
+end;
+
+function TSSLStreamSec.SSLCheck: Boolean;
+begin
+  Result := true;
+  FLastErrorDesc := '';
+  if not Assigned(FSlave) then
+    Exit;
+  FLastError := FSlave.ErrorCode;
+  if FLastError <> 0 then
+  begin
+    FLastErrorDesc := TlsConst.AlertMsg(FLastError);
+  end;
+end;
+
+procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
+begin
+  ExplicitTrust := true;
+end;
+
+function TSSLStreamSec.Init(server:Boolean): Boolean;
+var
+  st: TMemoryStream;
+  pass: ISecretKey;
+  ws: WideString;
+begin
+  Result := False;
+  ws := FKeyPassword;
+  pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
+  try
+    FIsServer := Server;
+    FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
+    if Assigned(FTLSServer) then
+      FSlave.MyTLSServer := FTLSServer
+    else
+      if Assigned(TLSInternalServer.GlobalServer) then
+        FSlave.MyTLSServer := TLSInternalServer.GlobalServer
+      else begin
+        FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
+        FServerCreated := True;
+      end;
+    if server then
+      FSlave.MyTLSServer.ClientOrServer := cosServerSide
+    else
+      FSlave.MyTLSServer.ClientOrServer := cosClientSide;
+    if not FVerifyCert then
+    begin
+      FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
+    end;
+    FSlave.MyTLSServer.Options.VerifyServerName := [];
+    FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
+    FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
+    FSlave.MyTLSServer.Options.RequestClientCertificate := False;
+    FSlave.MyTLSServer.Options.RequireClientCertificate := False;
+    if server and FVerifyCert then
+    begin
+      FSlave.MyTLSServer.Options.RequestClientCertificate := True;
+      FSlave.MyTLSServer.Options.RequireClientCertificate := True;
+    end;
+    if FCertCAFile <> '' then
+      FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
+    if FCertCA <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertCA);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadRootCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FTrustCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
+    if FTrustCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FTrustCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPrivateKeyFile <> '' then
+      FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
+//      FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
+    if FPrivateKey <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FPrivateKey);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
+      finally
+        st.free;
+      end;
+    end;
+    if FCertificateFile <> '' then
+      FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
+    if FCertificate <> '' then
+    begin
+      st := TMemoryStream.Create;
+      try
+        WriteStrToStream(st, FCertificate);
+        st.Seek(0, soFromBeginning);
+        FSlave.MyTLSServer.LoadMyCertsFromStream(st);
+      finally
+        st.free;
+      end;
+    end;
+    if FPFXfile <> '' then
+      FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
+    if server and FServerCreated then
+    begin
+      FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
+      FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
+      FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
+      FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
+      FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
+      FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
+      FSlave.MyTLSServer.TLSSetupServer;
+    end;
+    Result := true;
+  finally
+    pass := nil;
+  end;
+end;
+
+function TSSLStreamSec.DeInit: Boolean;
+var
+  obj: TObject;
+begin
+  Result := True;
+  if assigned(FSlave) then
+  begin
+    FSlave.Close;
+    if FServerCreated then
+      obj := FSlave.TLSServer
+    else
+      obj := nil;
+    FSlave.Free;
+    obj.Free;
+    FSlave := nil;
+  end;
+  FSSLEnabled := false;
+end;
+
+function TSSLStreamSec.Prepare(server:Boolean): Boolean;
+begin
+  Result := false;
+  DeInit;
+  if Init(server) then
+    Result := true
+  else
+    DeInit;
+end;
+
+function TSSLStreamSec.Connect: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(false) then
+  begin
+    FSlave.Open;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Accept: boolean;
+begin
+  Result := False;
+  if FSocket.Socket = INVALID_SOCKET then
+    Exit;
+  if Prepare(true) then
+  begin
+    FSlave.DoConnect;
+    SSLCheck;
+    if FLastError <> 0 then
+      Exit;
+    FSSLEnabled := True;
+    Result := True;
+  end;
+end;
+
+function TSSLStreamSec.Shutdown: boolean;
+begin
+  Result := BiShutdown;
+end;
+
+function TSSLStreamSec.BiShutdown: boolean;
+begin
+  DeInit;
+  Result := True;
+end;
+
+function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := len;
+  FSlave.SendBuf(Buffer^, l, true);
+  Result := l;
+  SSLCheck;
+end;
+
+function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
+var
+  l: integer;
+begin
+  l := Len;
+  Result := FSlave.ReceiveBuf(Buffer^, l);
+  SSLCheck;
+end;
+
+function TSSLStreamSec.WaitingData: Integer;
+begin
+  Result := 0;
+  while FSlave.Connected do begin
+    Result := FSlave.ReceiveLength;
+    if Result > 0 then
+      Break;
+    Sleep(1);
+  end;
+end;
+
+function TSSLStreamSec.GetSSLVersion: string;
+begin
+  Result := 'SSLv3 or TLSv1';
+end;
+
+function TSSLStreamSec.GetCert: PASN1Struct;
+begin
+  if FIsServer then
+    Result := FSlave.GetClientCert
+  else
+    Result := FSlave.GetServerCert;
+end;
+
+function TSSLStreamSec.GetPeerSubject: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerName: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractSubject(Cert^,XName, false);
+    Result := XName.commonName.Str;
+  end;
+end;
+
+function TSSLStreamSec.GetPeerIssuer: string;
+var
+  XName: TX501Name;
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    ExtractIssuer(Cert^, XName, false);
+    Result := X501NameToStr(XName);
+  end;
+end;
+
+function TSSLStreamSec.GetPeerFingerprint: string;
+var
+  Cert: PASN1Struct;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+    Result := MD5(Cert.ContentAsOctetString);
+end;
+
+function TSSLStreamSec.GetCertInfo: string;
+var
+  Cert: PASN1Struct;
+  l: Tstringlist;
+begin
+  Result := '';
+  Cert := GetCert;
+  if Assigned(cert) then
+  begin
+    l := TStringList.Create;
+    try
+      Asn1.RenderAsText(cert^, l, true, true, true, 2);
+      Result := l.Text;
+    finally
+      l.free;
+    end;
+  end;
+end;
+
+function TSSLStreamSec.X500StrToStr(const Prefix: string;
+  const Value: TX500String): string;
+begin
+  if Value.Str = '' then
+    Result := ''
+  else
+    Result := '/' + Prefix + '=' + Value.Str;
+end;
+
+function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
+begin
+  Result := X500StrToStr('CN',Value.commonName) +
+           X500StrToStr('C',Value.countryName) +
+           X500StrToStr('L',Value.localityName) +
+           X500StrToStr('ST',Value.stateOrProvinceName) +
+           X500StrToStr('O',Value.organizationName) +
+           X500StrToStr('OU',Value.organizationalUnitName) +
+           X500StrToStr('T',Value.title) +
+           X500StrToStr('N',Value.name) +
+           X500StrToStr('G',Value.givenName) +
+           X500StrToStr('I',Value.initials) +
+           X500StrToStr('SN',Value.surname) +
+           X500StrToStr('GQ',Value.generationQualifier) +
+           X500StrToStr('DNQ',Value.dnQualifier) +
+           X500StrToStr('E',Value.emailAddress);
+end;
+
+
+{==============================================================================}
+
+initialization
+  SSLImplementation := TSSLStreamSec;
+
+finalization
+
+end.
+
+

sslinux.inc

@@ -0,0 +1,1318 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.000.009 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - Linux definition include        |
+|==============================================================================|
+| Copyright (c)1999-2012, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2012.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF LINUX}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+  synafpc,
+  {$IFNDEF FPC}
+  Libc;
+  {$ELSE FPC}
+  libclite;
+  {$ENDIF ~FPC}
+
+function InitSocketInterface(stack: string): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+  WinsockLevel = $0202;
+
+type
+  u_char = Char;
+  u_short = Word;
+  u_int = Integer;
+  u_long = Longint;
+  pu_long = ^u_long;
+  pu_short = ^u_short;
+  TSocket = u_int;
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+
+const
+  DLLStackName = 'libc.so.6';
+
+  cLocalhost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  cBroadcast = '255.255.255.255';
+  c6Localhost = '::1';
+  c6AnyHost = '::0';
+  c6Broadcast = 'ffff::1';
+  cAnyPort = '0';
+
+type
+  DWORD = Integer;
+  __fd_mask = LongWord;
+const
+  __FD_SETSIZE    = 1024;
+  __NFDBITS       = 8 * sizeof(__fd_mask);
+type
+  __fd_set = {packed} record
+    fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask;
+  end;
+  TFDSet = __fd_set;
+  PFDSet = ^TFDSet;
+
+const
+  FIONREAD        = $541B;
+  FIONBIO         = $5421;
+  FIOASYNC        = $5452;
+
+type
+  PTimeVal = ^TTimeVal;
+  TTimeVal = packed record
+    tv_sec: Longint;
+    tv_usec: Longint;
+  end;
+
+const
+  IPPROTO_IP     =   0;		{ Dummy					}
+  IPPROTO_ICMP   =   1;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   2;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   6;		{ TCP           			}
+  IPPROTO_UDP    =   17;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   41;
+  IPPROTO_ICMPV6 =   58;
+  IPPROTO_RM     =  113;
+
+  IPPROTO_RAW    =   255;
+  IPPROTO_MAX    =   256;
+
+type
+  PInAddr = ^TInAddr;
+  TInAddr = packed record
+    case integer of
+      0: (S_bytes: packed array [0..3] of byte);
+      1: (S_addr: u_long);
+  end;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = packed record
+    case Integer of
+      0: (sin_family: u_short;
+          sin_port: u_short;
+          sin_addr: TInAddr;
+          sin_zero: array[0..7] of Char);
+      1: (sa_family: u_short;
+          sa_data: array[0..13] of Char)
+  end;
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     { IP multicast address of group }
+    imr_interface: TInAddr;     { local IP address of interface }
+  end;
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = packed record
+    case integer of
+      0: (S6_addr: packed array [0..15] of byte);
+      1: (u6_addr8: packed array [0..15] of byte);
+      2: (u6_addr16: packed array [0..7] of word);
+      3: (u6_addr32: packed array [0..3] of integer);
+  end;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = packed record
+		sin6_family:   u_short;     // AF_INET6
+		sin6_port:     u_short;     // Transport level port number
+		sin6_flowinfo: u_long;	    // IPv6 flow information
+		sin6_addr:     TInAddr6;    // IPv6 address
+		sin6_scope_id: u_long;      // Scope Id: IF number for link-local
+                                //           SITE id for site-local
+  end;
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+    padding: u_long;
+  end;
+
+  PHostEnt = ^THostEnt;
+  THostent = record
+    h_name: PChar;
+    h_aliases: PPChar;
+    h_addrtype: Integer;
+    h_length: Cardinal;
+    case Byte of
+      0: (h_addr_list: PPChar);
+      1: (h_addr: PPChar);
+  end;
+
+  PNetEnt = ^TNetEnt;
+  TNetEnt = record
+    n_name: PChar;
+    n_aliases: PPChar;
+    n_addrtype: Integer;
+    n_net: uint32_t;
+  end;
+
+  PServEnt = ^TServEnt;
+  TServEnt = record
+    s_name: PChar;
+    s_aliases: PPChar;
+    s_port: Integer;
+    s_proto: PChar;
+  end;
+
+  PProtoEnt = ^TProtoEnt;
+  TProtoEnt = record
+    p_name: PChar;
+    p_aliases: ^PChar;
+    p_proto: u_short;
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  IP_TOS             = 1;  { int; IP type of service and precedence.  }
+  IP_TTL             = 2;  { int; IP time to live.  }
+  IP_HDRINCL         = 3;  { int; Header is included with data.  }
+  IP_OPTIONS         = 4;  { ip_opts; IP per-packet options.  }
+  IP_ROUTER_ALERT    = 5;  { bool }
+  IP_RECVOPTS        = 6;  { bool }
+  IP_RETOPTS         = 7;  { bool }
+  IP_PKTINFO         = 8;  { bool }
+  IP_PKTOPTIONS      = 9;
+  IP_PMTUDISC        = 10; { obsolete name? }
+  IP_MTU_DISCOVER    = 10; { int; see below }
+  IP_RECVERR         = 11; { bool }
+  IP_RECVTTL         = 12; { bool }
+  IP_RECVTOS         = 13; { bool }
+  IP_MULTICAST_IF    = 32; { in_addr; set/get IP multicast i/f }
+  IP_MULTICAST_TTL   = 33; { u_char; set/get IP multicast ttl }
+  IP_MULTICAST_LOOP  = 34; { i_char; set/get IP multicast loopback }
+  IP_ADD_MEMBERSHIP  = 35; { ip_mreq; add an IP group membership }
+  IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership }
+
+  SOL_SOCKET    = 1;
+
+  SO_DEBUG      = 1;
+  SO_REUSEADDR  = 2;
+  SO_TYPE       = 3;
+  SO_ERROR      = 4;
+  SO_DONTROUTE  = 5;
+  SO_BROADCAST  = 6;
+  SO_SNDBUF     = 7;
+  SO_RCVBUF     = 8;
+  SO_KEEPALIVE  = 9;
+  SO_OOBINLINE  = 10;
+  SO_NO_CHECK   = 11;
+  SO_PRIORITY   = 12;
+  SO_LINGER     = 13;
+  SO_BSDCOMPAT  = 14;
+  SO_REUSEPORT  = 15;
+  SO_PASSCRED   = 16;
+  SO_PEERCRED   = 17;
+  SO_RCVLOWAT   = 18;
+  SO_SNDLOWAT   = 19;
+  SO_RCVTIMEO   = 20;
+  SO_SNDTIMEO   = 21;
+{ Security levels - as per NRL IPv6 - don't actually do anything }
+  SO_SECURITY_AUTHENTICATION       = 22;
+  SO_SECURITY_ENCRYPTION_TRANSPORT = 23;
+  SO_SECURITY_ENCRYPTION_NETWORK   = 24;
+  SO_BINDTODEVICE                  = 25;
+{ Socket filtering }
+  SO_ATTACH_FILTER = 26;
+  SO_DETACH_FILTER = 27;
+
+  SOMAXCONN       = 128;
+
+  IPV6_UNICAST_HOPS     = 16;
+  IPV6_MULTICAST_IF     = 17;
+  IPV6_MULTICAST_HOPS   = 18;
+  IPV6_MULTICAST_LOOP   = 19;
+  IPV6_JOIN_GROUP       = 20;
+  IPV6_LEAVE_GROUP      = 21;
+
+  MSG_NOSIGNAL  = $4000;                // Do not generate SIGPIPE.
+
+  // getnameinfo constants
+  NI_MAXHOST	   = 1025;
+  NI_MAXSERV	   = 32;
+  NI_NOFQDN 	   = $4;
+  NI_NUMERICHOST = $1;
+  NI_NAMEREQD	   = $8;
+  NI_NUMERICSERV = $2;
+  NI_DGRAM       = $10;
+
+const
+  SOCK_STREAM     = 1;               { stream socket }
+  SOCK_DGRAM      = 2;               { datagram socket }
+  SOCK_RAW        = 3;               { raw-protocol interface }
+  SOCK_RDM        = 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001;
+
+{ Address families. }
+
+  AF_UNSPEC       = 0;               { unspecified }
+  AF_INET         = 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = 10;              { Internetwork Version 6 }
+  AF_MAX          = 24;
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+  { Structure used by kernel to store most addresses. }
+  PSockAddr = ^TSockAddr;
+  TSockAddr = TSockAddrIn;
+
+  { Structure used by kernel to pass protocol information in raw sockets. }
+  PSockProto = ^TSockProto;
+  TSockProto = packed record
+    sp_family: u_short;
+    sp_protocol: u_short;
+  end;
+
+type
+  PAddrInfo = ^TAddrInfo;
+  TAddrInfo = record
+                ai_flags: integer;    // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
+                ai_family: integer;   // PF_xxx.
+                ai_socktype: integer; // SOCK_xxx.
+                ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
+                ai_addrlen: u_int;    // Length of ai_addr.
+                ai_addr: PSockAddr;   // Binary address.
+                ai_canonname: PChar;  // Canonical name for nodename.
+                ai_next: PAddrInfo;     // Next structure in linked list.
+              end;
+
+const
+  // Flags used in "hints" argument to getaddrinfo().
+  AI_PASSIVE     = $1;  // Socket address will be used in bind() call.
+  AI_CANONNAME   = $2;  // Return canonical name in first ai_canonname.
+  AI_NUMERICHOST = $4;  // Nodename must be a numeric address string.
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = packed record
+    l_onoff: integer;
+    l_linger: integer;
+  end;
+
+const
+
+  MSG_OOB       = $01;                  // Process out-of-band data.
+  MSG_PEEK      = $02;                  // Peek at incoming messages.
+
+const
+  WSAEINTR = EINTR;
+  WSAEBADF = EBADF;
+  WSAEACCES = EACCES;
+  WSAEFAULT = EFAULT;
+  WSAEINVAL = EINVAL;
+  WSAEMFILE = EMFILE;
+  WSAEWOULDBLOCK = EWOULDBLOCK;
+  WSAEINPROGRESS = EINPROGRESS;
+  WSAEALREADY = EALREADY;
+  WSAENOTSOCK = ENOTSOCK;
+  WSAEDESTADDRREQ = EDESTADDRREQ;
+  WSAEMSGSIZE = EMSGSIZE;
+  WSAEPROTOTYPE = EPROTOTYPE;
+  WSAENOPROTOOPT = ENOPROTOOPT;
+  WSAEPROTONOSUPPORT = EPROTONOSUPPORT;
+  WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT;
+  WSAEOPNOTSUPP = EOPNOTSUPP;
+  WSAEPFNOSUPPORT = EPFNOSUPPORT;
+  WSAEAFNOSUPPORT = EAFNOSUPPORT;
+  WSAEADDRINUSE = EADDRINUSE;
+  WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
+  WSAENETDOWN = ENETDOWN;
+  WSAENETUNREACH = ENETUNREACH;
+  WSAENETRESET = ENETRESET;
+  WSAECONNABORTED = ECONNABORTED;
+  WSAECONNRESET = ECONNRESET;
+  WSAENOBUFS = ENOBUFS;
+  WSAEISCONN = EISCONN;
+  WSAENOTCONN = ENOTCONN;
+  WSAESHUTDOWN = ESHUTDOWN;
+  WSAETOOMANYREFS = ETOOMANYREFS;
+  WSAETIMEDOUT = ETIMEDOUT;
+  WSAECONNREFUSED = ECONNREFUSED;
+  WSAELOOP = ELOOP;
+  WSAENAMETOOLONG = ENAMETOOLONG;
+  WSAEHOSTDOWN = EHOSTDOWN;
+  WSAEHOSTUNREACH = EHOSTUNREACH;
+  WSAENOTEMPTY = ENOTEMPTY;
+  WSAEPROCLIM = -1;
+  WSAEUSERS = EUSERS;
+  WSAEDQUOT = EDQUOT;
+  WSAESTALE = ESTALE;
+  WSAEREMOTE = EREMOTE;
+  WSASYSNOTREADY = -2;
+  WSAVERNOTSUPPORTED = -3;
+  WSANOTINITIALISED = -4;
+  WSAEDISCON = -5;
+  WSAHOST_NOT_FOUND = HOST_NOT_FOUND;
+  WSATRY_AGAIN = TRY_AGAIN;
+  WSANO_RECOVERY = NO_RECOVERY;
+  WSANO_DATA = -6;
+  WSABASEERR = 10000;
+
+  EAI_BADFLAGS    = -1;   { Invalid value for `ai_flags' field.  }
+  EAI_NONAME      = -2;   { NAME or SERVICE is unknown.  }
+  EAI_AGAIN       = -3;   { Temporary failure in name resolution.  }
+  EAI_FAIL        = -4;   { Non-recoverable failure in name res.  }
+  EAI_NODATA      = -5;   { No address associated with NAME.  }
+  EAI_FAMILY      = -6;   { `ai_family' not supported.  }
+  EAI_SOCKTYPE    = -7;   { `ai_socktype' not supported.  }
+  EAI_SERVICE     = -8;   { SERVICE not supported for `ai_socktype'.  }
+  EAI_ADDRFAMILY  = -9;   { Address family for NAME not supported.  }
+  EAI_MEMORY      = -10;  { Memory allocation failure.  }
+  EAI_SYSTEM      = -11;  { System error returned in `errno'.  }
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = packed record
+    wVersion: Word;
+    wHighVersion: Word;
+    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PChar;
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+type
+  TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
+    cdecl;
+  TWSACleanup = function: Integer;
+    cdecl;
+  TWSAGetLastError = function: Integer;
+    cdecl;
+  TGetServByName = function(name, proto: PChar): PServEnt;
+    cdecl;
+  TGetServByPort = function(port: Integer; proto: PChar): PServEnt;
+    cdecl;
+  TGetProtoByName = function(name: PChar): PProtoEnt;
+    cdecl;
+  TGetProtoByNumber = function(proto: Integer): PProtoEnt;
+    cdecl;
+  TGetHostByName = function(name: PChar): PHostEnt;
+    cdecl;
+  TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
+    cdecl;
+  TGetHostName = function(name: PChar; len: Integer): Integer;
+    cdecl;
+  TShutdown = function(s: TSocket; how: Integer): Integer;
+    cdecl;
+  TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
+    optlen: Integer): Integer;
+    cdecl;
+  TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
+    var optlen: Integer): Integer;
+    cdecl;
+  TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
+    tolen: Integer): Integer;
+    cdecl;
+  TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
+    cdecl;
+  TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
+    cdecl;
+  TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
+    var fromlen: Integer): Integer;
+    cdecl;
+  Tntohs = function(netshort: u_short): u_short;
+    cdecl;
+  Tntohl = function(netlong: u_long): u_long;
+    cdecl;
+  TListen = function(s: TSocket; backlog: Integer): Integer;
+    cdecl;
+  TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer;
+    cdecl;
+  TInet_ntoa = function(inaddr: TInAddr): PChar;
+    cdecl;
+  TInet_addr = function(cp: PChar): u_long;
+    cdecl;
+  Thtons = function(hostshort: u_short): u_short;
+    cdecl;
+  Thtonl = function(hostlong: u_long): u_long;
+    cdecl;
+  TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    cdecl;
+  TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    cdecl;
+  TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
+    cdecl;
+  TCloseSocket = function(s: TSocket): Integer;
+    cdecl;
+  TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
+    cdecl;
+  TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
+    cdecl;
+  TTSocket = function(af, Struc, Protocol: Integer): TSocket;
+    cdecl;
+  TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+    cdecl;
+
+  TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo;
+    var Addrinfo: PAddrInfo): integer;
+    cdecl;
+  TFreeAddrInfo = procedure(ai: PAddrInfo);
+    cdecl;
+  TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar;
+    hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer;
+    cdecl;
+
+var
+  WSAStartup: TWSAStartup = nil;
+  WSACleanup: TWSACleanup = nil;
+  WSAGetLastError: TWSAGetLastError = nil;
+  GetServByName: TGetServByName = nil;
+  GetServByPort: TGetServByPort = nil;
+  GetProtoByName: TGetProtoByName = nil;
+  GetProtoByNumber: TGetProtoByNumber = nil;
+  GetHostByName: TGetHostByName = nil;
+  GetHostByAddr: TGetHostByAddr = nil;
+  ssGetHostName: TGetHostName = nil;
+  Shutdown: TShutdown = nil;
+  SetSockOpt: TSetSockOpt = nil;
+  GetSockOpt: TGetSockOpt = nil;
+  ssSendTo: TSendTo = nil;
+  ssSend: TSend = nil;
+  ssRecv: TRecv = nil;
+  ssRecvFrom: TRecvFrom = nil;
+  ntohs: Tntohs = nil;
+  ntohl: Tntohl = nil;
+  Listen: TListen = nil;
+  IoctlSocket: TIoctlSocket = nil;
+  Inet_ntoa: TInet_ntoa = nil;
+  Inet_addr: TInet_addr = nil;
+  htons: Thtons = nil;
+  htonl: Thtonl = nil;
+  ssGetSockName: TGetSockName = nil;
+  ssGetPeerName: TGetPeerName = nil;
+  ssConnect: TConnect = nil;
+  CloseSocket: TCloseSocket = nil;
+  ssBind: TBind = nil;
+  ssAccept: TAccept = nil;
+  Socket: TTSocket = nil;
+  Select: TSelect = nil;
+
+  GetAddrInfo: TGetAddrInfo = nil;
+  FreeAddrInfo: TFreeAddrInfo = nil;
+  GetNameInfo: TGetNameInfo = nil;
+
+function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl;
+function LSWSACleanup: Integer; cdecl;
+function LSWSAGetLastError: Integer; cdecl;
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+    case integer of
+      0: (AddressFamily: u_short);
+      1: (
+        case sin_family: u_short of
+          AF_INET: (sin_port: u_short;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of Char);
+          AF_INET6: (sin6_port:     u_short;
+                		sin6_flowinfo: u_long;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: u_long);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+function Connect(s: TSocket; const name: TVarSin): Integer;
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+function GetHostName: string;
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): string;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: string;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+
+{==============================================================================}
+implementation
+
+var
+  SynSockCount: Integer = 0;
+  LibHandle: TLibHandle = 0;
+  Libwship6Handle: TLibHandle = 0;
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.u6_addr8[15] := 1;
+end;
+
+{=============================================================================}
+var
+{$IFNDEF VER1_0}  //FTP version 1.0.x
+  errno_loc: function: PInteger cdecl = nil;
+{$ELSE}
+  errno_loc: function: PInteger = nil; cdecl;
+{$ENDIF}
+
+function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+begin
+  with WSData do
+  begin
+    wVersion := wVersionRequired;
+    wHighVersion := $202;
+    szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
+    szSystemStatus := 'Running on Linux';
+    iMaxSockets := 32768;
+    iMaxUdpDg := 8192;
+  end;
+  Result := 0;
+end;
+
+function LSWSACleanup: Integer;
+begin
+  Result := 0;
+end;
+
+function LSWSAGetLastError: Integer;
+var
+  p: PInteger;
+begin
+  p := errno_loc;
+  Result := p^;
+end;
+
+function __FDELT(Socket: TSocket): Integer;
+begin
+  Result := Socket div __NFDBITS;
+end;
+
+function __FDMASK(Socket: TSocket): __fd_mask;
+begin
+  Result := LongWord(1) shl (Socket mod __NFDBITS);
+end;
+
+function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
+begin
+  Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0;
+end;
+
+procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
+begin
+  fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket);
+end;
+
+procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
+begin
+  fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket));
+end;
+
+procedure FD_ZERO(var fdset: TFDSet);
+var
+  I: Integer;
+begin
+  with fdset do
+    for I := Low(fds_bits) to High(fds_bits) do
+      fds_bits[I] := 0;
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+  Result := ssBind(s, @addr, SizeOfVarSin(addr));
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+  Result := ssConnect(s, @name, SizeOfVarSin(name));
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetSockName(s, @name, Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetPeerName(s, @name, Len);
+end;
+
+function GetHostName: string;
+var
+  s: string;
+begin
+  Result := '';
+  setlength(s, 255);
+  ssGetHostName(pchar(s), Length(s) - 1);
+  Result := Pchar(s);
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := ssSend(s, Buf^, len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := ssRecv(s, Buf^, len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+  Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: integer;
+begin
+  x := SizeOf(from);
+  Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: integer;
+begin
+  x := SizeOf(addr);
+  Result := ssAccept(s, @addr, x);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+type
+  pu_long = ^u_long;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  HostEnt: PHostEnt;
+  r: integer;
+  Hints1, Hints2: TAddrInfo;
+  Sin1, Sin2: TVarSin;
+  TwoPass: boolean;
+
+  function GetAddr(const IP, port: string; Hints: TAddrInfo; var Sin: TVarSin): integer;
+  var
+    Addr: PAddrInfo;
+  begin
+    Addr := nil;
+    try
+      FillChar(Sin, Sizeof(Sin), 0);
+      if Hints.ai_socktype = SOCK_RAW then
+      begin
+        Hints.ai_socktype := 0;
+        Hints.ai_protocol := 0;
+        Result := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr);
+      end
+      else
+      begin
+        if (IP = cAnyHost) or (IP = c6AnyHost) then
+        begin
+          Hints.ai_flags := AI_PASSIVE;
+          Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
+        end
+        else
+          if (IP = cLocalhost) or (IP = c6Localhost) then
+          begin
+            Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
+          end
+          else
+          begin
+            Result := synsock.GetAddrInfo(PChar(IP), PChar(Port), @Hints, Addr);
+          end;
+      end;
+      if Result = 0 then
+        if (Addr <> nil) then
+          Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  if not IsNewApi(family) then
+  begin
+    SynSockCS.Enter;
+    try
+      Sin.sin_family := AF_INET;
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+        ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Sin.sin_port := synsock.htons(StrToIntDef(Port, 0))
+      else
+        Sin.sin_port := ServEnt^.s_port;
+      if IP = cBroadcast then
+        Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
+      else
+      begin
+        Sin.sin_addr.s_addr := synsock.inet_addr(PChar(IP));
+        if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then
+        begin
+          HostEnt := synsock.GetHostByName(PChar(IP));
+          Result := synsock.WSAGetLastError;
+          if HostEnt <> nil then
+            Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
+        end;
+      end;
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    FillChar(Hints1, Sizeof(Hints1), 0);
+    FillChar(Hints2, Sizeof(Hints2), 0);
+    TwoPass := False;
+    if Family = AF_UNSPEC then
+    begin
+      if PreferIP4 then
+      begin
+        Hints1.ai_family := AF_INET;
+        Hints2.ai_family := AF_INET6;
+        TwoPass := True;
+      end
+      else
+      begin
+        Hints2.ai_family := AF_INET;
+        Hints1.ai_family := AF_INET6;
+        TwoPass := True;
+      end;
+    end
+    else
+      Hints1.ai_family := Family;
+
+    Hints1.ai_socktype := SockType;
+    Hints1.ai_protocol := SockProtocol;
+    Hints2.ai_socktype := Hints1.ai_socktype;
+    Hints2.ai_protocol := Hints1.ai_protocol;
+
+    r := GetAddr(IP, Port, Hints1, Sin1);
+    Result := r;
+    sin := sin1;
+    if r <> 0 then
+      if TwoPass then
+      begin
+        r := GetAddr(IP, Port, Hints2, Sin2);
+        Result := r;
+        if r = 0 then
+          sin := sin2;
+      end;
+  end;
+end;
+
+function GetSinIP(Sin: TVarSin): string;
+var
+  p: PChar;
+  host, serv: string;
+  hostlen, servlen: integer;
+  r: integer;
+begin
+  Result := '';
+  if not IsNewApi(Sin.AddressFamily) then
+  begin
+    p := synsock.inet_ntoa(Sin.sin_addr);
+    if p <> nil then
+      Result := p;
+  end
+  else
+  begin
+    hostlen := NI_MAXHOST;
+    servlen := NI_MAXSERV;
+    setlength(host, hostlen);
+    setlength(serv, servlen);
+    r := getnameinfo(@sin, SizeOfVarSin(sin), PChar(host), hostlen,
+      PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV);
+    if r = 0 then
+      Result := PChar(host);
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
+type
+  TaPInAddr = array[0..250] of PInAddr;
+  PaPInAddr = ^TaPInAddr;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  AddrNext: PAddrInfo;
+  r: integer;
+  host, serv: string;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IP: u_long;
+  PAdrPtr: PaPInAddr;
+  i: Integer;
+  s: string;
+  InAddr: TInAddr;
+begin
+  IPList.Clear;
+  if not IsNewApi(Family) then
+  begin
+    IP := synsock.inet_addr(PChar(Name));
+    if IP = u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := synsock.GetHostByName(PChar(Name));
+        if RemoteHost <> nil then
+        begin
+          PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
+          i := 0;
+          while PAdrPtr^[i] <> nil do
+          begin
+            InAddr := PAdrPtr^[i]^;
+            s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1],
+              InAddr.S_bytes[2], InAddr.S_bytes[3]]);
+            IPList.Add(s);
+            Inc(i);
+          end;
+        end;
+      finally
+        SynSockCS.Leave;
+      end;
+    end
+    else
+      IPList.Add(Name);
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr);
+      if r = 0 then
+      begin
+        AddrNext := Addr;
+        while not(AddrNext = nil) do
+        begin
+          if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
+            or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
+          begin
+            hostlen := NI_MAXHOST;
+            servlen := NI_MAXSERV;
+            setlength(host, hostlen);
+            setlength(serv, servlen);
+            r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen,
+              PChar(host), hostlen, PChar(serv), servlen,
+              NI_NUMERICHOST + NI_NUMERICSERV);
+            if r = 0 then
+            begin
+              host := PChar(host);
+              IPList.Add(host);
+            end;
+          end;
+          AddrNext := AddrNext^.ai_next;
+        end;
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+  if IPList.Count = 0 then
+    IPList.Add(cAnyHost);
+end;
+
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+begin
+  Result := 0;
+  if not IsNewApi(Family) then
+  begin
+    SynSockCS.Enter;
+    try
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+        ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Result := StrToIntDef(Port, 0)
+      else
+        Result := synsock.htons(ServEnt^.s_port);
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := Sockprotocol;
+      Hints.ai_flags := AI_PASSIVE;
+      r := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr);
+      if (r = 0) and Assigned(Addr) then
+      begin
+        if Addr^.ai_family = AF_INET then
+          Result := synsock.htons(Addr^.ai_addr^.sin_port);
+        if Addr^.ai_family = AF_INET6 then
+          Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+  host, serv: string;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IPn: u_long;
+begin
+  Result := IP;
+  if not IsNewApi(Family) then
+  begin
+    IPn := synsock.inet_addr(PChar(IP));
+    if IPn <> u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET);
+        if RemoteHost <> nil then
+          Result := RemoteHost^.h_name;
+      finally
+        SynSockCS.Leave;
+      end;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PChar(IP), nil, @Hints, Addr);
+      if (r = 0) and Assigned(Addr)then
+      begin
+        hostlen := NI_MAXHOST;
+        servlen := NI_MAXSERV;
+        setlength(host, hostlen);
+        setlength(serv, servlen);
+        r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen,
+          PChar(host), hostlen, PChar(serv), servlen,
+          NI_NUMERICSERV);
+        if r = 0 then
+          Result := PChar(host);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: string): Boolean;
+begin
+  Result := False;
+  if stack = '' then
+    stack := DLLStackName;
+  SynSockCS.Enter;
+  try
+    if SynSockCount = 0 then
+    begin
+      SockEnhancedApi := False;
+      SockWship6Api := False;
+      Signal(SIGPIPE, TSignalHandler(SIG_IGN));
+      LibHandle := LoadLibrary(PChar(Stack));
+      if LibHandle <> 0 then
+      begin
+        errno_loc := GetProcAddress(LibHandle, PChar('__errno_location'));
+        CloseSocket := GetProcAddress(LibHandle, PChar('close'));
+        IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl'));
+        WSAGetLastError := LSWSAGetLastError;
+        WSAStartup := LSWSAStartup;
+        WSACleanup := LSWSACleanup;
+        ssAccept := GetProcAddress(LibHandle, PChar('accept'));
+        ssBind := GetProcAddress(LibHandle, PChar('bind'));
+        ssConnect := GetProcAddress(LibHandle, PChar('connect'));
+        ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername'));
+        ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname'));
+        GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt'));
+        Htonl := GetProcAddress(LibHandle, PChar('htonl'));
+        Htons := GetProcAddress(LibHandle, PChar('htons'));
+        Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr'));
+        Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa'));
+        Listen := GetProcAddress(LibHandle, PChar('listen'));
+        Ntohl := GetProcAddress(LibHandle, PChar('ntohl'));
+        Ntohs := GetProcAddress(LibHandle, PChar('ntohs'));
+        ssRecv := GetProcAddress(LibHandle, PChar('recv'));
+        ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom'));
+        Select := GetProcAddress(LibHandle, PChar('select'));
+        ssSend := GetProcAddress(LibHandle, PChar('send'));
+        ssSendTo := GetProcAddress(LibHandle, PChar('sendto'));
+        SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt'));
+        ShutDown := GetProcAddress(LibHandle, PChar('shutdown'));
+        Socket := GetProcAddress(LibHandle, PChar('socket'));
+        GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr'));
+        GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname'));
+        GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname'));
+        GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber'));
+        GetServByName := GetProcAddress(LibHandle, PChar('getservbyname'));
+        GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport'));
+        ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname'));
+
+{$IFNDEF FORCEOLDAPI}
+        GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo'));
+        FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo'));
+        GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo'));
+        SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
+          and Assigned(GetNameInfo);
+{$ENDIF}
+        Result := True;
+      end;
+    end
+    else Result := True;
+    if Result then
+      Inc(SynSockCount);
+  finally
+    SynSockCS.Leave;
+  end;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  SynSockCS.Enter;
+  try
+    Dec(SynSockCount);
+    if SynSockCount < 0 then
+      SynSockCount := 0;
+    if SynSockCount = 0 then
+    begin
+      if LibHandle <> 0 then
+      begin
+        FreeLibrary(libHandle);
+        LibHandle := 0;
+      end;
+      if LibWship6Handle <> 0 then
+      begin
+        FreeLibrary(LibWship6Handle);
+        LibWship6Handle := 0;
+      end;
+    end;
+  finally
+    SynSockCS.Leave;
+  end;
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;
+
+{$ENDIF}
+

ssos2ws1.inc

@@ -0,0 +1,1843 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.000.000 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - OS/2 winsock1                   |
+|==============================================================================|
+| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Tomas Hajny (OS2 support)                                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$MACRO ON}
+
+{$IFNDEF ODIN}
+ {$DEFINE WINSOCK1}
+ {$DEFINE PMWSOCK}
+{$ENDIF ODIN}
+
+{$IFDEF PMWSOCK}
+  {$DEFINE extdecl := cdecl}
+{$ELSE PMWSOCK}
+  {$DEFINE extdecl := stdcall}
+{$ENDIF PMWSOCK}
+
+//{$DEFINE WINSOCK1}
+{Note about define WINSOCK1:
+If you activate this compiler directive, then socket interface level 1.1 is
+used instead default level 2.2. Level 2.2 is not available on old W95, however
+you can install update.
+}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+  (*$HPPEMIT '/* EDE 2003-02-19 */' *)
+  (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *)
+  (*$HPPEMIT '#undef h_addr' *)
+  (*$HPPEMIT '#undef IOCPARM_MASK' *)
+  (*$HPPEMIT '#undef FD_SETSIZE' *)
+  (*$HPPEMIT '#undef IOC_VOID' *)
+  (*$HPPEMIT '#undef IOC_OUT' *)
+  (*$HPPEMIT '#undef IOC_IN' *)
+  (*$HPPEMIT '#undef IOC_INOUT' *)
+  (*$HPPEMIT '#undef FIONREAD' *)
+  (*$HPPEMIT '#undef FIONBIO' *)
+  (*$HPPEMIT '#undef FIOASYNC' *)
+  (*$HPPEMIT '#undef IPPROTO_IP' *)
+  (*$HPPEMIT '#undef IPPROTO_ICMP' *)
+  (*$HPPEMIT '#undef IPPROTO_IGMP' *)
+  (*$HPPEMIT '#undef IPPROTO_TCP' *)
+  (*$HPPEMIT '#undef IPPROTO_UDP' *)
+  (*$HPPEMIT '#undef IPPROTO_RAW' *)
+  (*$HPPEMIT '#undef IPPROTO_MAX' *)
+  (*$HPPEMIT '#undef INADDR_ANY' *)
+  (*$HPPEMIT '#undef INADDR_LOOPBACK' *)
+  (*$HPPEMIT '#undef INADDR_BROADCAST' *)
+  (*$HPPEMIT '#undef INADDR_NONE' *)
+  (*$HPPEMIT '#undef INVALID_SOCKET' *)
+  (*$HPPEMIT '#undef SOCKET_ERROR' *)
+  (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *)
+  (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *)
+  (*$HPPEMIT '#undef IP_OPTIONS' *)
+  (*$HPPEMIT '#undef IP_TOS' *)
+  (*$HPPEMIT '#undef IP_TTL' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_IF' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_TTL' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *)
+  (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *)
+  (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *)
+  (*$HPPEMIT '#undef IP_DONTFRAGMENT' *)
+  (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *)
+  (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *)
+  (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *)
+  (*$HPPEMIT '#undef SOL_SOCKET' *)
+  (*$HPPEMIT '#undef SO_DEBUG' *)
+  (*$HPPEMIT '#undef SO_ACCEPTCONN' *)
+  (*$HPPEMIT '#undef SO_REUSEADDR' *)
+  (*$HPPEMIT '#undef SO_KEEPALIVE' *)
+  (*$HPPEMIT '#undef SO_DONTROUTE' *)
+  (*$HPPEMIT '#undef SO_BROADCAST' *)
+  (*$HPPEMIT '#undef SO_USELOOPBACK' *)
+  (*$HPPEMIT '#undef SO_LINGER' *)
+  (*$HPPEMIT '#undef SO_OOBINLINE' *)
+  (*$HPPEMIT '#undef SO_DONTLINGER' *)
+  (*$HPPEMIT '#undef SO_SNDBUF' *)
+  (*$HPPEMIT '#undef SO_RCVBUF' *)
+  (*$HPPEMIT '#undef SO_SNDLOWAT' *)
+  (*$HPPEMIT '#undef SO_RCVLOWAT' *)
+  (*$HPPEMIT '#undef SO_SNDTIMEO' *)
+  (*$HPPEMIT '#undef SO_RCVTIMEO' *)
+  (*$HPPEMIT '#undef SO_ERROR' *)
+  (*$HPPEMIT '#undef SO_OPENTYPE' *)
+  (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *)
+  (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *)
+  (*$HPPEMIT '#undef SO_MAXDG' *)
+  (*$HPPEMIT '#undef SO_MAXPATHDG' *)
+  (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *)
+  (*$HPPEMIT '#undef SO_CONNECT_TIME' *)
+  (*$HPPEMIT '#undef SO_TYPE' *)
+  (*$HPPEMIT '#undef SOCK_STREAM' *)
+  (*$HPPEMIT '#undef SOCK_DGRAM' *)
+  (*$HPPEMIT '#undef SOCK_RAW' *)
+  (*$HPPEMIT '#undef SOCK_RDM' *)
+  (*$HPPEMIT '#undef SOCK_SEQPACKET' *)
+  (*$HPPEMIT '#undef TCP_NODELAY' *)
+  (*$HPPEMIT '#undef AF_UNSPEC' *)
+  (*$HPPEMIT '#undef SOMAXCONN' *)
+  (*$HPPEMIT '#undef AF_INET' *)
+  (*$HPPEMIT '#undef AF_MAX' *)
+  (*$HPPEMIT '#undef PF_UNSPEC' *)
+  (*$HPPEMIT '#undef PF_INET' *)
+  (*$HPPEMIT '#undef PF_MAX' *)
+  (*$HPPEMIT '#undef MSG_OOB' *)
+  (*$HPPEMIT '#undef MSG_PEEK' *)
+  (*$HPPEMIT '#undef WSABASEERR' *)
+  (*$HPPEMIT '#undef WSAEINTR' *)
+  (*$HPPEMIT '#undef WSAEBADF' *)
+  (*$HPPEMIT '#undef WSAEACCES' *)
+  (*$HPPEMIT '#undef WSAEFAULT' *)
+  (*$HPPEMIT '#undef WSAEINVAL' *)
+  (*$HPPEMIT '#undef WSAEMFILE' *)
+  (*$HPPEMIT '#undef WSAEWOULDBLOCK' *)
+  (*$HPPEMIT '#undef WSAEINPROGRESS' *)
+  (*$HPPEMIT '#undef WSAEALREADY' *)
+  (*$HPPEMIT '#undef WSAENOTSOCK' *)
+  (*$HPPEMIT '#undef WSAEDESTADDRREQ' *)
+  (*$HPPEMIT '#undef WSAEMSGSIZE' *)
+  (*$HPPEMIT '#undef WSAEPROTOTYPE' *)
+  (*$HPPEMIT '#undef WSAENOPROTOOPT' *)
+  (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEOPNOTSUPP' *)
+  (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEADDRINUSE' *)
+  (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *)
+  (*$HPPEMIT '#undef WSAENETDOWN' *)
+  (*$HPPEMIT '#undef WSAENETUNREACH' *)
+  (*$HPPEMIT '#undef WSAENETRESET' *)
+  (*$HPPEMIT '#undef WSAECONNABORTED' *)
+  (*$HPPEMIT '#undef WSAECONNRESET' *)
+  (*$HPPEMIT '#undef WSAENOBUFS' *)
+  (*$HPPEMIT '#undef WSAEISCONN' *)
+  (*$HPPEMIT '#undef WSAENOTCONN' *)
+  (*$HPPEMIT '#undef WSAESHUTDOWN' *)
+  (*$HPPEMIT '#undef WSAETOOMANYREFS' *)
+  (*$HPPEMIT '#undef WSAETIMEDOUT' *)
+  (*$HPPEMIT '#undef WSAECONNREFUSED' *)
+  (*$HPPEMIT '#undef WSAELOOP' *)
+  (*$HPPEMIT '#undef WSAENAMETOOLONG' *)
+  (*$HPPEMIT '#undef WSAEHOSTDOWN' *)
+  (*$HPPEMIT '#undef WSAEHOSTUNREACH' *)
+  (*$HPPEMIT '#undef WSAENOTEMPTY' *)
+  (*$HPPEMIT '#undef WSAEPROCLIM' *)
+  (*$HPPEMIT '#undef WSAEUSERS' *)
+  (*$HPPEMIT '#undef WSAEDQUOT' *)
+  (*$HPPEMIT '#undef WSAESTALE' *)
+  (*$HPPEMIT '#undef WSAEREMOTE' *)
+  (*$HPPEMIT '#undef WSASYSNOTREADY' *)
+  (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *)
+  (*$HPPEMIT '#undef WSANOTINITIALISED' *)
+  (*$HPPEMIT '#undef WSAEDISCON' *)
+  (*$HPPEMIT '#undef WSAENOMORE' *)
+  (*$HPPEMIT '#undef WSAECANCELLED' *)
+  (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *)
+  (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *)
+  (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *)
+  (*$HPPEMIT '#undef WSASYSCALLFAILURE' *)
+  (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSA_E_NO_MORE' *)
+  (*$HPPEMIT '#undef WSA_E_CANCELLED' *)
+  (*$HPPEMIT '#undef WSAEREFUSED' *)
+  (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *)
+  (*$HPPEMIT '#undef HOST_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSATRY_AGAIN' *)
+  (*$HPPEMIT '#undef TRY_AGAIN' *)
+  (*$HPPEMIT '#undef WSANO_RECOVERY' *)
+  (*$HPPEMIT '#undef NO_RECOVERY' *)
+  (*$HPPEMIT '#undef WSANO_DATA' *)
+  (*$HPPEMIT '#undef NO_DATA' *)
+  (*$HPPEMIT '#undef WSANO_ADDRESS' *)
+  (*$HPPEMIT '#undef ENAMETOOLONG' *)
+  (*$HPPEMIT '#undef ENOTEMPTY' *)
+  (*$HPPEMIT '#undef FD_CLR' *)
+  (*$HPPEMIT '#undef FD_ISSET' *)
+  (*$HPPEMIT '#undef FD_SET' *)
+  (*$HPPEMIT '#undef FD_ZERO' *)
+  (*$HPPEMIT '#undef NO_ADDRESS' *)
+  (*$HPPEMIT '#undef ADDR_ANY' *)
+  (*$HPPEMIT '#undef SO_GROUP_ID' *)
+  (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *)
+  (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *)
+  (*$HPPEMIT '#undef PVD_CONFIG' *)
+  (*$HPPEMIT '#undef AF_INET6' *)
+  (*$HPPEMIT '#undef PF_INET6' *)
+{$ENDIF}
+
+{$IFDEF FPC}
+  {$IFDEF WIN32}
+    {$ALIGN OFF}
+  {$ELSE}
+    {$PACKRECORDS C}
+  {$ENDIF}
+{$ELSE}
+  {$IFDEF WIN64}
+    {$ALIGN ON}
+    {$MINENUMSIZE 4}
+  {$ELSE}
+    {$MINENUMSIZE 4}
+    {$ALIGN OFF}
+  {$ENDIF}
+{$ENDIF}
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+{$IFDEF OS2}
+  Sockets, Dynlibs
+{$ELSE OS2}
+  Windows
+{$ENDIF OS2}
+;
+
+function InitSocketInterface(stack: String): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+{$IFDEF WINSOCK1}
+  WinsockLevel = $0101;
+{$ELSE}
+  WinsockLevel = $0202;
+{$ENDIF}
+
+type
+{$IFDEF OS2}
+  Bool = longint;
+{$ENDIF OS2}
+  u_short = Word;
+  u_int = Integer;
+  u_long = Longint;
+  pu_long = ^u_long;
+  pu_short = ^u_short;
+{$IFDEF FPC}
+  TSocket = ptruint;
+{$ELSE}
+  {$IFDEF WIN64}
+  TSocket = UINT_PTR;
+  {$ELSE}
+  TSocket = u_int;
+  {$ENDIF}
+{$ENDIF}
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+const
+  {$IFDEF WINCE}
+    DLLStackName = 'ws2.dll';
+  {$ELSE}
+    {$IFDEF WINSOCK1}
+     {$IFDEF OS2}
+      {$IFDEF DAPWSOCK}
+    DLLStackName = 'dapwsock.dll';
+      {$ELSE DAPWSOCK}
+    DLLStackName = 'pmwsock.dll';
+      {$ENDIF DAPWSOCK}
+     {$ELSE OS2}
+    DLLStackName = 'wsock32.dll';
+     {$ENDIF OS2}
+    {$ELSE}
+    DLLStackName = 'ws2_32.dll';
+    {$ENDIF}
+  {$ENDIF}
+  DLLwship6 = 'wship6.dll';
+
+  cLocalhost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  cBroadcast = '255.255.255.255';
+  c6Localhost = '::1';
+  c6AnyHost = '::0';
+  c6Broadcast = 'ffff::1';
+  cAnyPort = '0';
+
+
+const
+  FD_SETSIZE     =   64;
+type
+  PFDSet = ^TFDSet;
+  TFDSet = record
+    fd_count: u_int;
+    fd_array: array[0..FD_SETSIZE-1] of TSocket;
+  end;
+
+const
+  FIONREAD     = $4004667f;
+  FIONBIO      = $8004667e;
+  FIOASYNC     = $8004667d;
+
+type
+  PTimeVal = ^TTimeVal;
+  TTimeVal = record
+    tv_sec: Longint;
+    tv_usec: Longint;
+  end;
+
+const
+  IPPROTO_IP     =   0;		{ Dummy					}
+  IPPROTO_ICMP   =   1;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   2;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   6;		{ TCP           			}
+  IPPROTO_UDP    =   17;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   41;
+  IPPROTO_ICMPV6 =   58;
+  IPPROTO_RM     =  113;
+
+  IPPROTO_RAW    =   255;
+  IPPROTO_MAX    =   256;
+
+type
+
+  PInAddr = ^TInAddr;
+  TInAddr = record
+    case integer of
+      0: (S_bytes: packed array [0..3] of byte);
+      1: (S_addr: u_long);
+  end;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = record
+    case Integer of
+      0: (sin_family: u_short;
+          sin_port: u_short;
+          sin_addr: TInAddr;
+          sin_zero: array[0..7] of byte);
+      1: (sa_family: u_short;
+          sa_data: array[0..13] of byte)
+  end;
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     { IP multicast address of group }
+    imr_interface: TInAddr;     { local IP address of interface }
+  end;
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = record
+    case integer of
+      0: (S6_addr: packed array [0..15] of byte);
+      1: (u6_addr8: packed array [0..15] of byte);
+      2: (u6_addr16: packed array [0..7] of word);
+      3: (u6_addr32: packed array [0..3] of integer);
+  end;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = record
+		sin6_family:   u_short;     // AF_INET6
+		sin6_port:     u_short;     // Transport level port number
+		sin6_flowinfo: u_long;	    // IPv6 flow information
+		sin6_addr:     TInAddr6;    // IPv6 address
+		sin6_scope_id: u_long;      // Scope Id: IF number for link-local
+                                //           SITE id for site-local
+  end;
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+    padding: integer;
+  end;
+
+  PHostEnt = ^THostEnt;
+  THostEnt = record
+    h_name: PAnsiChar;
+    h_aliases: ^PAnsiChar;
+{$IFDEF PMWSOCK}
+    h_addrtype: longint;
+    h_length: longint;
+{$ELSE PMWSOCK}
+    h_addrtype: Smallint;
+    h_length: Smallint;
+{$ENDIF PMWSOCK}
+    case integer of
+     0: (h_addr_list: ^PAnsiChar);
+     1: (h_addr: ^PInAddr);
+  end;
+
+  PNetEnt = ^TNetEnt;
+  TNetEnt = record
+    n_name: PAnsiChar;
+    n_aliases: ^PAnsiChar;
+{$IFDEF PMWSOCK}
+    n_addrtype: longint;
+{$ELSE PMWSOCK}
+    n_addrtype: Smallint;
+{$ENDIF PMWSOCK}
+    n_net: u_long;
+  end;
+
+  PServEnt = ^TServEnt;
+  TServEnt = record
+    s_name: PAnsiChar;
+    s_aliases: ^PAnsiChar;
+{$ifdef WIN64}
+    s_proto: PAnsiChar;
+    s_port: Smallint;
+{$else} 
+{$IFDEF PMWSOCK}
+    s_port: longint;
+{$ELSE PMWSOCK}
+    s_port: Smallint;
+{$ENDIF PMWSOCK}
+    s_proto: PAnsiChar;
+{$endif}
+  end;
+
+  PProtoEnt = ^TProtoEnt;
+  TProtoEnt = record
+    p_name: PAnsiChar;
+    p_aliases: ^PAnsichar;
+{$IFDEF PMWSOCK}
+    p_proto: longint;
+{$ELSE PMWSOCK}
+    p_proto: Smallint;
+{$ENDIF PMWSOCK}
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  {$IFDEF WINSOCK1}
+    IP_OPTIONS          = 1;
+    IP_MULTICAST_IF     = 2;           { set/get IP multicast interface   }
+    IP_MULTICAST_TTL    = 3;           { set/get IP multicast timetolive  }
+    IP_MULTICAST_LOOP   = 4;           { set/get IP multicast loopback    }
+    IP_ADD_MEMBERSHIP   = 5;           { add  an IP group membership      }
+    IP_DROP_MEMBERSHIP  = 6;           { drop an IP group membership      }
+    IP_TTL              = 7;           { set/get IP Time To Live          }
+    IP_TOS              = 8;           { set/get IP Type Of Service       }
+    IP_DONTFRAGMENT     = 9;           { set/get IP Don't Fragment flag   }
+  {$ELSE}
+    IP_OPTIONS          = 1;
+    IP_HDRINCL          = 2;
+    IP_TOS              = 3;           { set/get IP Type Of Service       }
+    IP_TTL              = 4;           { set/get IP Time To Live          }
+    IP_MULTICAST_IF     = 9;           { set/get IP multicast interface   }
+    IP_MULTICAST_TTL    = 10;           { set/get IP multicast timetolive  }
+    IP_MULTICAST_LOOP   = 11;           { set/get IP multicast loopback    }
+    IP_ADD_MEMBERSHIP   = 12;           { add  an IP group membership      }
+    IP_DROP_MEMBERSHIP  = 13;           { drop an IP group membership      }
+    IP_DONTFRAGMENT     = 14;           { set/get IP Don't Fragment flag   }
+  {$ENDIF}
+
+  IP_DEFAULT_MULTICAST_TTL   = 1;    { normally limit m'casts to 1 hop  }
+  IP_DEFAULT_MULTICAST_LOOP  = 1;    { normally hear sends if a member  }
+  IP_MAX_MEMBERSHIPS         = 20;   { per socket; must fit in one mbuf }
+
+  SOL_SOCKET      = $ffff;          {options for socket level }
+{ Option flags per-socket. }
+  SO_DEBUG        = $0001;          { turn on debugging info recording }
+  SO_ACCEPTCONN   = $0002;          { socket has had listen() }
+  SO_REUSEADDR    = $0004;          { allow local address reuse }
+  SO_KEEPALIVE    = $0008;          { keep connections alive }
+  SO_DONTROUTE    = $0010;          { just use interface addresses }
+  SO_BROADCAST    = $0020;          { permit sending of broadcast msgs }
+  SO_USELOOPBACK  = $0040;          { bypass hardware when possible }
+  SO_LINGER       = $0080;          { linger on close if data present }
+  SO_OOBINLINE    = $0100;          { leave received OOB data in line }
+  SO_DONTLINGER  =   $ff7f;
+{ Additional options. }
+  SO_SNDBUF       = $1001;          { send buffer size }
+  SO_RCVBUF       = $1002;          { receive buffer size }
+  SO_SNDLOWAT     = $1003;          { send low-water mark }
+  SO_RCVLOWAT     = $1004;          { receive low-water mark }
+  SO_SNDTIMEO     = $1005;          { send timeout }
+  SO_RCVTIMEO     = $1006;          { receive timeout }
+  SO_ERROR        = $1007;          { get error status and clear }
+  SO_TYPE         = $1008;          { get socket type }
+{ WinSock 2 extension -- new options }
+  SO_GROUP_ID       = $2001; { ID of a socket group}
+  SO_GROUP_PRIORITY = $2002; { the relative priority within a group}
+  SO_MAX_MSG_SIZE   = $2003; { maximum message size }
+  SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure }
+  SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure }
+  SO_PROTOCOL_INFO  = SO_PROTOCOL_INFOA;
+  PVD_CONFIG        = $3001; {configuration info for service provider }
+{ Option for opening sockets for synchronous access. }
+  SO_OPENTYPE     = $7008;
+  SO_SYNCHRONOUS_ALERT    = $10;
+  SO_SYNCHRONOUS_NONALERT = $20;
+{ Other NT-specific options. }
+  SO_MAXDG        = $7009;
+  SO_MAXPATHDG    = $700A;
+  SO_UPDATE_ACCEPT_CONTEXT     = $700B;
+  SO_CONNECT_TIME = $700C;
+
+  SOMAXCONN       = $7fffffff;
+
+  IPV6_UNICAST_HOPS      = 8;  // ???
+  IPV6_MULTICAST_IF      = 9;  // set/get IP multicast i/f
+  IPV6_MULTICAST_HOPS    = 10; // set/get IP multicast ttl
+  IPV6_MULTICAST_LOOP    = 11; // set/get IP multicast loopback
+  IPV6_JOIN_GROUP        = 12; // add an IP group membership
+  IPV6_LEAVE_GROUP       = 13; // drop an IP group membership
+
+  MSG_NOSIGNAL  = 0;
+
+  // getnameinfo constants
+  NI_MAXHOST	   = 1025;
+  NI_MAXSERV	   = 32;
+  NI_NOFQDN 	   = $1;
+  NI_NUMERICHOST = $2;
+  NI_NAMEREQD	   = $4;
+  NI_NUMERICSERV = $8;
+  NI_DGRAM       = $10;
+
+
+const
+  SOCK_STREAM     = 1;               { stream socket }
+  SOCK_DGRAM      = 2;               { datagram socket }
+  SOCK_RAW        = 3;               { raw-protocol interface }
+  SOCK_RDM        = 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001;
+
+{ Address families. }
+
+  AF_UNSPEC       = 0;               { unspecified }
+  AF_INET         = 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = 23;              { Internetwork Version 6 }
+  AF_MAX          = 24;
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+  { Structure used by kernel to store most addresses. }
+  PSockAddr = ^TSockAddr;
+  TSockAddr = TSockAddrIn;
+
+  { Structure used by kernel to pass protocol information in raw sockets. }
+  PSockProto = ^TSockProto;
+  TSockProto = record
+    sp_family: u_short;
+    sp_protocol: u_short;
+  end;
+
+type
+  PAddrInfo = ^TAddrInfo;
+  TAddrInfo = record
+                ai_flags: integer;    // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
+                ai_family: integer;   // PF_xxx.
+                ai_socktype: integer; // SOCK_xxx.
+                ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
+                ai_addrlen: u_int;    // Length of ai_addr.
+                ai_canonname: PAnsiChar;  // Canonical name for nodename.
+                ai_addr: PSockAddr;   // Binary address.
+                ai_next: PAddrInfo;     // Next structure in linked list.
+              end;
+
+const
+  // Flags used in "hints" argument to getaddrinfo().
+  AI_PASSIVE     = $1;  // Socket address will be used in bind() call.
+  AI_CANONNAME   = $2;  // Return canonical name in first ai_canonname.
+  AI_NUMERICHOST = $4;  // Nodename must be a numeric address string.
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = record
+{$IFDEF PMWSOCK}
+    l_onoff: longint;
+    l_linger: longint;
+{$ELSE PMWSOCK}
+    l_onoff: u_short;
+    l_linger: u_short;
+{$ENDIF PMWSOCK}
+  end;
+
+const
+
+  MSG_OOB       = $01;                  // Process out-of-band data.
+  MSG_PEEK      = $02;                  // Peek at incoming messages.
+
+const
+
+{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
+  WSABASEERR              = 10000;
+
+{ Windows Sockets definitions of regular Microsoft C error constants }
+
+  WSAEINTR                = (WSABASEERR+4);
+  WSAEBADF                = (WSABASEERR+9);
+  WSAEACCES               = (WSABASEERR+13);
+  WSAEFAULT               = (WSABASEERR+14);
+  WSAEINVAL               = (WSABASEERR+22);
+  WSAEMFILE               = (WSABASEERR+24);
+
+{ Windows Sockets definitions of regular Berkeley error constants }
+
+  WSAEWOULDBLOCK          = (WSABASEERR+35);
+  WSAEINPROGRESS          = (WSABASEERR+36);
+  WSAEALREADY             = (WSABASEERR+37);
+  WSAENOTSOCK             = (WSABASEERR+38);
+  WSAEDESTADDRREQ         = (WSABASEERR+39);
+  WSAEMSGSIZE             = (WSABASEERR+40);
+  WSAEPROTOTYPE           = (WSABASEERR+41);
+  WSAENOPROTOOPT          = (WSABASEERR+42);
+  WSAEPROTONOSUPPORT      = (WSABASEERR+43);
+  WSAESOCKTNOSUPPORT      = (WSABASEERR+44);
+  WSAEOPNOTSUPP           = (WSABASEERR+45);
+  WSAEPFNOSUPPORT         = (WSABASEERR+46);
+  WSAEAFNOSUPPORT         = (WSABASEERR+47);
+  WSAEADDRINUSE           = (WSABASEERR+48);
+  WSAEADDRNOTAVAIL        = (WSABASEERR+49);
+  WSAENETDOWN             = (WSABASEERR+50);
+  WSAENETUNREACH          = (WSABASEERR+51);
+  WSAENETRESET            = (WSABASEERR+52);
+  WSAECONNABORTED         = (WSABASEERR+53);
+  WSAECONNRESET           = (WSABASEERR+54);
+  WSAENOBUFS              = (WSABASEERR+55);
+  WSAEISCONN              = (WSABASEERR+56);
+  WSAENOTCONN             = (WSABASEERR+57);
+  WSAESHUTDOWN            = (WSABASEERR+58);
+  WSAETOOMANYREFS         = (WSABASEERR+59);
+  WSAETIMEDOUT            = (WSABASEERR+60);
+  WSAECONNREFUSED         = (WSABASEERR+61);
+  WSAELOOP                = (WSABASEERR+62);
+  WSAENAMETOOLONG         = (WSABASEERR+63);
+  WSAEHOSTDOWN            = (WSABASEERR+64);
+  WSAEHOSTUNREACH         = (WSABASEERR+65);
+  WSAENOTEMPTY            = (WSABASEERR+66);
+  WSAEPROCLIM             = (WSABASEERR+67);
+  WSAEUSERS               = (WSABASEERR+68);
+  WSAEDQUOT               = (WSABASEERR+69);
+  WSAESTALE               = (WSABASEERR+70);
+  WSAEREMOTE              = (WSABASEERR+71);
+
+{ Extended Windows Sockets error constant definitions }
+
+  WSASYSNOTREADY          = (WSABASEERR+91);
+  WSAVERNOTSUPPORTED      = (WSABASEERR+92);
+  WSANOTINITIALISED       = (WSABASEERR+93);
+  WSAEDISCON              = (WSABASEERR+101);
+  WSAENOMORE              = (WSABASEERR+102);
+  WSAECANCELLED           = (WSABASEERR+103);
+  WSAEEINVALIDPROCTABLE   = (WSABASEERR+104);
+  WSAEINVALIDPROVIDER     = (WSABASEERR+105);
+  WSAEPROVIDERFAILEDINIT  = (WSABASEERR+106);
+  WSASYSCALLFAILURE       = (WSABASEERR+107);
+  WSASERVICE_NOT_FOUND    = (WSABASEERR+108);
+  WSATYPE_NOT_FOUND       = (WSABASEERR+109);
+  WSA_E_NO_MORE           = (WSABASEERR+110);
+  WSA_E_CANCELLED         = (WSABASEERR+111);
+  WSAEREFUSED             = (WSABASEERR+112);
+
+{ Error return codes from gethostbyname() and gethostbyaddr()
+  (when using the resolver). Note that these errors are
+  retrieved via WSAGetLastError() and must therefore follow
+  the rules for avoiding clashes with error numbers from
+  specific implementations or language run-time systems.
+  For this reason the codes are based at WSABASEERR+1001.
+  Note also that [WSA]NO_ADDRESS is defined only for
+  compatibility purposes. }
+
+{ Authoritative Answer: Host not found }
+  WSAHOST_NOT_FOUND       = (WSABASEERR+1001);
+  HOST_NOT_FOUND          = WSAHOST_NOT_FOUND;
+{ Non-Authoritative: Host not found, or SERVERFAIL }
+  WSATRY_AGAIN            = (WSABASEERR+1002);
+  TRY_AGAIN               = WSATRY_AGAIN;
+{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
+  WSANO_RECOVERY          = (WSABASEERR+1003);
+  NO_RECOVERY             = WSANO_RECOVERY;
+{ Valid name, no data record of requested type }
+  WSANO_DATA              = (WSABASEERR+1004);
+  NO_DATA                 = WSANO_DATA;
+{ no address, look for MX record }
+  WSANO_ADDRESS           = WSANO_DATA;
+  NO_ADDRESS              = WSANO_ADDRESS;
+
+  EWOULDBLOCK        =  WSAEWOULDBLOCK;
+  EINPROGRESS        =  WSAEINPROGRESS;
+  EALREADY           =  WSAEALREADY;
+  ENOTSOCK           =  WSAENOTSOCK;
+  EDESTADDRREQ       =  WSAEDESTADDRREQ;
+  EMSGSIZE           =  WSAEMSGSIZE;
+  EPROTOTYPE         =  WSAEPROTOTYPE;
+  ENOPROTOOPT        =  WSAENOPROTOOPT;
+  EPROTONOSUPPORT    =  WSAEPROTONOSUPPORT;
+  ESOCKTNOSUPPORT    =  WSAESOCKTNOSUPPORT;
+  EOPNOTSUPP         =  WSAEOPNOTSUPP;
+  EPFNOSUPPORT       =  WSAEPFNOSUPPORT;
+  EAFNOSUPPORT       =  WSAEAFNOSUPPORT;
+  EADDRINUSE         =  WSAEADDRINUSE;
+  EADDRNOTAVAIL      =  WSAEADDRNOTAVAIL;
+  ENETDOWN           =  WSAENETDOWN;
+  ENETUNREACH        =  WSAENETUNREACH;
+  ENETRESET          =  WSAENETRESET;
+  ECONNABORTED       =  WSAECONNABORTED;
+  ECONNRESET         =  WSAECONNRESET;
+  ENOBUFS            =  WSAENOBUFS;
+  EISCONN            =  WSAEISCONN;
+  ENOTCONN           =  WSAENOTCONN;
+  ESHUTDOWN          =  WSAESHUTDOWN;
+  ETOOMANYREFS       =  WSAETOOMANYREFS;
+  ETIMEDOUT          =  WSAETIMEDOUT;
+  ECONNREFUSED       =  WSAECONNREFUSED;
+  ELOOP              =  WSAELOOP;
+  ENAMETOOLONG       =  WSAENAMETOOLONG;
+  EHOSTDOWN          =  WSAEHOSTDOWN;
+  EHOSTUNREACH       =  WSAEHOSTUNREACH;
+  ENOTEMPTY          =  WSAENOTEMPTY;
+  EPROCLIM           =  WSAEPROCLIM;
+  EUSERS             =  WSAEUSERS;
+  EDQUOT             =  WSAEDQUOT;
+  ESTALE             =  WSAESTALE;
+  EREMOTE            =  WSAEREMOTE;
+
+  EAI_ADDRFAMILY  = 1;   // Address family for nodename not supported.
+  EAI_AGAIN       = 2;   // Temporary failure in name resolution.
+  EAI_BADFLAGS    = 3;   // Invalid value for ai_flags.
+  EAI_FAIL        = 4;   // Non-recoverable failure in name resolution.
+  EAI_FAMILY      = 5;   // Address family ai_family not supported.
+  EAI_MEMORY      = 6;   // Memory allocation failure.
+  EAI_NODATA      = 7;   // No address associated with nodename.
+  EAI_NONAME      = 8;   // Nodename nor servname provided, or not known.
+  EAI_SERVICE     = 9;   // Servname not supported for ai_socktype.
+  EAI_SOCKTYPE    = 10;  // Socket type ai_socktype not supported.
+  EAI_SYSTEM      = 11;  // System error returned in errno.
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = record
+    wVersion: Word;
+    wHighVersion: Word;
+{$ifdef win64}
+    iMaxSockets : Word;
+    iMaxUdpDg : Word;
+    lpVendorInfo : PAnsiChar;
+    szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar;
+    szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar;
+{$else}     
+    szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PAnsiChar;
+{$endif}
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+type
+  TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
+    extdecl;
+  TWSACleanup = function: Integer;
+    extdecl;
+  TWSAGetLastError = function: Integer;
+    extdecl;
+  TGetServByName = function(name, proto: PAnsiChar): PServEnt;
+    extdecl;
+  TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt;
+    extdecl;
+  TGetProtoByName = function(name: PAnsiChar): PProtoEnt;
+    extdecl;
+  TGetProtoByNumber = function(proto: Integer): PProtoEnt;
+    extdecl;
+  TGetHostByName = function(name: PAnsiChar): PHostEnt;
+    extdecl;
+  TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
+    extdecl;
+  TGetHostName = function(name: PAnsiChar; len: Integer): Integer;
+    extdecl;
+  TShutdown = function(s: TSocket; how: Integer): Integer;
+    extdecl;
+  TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
+    optlen: Integer): Integer;
+    extdecl;
+  TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
+    var optlen: Integer): Integer;
+    extdecl;
+  TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
+    tolen: Integer): Integer;
+    extdecl;
+  TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
+    extdecl;
+  TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
+    extdecl;
+  TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
+    var fromlen: Integer): Integer;
+    extdecl;
+  Tntohs = function(netshort: u_short): u_short;
+    extdecl;
+  Tntohl = function(netlong: u_long): u_long;
+    extdecl;
+  TListen = function(s: TSocket; backlog: Integer): Integer;
+    extdecl;
+  TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer;
+    extdecl;
+  TInet_ntoa = function(inaddr: TInAddr): PAnsiChar;
+    extdecl;
+  TInet_addr = function(cp: PAnsiChar): u_long;
+    extdecl;
+  Thtons = function(hostshort: u_short): u_short;
+    extdecl;
+  Thtonl = function(hostlong: u_long): u_long;
+    extdecl;
+  TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    extdecl;
+  TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    extdecl;
+  TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
+    extdecl;
+  TCloseSocket = function(s: TSocket): Integer;
+    extdecl;
+  TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
+    extdecl;
+  TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
+    extdecl;
+  TTSocket = function(af, Struc, Protocol: Integer): TSocket;
+    extdecl;
+  TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+    extdecl;
+
+  TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo;
+    var Addrinfo: PAddrInfo): integer;
+    extdecl;
+  TFreeAddrInfo = procedure(ai: PAddrInfo);
+    extdecl;
+  TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar;
+    hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer;
+    extdecl;
+
+  T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool;
+    extdecl;
+
+  TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
+    cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
+    lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
+    lpCompletionRoutine: pointer): u_int;
+    extdecl;
+
+var
+  WSAStartup: TWSAStartup = nil;
+  WSACleanup: TWSACleanup = nil;
+  WSAGetLastError: TWSAGetLastError = nil;
+  GetServByName: TGetServByName = nil;
+  GetServByPort: TGetServByPort = nil;
+  GetProtoByName: TGetProtoByName = nil;
+  GetProtoByNumber: TGetProtoByNumber = nil;
+  GetHostByName: TGetHostByName = nil;
+  GetHostByAddr: TGetHostByAddr = nil;
+  ssGetHostName: TGetHostName = nil;
+{$IFDEF OS2}
+  ssShutdown: TShutdown = nil;
+  ssSetSockOpt: TSetSockOpt = nil;
+  ssGetSockOpt: TGetSockOpt = nil;
+{$ELSE OS2}
+  Shutdown: TShutdown = nil;
+  SetSockOpt: TSetSockOpt = nil;
+  GetSockOpt: TGetSockOpt = nil;
+{$ENDIF OS2}
+  ssSendTo: TSendTo = nil;
+  ssSend: TSend = nil;
+  ssRecv: TRecv = nil;
+  ssRecvFrom: TRecvFrom = nil;
+  ntohs: Tntohs = nil;
+  ntohl: Tntohl = nil;
+{$IFDEF OS2}
+  ssListen: TListen = nil;
+  ssIoctlSocket: TIoctlSocket = nil;
+{$ELSE OS2}
+  Listen: TListen = nil;
+  IoctlSocket: TIoctlSocket = nil;
+{$ENDIF OS2}
+  Inet_ntoa: TInet_ntoa = nil;
+  Inet_addr: TInet_addr = nil;
+  htons: Thtons = nil;
+  htonl: Thtonl = nil;
+  ssGetSockName: TGetSockName = nil;
+  ssGetPeerName: TGetPeerName = nil;
+  ssConnect: TConnect = nil;
+{$IFDEF OS2}
+  ssCloseSocket: TCloseSocket = nil;
+{$ELSE OS2}
+  CloseSocket: TCloseSocket = nil;
+{$ENDIF OS2}
+  ssBind: TBind = nil;
+  ssAccept: TAccept = nil;
+{$IFDEF OS2}
+  ssSocket: TTSocket = nil;
+{$ELSE OS2}
+  Socket: TTSocket = nil;
+{$ENDIF OS2}
+  Select: TSelect = nil;
+
+  GetAddrInfo: TGetAddrInfo = nil;
+  FreeAddrInfo: TFreeAddrInfo = nil;
+  GetNameInfo: TGetNameInfo = nil;
+
+{$IFDEF OS2}
+  ss__WSAFDIsSet: T__WSAFDIsSet = nil;
+
+  ssWSAIoctl: TWSAIoctl = nil;
+{$ELSE OS2}
+  __WSAFDIsSet: T__WSAFDIsSet = nil;
+
+  WSAIoctl: TWSAIoctl = nil;
+{$ENDIF OS2}
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+    case integer of
+      0: (AddressFamily: u_short);
+      1: (
+        case sin_family: u_short of
+          AF_INET: (sin_port: u_short;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of byte);
+          AF_INET6: (sin6_port:     u_short;
+                		sin6_flowinfo: u_long;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: u_long);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+function Connect(s: TSocket; const name: TVarSin): Integer;
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+function GetHostName: AnsiString;
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): AnsiString;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: AnsiString;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString;
+function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word;
+{$IFDEF OS2}
+function Socket (af, Struc, Protocol: Integer): TSocket;
+function Shutdown (s: TSocket; how: Integer): Integer;
+function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar;
+                                                     optlen: Integer): Integer;
+function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar;
+                                                 var optlen: Integer): Integer;
+function Listen (s: TSocket; backlog: Integer): Integer;
+function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer;
+function CloseSocket (s: TSocket): Integer;
+
+function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool;
+
+function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
+                  cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
+                              lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
+                                          lpCompletionRoutine: pointer): u_int;
+{$ENDIF OS2}
+
+{==============================================================================}
+implementation
+
+var
+  SynSockCount: Integer = 0;
+  LibHandle: THandle = 0;
+  Libwship6Handle: THandle = 0;
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.u6_addr8[15] := 1;
+end;
+
+{=============================================================================}
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+var
+  I: Integer;
+begin
+{$IFDEF OS2}
+  Socket := TSocket (NativeSocket (cInt (Socket)));
+{$ENDIF OS2}
+  I := 0;
+  while I < FDSet.fd_count do
+  begin
+    if FDSet.fd_array[I] = Socket then
+    begin
+      while I < FDSet.fd_count - 1 do
+      begin
+        FDSet.fd_array[I] := FDSet.fd_array[I + 1];
+        Inc(I);
+      end;
+      Dec(FDSet.fd_count);
+      Break;
+    end;
+    Inc(I);
+  end;
+end;
+
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+begin
+{$IFDEF OS2}
+  Socket := TSocket (NativeSocket (cInt (Socket)));
+{$ENDIF OS2}
+  Result := __WSAFDIsSet(Socket, FDSet)
+{$IFDEF OS2}
+                                        <> 0
+{$ENDIF OS2}                                ;
+end;
+
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+begin
+{$IFDEF OS2}
+  Socket := TSocket (NativeSocket (cInt (Socket)));
+{$ENDIF OS2}
+  if FDSet.fd_count < FD_SETSIZE then
+  begin
+    FDSet.fd_array[FDSet.fd_count] := Socket;
+    Inc(FDSet.fd_count);
+  end;
+end;
+
+procedure FD_ZERO(var FDSet: TFDSet);
+begin
+  FDSet.fd_count := 0;
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  Result := ssBind(s, @addr, SizeOfVarSin(addr));
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  Result := ssConnect(s, @name, SizeOfVarSin(name));
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetSockName(s, @name, Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetPeerName(s, @name, Len);
+end;
+
+function GetHostName: AnsiString;
+var
+  s: AnsiString;
+begin
+  Result := '';
+  setlength(s, 255);
+  ssGetHostName(pAnsichar(s), Length(s) - 1);
+  Result := PAnsichar(s);
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  Result := ssSend(s, Buf^, len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  Result := ssRecv(s, Buf^, len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  x := SizeOf(from);
+  Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: integer;
+begin
+{$IFDEF OS2}
+  S := TSocket (NativeSocket (cInt (S)));
+{$ENDIF OS2}
+  x := SizeOf(addr);
+{$IFDEF OS2}
+  Result := TSocket (EMXSocket (cInt (ssAccept (S, @Addr, X))));
+{$ELSE OS2}
+  Result := ssAccept(s, @addr, x);
+{$ENDIF OS2}
+end;
+
+{$IFDEF OS2}
+function Shutdown (s: TSocket; how: Integer): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  Shutdown := ssShutdown (s, how);
+end;
+
+function Socket (af, Struc, Protocol: Integer): TSocket;
+begin
+  Socket := TSocket (EMXSocket (cInt (ssSocket (af, Struc, Protocol))));
+end;
+
+function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar;
+                                                     optlen: Integer): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  SetSockOpt := ssSetSockOpt (S, Level, OptName, OptVal, OptLen);
+end;
+
+function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar;
+                                                 var optlen: Integer): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  GetSockOpt := ssGetSockOpt (S, Level, OptName, OptVal, OptLen);
+end;
+
+function Listen (s: TSocket; backlog: Integer): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  Listen := ssListen (S, BackLog);
+end;
+
+function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  IOCtlSocket := ssIOCtlSocket (S, Cmd, Arg);
+end;
+
+function CloseSocket (s: TSocket): Integer;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  CloseSocket := ssCloseSocket (S);
+end;
+
+function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  __WSAFDIsSet := ss__WSAFDIsSet (S, FDSet);
+end;
+
+function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
+                  cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
+                              lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
+                                          lpCompletionRoutine: pointer): u_int;
+begin
+  S := TSocket (NativeSocket (cInt (S)));
+  WSAIOCtl := ssWSAIOCtl (S, dwIoControlCode, lpvInBuffer, cbInBuffer,
+                lpvOutBuffer, cbOutBuffer, lpcbBytesReturned, lpOverlapped,
+                                                          lpCompletionRoutine);
+end;
+{$ENDIF OS2}
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+type
+  pu_long = ^u_long;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  HostEnt: PHostEnt;
+  r: integer;
+  Hints1, Hints2: TAddrInfo;
+  Sin1, Sin2: TVarSin;
+  TwoPass: boolean;
+
+  function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer;
+  var
+    Addr: PAddrInfo;
+  begin
+    Addr := nil;
+    try
+      FillChar(Sin, Sizeof(Sin), 0);
+      if Hints.ai_socktype = SOCK_RAW then
+      begin
+        Hints.ai_socktype := 0;
+        Hints.ai_protocol := 0;
+        Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
+      end
+      else
+      begin
+        if (IP = cAnyHost) or (IP = c6AnyHost) then
+        begin
+          Hints.ai_flags := AI_PASSIVE;
+          Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+        end
+        else
+          if (IP = cLocalhost) or (IP = c6Localhost) then
+          begin
+            Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+          end
+          else
+          begin
+            Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr);
+          end;
+      end;
+      if Result = 0 then
+        if (Addr <> nil) then
+          Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  if not IsNewApi(family) then
+  begin
+    SynSockCS.Enter;
+    try
+      Sin.sin_family := AF_INET;
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then
+        ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0))
+      else
+        Sin.sin_port := ServEnt^.s_port;
+      if IP = cBroadcast then
+        Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
+      else
+      begin
+        Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP));
+        if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then
+        begin
+          HostEnt := synsock.GetHostByName(PAnsiChar(IP));
+          Result := synsock.WSAGetLastError;
+          if HostEnt <> nil then
+            Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
+        end;
+      end;
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    FillChar(Hints1, Sizeof(Hints1), 0);
+    FillChar(Hints2, Sizeof(Hints2), 0);
+    TwoPass := False;
+    if Family = AF_UNSPEC then
+    begin
+      if PreferIP4 then
+      begin
+        Hints1.ai_family := AF_INET;
+        Hints2.ai_family := AF_INET6;
+        TwoPass := True;
+      end
+      else
+      begin
+        Hints2.ai_family := AF_INET;
+        Hints1.ai_family := AF_INET6;
+        TwoPass := True;
+      end;
+    end
+    else
+      Hints1.ai_family := Family;
+
+    Hints1.ai_socktype := SockType;
+    Hints1.ai_protocol := SockProtocol;
+    Hints2.ai_socktype := Hints1.ai_socktype;
+    Hints2.ai_protocol := Hints1.ai_protocol;
+
+    r := GetAddr(IP, Port, Hints1, Sin1);
+    Result := r;
+    sin := sin1;
+    if r <> 0 then
+      if TwoPass then
+      begin
+        r := GetAddr(IP, Port, Hints2, Sin2);
+        Result := r;
+        if r = 0 then
+          sin := sin2;
+      end;
+  end;
+end;
+
+function GetSinIP(Sin: TVarSin): AnsiString;
+var
+  p: PAnsiChar;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  r: integer;
+begin
+  Result := '';
+  if not IsNewApi(Sin.AddressFamily) then
+  begin
+    p := synsock.inet_ntoa(Sin.sin_addr);
+    if p <> nil then
+      Result := p;
+  end
+  else
+  begin
+    hostlen := NI_MAXHOST;
+    servlen := NI_MAXSERV;
+    setlength(host, hostlen);
+    setlength(serv, servlen);
+    r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen,
+      PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV);
+    if r = 0 then
+      Result := PAnsiChar(host);
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings);
+type
+  TaPInAddr = array[0..250] of PInAddr;
+  PaPInAddr = ^TaPInAddr;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  AddrNext: PAddrInfo;
+  r: integer;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IP: u_long;
+  PAdrPtr: PaPInAddr;
+  i: Integer;
+  s: String;
+  InAddr: TInAddr;
+begin
+  IPList.Clear;
+  if not IsNewApi(Family) then
+  begin
+    IP := synsock.inet_addr(PAnsiChar(Name));
+    if IP = u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := synsock.GetHostByName(PAnsiChar(Name));
+        if RemoteHost <> nil then
+        begin
+          PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
+          i := 0;
+          while PAdrPtr^[i] <> nil do
+          begin
+            InAddr := PAdrPtr^[i]^;
+            s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1],
+              InAddr.S_bytes[2], InAddr.S_bytes[3]]);
+            IPList.Add(s);
+            Inc(i);
+          end;
+        end;
+      finally
+        SynSockCS.Leave;
+      end;
+    end
+    else
+      IPList.Add(string(Name));
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr);
+      if r = 0 then
+      begin
+        AddrNext := Addr;
+        while not(AddrNext = nil) do
+        begin
+          if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
+            or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
+          begin
+            hostlen := NI_MAXHOST;
+            servlen := NI_MAXSERV;
+            setlength(host, hostlen);
+            setlength(serv, servlen);
+            r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen,
+              PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
+              NI_NUMERICHOST + NI_NUMERICSERV);
+            if r = 0 then
+            begin
+              host := PAnsiChar(host);
+              IPList.Add(string(host));
+            end;
+          end;
+          AddrNext := AddrNext^.ai_next;
+        end;
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+  if IPList.Count = 0 then
+    IPList.Add(cAnyHost);
+end;
+
+function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+begin
+  Result := 0;
+  if not IsNewApi(Family) then
+  begin
+    SynSockCS.Enter;
+    try
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+        ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Result := StrToIntDef(string(Port), 0)
+      else
+        Result := synsock.htons(ServEnt^.s_port);
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := Sockprotocol;
+      Hints.ai_flags := AI_PASSIVE;
+      r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+      if (r = 0) and Assigned(Addr) then
+      begin
+        if Addr^.ai_family = AF_INET then
+          Result := synsock.htons(Addr^.ai_addr^.sin_port);
+        if Addr^.ai_family = AF_INET6 then
+          Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IPn: u_long;
+begin
+  Result := IP;
+  if not IsNewApi(Family) then
+  begin
+    IPn := synsock.inet_addr(PAnsiChar(IP));
+    if IPn <> u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET);
+        if RemoteHost <> nil then
+          Result := RemoteHost^.h_name;
+      finally
+        SynSockCS.Leave;
+      end;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
+      if (r = 0) and Assigned(Addr)then
+      begin
+        hostlen := NI_MAXHOST;
+        servlen := NI_MAXSERV;
+        setlength(host, hostlen);
+        setlength(serv, servlen);
+        r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen,
+          PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
+          NI_NUMERICSERV);
+        if r = 0 then
+          Result := PAnsiChar(host);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: String): Boolean;
+begin
+  Result := False;
+  if stack = '' then
+    stack := DLLStackName;
+  SynSockCS.Enter;
+  try
+    if SynSockCount = 0 then
+    begin
+      SockEnhancedApi := False;
+      SockWship6Api := False;
+      LibHandle := LoadLibrary(PChar(Stack));
+      if LibHandle <> 0 then
+      begin
+{$IFDEF OS2}
+        ssWSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl')));
+        ss__WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet')));
+        ssCloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket')));
+        ssIoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket')));
+{$ELSE OS2}
+        WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl')));
+        __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet')));
+        CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket')));
+        IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket')));
+{$ENDIF OS2}
+        WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError')));
+        WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup')));
+        WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup')));
+        ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept')));
+        ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind')));
+        ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect')));
+        ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername')));
+        ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname')));
+{$IFDEF OS2}
+        ssGetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt')));
+{$ELSE OS2}
+        GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt')));
+{$ENDIF OS2}
+        Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl')));
+        Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons')));
+        Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr')));
+        Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa')));
+{$IFDEF OS2}
+        ssListen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen')));
+{$ELSE OS2}
+        Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen')));
+{$ENDIF OS2}
+        Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl')));
+        Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs')));
+        ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv')));
+        ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom')));
+        Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select')));
+        ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send')));
+        ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto')));
+{$IFDEF OS2}
+        ssSetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt')));
+        ssShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown')));
+        ssSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket')));
+{$ELSE OS2}
+        SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt')));
+        ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown')));
+        Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket')));
+{$ENDIF OS2}
+        GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr')));
+        GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname')));
+        GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname')));
+        GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber')));
+        GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname')));
+        GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport')));
+        ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname')));
+
+{$IFNDEF FORCEOLDAPI}
+        GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo')));
+        FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo')));
+        GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo')));
+        SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
+          and Assigned(GetNameInfo);
+        if not SockEnhancedApi then
+        begin
+          LibWship6Handle := LoadLibrary(PChar(DLLWship6));
+          if LibWship6Handle <> 0 then
+          begin
+            GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo')));
+            FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo')));
+            GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo')));
+            SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
+              and Assigned(GetNameInfo);
+          end;
+        end;
+{$ENDIF}
+        Result := True;
+      end;
+    end
+    else Result := True;
+    if Result then
+      Inc(SynSockCount);
+  finally
+    SynSockCS.Leave;
+  end;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  SynSockCS.Enter;
+  try
+    Dec(SynSockCount);
+    if SynSockCount < 0 then
+      SynSockCount := 0;
+    if SynSockCount = 0 then
+    begin
+      if LibHandle <> 0 then
+      begin
+        FreeLibrary(libHandle);
+        LibHandle := 0;
+      end;
+      if LibWship6Handle <> 0 then
+      begin
+        FreeLibrary(LibWship6Handle);
+        LibWship6Handle := 0;
+      end;
+    end;
+  finally
+    SynSockCS.Leave;
+  end;
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;

ssposix.inc

@@ -0,0 +1,1116 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.004 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - Delphi Posix definition include |
+|==============================================================================|
+| Copyright (c)2006-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2006-2012.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|  Radek Cervinka                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF POSIX}
+{for delphi XE2+}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{
+note RC:
+partially compatible with NextGen Delphi compiler - iOS
+
+
+}
+
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes, synabyte,
+  Posix.SysSocket, Posix.SysSelect, Posix.SysTime, Posix.NetinetIn,
+  Posix.StrOpts, Posix.Errno, Posix.Signal;
+
+function InitSocketInterface(stack: string): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+  DLLStackName = '';
+  WinsockLevel = $0202;
+
+  cLocalHost = '127.0.0.1';
+  cBroadcast = '255.255.255.255';
+  cAnyHost = '0.0.0.0';
+  c6AnyHost = '::0';
+  c6Localhost = '::1';
+  cLocalHostStr = 'localhost';
+
+type
+  TSocket = longint;
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+
+type
+  TFDSet = fd_set;
+  PFDSet = Pfd_set;
+  Ptimeval = Posix.SysTime.ptimeval;
+  Ttimeval = Posix.SysTime.timeval;
+
+const
+{$IFDEF ANDROID}
+  FIONREAD        = Posix.StrOpts.FIONREAD;
+{$ELSE}
+   {$IFDEF LINUX}
+     FIONREAD        = $541B;
+     FIONBIO         = $5421;
+     FIOASYNC        = $5452;
+   {$ELSE}
+     FIONREAD = $4004667F;
+     FIONBIO	 = $8004667E; //OSX FIONBIO         = Posix.StrOpts.FIONBIO;
+     FIOASYNC = $8004667D; //OSX  FIOASYNC        = Posix.StrOpts.FIOASYNC;  // not defined in XE2
+   {$ENDIF}
+{$ENDIF}
+
+const
+  IPPROTO_IP     =   Posix.NetinetIn.IPPROTO_IP;		{ Dummy					}
+  IPPROTO_ICMP   =   Posix.NetinetIn.IPPROTO_ICMP;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   Posix.NetinetIn.IPPROTO_IGMP;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   Posix.NetinetIn.IPPROTO_TCP;		{ TCP           			}
+  IPPROTO_UDP    =   Posix.NetinetIn.IPPROTO_UDP;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   Posix.NetinetIn.IPPROTO_IPV6;
+  IPPROTO_ICMPV6 =   58;
+  IPPROTO_RM     =  113;
+
+  IPPROTO_RAW    =   Posix.NetinetIn.IPPROTO_RAW;
+  IPPROTO_MAX    =   Posix.NetinetIn.IPPROTO_MAX;
+
+type
+  PInAddr = ^TInAddr;
+  TInAddr = Posix.NetinetIn.in_addr;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = Posix.NetinetIn.sockaddr_in;
+
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     // IP multicast address of group
+    imr_interface: TInAddr;     // local IP address of interface
+  end;
+
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = Posix.NetinetIn.in6_addr;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = Posix.NetinetIn.sockaddr_in6;
+
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  IP_TOS             = Posix.NetinetIn.IP_TOS;             { int; IP type of service and precedence.  }
+  IP_TTL             = Posix.NetinetIn.IP_TTL;             { int; IP time to live.  }
+  IP_HDRINCL         = Posix.NetinetIn.IP_HDRINCL;         { int; Header is included with data.  }
+  IP_OPTIONS         = Posix.NetinetIn.IP_OPTIONS;         { ip_opts; IP per-packet options.  }
+//  IP_ROUTER_ALERT    = sockets.IP_ROUTER_ALERT;    { bool }
+  IP_RECVOPTS        = Posix.NetinetIn.IP_RECVOPTS;        { bool }
+  IP_RETOPTS         = Posix.NetinetIn.IP_RETOPTS;         { bool }
+//  IP_PKTINFO         = sockets.IP_PKTINFO;         { bool }
+//  IP_PKTOPTIONS      = sockets.IP_PKTOPTIONS;
+//  IP_PMTUDISC        = sockets.IP_PMTUDISC;        { obsolete name? }
+//  IP_MTU_DISCOVER    = sockets.IP_MTU_DISCOVER;    { int; see below }
+//  IP_RECVERR         = sockets.IP_RECVERR;         { bool }
+//  IP_RECVTTL         = sockets.IP_RECVTTL;         { bool }
+//  IP_RECVTOS         = sockets.IP_RECVTOS;         { bool }
+  IP_MULTICAST_IF    = Posix.NetinetIn.IP_MULTICAST_IF;    { in_addr; set/get IP multicast i/f }
+  IP_MULTICAST_TTL   = Posix.NetinetIn.IP_MULTICAST_TTL;   { u_char; set/get IP multicast ttl }
+  IP_MULTICAST_LOOP  = Posix.NetinetIn.IP_MULTICAST_LOOP;  { i_char; set/get IP multicast loopback }
+  IP_ADD_MEMBERSHIP  = Posix.NetinetIn.IP_ADD_MEMBERSHIP;  { ip_mreq; add an IP group membership }
+  IP_DROP_MEMBERSHIP = Posix.NetinetIn.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership }
+
+  SOL_SOCKET    = Posix.SysSocket.SOL_SOCKET;
+
+  SO_DEBUG      = Posix.SysSocket.SO_DEBUG;
+  SO_REUSEADDR  = Posix.SysSocket.SO_REUSEADDR;
+  SO_TYPE       = Posix.SysSocket.SO_TYPE;
+  SO_ERROR      = Posix.SysSocket.SO_ERROR;
+  SO_DONTROUTE  = Posix.SysSocket.SO_DONTROUTE;
+  SO_BROADCAST  = Posix.SysSocket.SO_BROADCAST;
+  SO_SNDBUF     = Posix.SysSocket.SO_SNDBUF;
+  SO_RCVBUF     = Posix.SysSocket.SO_RCVBUF;
+  SO_KEEPALIVE  = Posix.SysSocket.SO_KEEPALIVE;
+  SO_OOBINLINE  = Posix.SysSocket.SO_OOBINLINE;
+//  SO_NO_CHECK   = SysSocket.SO_NO_CHECK;
+//  SO_PRIORITY   = SysSocket.SO_PRIORITY;
+  SO_LINGER     = Posix.SysSocket.SO_LINGER;
+//  SO_BSDCOMPAT  = SysSocket.SO_BSDCOMPAT;
+//  SO_REUSEPORT  = SysSocket.SO_REUSEPORT;
+//  SO_PASSCRED   = SysSocket.SO_PASSCRED;
+//  SO_PEERCRED   = SysSocket.SO_PEERCRED;
+  SO_RCVLOWAT   = Posix.SysSocket.SO_RCVLOWAT;
+  SO_SNDLOWAT   = Posix.SysSocket.SO_SNDLOWAT;
+  SO_RCVTIMEO   = Posix.SysSocket.SO_RCVTIMEO;
+  SO_SNDTIMEO   = Posix.SysSocket.SO_SNDTIMEO;
+{ Security levels - as per NRL IPv6 - don't actually do anything }
+//  SO_SECURITY_AUTHENTICATION       = SysSocket.SO_SECURITY_AUTHENTICATION;
+//  SO_SECURITY_ENCRYPTION_TRANSPORT = SysSocket.SO_SECURITY_ENCRYPTION_TRANSPORT;
+//  SO_SECURITY_ENCRYPTION_NETWORK   = SysSocket.SO_SECURITY_ENCRYPTION_NETWORK;
+//  SO_BINDTODEVICE                  = SysSocket.SO_BINDTODEVICE;
+{ Socket filtering }
+//  SO_ATTACH_FILTER = SysSocket.SO_ATTACH_FILTER;
+//  SO_DETACH_FILTER = SysSocket.SO_DETACH_FILTER;
+
+  SOMAXCONN       = 1024;
+
+  IPV6_UNICAST_HOPS     = Posix.NetinetIn.IPV6_UNICAST_HOPS;
+  IPV6_MULTICAST_IF     = Posix.NetinetIn.IPV6_MULTICAST_IF;
+  IPV6_MULTICAST_HOPS   = Posix.NetinetIn.IPV6_MULTICAST_HOPS;
+  IPV6_MULTICAST_LOOP   = Posix.NetinetIn.IPV6_MULTICAST_LOOP;
+  IPV6_JOIN_GROUP       = Posix.NetinetIn.IPV6_JOIN_GROUP;
+  IPV6_LEAVE_GROUP      = Posix.NetinetIn.IPV6_LEAVE_GROUP;
+
+const
+  SOCK_STREAM     = Posix.SysSocket.SOCK_STREAM;// 1;               { stream socket }
+  SOCK_DGRAM      = Posix.SysSocket.SOCK_DGRAM;// 2;               { datagram socket }
+  SOCK_RAW        = Posix.SysSocket.SOCK_RAW;// 3;               { raw-protocol interface }
+  SOCK_RDM        = Posix.SysSocket.SOCK_RDM;// 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = Posix.SysSocket.SOCK_SEQPACKET;// 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001; //netinettcp.pas
+
+{ Address families. }
+
+  AF_UNSPEC       = Posix.SysSocket.AF_UNSPEC;// 0;               { unspecified }
+  AF_INET         = Posix.SysSocket.AF_INET;  // 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = Posix.SysSocket.AF_INET6; // !! 30            { Internetwork Version 6 }
+  AF_MAX          = Posix.SysSocket.AF_MAX;   // !! - variable by OS
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = Posix.SysSocket.linger;
+
+const
+
+  MSG_OOB       = Posix.SysSocket.MSG_OOB;      // Process out-of-band data.
+  MSG_PEEK      = Posix.SysSocket.MSG_PEEK;     // Peek at incoming messages.
+  {$IFDEF MACOS}
+  MSG_NOSIGNAL  = $20000;  // Do not generate SIGPIPE.
+                           // Works under MAC OS X, but is undocumented,
+                           // So FPC doesn't include it
+  {$ELSE}
+   MSG_NOSIGNAL  = $4000; // Do not generate SIGPIPE.
+  {$ENDIF}
+
+const
+  WSAEINTR = EINTR;
+  WSAEBADF = EBADF;
+  WSAEACCES = EACCES;
+  WSAEFAULT = EFAULT;
+  WSAEINVAL = EINVAL;
+  WSAEMFILE = EMFILE;
+  WSAEWOULDBLOCK = EWOULDBLOCK;
+  WSAEINPROGRESS = EINPROGRESS;
+  WSAEALREADY = EALREADY;
+  WSAENOTSOCK = ENOTSOCK;
+  WSAEDESTADDRREQ = EDESTADDRREQ;
+  WSAEMSGSIZE = EMSGSIZE;
+  WSAEPROTOTYPE = EPROTOTYPE;
+  WSAENOPROTOOPT = ENOPROTOOPT;
+  WSAEPROTONOSUPPORT = EPROTONOSUPPORT;
+  WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT;
+  WSAEOPNOTSUPP = EOPNOTSUPP;
+  WSAEPFNOSUPPORT = EPFNOSUPPORT;
+  WSAEAFNOSUPPORT = EAFNOSUPPORT;
+  WSAEADDRINUSE = EADDRINUSE;
+  WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
+  WSAENETDOWN = ENETDOWN;
+  WSAENETUNREACH = ENETUNREACH;
+  WSAENETRESET = ENETRESET;
+  WSAECONNABORTED = ECONNABORTED;
+  WSAECONNRESET = ECONNRESET;
+  WSAENOBUFS = ENOBUFS;
+  WSAEISCONN = EISCONN;
+  WSAENOTCONN = ENOTCONN;
+  WSAESHUTDOWN = ESHUTDOWN;
+  WSAETOOMANYREFS = ETOOMANYREFS;
+  WSAETIMEDOUT = ETIMEDOUT;
+  WSAECONNREFUSED = ECONNREFUSED;
+  WSAELOOP = ELOOP;
+  WSAENAMETOOLONG = ENAMETOOLONG;
+  WSAEHOSTDOWN = EHOSTDOWN;
+  WSAEHOSTUNREACH = EHOSTUNREACH;
+  WSAENOTEMPTY = ENOTEMPTY;
+  WSAEPROCLIM = -1;
+  WSAEUSERS = EUSERS;
+  WSAEDQUOT = EDQUOT;
+  WSAESTALE = ESTALE;
+  WSAEREMOTE = EREMOTE;
+  WSASYSNOTREADY = -2;
+  WSAVERNOTSUPPORTED = -3;
+  WSANOTINITIALISED = -4;
+  WSAEDISCON = -5;
+  WSAHOST_NOT_FOUND = 1;
+  WSATRY_AGAIN = 2;
+  WSANO_RECOVERY = 3;
+  WSANO_DATA = -6;
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = packed record
+    wVersion: Word;
+    wHighVersion: Word;
+    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PChar;
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+  {$IF defined(MACOS32) OR defined(IOS))}
+     sin_len     : UInt8;
+  {$endif}
+
+    case integer of
+      0: (AddressFamily: sa_family_t);
+      1: (
+        case sin_family: sa_family_t of
+          AF_INET: (sin_port: word;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of Byte);
+          AF_INET6: (sin6_port:     word;
+                		sin6_flowinfo: longword;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: longword);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+  function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+  function WSACleanup: Integer;
+  function WSAGetLastError: Integer;
+  function GetHostName: string;
+  function Shutdown(s: TSocket; how: Integer): Integer;
+  function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    optlen: Integer): Integer;
+  function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
+    var optlen: Integer): Integer;
+  function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+  function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+  function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+  function ntohs(netshort: word): word;
+  function ntohl(netlong: longword): longword;
+  function Listen(s: TSocket; backlog: Integer): Integer;
+  function IoctlSocket(s: TSocket; cmd: Integer; var arg: integer): Integer;
+  function htons(hostshort: word): word;
+  function htonl(hostlong: longword): longword;
+  function GetSockName(s: TSocket; var name: TVarSin): Integer;
+  function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+  function Connect(s: TSocket; const name: TVarSin): Integer;
+  function CloseSocket(s: TSocket): Integer;
+  function Bind(s: TSocket; const addr: TVarSin): Integer;
+  function Accept(s: TSocket; var addr: TVarSin): TSocket;
+  function Socket(af, Struc, Protocol: Integer): TSocket;
+  function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): string;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(Name: string;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+
+
+{==============================================================================}
+implementation
+uses
+  Posix.Base, Posix.Unistd, Posix.ArpaInet, Posix.NetDB;
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := Posix.NetinetIn.IN6_IS_ADDR_UNSPECIFIED(a^);
+{  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));}
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := Posix.NetinetIn.IN6_IS_ADDR_LOOPBACK(a^);
+{  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));}
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := Posix.NetinetIn.IN6_IS_ADDR_LINKLOCAL(a^);
+{  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));}
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := Posix.NetinetIn.IN6_IS_ADDR_SITELOCAL(a^);
+//  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := Posix.NetinetIn.IN6_IS_ADDR_MULTICAST(a^);
+//  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.s6_addr[15] := 1;
+end;
+
+{=============================================================================}
+
+function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
+begin
+  with WSData do
+  begin
+    wVersion := wVersionRequired;
+    wHighVersion := $202;
+    szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
+    szSystemStatus := 'Running on Posix by Delphi';
+    iMaxSockets := 32768;
+    iMaxUdpDg := 8192;
+  end;
+  Result := 0;
+end;
+
+function WSACleanup: Integer;
+begin
+  Result := 0;
+end;
+
+function WSAGetLastError: Integer;
+begin
+  Result := Posix.Errno.errno;
+end;
+
+function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
+begin
+  Result := __FD_ISSET(socket, fdset);
+end;
+
+procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
+begin
+  __FD_SET(Socket, fdset);
+end;
+
+procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
+begin
+  __FD_CLR(Socket, fdset);
+end;
+
+procedure FD_ZERO(var fdset: TFDSet);
+begin
+  __FD_ZERO(fdset);
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+var
+  sa: sockaddr absolute addr;
+begin
+  Result :=  Posix.SysSocket.Bind(s, sa, SizeOfVarSin(addr));
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+var
+  sa: sockaddr absolute name;
+begin
+  Result := Posix.SysSocket.Connect(s,  sa, SizeOfVarSin(name));
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: socklen_t;
+  address : sockaddr absolute name;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := Posix.SysSocket.GetSockName(s, address, Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: socklen_t;
+  address : sockaddr absolute name;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := Posix.SysSocket.GetPeerName(s, address, Len);
+end;
+
+function GetHostName: string;
+var
+  name: TBytes;
+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';
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := Posix.SysSocket.Send(s, Buf^, len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := Posix.SysSocket.Recv(s, Buf^, len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+var
+  sa: sockaddr absolute addrto;
+begin
+  Result := Posix.SysSocket.SendTo(s, Buf^, len, flags, sa, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: socklen_t;
+  address : sockaddr absolute from;
+begin
+  x := SizeOf(from);
+  Result := Posix.SysSocket.RecvFrom(s, Buf^, len, flags, address, x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: socklen_t;
+  address : sockaddr absolute addr;
+begin
+  x := SizeOf(addr);
+  Result := Posix.SysSocket.Accept(s, address, x);
+end;
+
+function Shutdown(s: TSocket; how: Integer): Integer;
+begin
+  Result := Posix.SysSocket.Shutdown(s, how);
+end;
+
+function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  optlen: Integer): Integer;
+begin
+  Result := Posix.SysSocket.setsockopt(s, level, optname, pointer(optval), optlen);
+end;
+
+function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
+  var optlen: Integer): Integer;
+var
+  x: socklen_t;
+begin
+  x := optlen;
+  Result := Posix.SysSocket.getsockopt(s, level, optname, pointer(optval), x);
+  optlen := x;
+end;
+
+function  ntohs(netshort: word): word;
+begin
+  Result := Posix.ArpaInet.ntohs(NetShort);
+end;
+
+function  ntohl(netlong: longword): longword;
+begin
+  Result := Posix.ArpaInet.ntohl(NetLong);
+end;
+
+function  Listen(s: TSocket; backlog: Integer): Integer;
+begin
+  if Posix.SysSocket.Listen(s, backlog) = 0 then
+    Result := 0
+  else
+    Result := SOCKET_ERROR;
+end;
+
+function  IoctlSocket(s: TSocket; cmd: Integer; var arg: integer): Integer;
+begin
+  Result := Posix.StrOpts.Ioctl(s, cmd, @arg);
+end;
+
+function  htons(hostshort: word): word;
+begin
+  Result := Posix.ArpaInet.htons(Hostshort);
+end;
+
+function  htonl(hostlong: longword): longword;
+begin
+  Result := Posix.ArpaInet.htonl(HostLong);
+end;
+
+function CloseSocket(s: TSocket): Integer;
+begin
+  Result := Posix.Unistd.__close(s);
+end;
+
+function Socket(af, Struc, Protocol: Integer): TSocket;
+begin
+  Result := Posix.SysSocket.Socket(af, struc, protocol);
+end;
+
+function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+  timeout: PTimeVal): Longint;
+begin
+  Result := Posix.SysSelect.Select(nfds, readfds, writefds, exceptfds, timeout);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function 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;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  HostEnt: PHostEnt;
+  r: integer;
+  Hints1, Hints2: AddrInfo;
+  Sin1, Sin2: TVarSin;
+  TwoPass: boolean;
+
+  function GetAddr(const IP, port: string; Hints: AddrInfo; var Sin: TVarSin): integer;
+  var
+    Addr: PAddrInfo;
+  begin
+    Addr := nil;
+    try
+      FillChar(Sin, Sizeof(Sin), 0);
+      if Hints.ai_socktype = SOCK_RAW then
+      begin
+        Hints.ai_socktype := 0;
+        Hints.ai_protocol := 0;
+        Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), nil, Hints, Addr);
+      end
+      else
+      begin
+        if (IP = cAnyHost) or (IP = c6AnyHost) then
+        begin
+          Hints.ai_flags := AI_PASSIVE;
+          Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+        end
+        else
+          if (IP = cLocalhost) or (IP = c6Localhost) then
+          begin
+            Result := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+          end
+          else
+          begin
+            Result := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+          end;
+      end;
+      if Result = 0 then
+        if (Addr <> nil) then
+          Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
+    finally
+      if Assigned(Addr) then
+        FreeAddrInfo(Addr^);
+    end;
+  end;
+
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  if not IsNewApi(family) then
+  begin
+    SynSockCS.Enter;
+    try
+      Sin.sin_family := AF_INET;
+      ProtoEnt := GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+      {$IFDEF NEXTGEN}
+        ServEnt := GetServByName(MarshaledAString(TMarshal.AsAnsi(Port)), ProtoEnt^.p_name);
+      {$ELSE}
+        ServEnt := GetServByName(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name);
+      {$ENDIF}
+      if ServEnt = nil then
+        Sin.sin_port := htons(StrToIntDef(Port, 0))
+      else
+        Sin.sin_port := ServEnt^.s_port;
+      if IP = cBroadcast then
+        Sin.sin_addr.s_addr := UInt32(INADDR_BROADCAST)
+      else
+      begin
+      {$IFDEF NEXTGEN}
+        Sin.sin_addr.s_addr := inet_addr(MarshaledAString(TMarshal.AsAnsi(IP)));
+      {$ELSE}
+        Sin.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(IP)));
+      {$ENDIF}
+        if Sin.sin_addr.s_addr = UInt32(INADDR_NONE) then
+        begin
+          {$IFDEF NEXTGEN}
+          HostEnt := GetHostByName(MarshaledAString(TMarshal.AsAnsi(IP)));
+          {$ELSE}
+          HostEnt := GetHostByName(PAnsiChar(AnsiString(IP)));
+          {$ENDIF}
+          Result := WSAGetLastError;
+          if HostEnt <> nil then
+            Sin.sin_addr.S_addr := UInt32(HostEnt.h_addr_list);
+        end;
+      end;
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    FillChar(Hints1, Sizeof(Hints1), 0);
+    FillChar(Hints2, Sizeof(Hints2), 0);
+    TwoPass := False;
+    if Family = AF_UNSPEC then
+    begin
+      if PreferIP4 then
+      begin
+        Hints1.ai_family := AF_INET;
+        Hints2.ai_family := AF_INET6;
+        TwoPass := True;
+      end
+      else
+      begin
+        Hints2.ai_family := AF_INET;
+        Hints1.ai_family := AF_INET6;
+        TwoPass := True;
+      end;
+    end
+    else
+      Hints1.ai_family := Family;
+
+    Hints1.ai_socktype := SockType;
+    Hints1.ai_protocol := SockProtocol;
+    Hints2.ai_socktype := Hints1.ai_socktype;
+    Hints2.ai_protocol := Hints1.ai_protocol;
+
+    r := GetAddr(IP, Port, Hints1, Sin1);
+    Result := r;
+    sin := sin1;
+    if r <> 0 then
+      if TwoPass then
+      begin
+        r := GetAddr(IP, Port, Hints2, Sin2);
+        Result := r;
+        if r = 0 then
+          sin := sin2;
+      end;
+  end;
+end;
+
+function GetSinIP(Sin: TVarSin): string;
+var
+  p: pointer;
+  hostlen, servlen: integer;
+  r: integer;
+  sa:sockaddr absolute Sin;
+  byHost, byServ: TBytes;
+  HostWrapper, ServWrapper: Pointer;
+begin
+  Result := '';
+  if not IsNewApi(Sin.AddressFamily) then
+  begin
+    p := inet_ntoa(Sin.sin_addr);
+    if p <> nil then
+      Result := string(p);
+  end
+  else
+  begin
+    // NEXTGEN compatible
+    hostlen := NI_MAXHOST;
+    servlen := NI_MAXSERV;
+    Setlength(byHost, hostLen);
+    Setlength(byServ, hostLen);
+    HostWrapper := @byHost[0];
+    ServWrapper := @byServ[0];
+    r := getnameinfo(sa, SizeOfVarSin(sin), HostWrapper, hostlen,
+      ServWrapper, servlen, NI_NUMERICHOST + NI_NUMERICSERV);
+    if r = 0 then
+      Result := MarshaledAString(HostWrapper);
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
+type
+  TaPInAddr = array[0..250] of PInAddr;
+  PaPInAddr = ^TaPInAddr;
+var
+  Hints: AddrInfo;
+  Addr: PAddrInfo;
+  AddrNext: PAddrInfo;
+  r: integer;
+  host, serv: TBytes;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IP: UINT32;
+  PAdrPtr: PaPInAddr;
+  i: Integer;
+  s: string;
+  InAddr: TInAddr;
+  aby:TArray<Byte>;
+begin
+  IPList.Clear;
+  if not IsNewApi(Family) then
+  begin
+  {$IFDEF NEXTGEN}
+    IP := inet_addr(MarshaledAString(TMarshal.AsAnsi(Name)));
+  {$ELSE}
+    IP := inet_addr(PAnsiChar(AnsiString(Name)));
+  {$ENDIF}
+    if IP = UINT32(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+  {$IFDEF NEXTGEN}
+        RemoteHost := GetHostByName(MarshaledAString(TMarshal.AsAnsi(Name)));
+  {$ELSE}
+        RemoteHost := GetHostByName(PAnsiChar(AnsiString(Name)));
+  {$ENDIF}
+        if RemoteHost <> nil then
+        begin
+          PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
+          i := 0;
+          while PAdrPtr^[i] <> nil do
+          begin
+            InAddr := PAdrPtr^[i]^;
+            aby := TArray<byte>(Cardinal(InAddr));
+            s := Format('%d.%d.%d.%d', [aby[0], aby[1],
+              aby[2], aby[3]]);
+            IPList.Add(s);
+            Inc(i);
+          end;
+        end;
+      finally
+        SynSockCS.Leave;
+      end;
+    end
+    else
+      IPList.Add(Name);
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(Name)), nil, Hints, Addr);
+      if r = 0 then
+      begin
+        AddrNext := Addr;
+        while not(AddrNext = nil) do
+        begin
+          if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
+            or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
+          begin
+            hostlen := NI_MAXHOST;
+            servlen := NI_MAXSERV;
+            setlength(host, hostlen);
+            setlength(serv, servlen);
+            r := getnameinfo(AddrNext^.ai_addr^, AddrNext^.ai_addrlen,
+              @host[0], hostlen, @serv[0], servlen,
+              NI_NUMERICHOST + NI_NUMERICSERV);
+            if r = 0 then
+              IPList.Add(StringOf(host));
+            SetLength(host, 0);
+            SetLength(serv, 0);
+          end;
+          AddrNext := AddrNext^.ai_next;
+        end;
+      end;
+    finally
+      if Assigned(Addr) then
+        FreeAddrInfo(Addr^);
+    end;
+  end;
+  if IPList.Count = 0 then
+    IPList.Add(cAnyHost);
+end;
+
+function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  Hints: AddrInfo;
+  Addr: PAddrInfo;
+  _Addr: AddrInfo;
+  r: integer;
+begin
+  Result := 0;
+  if not IsNewApi(Family) then
+  begin
+    SynSockCS.Enter;
+    try
+      ProtoEnt := GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+        ServEnt := GetServByName(MarshaledAString(TMarshal.AsAnsi(Port)), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Result := StrToIntDef(Port, 0)
+      else
+        Result := htons(ServEnt^.s_port);
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := Sockprotocol;
+      Hints.ai_flags := AI_PASSIVE;
+      r := GetAddrInfo(nil, MarshaledAString(TMarshal.AsAnsi(Port)), Hints, Addr);
+      if (r = 0) and Assigned(Addr) then
+      begin
+        if Addr^.ai_family = AF_INET then
+          Result := htons(Addr^.ai_addr^.sa_data[0]); // port
+        if Addr^.ai_family = AF_INET6 then
+          Result := htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
+      end;
+    finally
+      if Assigned(Addr) then
+      begin
+        _Addr := Addr^;
+        FreeAddrInfo(_Addr);
+      end;
+    end;
+  end;
+end;
+
+function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
+var
+  Hints: AddrInfo;
+  Addr: PAddrInfo;
+  _Addr: AddrInfo;
+  r: integer;
+  host, serv: TBytes;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IPn: UINT32;
+begin
+  Result := IP;
+  if not IsNewApi(Family) then
+  begin
+    IPn := inet_addr(MarshaledAString(TMarshal.AsAnsi(IP)));
+    if IPn <> UINT32(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := GetHostByAddr(IPn, SizeOf(IPn), AF_INET);
+        if RemoteHost <> nil then
+          Result := string(RemoteHost^.h_name);
+      finally
+        SynSockCS.Leave;
+      end;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := GetAddrInfo(MarshaledAString(TMarshal.AsAnsi(IP)), nil, Hints, Addr);
+      if (r = 0) and Assigned(Addr)then
+      begin
+        hostlen := NI_MAXHOST;
+        servlen := NI_MAXSERV;
+        setlength(host, hostlen);
+        setlength(serv, servlen);
+        r := getnameinfo(Addr^.ai_addr^, Addr^.ai_addrlen,
+          @host[0], hostlen, @serv[0], servlen,
+          NI_NUMERICSERV);
+        if r = 0 then
+          Result := StringOf(host);
+        SetLength(host, 0);
+        SetLength(serv, 0);
+      end;
+    finally
+      if Assigned(Addr) then
+      begin
+        _Addr := Addr^;
+        FreeAddrInfo(_Addr);
+      end;
+    end;
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: string): Boolean;
+begin
+  SockEnhancedApi := True;
+  SockWship6Api := False;
+  Signal(SIGPIPE, TSignalHandler(SIG_IGN));
+  Result := True;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;
+
+{$ENDIF}

sswin32.inc

@@ -0,0 +1,1661 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.003.001 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer - Win32/64 definition include     |
+|==============================================================================|
+| Copyright (c)1999-2012, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2012.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+//{$DEFINE WINSOCK1}
+{Note about define WINSOCK1:
+If you activate this compiler directive, then socket interface level 1.1 is
+used instead default level 2.2. Level 2.2 is not available on old W95, however
+you can install update.
+}
+
+//{$DEFINE FORCEOLDAPI}
+{Note about define FORCEOLDAPI:
+If you activate this compiler directive, then is allways used old socket API
+for name resolution. If you leave this directive inactive, then the new API
+is used, when running system allows it.
+
+For IPv6 support you must have new API!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+  (*$HPPEMIT '/* EDE 2003-02-19 */' *)
+  (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *)
+  (*$HPPEMIT '#undef h_addr' *)
+  (*$HPPEMIT '#undef IOCPARM_MASK' *)
+  (*$HPPEMIT '#undef FD_SETSIZE' *)
+  (*$HPPEMIT '#undef IOC_VOID' *)
+  (*$HPPEMIT '#undef IOC_OUT' *)
+  (*$HPPEMIT '#undef IOC_IN' *)
+  (*$HPPEMIT '#undef IOC_INOUT' *)
+  (*$HPPEMIT '#undef FIONREAD' *)
+  (*$HPPEMIT '#undef FIONBIO' *)
+  (*$HPPEMIT '#undef FIOASYNC' *)
+  (*$HPPEMIT '#undef IPPROTO_IP' *)
+  (*$HPPEMIT '#undef IPPROTO_ICMP' *)
+  (*$HPPEMIT '#undef IPPROTO_IGMP' *)
+  (*$HPPEMIT '#undef IPPROTO_TCP' *)
+  (*$HPPEMIT '#undef IPPROTO_UDP' *)
+  (*$HPPEMIT '#undef IPPROTO_RAW' *)
+  (*$HPPEMIT '#undef IPPROTO_MAX' *)
+  (*$HPPEMIT '#undef INADDR_ANY' *)
+  (*$HPPEMIT '#undef INADDR_LOOPBACK' *)
+  (*$HPPEMIT '#undef INADDR_BROADCAST' *)
+  (*$HPPEMIT '#undef INADDR_NONE' *)
+  (*$HPPEMIT '#undef INVALID_SOCKET' *)
+  (*$HPPEMIT '#undef SOCKET_ERROR' *)
+  (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *)
+  (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *)
+  (*$HPPEMIT '#undef IP_OPTIONS' *)
+  (*$HPPEMIT '#undef IP_TOS' *)
+  (*$HPPEMIT '#undef IP_TTL' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_IF' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_TTL' *)
+  (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *)
+  (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *)
+  (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *)
+  (*$HPPEMIT '#undef IP_DONTFRAGMENT' *)
+  (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *)
+  (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *)
+  (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *)
+  (*$HPPEMIT '#undef SOL_SOCKET' *)
+  (*$HPPEMIT '#undef SO_DEBUG' *)
+  (*$HPPEMIT '#undef SO_ACCEPTCONN' *)
+  (*$HPPEMIT '#undef SO_REUSEADDR' *)
+  (*$HPPEMIT '#undef SO_KEEPALIVE' *)
+  (*$HPPEMIT '#undef SO_DONTROUTE' *)
+  (*$HPPEMIT '#undef SO_BROADCAST' *)
+  (*$HPPEMIT '#undef SO_USELOOPBACK' *)
+  (*$HPPEMIT '#undef SO_LINGER' *)
+  (*$HPPEMIT '#undef SO_OOBINLINE' *)
+  (*$HPPEMIT '#undef SO_DONTLINGER' *)
+  (*$HPPEMIT '#undef SO_SNDBUF' *)
+  (*$HPPEMIT '#undef SO_RCVBUF' *)
+  (*$HPPEMIT '#undef SO_SNDLOWAT' *)
+  (*$HPPEMIT '#undef SO_RCVLOWAT' *)
+  (*$HPPEMIT '#undef SO_SNDTIMEO' *)
+  (*$HPPEMIT '#undef SO_RCVTIMEO' *)
+  (*$HPPEMIT '#undef SO_ERROR' *)
+  (*$HPPEMIT '#undef SO_OPENTYPE' *)
+  (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *)
+  (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *)
+  (*$HPPEMIT '#undef SO_MAXDG' *)
+  (*$HPPEMIT '#undef SO_MAXPATHDG' *)
+  (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *)
+  (*$HPPEMIT '#undef SO_CONNECT_TIME' *)
+  (*$HPPEMIT '#undef SO_TYPE' *)
+  (*$HPPEMIT '#undef SOCK_STREAM' *)
+  (*$HPPEMIT '#undef SOCK_DGRAM' *)
+  (*$HPPEMIT '#undef SOCK_RAW' *)
+  (*$HPPEMIT '#undef SOCK_RDM' *)
+  (*$HPPEMIT '#undef SOCK_SEQPACKET' *)
+  (*$HPPEMIT '#undef TCP_NODELAY' *)
+  (*$HPPEMIT '#undef AF_UNSPEC' *)
+  (*$HPPEMIT '#undef SOMAXCONN' *)
+  (*$HPPEMIT '#undef AF_INET' *)
+  (*$HPPEMIT '#undef AF_MAX' *)
+  (*$HPPEMIT '#undef PF_UNSPEC' *)
+  (*$HPPEMIT '#undef PF_INET' *)
+  (*$HPPEMIT '#undef PF_MAX' *)
+  (*$HPPEMIT '#undef MSG_OOB' *)
+  (*$HPPEMIT '#undef MSG_PEEK' *)
+  (*$HPPEMIT '#undef WSABASEERR' *)
+  (*$HPPEMIT '#undef WSAEINTR' *)
+  (*$HPPEMIT '#undef WSAEBADF' *)
+  (*$HPPEMIT '#undef WSAEACCES' *)
+  (*$HPPEMIT '#undef WSAEFAULT' *)
+  (*$HPPEMIT '#undef WSAEINVAL' *)
+  (*$HPPEMIT '#undef WSAEMFILE' *)
+  (*$HPPEMIT '#undef WSAEWOULDBLOCK' *)
+  (*$HPPEMIT '#undef WSAEINPROGRESS' *)
+  (*$HPPEMIT '#undef WSAEALREADY' *)
+  (*$HPPEMIT '#undef WSAENOTSOCK' *)
+  (*$HPPEMIT '#undef WSAEDESTADDRREQ' *)
+  (*$HPPEMIT '#undef WSAEMSGSIZE' *)
+  (*$HPPEMIT '#undef WSAEPROTOTYPE' *)
+  (*$HPPEMIT '#undef WSAENOPROTOOPT' *)
+  (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEOPNOTSUPP' *)
+  (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *)
+  (*$HPPEMIT '#undef WSAEADDRINUSE' *)
+  (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *)
+  (*$HPPEMIT '#undef WSAENETDOWN' *)
+  (*$HPPEMIT '#undef WSAENETUNREACH' *)
+  (*$HPPEMIT '#undef WSAENETRESET' *)
+  (*$HPPEMIT '#undef WSAECONNABORTED' *)
+  (*$HPPEMIT '#undef WSAECONNRESET' *)
+  (*$HPPEMIT '#undef WSAENOBUFS' *)
+  (*$HPPEMIT '#undef WSAEISCONN' *)
+  (*$HPPEMIT '#undef WSAENOTCONN' *)
+  (*$HPPEMIT '#undef WSAESHUTDOWN' *)
+  (*$HPPEMIT '#undef WSAETOOMANYREFS' *)
+  (*$HPPEMIT '#undef WSAETIMEDOUT' *)
+  (*$HPPEMIT '#undef WSAECONNREFUSED' *)
+  (*$HPPEMIT '#undef WSAELOOP' *)
+  (*$HPPEMIT '#undef WSAENAMETOOLONG' *)
+  (*$HPPEMIT '#undef WSAEHOSTDOWN' *)
+  (*$HPPEMIT '#undef WSAEHOSTUNREACH' *)
+  (*$HPPEMIT '#undef WSAENOTEMPTY' *)
+  (*$HPPEMIT '#undef WSAEPROCLIM' *)
+  (*$HPPEMIT '#undef WSAEUSERS' *)
+  (*$HPPEMIT '#undef WSAEDQUOT' *)
+  (*$HPPEMIT '#undef WSAESTALE' *)
+  (*$HPPEMIT '#undef WSAEREMOTE' *)
+  (*$HPPEMIT '#undef WSASYSNOTREADY' *)
+  (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *)
+  (*$HPPEMIT '#undef WSANOTINITIALISED' *)
+  (*$HPPEMIT '#undef WSAEDISCON' *)
+  (*$HPPEMIT '#undef WSAENOMORE' *)
+  (*$HPPEMIT '#undef WSAECANCELLED' *)
+  (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *)
+  (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *)
+  (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *)
+  (*$HPPEMIT '#undef WSASYSCALLFAILURE' *)
+  (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSA_E_NO_MORE' *)
+  (*$HPPEMIT '#undef WSA_E_CANCELLED' *)
+  (*$HPPEMIT '#undef WSAEREFUSED' *)
+  (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *)
+  (*$HPPEMIT '#undef HOST_NOT_FOUND' *)
+  (*$HPPEMIT '#undef WSATRY_AGAIN' *)
+  (*$HPPEMIT '#undef TRY_AGAIN' *)
+  (*$HPPEMIT '#undef WSANO_RECOVERY' *)
+  (*$HPPEMIT '#undef NO_RECOVERY' *)
+  (*$HPPEMIT '#undef WSANO_DATA' *)
+  (*$HPPEMIT '#undef NO_DATA' *)
+  (*$HPPEMIT '#undef WSANO_ADDRESS' *)
+  (*$HPPEMIT '#undef ENAMETOOLONG' *)
+  (*$HPPEMIT '#undef ENOTEMPTY' *)
+  (*$HPPEMIT '#undef FD_CLR' *)
+  (*$HPPEMIT '#undef FD_ISSET' *)
+  (*$HPPEMIT '#undef FD_SET' *)
+  (*$HPPEMIT '#undef FD_ZERO' *)
+  (*$HPPEMIT '#undef NO_ADDRESS' *)
+  (*$HPPEMIT '#undef ADDR_ANY' *)
+  (*$HPPEMIT '#undef SO_GROUP_ID' *)
+  (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *)
+  (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *)
+  (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *)
+  (*$HPPEMIT '#undef PVD_CONFIG' *)
+  (*$HPPEMIT '#undef AF_INET6' *)
+  (*$HPPEMIT '#undef PF_INET6' *)
+  (*$HPPEMIT '#undef NI_MAXHOST' *)
+  (*$HPPEMIT '#undef NI_MAXSERV' *)
+  (*$HPPEMIT '#undef NI_NOFQDN' *)
+  (*$HPPEMIT '#undef NI_NUMERICHOST' *)
+  (*$HPPEMIT '#undef NI_NAMEREQD' *)
+  (*$HPPEMIT '#undef NI_NUMERICSERV' *)
+  (*$HPPEMIT '#undef NI_DGRAM' *)
+  (*$HPPEMIT '#undef AI_PASSIVE' *)
+  (*$HPPEMIT '#undef AI_CANONNAME' *)
+  (*$HPPEMIT '#undef AI_NUMERICHOST' *)
+  (*$HPPEMIT '#undef EWOULDBLOCK' *)
+  (*$HPPEMIT '#undef EINPROGRESS' *)
+  (*$HPPEMIT '#undef EALREADY' *)
+  (*$HPPEMIT '#undef ENOTSOCK' *)
+  (*$HPPEMIT '#undef EDESTADDRREQ' *)
+  (*$HPPEMIT '#undef EMSGSIZE' *)
+  (*$HPPEMIT '#undef EPROTOTYPE' *)
+  (*$HPPEMIT '#undef ENOPROTOOPT' *)
+  (*$HPPEMIT '#undef EPROTONOSUPPORT' *)
+  (*$HPPEMIT '#undef EOPNOTSUPP' *)
+  (*$HPPEMIT '#undef EAFNOSUPPORT' *)
+  (*$HPPEMIT '#undef EADDRINUSE' *)
+  (*$HPPEMIT '#undef EADDRNOTAVAIL' *)
+  (*$HPPEMIT '#undef ENETDOWN' *)
+  (*$HPPEMIT '#undef ENETUNREACH' *)
+  (*$HPPEMIT '#undef ENETRESET' *)
+  (*$HPPEMIT '#undef ECONNABORTED' *)
+  (*$HPPEMIT '#undef ECONNRESET' *)
+  (*$HPPEMIT '#undef ENOBUFS' *)
+  (*$HPPEMIT '#undef EISCONN' *)
+  (*$HPPEMIT '#undef ENOTCONN' *)
+  (*$HPPEMIT '#undef ETIMEDOUT' *)
+  (*$HPPEMIT '#undef ECONNREFUSED' *)
+  (*$HPPEMIT '#undef ELOOP' *)
+  (*$HPPEMIT '#undef EHOSTUNREACH' *)
+{$ENDIF}
+
+{$IFDEF FPC}
+  {$IFDEF WIN32}
+    {$ALIGN OFF}
+  {$ELSE}
+    {$PACKRECORDS C}
+  {$ENDIF}
+{$ELSE}
+  {$IFDEF WIN64}
+    {$ALIGN ON}
+    {$MINENUMSIZE 4}
+  {$ELSE}
+    {$MINENUMSIZE 4}
+    {$ALIGN OFF}
+  {$ENDIF}
+{$ENDIF}
+
+interface
+
+uses
+  SyncObjs, SysUtils, Classes,
+  Windows;
+
+function InitSocketInterface(stack: String): Boolean;
+function DestroySocketInterface: Boolean;
+
+const
+{$IFDEF WINSOCK1}
+  WinsockLevel = $0101;
+{$ELSE}
+  WinsockLevel = $0202;
+{$ENDIF}
+
+type
+  u_short = Word;
+  u_int = Integer;
+  u_long = Longint;
+  pu_long = ^u_long;
+  pu_short = ^u_short;
+{$IFDEF FPC}
+  TSocket = ptruint;
+{$ELSE}
+  {$IFDEF WIN64}
+  TSocket = UINT_PTR;
+  {$ELSE}
+  TSocket = u_int;
+  {$ENDIF}
+{$ENDIF}
+  TAddrFamily = integer;
+
+  TMemory = pointer;
+
+const
+  {$IFDEF WINCE}
+    DLLStackName = 'ws2.dll';
+  {$ELSE}
+    {$IFDEF WINSOCK1}
+    DLLStackName = 'wsock32.dll';
+    {$ELSE}
+    DLLStackName = 'ws2_32.dll';
+    {$ENDIF}
+  {$ENDIF}
+  DLLwship6 = 'wship6.dll';
+
+  cLocalhost = '127.0.0.1';
+  cAnyHost = '0.0.0.0';
+  cBroadcast = '255.255.255.255';
+  c6Localhost = '::1';
+  c6AnyHost = '::0';
+  c6Broadcast = 'ffff::1';
+  cAnyPort = '0';
+
+
+const
+  FD_SETSIZE     =   64;
+type
+  PFDSet = ^TFDSet;
+  TFDSet = record
+    fd_count: u_int;
+    fd_array: array[0..FD_SETSIZE-1] of TSocket;
+  end;
+
+const
+  FIONREAD     = $4004667f;
+  FIONBIO      = $8004667e;
+  FIOASYNC     = $8004667d;
+
+type
+  PTimeVal = ^TTimeVal;
+  TTimeVal = record
+    tv_sec: Longint;
+    tv_usec: Longint;
+  end;
+
+const
+  IPPROTO_IP     =   0;		{ Dummy					}
+  IPPROTO_ICMP   =   1;		{ Internet Control Message Protocol }
+  IPPROTO_IGMP   =   2;		{ Internet Group Management Protocol}
+  IPPROTO_TCP    =   6;		{ TCP           			}
+  IPPROTO_UDP    =   17;	{ User Datagram Protocol		}
+  IPPROTO_IPV6   =   41;
+  IPPROTO_ICMPV6 =   58;
+  IPPROTO_RM     =  113;
+
+  IPPROTO_RAW    =   255;
+  IPPROTO_MAX    =   256;
+
+type
+
+  PInAddr = ^TInAddr;
+  TInAddr = record
+    case integer of
+      0: (S_bytes: packed array [0..3] of byte);
+      1: (S_addr: u_long);
+  end;
+
+  PSockAddrIn = ^TSockAddrIn;
+  TSockAddrIn = record
+    case Integer of
+      0: (sin_family: u_short;
+          sin_port: u_short;
+          sin_addr: TInAddr;
+          sin_zero: array[0..7] of byte);
+      1: (sa_family: u_short;
+          sa_data: array[0..13] of byte)
+  end;
+
+  TIP_mreq =  record
+    imr_multiaddr: TInAddr;     { IP multicast address of group }
+    imr_interface: TInAddr;     { local IP address of interface }
+  end;
+
+  PInAddr6 = ^TInAddr6;
+  TInAddr6 = record
+    case integer of
+      0: (S6_addr: packed array [0..15] of byte);
+      1: (u6_addr8: packed array [0..15] of byte);
+      2: (u6_addr16: packed array [0..7] of word);
+      3: (u6_addr32: packed array [0..3] of integer);
+  end;
+
+  PSockAddrIn6 = ^TSockAddrIn6;
+  TSockAddrIn6 = record
+		sin6_family:   u_short;     // AF_INET6
+		sin6_port:     u_short;     // Transport level port number
+		sin6_flowinfo: u_long;	    // IPv6 flow information
+		sin6_addr:     TInAddr6;    // IPv6 address
+		sin6_scope_id: u_long;      // Scope Id: IF number for link-local
+                                //           SITE id for site-local
+  end;
+
+  TIPv6_mreq = record
+    ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
+    ipv6mr_interface: integer;   // Interface index.
+    padding: integer;
+  end;
+
+  PHostEnt = ^THostEnt;
+  THostEnt = record
+    h_name: PAnsiChar;
+    h_aliases: ^PAnsiChar;
+    h_addrtype: Smallint;
+    h_length: Smallint;
+    case integer of
+     0: (h_addr_list: ^PAnsiChar);
+     1: (h_addr: ^PInAddr);
+  end;
+
+  PNetEnt = ^TNetEnt;
+  TNetEnt = record
+    n_name: PAnsiChar;
+    n_aliases: ^PAnsiChar;
+    n_addrtype: Smallint;
+    n_net: u_long;
+  end;
+
+  PServEnt = ^TServEnt;
+  TServEnt = record
+    s_name: PAnsiChar;
+    s_aliases: ^PAnsiChar;
+{$ifdef WIN64}
+    s_proto: PAnsiChar;
+    s_port: Smallint;
+{$else}
+    s_port: Smallint;
+    s_proto: PAnsiChar;
+{$endif}
+  end;
+
+  PProtoEnt = ^TProtoEnt;
+  TProtoEnt = record
+    p_name: PAnsiChar;
+    p_aliases: ^PAnsichar;
+    p_proto: Smallint;
+  end;
+
+const
+  INADDR_ANY       = $00000000;
+  INADDR_LOOPBACK  = $7F000001;
+  INADDR_BROADCAST = $FFFFFFFF;
+  INADDR_NONE      = $FFFFFFFF;
+  ADDR_ANY		 = INADDR_ANY;
+  INVALID_SOCKET		= TSocket(NOT(0));
+  SOCKET_ERROR			= -1;
+
+Const
+  {$IFDEF WINSOCK1}
+    IP_OPTIONS          = 1;
+    IP_MULTICAST_IF     = 2;           { set/get IP multicast interface   }
+    IP_MULTICAST_TTL    = 3;           { set/get IP multicast timetolive  }
+    IP_MULTICAST_LOOP   = 4;           { set/get IP multicast loopback    }
+    IP_ADD_MEMBERSHIP   = 5;           { add  an IP group membership      }
+    IP_DROP_MEMBERSHIP  = 6;           { drop an IP group membership      }
+    IP_TTL              = 7;           { set/get IP Time To Live          }
+    IP_TOS              = 8;           { set/get IP Type Of Service       }
+    IP_DONTFRAGMENT     = 9;           { set/get IP Don't Fragment flag   }
+  {$ELSE}
+    IP_OPTIONS          = 1;
+    IP_HDRINCL          = 2;
+    IP_TOS              = 3;           { set/get IP Type Of Service       }
+    IP_TTL              = 4;           { set/get IP Time To Live          }
+    IP_MULTICAST_IF     = 9;           { set/get IP multicast interface   }
+    IP_MULTICAST_TTL    = 10;           { set/get IP multicast timetolive  }
+    IP_MULTICAST_LOOP   = 11;           { set/get IP multicast loopback    }
+    IP_ADD_MEMBERSHIP   = 12;           { add  an IP group membership      }
+    IP_DROP_MEMBERSHIP  = 13;           { drop an IP group membership      }
+    IP_DONTFRAGMENT     = 14;           { set/get IP Don't Fragment flag   }
+  {$ENDIF}
+
+  IP_DEFAULT_MULTICAST_TTL   = 1;    { normally limit m'casts to 1 hop  }
+  IP_DEFAULT_MULTICAST_LOOP  = 1;    { normally hear sends if a member  }
+  IP_MAX_MEMBERSHIPS         = 20;   { per socket; must fit in one mbuf }
+
+  SOL_SOCKET      = $ffff;          {options for socket level }
+{ Option flags per-socket. }
+  SO_DEBUG        = $0001;          { turn on debugging info recording }
+  SO_ACCEPTCONN   = $0002;          { socket has had listen() }
+  SO_REUSEADDR    = $0004;          { allow local address reuse }
+  SO_KEEPALIVE    = $0008;          { keep connections alive }
+  SO_DONTROUTE    = $0010;          { just use interface addresses }
+  SO_BROADCAST    = $0020;          { permit sending of broadcast msgs }
+  SO_USELOOPBACK  = $0040;          { bypass hardware when possible }
+  SO_LINGER       = $0080;          { linger on close if data present }
+  SO_OOBINLINE    = $0100;          { leave received OOB data in line }
+  SO_DONTLINGER  =   $ff7f;
+{ Additional options. }
+  SO_SNDBUF       = $1001;          { send buffer size }
+  SO_RCVBUF       = $1002;          { receive buffer size }
+  SO_SNDLOWAT     = $1003;          { send low-water mark }
+  SO_RCVLOWAT     = $1004;          { receive low-water mark }
+  SO_SNDTIMEO     = $1005;          { send timeout }
+  SO_RCVTIMEO     = $1006;          { receive timeout }
+  SO_ERROR        = $1007;          { get error status and clear }
+  SO_TYPE         = $1008;          { get socket type }
+{ WinSock 2 extension -- new options }
+  SO_GROUP_ID       = $2001; { ID of a socket group}
+  SO_GROUP_PRIORITY = $2002; { the relative priority within a group}
+  SO_MAX_MSG_SIZE   = $2003; { maximum message size }
+  SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure }
+  SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure }
+  SO_PROTOCOL_INFO  = SO_PROTOCOL_INFOA;
+  PVD_CONFIG        = $3001; {configuration info for service provider }
+{ Option for opening sockets for synchronous access. }
+  SO_OPENTYPE     = $7008;
+  SO_SYNCHRONOUS_ALERT    = $10;
+  SO_SYNCHRONOUS_NONALERT = $20;
+{ Other NT-specific options. }
+  SO_MAXDG        = $7009;
+  SO_MAXPATHDG    = $700A;
+  SO_UPDATE_ACCEPT_CONTEXT     = $700B;
+  SO_CONNECT_TIME = $700C;
+
+  SOMAXCONN       = $7fffffff;
+
+  IPV6_UNICAST_HOPS      = 8;  // ???
+  IPV6_MULTICAST_IF      = 9;  // set/get IP multicast i/f
+  IPV6_MULTICAST_HOPS    = 10; // set/get IP multicast ttl
+  IPV6_MULTICAST_LOOP    = 11; // set/get IP multicast loopback
+  IPV6_JOIN_GROUP        = 12; // add an IP group membership
+  IPV6_LEAVE_GROUP       = 13; // drop an IP group membership
+
+  MSG_NOSIGNAL  = 0;
+
+  // getnameinfo constants
+  NI_MAXHOST	   = 1025;
+  NI_MAXSERV	   = 32;
+  NI_NOFQDN 	   = $1;
+  NI_NUMERICHOST = $2;
+  NI_NAMEREQD	   = $4;
+  NI_NUMERICSERV = $8;
+  NI_DGRAM       = $10;
+
+
+const
+  SOCK_STREAM     = 1;               { stream socket }
+  SOCK_DGRAM      = 2;               { datagram socket }
+  SOCK_RAW        = 3;               { raw-protocol interface }
+  SOCK_RDM        = 4;               { reliably-delivered message }
+  SOCK_SEQPACKET  = 5;               { sequenced packet stream }
+
+{ TCP options. }
+  TCP_NODELAY     = $0001;
+
+{ Address families. }
+
+  AF_UNSPEC       = 0;               { unspecified }
+  AF_INET         = 2;               { internetwork: UDP, TCP, etc. }
+  AF_INET6        = 23;              { Internetwork Version 6 }
+  AF_MAX          = 24;
+
+{ Protocol families, same as address families for now. }
+  PF_UNSPEC       = AF_UNSPEC;
+  PF_INET         = AF_INET;
+  PF_INET6        = AF_INET6;
+  PF_MAX          = AF_MAX;
+
+type
+  { Structure used by kernel to store most addresses. }
+  PSockAddr = ^TSockAddr;
+  TSockAddr = TSockAddrIn;
+
+  { Structure used by kernel to pass protocol information in raw sockets. }
+  PSockProto = ^TSockProto;
+  TSockProto = record
+    sp_family: u_short;
+    sp_protocol: u_short;
+  end;
+
+type
+  PAddrInfo = ^TAddrInfo;
+  TAddrInfo = record
+                ai_flags: integer;    // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
+                ai_family: integer;   // PF_xxx.
+                ai_socktype: integer; // SOCK_xxx.
+                ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
+                ai_addrlen: u_int;    // Length of ai_addr.
+                ai_canonname: PAnsiChar;  // Canonical name for nodename.
+                ai_addr: PSockAddr;   // Binary address.
+                ai_next: PAddrInfo;     // Next structure in linked list.
+              end;
+
+const
+  // Flags used in "hints" argument to getaddrinfo().
+  AI_PASSIVE     = $1;  // Socket address will be used in bind() call.
+  AI_CANONNAME   = $2;  // Return canonical name in first ai_canonname.
+  AI_NUMERICHOST = $4;  // Nodename must be a numeric address string.
+
+type
+{ Structure used for manipulating linger option. }
+  PLinger = ^TLinger;
+  TLinger = record
+    l_onoff: u_short;
+    l_linger: u_short;
+  end;
+
+const
+
+  MSG_OOB       = $01;                  // Process out-of-band data.
+  MSG_PEEK      = $02;                  // Peek at incoming messages.
+
+const
+
+{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
+  WSABASEERR              = 10000;
+
+{ Windows Sockets definitions of regular Microsoft C error constants }
+
+  WSAEINTR                = (WSABASEERR+4);
+  WSAEBADF                = (WSABASEERR+9);
+  WSAEACCES               = (WSABASEERR+13);
+  WSAEFAULT               = (WSABASEERR+14);
+  WSAEINVAL               = (WSABASEERR+22);
+  WSAEMFILE               = (WSABASEERR+24);
+
+{ Windows Sockets definitions of regular Berkeley error constants }
+
+  WSAEWOULDBLOCK          = (WSABASEERR+35);
+  WSAEINPROGRESS          = (WSABASEERR+36);
+  WSAEALREADY             = (WSABASEERR+37);
+  WSAENOTSOCK             = (WSABASEERR+38);
+  WSAEDESTADDRREQ         = (WSABASEERR+39);
+  WSAEMSGSIZE             = (WSABASEERR+40);
+  WSAEPROTOTYPE           = (WSABASEERR+41);
+  WSAENOPROTOOPT          = (WSABASEERR+42);
+  WSAEPROTONOSUPPORT      = (WSABASEERR+43);
+  WSAESOCKTNOSUPPORT      = (WSABASEERR+44);
+  WSAEOPNOTSUPP           = (WSABASEERR+45);
+  WSAEPFNOSUPPORT         = (WSABASEERR+46);
+  WSAEAFNOSUPPORT         = (WSABASEERR+47);
+  WSAEADDRINUSE           = (WSABASEERR+48);
+  WSAEADDRNOTAVAIL        = (WSABASEERR+49);
+  WSAENETDOWN             = (WSABASEERR+50);
+  WSAENETUNREACH          = (WSABASEERR+51);
+  WSAENETRESET            = (WSABASEERR+52);
+  WSAECONNABORTED         = (WSABASEERR+53);
+  WSAECONNRESET           = (WSABASEERR+54);
+  WSAENOBUFS              = (WSABASEERR+55);
+  WSAEISCONN              = (WSABASEERR+56);
+  WSAENOTCONN             = (WSABASEERR+57);
+  WSAESHUTDOWN            = (WSABASEERR+58);
+  WSAETOOMANYREFS         = (WSABASEERR+59);
+  WSAETIMEDOUT            = (WSABASEERR+60);
+  WSAECONNREFUSED         = (WSABASEERR+61);
+  WSAELOOP                = (WSABASEERR+62);
+  WSAENAMETOOLONG         = (WSABASEERR+63);
+  WSAEHOSTDOWN            = (WSABASEERR+64);
+  WSAEHOSTUNREACH         = (WSABASEERR+65);
+  WSAENOTEMPTY            = (WSABASEERR+66);
+  WSAEPROCLIM             = (WSABASEERR+67);
+  WSAEUSERS               = (WSABASEERR+68);
+  WSAEDQUOT               = (WSABASEERR+69);
+  WSAESTALE               = (WSABASEERR+70);
+  WSAEREMOTE              = (WSABASEERR+71);
+
+{ Extended Windows Sockets error constant definitions }
+
+  WSASYSNOTREADY          = (WSABASEERR+91);
+  WSAVERNOTSUPPORTED      = (WSABASEERR+92);
+  WSANOTINITIALISED       = (WSABASEERR+93);
+  WSAEDISCON              = (WSABASEERR+101);
+  WSAENOMORE              = (WSABASEERR+102);
+  WSAECANCELLED           = (WSABASEERR+103);
+  WSAEEINVALIDPROCTABLE   = (WSABASEERR+104);
+  WSAEINVALIDPROVIDER     = (WSABASEERR+105);
+  WSAEPROVIDERFAILEDINIT  = (WSABASEERR+106);
+  WSASYSCALLFAILURE       = (WSABASEERR+107);
+  WSASERVICE_NOT_FOUND    = (WSABASEERR+108);
+  WSATYPE_NOT_FOUND       = (WSABASEERR+109);
+  WSA_E_NO_MORE           = (WSABASEERR+110);
+  WSA_E_CANCELLED         = (WSABASEERR+111);
+  WSAEREFUSED             = (WSABASEERR+112);
+
+{ Error return codes from gethostbyname() and gethostbyaddr()
+  (when using the resolver). Note that these errors are
+  retrieved via WSAGetLastError() and must therefore follow
+  the rules for avoiding clashes with error numbers from
+  specific implementations or language run-time systems.
+  For this reason the codes are based at WSABASEERR+1001.
+  Note also that [WSA]NO_ADDRESS is defined only for
+  compatibility purposes. }
+
+{ Authoritative Answer: Host not found }
+  WSAHOST_NOT_FOUND       = (WSABASEERR+1001);
+  HOST_NOT_FOUND          = WSAHOST_NOT_FOUND;
+{ Non-Authoritative: Host not found, or SERVERFAIL }
+  WSATRY_AGAIN            = (WSABASEERR+1002);
+  TRY_AGAIN               = WSATRY_AGAIN;
+{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
+  WSANO_RECOVERY          = (WSABASEERR+1003);
+  NO_RECOVERY             = WSANO_RECOVERY;
+{ Valid name, no data record of requested type }
+  WSANO_DATA              = (WSABASEERR+1004);
+  NO_DATA                 = WSANO_DATA;
+{ no address, look for MX record }
+  WSANO_ADDRESS           = WSANO_DATA;
+  NO_ADDRESS              = WSANO_ADDRESS;
+
+  EWOULDBLOCK        =  WSAEWOULDBLOCK;
+  EINPROGRESS        =  WSAEINPROGRESS;
+  EALREADY           =  WSAEALREADY;
+  ENOTSOCK           =  WSAENOTSOCK;
+  EDESTADDRREQ       =  WSAEDESTADDRREQ;
+  EMSGSIZE           =  WSAEMSGSIZE;
+  EPROTOTYPE         =  WSAEPROTOTYPE;
+  ENOPROTOOPT        =  WSAENOPROTOOPT;
+  EPROTONOSUPPORT    =  WSAEPROTONOSUPPORT;
+  ESOCKTNOSUPPORT    =  WSAESOCKTNOSUPPORT;
+  EOPNOTSUPP         =  WSAEOPNOTSUPP;
+  EPFNOSUPPORT       =  WSAEPFNOSUPPORT;
+  EAFNOSUPPORT       =  WSAEAFNOSUPPORT;
+  EADDRINUSE         =  WSAEADDRINUSE;
+  EADDRNOTAVAIL      =  WSAEADDRNOTAVAIL;
+  ENETDOWN           =  WSAENETDOWN;
+  ENETUNREACH        =  WSAENETUNREACH;
+  ENETRESET          =  WSAENETRESET;
+  ECONNABORTED       =  WSAECONNABORTED;
+  ECONNRESET         =  WSAECONNRESET;
+  ENOBUFS            =  WSAENOBUFS;
+  EISCONN            =  WSAEISCONN;
+  ENOTCONN           =  WSAENOTCONN;
+  ESHUTDOWN          =  WSAESHUTDOWN;
+  ETOOMANYREFS       =  WSAETOOMANYREFS;
+  ETIMEDOUT          =  WSAETIMEDOUT;
+  ECONNREFUSED       =  WSAECONNREFUSED;
+  ELOOP              =  WSAELOOP;
+  ENAMETOOLONG       =  WSAENAMETOOLONG;
+  EHOSTDOWN          =  WSAEHOSTDOWN;
+  EHOSTUNREACH       =  WSAEHOSTUNREACH;
+  ENOTEMPTY          =  WSAENOTEMPTY;
+  EPROCLIM           =  WSAEPROCLIM;
+  EUSERS             =  WSAEUSERS;
+  EDQUOT             =  WSAEDQUOT;
+  ESTALE             =  WSAESTALE;
+  EREMOTE            =  WSAEREMOTE;
+
+  EAI_ADDRFAMILY  = 1;   // Address family for nodename not supported.
+  EAI_AGAIN       = 2;   // Temporary failure in name resolution.
+  EAI_BADFLAGS    = 3;   // Invalid value for ai_flags.
+  EAI_FAIL        = 4;   // Non-recoverable failure in name resolution.
+  EAI_FAMILY      = 5;   // Address family ai_family not supported.
+  EAI_MEMORY      = 6;   // Memory allocation failure.
+  EAI_NODATA      = 7;   // No address associated with nodename.
+  EAI_NONAME      = 8;   // Nodename nor servname provided, or not known.
+  EAI_SERVICE     = 9;   // Servname not supported for ai_socktype.
+  EAI_SOCKTYPE    = 10;  // Socket type ai_socktype not supported.
+  EAI_SYSTEM      = 11;  // System error returned in errno.
+
+const
+  WSADESCRIPTION_LEN     =   256;
+  WSASYS_STATUS_LEN      =   128;
+type
+  PWSAData = ^TWSAData;
+  TWSAData = record
+    wVersion: Word;
+    wHighVersion: Word;
+{$ifdef win64}
+    iMaxSockets : Word;
+    iMaxUdpDg : Word;
+    lpVendorInfo : PAnsiChar;
+    szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar;
+    szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar;
+{$else}     
+    szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar;
+    szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar;
+    iMaxSockets: Word;
+    iMaxUdpDg: Word;
+    lpVendorInfo: PAnsiChar;
+{$endif}
+  end;
+
+  function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+  function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+  function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
+  procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+  procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+var
+  in6addr_any, in6addr_loopback : TInAddr6;
+
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+procedure FD_ZERO(var FDSet: TFDSet);
+
+{=============================================================================}
+
+type
+  TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
+    stdcall;
+  TWSACleanup = function: Integer;
+    stdcall;
+  TWSAGetLastError = function: Integer;
+    stdcall;
+  TGetServByName = function(name, proto: PAnsiChar): PServEnt;
+    stdcall;
+  TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt;
+    stdcall;
+  TGetProtoByName = function(name: PAnsiChar): PProtoEnt;
+    stdcall;
+  TGetProtoByNumber = function(proto: Integer): PProtoEnt;
+    stdcall;
+  TGetHostByName = function(name: PAnsiChar): PHostEnt;
+    stdcall;
+  TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
+    stdcall;
+  TGetHostName = function(name: PAnsiChar; len: Integer): Integer;
+    stdcall;
+  TShutdown = function(s: TSocket; how: Integer): Integer;
+    stdcall;
+  TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
+    optlen: Integer): Integer;
+    stdcall;
+  TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar;
+    var optlen: Integer): Integer;
+    stdcall;
+  TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
+    tolen: Integer): Integer;
+    stdcall;
+  TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
+    stdcall;
+  TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
+    stdcall;
+  TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
+    var fromlen: Integer): Integer;
+    stdcall;
+  Tntohs = function(netshort: u_short): u_short;
+    stdcall;
+  Tntohl = function(netlong: u_long): u_long;
+    stdcall;
+  TListen = function(s: TSocket; backlog: Integer): Integer;
+    stdcall;
+  TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer;
+    stdcall;
+  TInet_ntoa = function(inaddr: TInAddr): PAnsiChar;
+    stdcall;
+  TInet_addr = function(cp: PAnsiChar): u_long;
+    stdcall;
+  Thtons = function(hostshort: u_short): u_short;
+    stdcall;
+  Thtonl = function(hostlong: u_long): u_long;
+    stdcall;
+  TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    stdcall;
+  TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
+    stdcall;
+  TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
+    stdcall;
+  TCloseSocket = function(s: TSocket): Integer;
+    stdcall;
+  TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
+    stdcall;
+  TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
+    stdcall;
+  TTSocket = function(af, Struc, Protocol: Integer): TSocket;
+    stdcall;
+  TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
+    timeout: PTimeVal): Longint;
+    stdcall;
+
+  TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo;
+    var Addrinfo: PAddrInfo): integer;
+    stdcall;
+  TFreeAddrInfo = procedure(ai: PAddrInfo);
+    stdcall;
+  TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar;
+    hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer;
+    stdcall;
+
+  T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool;
+    stdcall;
+
+  TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
+    cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
+    lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
+    lpCompletionRoutine: pointer): u_int;
+    stdcall;
+
+var
+  WSAStartup: TWSAStartup = nil;
+  WSACleanup: TWSACleanup = nil;
+  WSAGetLastError: TWSAGetLastError = nil;
+  GetServByName: TGetServByName = nil;
+  GetServByPort: TGetServByPort = nil;
+  GetProtoByName: TGetProtoByName = nil;
+  GetProtoByNumber: TGetProtoByNumber = nil;
+  GetHostByName: TGetHostByName = nil;
+  GetHostByAddr: TGetHostByAddr = nil;
+  ssGetHostName: TGetHostName = nil;
+  Shutdown: TShutdown = nil;
+  SetSockOpt: TSetSockOpt = nil;
+  GetSockOpt: TGetSockOpt = nil;
+  ssSendTo: TSendTo = nil;
+  ssSend: TSend = nil;
+  ssRecv: TRecv = nil;
+  ssRecvFrom: TRecvFrom = nil;
+  ntohs: Tntohs = nil;
+  ntohl: Tntohl = nil;
+  Listen: TListen = nil;
+  IoctlSocket: TIoctlSocket = nil;
+  Inet_ntoa: TInet_ntoa = nil;
+  Inet_addr: TInet_addr = nil;
+  htons: Thtons = nil;
+  htonl: Thtonl = nil;
+  ssGetSockName: TGetSockName = nil;
+  ssGetPeerName: TGetPeerName = nil;
+  ssConnect: TConnect = nil;
+  CloseSocket: TCloseSocket = nil;
+  ssBind: TBind = nil;
+  ssAccept: TAccept = nil;
+  Socket: TTSocket = nil;
+  Select: TSelect = nil;
+
+  GetAddrInfo: TGetAddrInfo = nil;
+  FreeAddrInfo: TFreeAddrInfo = nil;
+  GetNameInfo: TGetNameInfo = nil;
+
+  __WSAFDIsSet: T__WSAFDIsSet = nil;
+
+  WSAIoctl: TWSAIoctl = nil;
+
+var
+  SynSockCS: SyncObjs.TCriticalSection;
+  SockEnhancedApi: Boolean;
+  SockWship6Api: Boolean;
+
+type
+  TVarSin = packed record
+    case integer of
+      0: (AddressFamily: u_short);
+      1: (
+        case sin_family: u_short of
+          AF_INET: (sin_port: u_short;
+                    sin_addr: TInAddr;
+                    sin_zero: array[0..7] of byte);
+          AF_INET6: (sin6_port:     u_short;
+                		sin6_flowinfo: u_long;
+      	    	      sin6_addr:     TInAddr6;
+      		          sin6_scope_id: u_long);
+          );
+  end;
+
+function SizeOfVarSin(sin: TVarSin): integer;
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+function Connect(s: TSocket; const name: TVarSin): Integer;
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+function GetHostName: AnsiString;
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+
+function IsNewApi(Family: integer): Boolean;
+function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+function GetSinIP(Sin: TVarSin): AnsiString;
+function GetSinPort(Sin: TVarSin): Integer;
+procedure ResolveNameToIP(const Name: AnsiString;  Family, SockProtocol, SockType: integer; const IPList: TStrings);
+function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString;
+function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType: integer): Word;
+
+{==============================================================================}
+implementation
+
+var
+  SynSockCount: Integer = 0;
+  LibHandle: THandle = 0;
+  Libwship6Handle: THandle = 0;
+
+function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
+end;
+
+function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
+             (a^.u6_addr32[2] = 0) and
+             (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
+             (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
+end;
+
+function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
+end;
+
+function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
+begin
+  Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
+end;
+
+function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
+begin
+  Result := (a^.u6_addr8[0] = $FF);
+end;
+
+function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
+begin
+  Result := (CompareMem( a, b, sizeof(TInAddr6)));
+end;
+
+procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+end;
+
+procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
+begin
+  FillChar(a^, sizeof(TInAddr6), 0);
+  a^.u6_addr8[15] := 1;
+end;
+
+{=============================================================================}
+procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
+var
+  I: Integer;
+begin
+  I := 0;
+  while I < FDSet.fd_count do
+  begin
+    if FDSet.fd_array[I] = Socket then
+    begin
+      while I < FDSet.fd_count - 1 do
+      begin
+        FDSet.fd_array[I] := FDSet.fd_array[I + 1];
+        Inc(I);
+      end;
+      Dec(FDSet.fd_count);
+      Break;
+    end;
+    Inc(I);
+  end;
+end;
+
+function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
+begin
+  Result := __WSAFDIsSet(Socket, FDSet);
+end;
+
+procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
+begin
+  if FDSet.fd_count < FD_SETSIZE then
+  begin
+    FDSet.fd_array[FDSet.fd_count] := Socket;
+    Inc(FDSet.fd_count);
+  end;
+end;
+
+procedure FD_ZERO(var FDSet: TFDSet);
+begin
+  FDSet.fd_count := 0;
+end;
+
+{=============================================================================}
+
+function SizeOfVarSin(sin: TVarSin): integer;
+begin
+  case sin.sin_family of
+    AF_INET:
+            Result := SizeOf(TSockAddrIn);
+    AF_INET6:
+            Result := SizeOf(TSockAddrIn6);
+  else
+    Result := 0;
+  end;
+end;
+
+{=============================================================================}
+
+function Bind(s: TSocket; const addr: TVarSin): Integer;
+begin
+  Result := ssBind(s, @addr, SizeOfVarSin(addr));
+end;
+
+function Connect(s: TSocket; const name: TVarSin): Integer;
+begin
+  Result := ssConnect(s, @name, SizeOfVarSin(name));
+end;
+
+function GetSockName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetSockName(s, @name, Len);
+end;
+
+function GetPeerName(s: TSocket; var name: TVarSin): Integer;
+var
+  len: integer;
+begin
+  len := SizeOf(name);
+  FillChar(name, len, 0);
+  Result := ssGetPeerName(s, @name, Len);
+end;
+
+function GetHostName: AnsiString;
+var
+  s: AnsiString;
+begin
+  Result := '';
+  setlength(s, 255);
+  ssGetHostName(pAnsichar(s), Length(s) - 1);
+  Result := PAnsichar(s);
+end;
+
+function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := ssSend(s, Buf^, len, flags);
+end;
+
+function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
+begin
+  Result := ssRecv(s, Buf^, len, flags);
+end;
+
+function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
+begin
+  Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
+end;
+
+function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
+var
+  x: integer;
+begin
+  x := SizeOf(from);
+  Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
+end;
+
+function Accept(s: TSocket; var addr: TVarSin): TSocket;
+var
+  x: integer;
+begin
+  x := SizeOf(addr);
+  Result := ssAccept(s, @addr, x);
+end;
+
+{=============================================================================}
+function IsNewApi(Family: integer): Boolean;
+begin
+  Result := SockEnhancedApi;
+  if not Result then
+    Result := (Family = AF_INET6) and SockWship6Api;
+end;
+
+function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family,
+    SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
+type
+  pu_long = ^u_long;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  HostEnt: PHostEnt;
+  r: integer;
+  Hints1, Hints2: TAddrInfo;
+  Sin1, Sin2: TVarSin;
+  TwoPass: boolean;
+
+  function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer;
+  var
+    Addr: PAddrInfo;
+  begin
+    Addr := nil;
+    try
+      FillChar(Sin, Sizeof(Sin), 0);
+      if Hints.ai_socktype = SOCK_RAW then
+      begin
+        Hints.ai_socktype := 0;
+        Hints.ai_protocol := 0;
+        Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
+      end
+      else
+      begin
+        if (IP = cAnyHost) or (IP = c6AnyHost) then
+        begin
+          Hints.ai_flags := AI_PASSIVE;
+          Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+        end
+        else
+          if (IP = cLocalhost) or (IP = c6Localhost) then
+          begin
+            Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+          end
+          else
+          begin
+            Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr);
+          end;
+      end;
+      if Result = 0 then
+        if (Addr <> nil) then
+          Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen);
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+
+begin
+  Result := 0;
+  FillChar(Sin, Sizeof(Sin), 0);
+  if not IsNewApi(family) then
+  begin
+    SynSockCS.Enter;
+    try
+      Sin.sin_family := AF_INET;
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then
+        ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0))
+      else
+        Sin.sin_port := ServEnt^.s_port;
+      if IP = cBroadcast then
+        Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST)
+      else
+      begin
+        Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP));
+        if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then
+        begin
+          HostEnt := synsock.GetHostByName(PAnsiChar(IP));
+          Result := synsock.WSAGetLastError;
+          if HostEnt <> nil then
+            Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
+        end;
+      end;
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    FillChar(Hints1, Sizeof(Hints1), 0);
+    FillChar(Hints2, Sizeof(Hints2), 0);
+    TwoPass := False;
+    if Family = AF_UNSPEC then
+    begin
+      if PreferIP4 then
+      begin
+        Hints1.ai_family := AF_INET;
+        Hints2.ai_family := AF_INET6;
+        TwoPass := True;
+      end
+      else
+      begin
+        Hints2.ai_family := AF_INET;
+        Hints1.ai_family := AF_INET6;
+        TwoPass := True;
+      end;
+    end
+    else
+      Hints1.ai_family := Family;
+
+    Hints1.ai_socktype := SockType;
+    Hints1.ai_protocol := SockProtocol;
+    Hints2.ai_socktype := Hints1.ai_socktype;
+    Hints2.ai_protocol := Hints1.ai_protocol;
+
+    r := GetAddr(IP, Port, Hints1, Sin1);
+    Result := r;
+    sin := sin1;
+    if r <> 0 then
+      if TwoPass then
+      begin
+        r := GetAddr(IP, Port, Hints2, Sin2);
+        Result := r;
+        if r = 0 then
+          sin := sin2;
+      end;
+  end;
+end;
+
+function GetSinIP(Sin: TVarSin): AnsiString;
+var
+  p: PAnsiChar;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  r: integer;
+begin
+  Result := '';
+  if not IsNewApi(Sin.AddressFamily) then
+  begin
+    p := synsock.inet_ntoa(Sin.sin_addr);
+    if p <> nil then
+      Result := p;
+  end
+  else
+  begin
+    hostlen := NI_MAXHOST;
+    servlen := NI_MAXSERV;
+    setlength(host, hostlen);
+    setlength(serv, servlen);
+    r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen,
+      PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV);
+    if r = 0 then
+      Result := PAnsiChar(host);
+  end;
+end;
+
+function GetSinPort(Sin: TVarSin): Integer;
+begin
+  if (Sin.sin_family = AF_INET6) then
+    Result := synsock.ntohs(Sin.sin6_port)
+  else
+    Result := synsock.ntohs(Sin.sin_port);
+end;
+
+procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol,
+    SockType: integer; const IPList: TStrings);
+type
+  TaPInAddr = array[0..250] of PInAddr;
+  PaPInAddr = ^TaPInAddr;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  AddrNext: PAddrInfo;
+  r: integer;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IP: u_long;
+  PAdrPtr: PaPInAddr;
+  i: Integer;
+  s: String;
+  InAddr: TInAddr;
+begin
+  IPList.Clear;
+  if not IsNewApi(Family) then
+  begin
+    IP := synsock.inet_addr(PAnsiChar(Name));
+    if IP = u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := synsock.GetHostByName(PAnsiChar(Name));
+        if RemoteHost <> nil then
+        begin
+          PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
+          i := 0;
+          while PAdrPtr^[i] <> nil do
+          begin
+            InAddr := PAdrPtr^[i]^;
+            s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1],
+              InAddr.S_bytes[2], InAddr.S_bytes[3]]);
+            IPList.Add(s);
+            Inc(i);
+          end;
+        end;
+      finally
+        SynSockCS.Leave;
+      end;
+    end
+    else
+      IPList.Add(string(Name));
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr);
+      if r = 0 then
+      begin
+        AddrNext := Addr;
+        while not(AddrNext = nil) do
+        begin
+          if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET))
+            or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then
+          begin
+            hostlen := NI_MAXHOST;
+            servlen := NI_MAXSERV;
+            setlength(host, hostlen);
+            setlength(serv, servlen);
+            r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen,
+              PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
+              NI_NUMERICHOST + NI_NUMERICSERV);
+            if r = 0 then
+            begin
+              host := PAnsiChar(host);
+              IPList.Add(string(host));
+            end;
+          end;
+          AddrNext := AddrNext^.ai_next;
+        end;
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+  if IPList.Count = 0 then
+    IPList.Add(cAnyHost);
+end;
+
+function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType:
+    integer): Word;
+var
+  ProtoEnt: PProtoEnt;
+  ServEnt: PServEnt;
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+begin
+  Result := 0;
+  if not IsNewApi(Family) then
+  begin
+    SynSockCS.Enter;
+    try
+      ProtoEnt := synsock.GetProtoByNumber(SockProtocol);
+      ServEnt := nil;
+      if ProtoEnt <> nil then
+        ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name);
+      if ServEnt = nil then
+        Result := StrToIntDef(string(Port), 0)
+      else
+        Result := synsock.htons(ServEnt^.s_port);
+    finally
+      SynSockCS.Leave;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := Sockprotocol;
+      Hints.ai_flags := AI_PASSIVE;
+      r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr);
+      if (r = 0) and Assigned(Addr) then
+      begin
+        if Addr^.ai_family = AF_INET then
+          Result := synsock.htons(Addr^.ai_addr^.sin_port);
+        if Addr^.ai_family = AF_INET6 then
+          Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType:
+    integer): AnsiString;
+var
+  Hints: TAddrInfo;
+  Addr: PAddrInfo;
+  r: integer;
+  host, serv: AnsiString;
+  hostlen, servlen: integer;
+  RemoteHost: PHostEnt;
+  IPn: u_long;
+begin
+  Result := IP;
+  if not IsNewApi(Family) then
+  begin
+    IPn := synsock.inet_addr(PAnsiChar(IP));
+    if IPn <> u_long(INADDR_NONE) then
+    begin
+      SynSockCS.Enter;
+      try
+        RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET);
+        if RemoteHost <> nil then
+          Result := RemoteHost^.h_name;
+      finally
+        SynSockCS.Leave;
+      end;
+    end;
+  end
+  else
+  begin
+    Addr := nil;
+    try
+      FillChar(Hints, Sizeof(Hints), 0);
+      Hints.ai_family := AF_UNSPEC;
+      Hints.ai_socktype := SockType;
+      Hints.ai_protocol := SockProtocol;
+      Hints.ai_flags := 0;
+      r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr);
+      if (r = 0) and Assigned(Addr)then
+      begin
+        hostlen := NI_MAXHOST;
+        servlen := NI_MAXSERV;
+        setlength(host, hostlen);
+        setlength(serv, servlen);
+        r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen,
+          PAnsiChar(host), hostlen, PAnsiChar(serv), servlen,
+          NI_NUMERICSERV);
+        if r = 0 then
+          Result := PAnsiChar(host);
+      end;
+    finally
+      if Assigned(Addr) then
+        synsock.FreeAddrInfo(Addr);
+    end;
+  end;
+end;
+
+{=============================================================================}
+
+function InitSocketInterface(stack: String): Boolean;
+begin
+  Result := False;
+  if stack = '' then
+    stack := DLLStackName;
+  SynSockCS.Enter;
+  try
+    if SynSockCount = 0 then
+    begin
+      SockEnhancedApi := False;
+      SockWship6Api := False;
+      LibHandle := LoadLibrary(PChar(Stack));
+      if LibHandle <> 0 then
+      begin
+        WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl')));
+        __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet')));
+        CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket')));
+        IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket')));
+        WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError')));
+        WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup')));
+        WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup')));
+        ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept')));
+        ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind')));
+        ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect')));
+        ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername')));
+        ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname')));
+        GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt')));
+        Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl')));
+        Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons')));
+        Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr')));
+        Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa')));
+        Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen')));
+        Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl')));
+        Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs')));
+        ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv')));
+        ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom')));
+        Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select')));
+        ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send')));
+        ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto')));
+        SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt')));
+        ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown')));
+        Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket')));
+        GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr')));
+        GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname')));
+        GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname')));
+        GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber')));
+        GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname')));
+        GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport')));
+        ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname')));
+
+{$IFNDEF FORCEOLDAPI}
+        GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo')));
+        FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo')));
+        GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo')));
+        SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
+          and Assigned(GetNameInfo);
+        if not SockEnhancedApi then
+        begin
+          LibWship6Handle := LoadLibrary(PChar(DLLWship6));
+          if LibWship6Handle <> 0 then
+          begin
+            GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo')));
+            FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo')));
+            GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo')));
+            SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
+              and Assigned(GetNameInfo);
+          end;
+        end;
+{$ENDIF}
+        Result := True;
+      end;
+    end
+    else Result := True;
+    if Result then
+      Inc(SynSockCount);
+  finally
+    SynSockCS.Leave;
+  end;
+end;
+
+function DestroySocketInterface: Boolean;
+begin
+  SynSockCS.Enter;
+  try
+    Dec(SynSockCount);
+    if SynSockCount < 0 then
+      SynSockCount := 0;
+    if SynSockCount = 0 then
+    begin
+      if LibHandle <> 0 then
+      begin
+        FreeLibrary(libHandle);
+        LibHandle := 0;
+      end;
+      if LibWship6Handle <> 0 then
+      begin
+        FreeLibrary(LibWship6Handle);
+        LibWship6Handle := 0;
+      end;
+    end;
+  finally
+    SynSockCS.Leave;
+  end;
+  Result := True;
+end;
+
+initialization
+begin
+  SynSockCS := SyncObjs.TCriticalSection.Create;
+  SET_IN6_IF_ADDR_ANY (@in6addr_any);
+  SET_LOOPBACK_ADDR6  (@in6addr_loopback);
+end;
+
+finalization
+begin
+  SynSockCS.Free;
+end;

synabyte.pas

@@ -0,0 +1,368 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 003.012.008 |
+|==============================================================================|
+| Content: buffer wrapper layer
+|==============================================================================|
+| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2012.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s): Radek Cervinka, delphi.cz                                    |
+|                 Ondrej Pokorny, kluug.net
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(NextGen and Unicode buffer layer)}
+
+unit synabyte;
+{$i jedi.inc}
+
+interface
+uses
+  sysutils;
+{$IFDEF NEXTGEN}
+    {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+type
+{$IFDEF UNICODE}
+  TSynaByte = byte;
+  TSynaBytes = record
+  private
+    FBytes: TBytes;
+    FRefCheck: string;
+
+    function GetChars(const Index: NativeInt): Char;
+    procedure SetChars(const Index: NativeInt; const Value: Char);
+    function AGetLength: NativeInt;
+    procedure ASetLength(const Value: NativeInt);
+
+    procedure UpdateTerminator;
+    procedure CheckCow;
+    procedure Unique;
+  public
+    class operator Implicit(const V1: String): TSynaBytes;
+    class operator Implicit(const V1: RawByteString): TSynaBytes;
+    class operator Implicit(const V1: TSynaBytes): String;
+    class operator Implicit(const V1: Char): TSynaBytes;
+    class operator Explicit(const V1: TBytes): TSynaBytes;
+
+
+    class operator Add(const V1, V2: TSynaBytes): TSynaBytes;
+
+    class operator Equal(const V1, V2: TSynaBytes): Boolean;
+    class operator NotEqual(const V1, V2: TSynaBytes): Boolean;
+
+    function Clone: TSynaBytes;
+    procedure Delete(Start, Count: Integer);
+    function Data: Pointer;
+
+
+    property Chars[const Index: NativeInt]: Char read GetChars write SetChars; default;
+    property Length: NativeInt read AGetLength write ASetLength;
+    property Bytes:TBytes read FBytes;
+  end;
+
+//  procedure SetLength(var s: TSynaBytes; Count:Integer); overload;
+
+{$ELSE}
+  TSynaBytes = AnsiString;
+  TSynaByte = AnsiChar;
+{$ENDIF}
+
+{$IFNDEF DELPHI12_UP}
+  TBytes = Array of Byte;
+
+  function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
+{$ENDIF}
+
+  function StringOf(const bytes: TSynaBytes):string; overload;
+  function StringOf(const bytes: TBytes):string; overload;
+  function StringOf(const bytes: PByte): String; overload;
+
+  procedure DeleteInternal (var s: TSynaBytes; Start, Count: Integer);
+
+implementation
+
+{$IFDEF UNICODE}
+
+function IsBytesEquals(const Bytes1, Bytes2: TBytes; const Len1, Len2: NativeInt): Boolean;
+var
+  i: NativeInt;
+begin
+  if Len1 <> Len2 then
+    Exit(False);
+
+  for i := 0 to Len1 - 1 do
+    if Bytes1[i] <> Bytes2[i] then
+      Exit(False);
+
+  Result := True;
+end;
+
+class operator TSynaBytes.Implicit(const V1: String): TSynaBytes;
+begin
+  Result.FBytes := TEncoding.Default.GetBytes(V1);
+  Result.Length := System.Length(Result.FBytes);
+end;
+ 
+class operator TSynaBytes.Add(const V1, V2: TSynaBytes): TSynaBytes;
+begin
+  Result.Length := V1.Length + V2.Length;
+  if V1.Length > 0 then
+    Move(V1.FBytes[0], Result.FBytes[0], V1.Length);
+  if V2.Length > 0 then
+    Move(V2.FBytes[0], Result.FBytes[V1.Length], V2.Length);
+end;
+
+procedure TSynaBytes.CheckCow;
+  function RefCount: Integer;
+  var
+    xStrPtr: ^Integer;
+  begin
+    //get reference count of FStrBuffer, correct results on 32bit, 64bit and also mobile
+    xStrPtr := Pointer(PChar(FRefCheck));
+    Dec(xStrPtr, 2);
+    Result := xStrPtr^;
+  end;
+
+begin
+  if RefCount <> 1 then
+  begin
+    Unique;
+  end;
+  FRefCheck := '!';
+end;
+
+function TSynaBytes.Clone: TSynaBytes;
+begin
+  Result.Length := Self.Length;
+  Move(FBytes[0], Result.FBytes[0], Self.Length);
+end;
+
+function TSynaBytes.Data: Pointer;
+begin
+  Result := @FBytes[0];
+end;
+
+// zero based
+procedure TSynaBytes.Delete(Start, Count: Integer);
+begin
+  if Count <= 0 then
+    Exit;
+  CheckCow;
+  if Length - Count <= 0 then
+  begin
+    Length := 0;
+    Exit;
+  end;
+  if (Start >= 0) then
+  begin
+    Move(FBytes[Start + Count], FBytes[Start], Length - Count);
+    Length := Length - Count;
+  end;
+end;
+
+class operator TSynaBytes.Equal(const V1, V2: TSynaBytes): Boolean;
+begin
+  Result := IsBytesEquals(V1.FBytes, V2.FBytes, V1.Length, V2.Length);
+end;
+
+class operator TSynaBytes.Explicit(const V1: TBytes): TSynaBytes;
+begin
+  Result.FBytes := Copy(V1);
+  Result.Length := System.Length(V1);
+end;
+
+function TSynaBytes.GetChars(const Index: NativeInt): Char;
+begin
+  Result := Char(FBytes[Index]);
+end;
+
+function TSynaBytes.AGetLength: NativeInt;
+begin
+  Result := System.Length(FBytes);
+
+  if Result > 0 then
+    Result := Result - 1;  // Null Terminator
+end;
+
+class operator TSynaBytes.Implicit(const V1: Char): TSynaBytes;
+begin
+  Result.FBytes := TEncoding.Default.GetBytes(V1);
+  Result.Length := System.Length(Result.FBytes);
+end;
+
+class operator TSynaBytes.Implicit(const V1: RawByteString): TSynaBytes;
+var
+  I: Integer;
+begin
+  Result.Length := System.Length(V1);
+  for I := 1 to System.Length(V1) do
+    Result.FBytes[I-1] := Byte(V1[I]);//warning: null-terminated strings!
+end;
+
+class operator TSynaBytes.Implicit(const V1: TSynaBytes): String;
+var
+  //I: Integer;
+  //C: PWord;
+  S: RawByteString;
+begin
+  SetLength(Result, V1.Length);
+  if V1.Length > 0 then
+  begin
+    //ïåðåïèñàë, 4873
+    SetLength(s, V1.Length);
+    Move(V1.FBytes[0], s[1], V1.Length);
+    Result := string(s);
+    {C := PWord(PWideChar(Result));
+    for I := 0 to V1.Length-1 do
+    begin
+      C^ := V1.FBytes[I];
+      Inc(C);
+    end;}
+  end;
+end;
+
+class operator TSynaBytes.NotEqual(const V1, V2: TSynaBytes): Boolean;
+begin
+  Result := not IsBytesEquals(V1.FBytes, V2.FBytes, V1.Length, V2.Length);
+end;
+
+procedure TSynaBytes.SetChars(const Index: NativeInt; const Value: Char);
+begin
+  CheckCow;
+  FBytes[Index] := Byte(Value);
+end;
+
+procedure TSynaBytes.Unique;
+var
+  b:TBytes;
+begin
+  SetLength(b, Self.Length + 1);
+  Move(FBytes[0], b[0], Self.Length);
+  FBytes := b;
+end;
+
+procedure TSynaBytes.UpdateTerminator;
+begin
+  if System.Length(FBytes) > 0 then
+    FBytes[System.Length(FBytes) - 1] := 0;
+end;
+
+procedure TSynaBytes.ASetLength(const Value: NativeInt);
+begin
+  System.SetLength(FBytes, Value + 1); // +1, null terminator
+  Self.UpdateTerminator();
+end;
+{$ENDIF}
+
+function StringOf(const bytes: TSynaBytes):string;
+begin
+  Result := bytes;
+end;
+
+function StringOf(const bytes: TBytes):string;
+{$IFDEF UNICODE}
+var
+  I: Integer;
+  C: PWord;
+begin
+  SetLength(Result, Length(bytes));
+  if Length(bytes) > 0 then
+  begin
+    C := PWord(PWideChar(Result));
+    for I := 0 to Length(bytes)-1 do
+    begin
+      C^ := bytes[I];
+      Inc(C);
+    end;
+  end;
+{$ELSE}
+begin
+  SetLength(Result, Length(bytes));
+  if Length(bytes) > 0 then
+   Move(bytes[0], result[1], Length(bytes));
+{$ENDIF}
+end;
+
+function StringOf(const bytes: PByte):string;
+var
+  count: Integer;
+  buf: PByte;
+{$IFDEF UNICODE}
+  I: Integer;
+  C: PWord;
+{$ENDIF}
+begin
+  Count := 0;
+  buf := bytes;
+  while buf^<>0 do
+  begin
+   inc(count);
+   inc(buf);
+  end;
+{$IFDEF UNICODE}
+  SetLength(Result, count);
+  if count > 0 then
+  begin
+    C := PWord(PWideChar(Result));
+    for I := 0 to count-1 do
+    begin
+      C^ := bytes[I];
+      Inc(C);
+    end;
+  end;
+{$ELSE}
+  SetLength(Result, count);
+  Move(bytes^, result[1], count);
+{$ENDIF}
+end;
+
+procedure DeleteInternal (var s: TSynaBytes; Start, Count: Integer);
+begin
+{$IFDEF UNICODE}
+  s.Delete(Start - 1, Count);
+{$ELSE}
+  Delete(s, Start , Count);
+{$ENDIF}
+end;
+
+{$IFNDEF DELPHI12_UP}
+function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
+begin
+  Result := C in CharSet;
+end;
+{$ENDIF}
+
+end.

synachar.pas

@@ -0,0 +1,2041 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 005.002.004 |
+|==============================================================================|
+| Content: Charset conversion support                                          |
+|==============================================================================|
+| Copyright (c)1999-2015, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2015.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(Charset conversion support)
+This unit contains a routines for lot of charset conversions.
+
+It using built-in conversion tables or external Iconv library. Iconv is used
+ when needed conversion is known by Iconv library. When Iconv library is not
+ found or Iconv not know requested conversion, then are internal routines used
+ for conversion. (You can disable Iconv support from your program too!)
+
+Internal routines knows all major charsets for Europe or America. For East-Asian
+ charsets you must use Iconv library!
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit synachar;
+
+interface
+
+uses
+{$IFNDEF MSWINDOWS}
+  {$IFNDEF FPC}
+  Libc,
+  {$ENDIF}
+{$ELSE}
+  Windows,
+{$ENDIF}
+{$IFDEF ULTIBO}
+  Locale,
+{$ENDIF}
+  SysUtils,
+  synautil, synacode, synaicnv;
+
+type
+  {:Type with all supported charsets.}
+  TMimeChar = (ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
+    ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10, ISO_8859_13,
+    ISO_8859_14, ISO_8859_15, CP1250, CP1251, CP1252, CP1253, CP1254, CP1255,
+    CP1256, CP1257, CP1258, KOI8_R, CP895, CP852, UCS_2, UCS_4, UTF_8, UTF_7,
+    UTF_7mod, UCS_2LE, UCS_4LE,
+    //next is supported by Iconv only...
+    UTF_16, UTF_16LE, UTF_32, UTF_32LE, C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU,
+    CP862, CP866, MAC, MACCE, MACICE, MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU,
+    MACHEB, MACAR, MACTH, ROMAN8, NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS,
+    KOI8_T, MULELAO, CP1133, TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201,
+    JIS_X0208, JIS_X0212, GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP,
+    SHIFT_JIS, CP932, ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936,
+    GB18030, ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS,
+    EUC_KR, CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857,
+    CP858, CP860, CP861, CP863, CP864, CP865, CP869, CP1125);
+
+  {:Set of any charsets.}
+  TMimeSetChar = set of TMimeChar;
+
+const
+  {:Set of charsets supported by Iconv library only.}
+  IconvOnlyChars: set of TMimeChar = [UTF_16, UTF_16LE, UTF_32, UTF_32LE,
+    C99, JAVA, ISO_8859_16, KOI8_U, KOI8_RU, CP862, CP866, MAC, MACCE, MACICE,
+    MACCRO, MACRO, MACCYR, MACUK, MACGR, MACTU, MACHEB, MACAR, MACTH, ROMAN8,
+    NEXTSTEP, ARMASCII, GEORGIAN_AC, GEORGIAN_PS, KOI8_T, MULELAO, CP1133,
+    TIS620, CP874, VISCII, TCVN, ISO_IR_14, JIS_X0201, JIS_X0208, JIS_X0212,
+    GB1988_80, GB2312_80, ISO_IR_165, ISO_IR_149, EUC_JP, SHIFT_JIS, CP932,
+    ISO_2022_JP, ISO_2022_JP1, ISO_2022_JP2, GB2312, CP936, GB18030,
+    ISO_2022_CN, ISO_2022_CNE, HZ, EUC_TW, BIG5, CP950, BIG5_HKSCS, EUC_KR,
+    CP949, CP1361, ISO_2022_KR, CP737, CP775, CP853, CP855, CP857, CP858,
+    CP860, CP861, CP863, CP864, CP865, CP869, CP1125];
+
+  {:Set of charsets supported by internal routines only.}
+  NoIconvChars: set of TMimeChar = [CP895, UTF_7mod];
+
+  {:null character replace table. (Usable for disable charater replacing.)}
+  Replace_None: array[0..0] of Word =
+    (0);
+
+  {:Character replace table for remove Czech diakritics.}
+  Replace_Czech: array[0..59] of Word =
+    (
+      $00E1, $0061,
+      $010D, $0063,
+      $010F, $0064,
+      $010E, $0044,
+      $00E9, $0065,
+      $011B, $0065,
+      $00ED, $0069,
+      $0148, $006E,
+      $00F3, $006F,
+      $0159, $0072,
+      $0161, $0073,
+      $0165, $0074,
+      $00FA, $0075,
+      $016F, $0075,
+      $00FD, $0079,
+      $017E, $007A,
+      $00C1, $0041,
+      $010C, $0043,
+      $00C9, $0045,
+      $011A, $0045,
+      $00CD, $0049,
+      $0147, $004E,
+      $00D3, $004F,
+      $0158, $0052,
+      $0160, $0053,
+      $0164, $0054,
+      $00DA, $0055,
+      $016E, $0055,
+      $00DD, $0059,
+      $017D, $005A
+    );
+
+var
+  {:By this you can generally disable/enable Iconv support.}
+  DisableIconv: Boolean = False;
+
+  {:Default set of charsets for @link(IdealCharsetCoding) function.}
+  IdealCharsets: TMimeSetChar =
+    [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
+    ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
+    KOI8_R, KOI8_U
+    {$IFNDEF CIL} //error URW778 ??? :-O
+    , GB2312, EUC_KR, ISO_2022_JP, EUC_TW
+    {$ENDIF}
+    ];
+
+{==============================================================================}
+{:Convert Value from one charset to another. See: @link(CharsetConversionEx)}
+function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar): AnsiString;
+
+{:Convert Value from one charset to another with additional character conversion.
+see: @link(Replace_None) and @link(Replace_Czech)}
+function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar; const TransformTable: array of Word): AnsiString;
+
+{:Convert Value from one charset to another with additional character conversion.
+ This funtion is similar to @link(CharsetConversionEx), but you can disable
+ transliteration of unconvertible characters.}
+function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString;
+
+{:Returns charset used by operating system.}
+function GetCurCP: TMimeChar;
+
+{:Returns charset used by operating system as OEM charset. (in Windows DOS box,
+ for example)}
+function GetCurOEMCP: TMimeChar;
+
+{:Converting string with charset name to TMimeChar.}
+function GetCPFromID(Value: AnsiString): TMimeChar;
+
+{:Converting TMimeChar to string with name of charset.}
+function GetIDFromCP(Value: TMimeChar): AnsiString;
+
+{:return @true when value need to be converted. (It is not 7-bit ASCII)}
+function NeedCharsetConversion(const Value: AnsiString): Boolean;
+
+{:Finding best target charset from set of TMimeChars with minimal count of
+ unconvertible characters.}
+function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar;
+  CharTo: TMimeSetChar): TMimeChar;
+
+{:Return BOM (Byte Order Mark) for given unicode charset.}
+function GetBOM(Value: TMimeChar): AnsiString;
+
+{:Convert binary string with unicode content to WideString.}
+function StringToWide(const Value: AnsiString): WideString;
+
+{:Convert WideString to binary string with unicode content.}
+function WideToString(const Value: WideString): AnsiString;
+
+function GetIconvIDFromCP(Value: TMimeChar): AnsiString;
+function GetCPFromIconvID(Value: AnsiString): TMimeChar;
+
+{==============================================================================}
+implementation
+
+//character transcoding tables X to UCS-2
+{
+//dummy table
+$0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+$0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+$0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+$0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+$00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+$00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+$00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+$00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
+$00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+$00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+$00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+$00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
+$00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+$00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+$00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+$00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
+}
+
+const
+
+{Latin-1
+  Danish, Dutch, English, Faeroese, Finnish, French, German, Icelandic,
+  Irish, Italian, Norwegian, Portuguese, Spanish and Swedish.
+}
+  CharISO_8859_1: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
+    $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
+    );
+
+{Latin-2
+  Albanian, Czech, English, German, Hungarian, Polish, Rumanian,
+  Serbo-Croatian, Slovak, Slovene and Swedish.
+}
+  CharISO_8859_2: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7,
+    $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B,
+    $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7,
+    $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C,
+    $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
+    $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
+    $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
+    $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
+    $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
+    $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
+    $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
+    $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
+    );
+
+{Latin-3
+  Afrikaans, Catalan, English, Esperanto, French, Galician,
+  German, Italian, Maltese and Turkish.
+}
+  CharISO_8859_3: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0126, $02D8, $00A3, $00A4, $FFFD, $0124, $00A7,
+    $00A8, $0130, $015E, $011E, $0134, $00AD, $FFFD, $017B,
+    $00B0, $0127, $00B2, $00B3, $00B4, $00B5, $0125, $00B7,
+    $00B8, $0131, $015F, $011F, $0135, $00BD, $FFFD, $017C,
+    $00C0, $00C1, $00C2, $FFFD, $00C4, $010A, $0108, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $FFFD, $00D1, $00D2, $00D3, $00D4, $0120, $00D6, $00D7,
+    $011C, $00D9, $00DA, $00DB, $00DC, $016C, $015C, $00DF,
+    $00E0, $00E1, $00E2, $FFFD, $00E4, $010B, $0109, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $FFFD, $00F1, $00F2, $00F3, $00F4, $0121, $00F6, $00F7,
+    $011D, $00F9, $00FA, $00FB, $00FC, $016D, $015D, $02D9
+    );
+
+{Latin-4
+  Danish, English, Estonian, Finnish, German, Greenlandic,
+  Lappish, Latvian, Lithuanian, Norwegian and Swedish.
+}
+  CharISO_8859_4: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0104, $0138, $0156, $00A4, $0128, $013B, $00A7,
+    $00A8, $0160, $0112, $0122, $0166, $00AD, $017D, $00AF,
+    $00B0, $0105, $02DB, $0157, $00B4, $0129, $013C, $02C7,
+    $00B8, $0161, $0113, $0123, $0167, $014A, $017E, $014B,
+    $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E,
+    $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $012A,
+    $0110, $0145, $014C, $0136, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $0172, $00DA, $00DB, $00DC, $0168, $016A, $00DF,
+    $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F,
+    $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $012B,
+    $0111, $0146, $014D, $0137, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $0173, $00FA, $00FB, $00FC, $0169, $016B, $02D9
+    );
+
+{CYRILLIC
+  Bulgarian, Bielorussian, English, Macedonian, Russian,
+  Serbo-Croatian and Ukrainian.
+}
+  CharISO_8859_5: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0401, $0402, $0403, $0404, $0405, $0406, $0407,
+    $0408, $0409, $040A, $040B, $040C, $00AD, $040E, $040F,
+    $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417,
+    $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F,
+    $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427,
+    $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F,
+    $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437,
+    $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F,
+    $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447,
+    $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F,
+    $2116, $0451, $0452, $0453, $0454, $0455, $0456, $0457,
+    $0458, $0459, $045A, $045B, $045C, $00A7, $045E, $045F
+    );
+
+{ARABIC
+}
+  CharISO_8859_6: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $FFFD, $FFFD, $FFFD, $00A4, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $060C, $00AD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $061B, $FFFD, $FFFD, $FFFD, $061F,
+    $FFFD, $0621, $0622, $0623, $0624, $0625, $0626, $0627,
+    $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F,
+    $0630, $0631, $0632, $0633, $0634, $0635, $0636, $0637,
+    $0638, $0639, $063A, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $0640, $0641, $0642, $0643, $0644, $0645, $0646, $0647,
+    $0648, $0649, $064A, $064B, $064C, $064D, $064E, $064F,
+    $0650, $0651, $0652, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD
+    );
+
+{GREEK
+}
+  CharISO_8859_7: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $2018, $2019, $00A3, $FFFD, $FFFD, $00A6, $00A7,
+    $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $FFFD, $2015,
+    $00B0, $00B1, $00B2, $00B3, $0384, $0385, $0386, $00B7,
+    $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F,
+    $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397,
+    $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F,
+    $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7,
+    $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF,
+    $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7,
+    $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF,
+    $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7,
+    $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD
+    );
+
+{HEBREW
+}
+  CharISO_8859_8: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $FFFD, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $2017,
+    $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7,
+    $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF,
+    $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7,
+    $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD
+    );
+
+{Latin-5
+  English, Finnish, French, German, Irish, Italian, Norwegian,
+  Portuguese, Spanish, Swedish and Turkish.
+}
+  CharISO_8859_9: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7,
+    $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B,
+    $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7,
+    $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C,
+    $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
+    $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
+    $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF
+    );
+
+{Latin-6
+  Danish, English, Estonian, Faeroese, Finnish, German, Greenlandic,
+  Icelandic, Lappish, Latvian, Lithuanian, Norwegian and Swedish.
+}
+  CharISO_8859_10: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $0104, $0112, $0122, $012A, $0128, $0136, $00A7,
+    $013B, $0110, $0160, $0166, $017D, $00AD, $016A, $014A,
+    $00B0, $0105, $0113, $0123, $012B, $0129, $0137, $00B7,
+    $013C, $0111, $0161, $0167, $017E, $2015, $016B, $014B,
+    $0100, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $012E,
+    $010C, $00C9, $0118, $00CB, $0116, $00CD, $00CE, $00CF,
+    $00D0, $0145, $014C, $00D3, $00D4, $00D5, $00D6, $0168,
+    $00D8, $0172, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
+    $0101, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $012F,
+    $010D, $00E9, $0119, $00EB, $0117, $00ED, $00EE, $00EF,
+    $00F0, $0146, $014D, $00F3, $00F4, $00F5, $00F6, $0169,
+    $00F8, $0173, $00FA, $00FB, $00FC, $00FD, $00FE, $0138
+    );
+
+  CharISO_8859_13: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $201D, $00A2, $00A3, $00A4, $201E, $00A6, $00A7,
+    $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6,
+    $00B0, $00B1, $00B2, $00B3, $201C, $00B5, $00B6, $00B7,
+    $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6,
+    $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112,
+    $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B,
+    $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7,
+    $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF,
+    $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113,
+    $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C,
+    $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7,
+    $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $2019
+    );
+
+  CharISO_8859_14: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $1E02, $1E03, $00A3, $010A, $010B, $1E0A, $00A7,
+    $1E80, $00A9, $1E82, $1E0B, $1EF2, $00AD, $00AE, $0178,
+    $1E1E, $1E1F, $0120, $0121, $1E40, $1E41, $00B6, $1E56,
+    $1E81, $1E57, $1E83, $1E60, $1EF3, $1E84, $1E85, $1E61,
+    $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $0174, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $1E6A,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $0176, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $0175, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $1E6B,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $0177, $00FF
+    );
+
+  CharISO_8859_15: array[128..255] of Word =
+  (
+    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
+    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
+    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
+    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
+    $00A0, $00A1, $00A2, $00A3, $20AC, $00A5, $0160, $00A7,
+    $0161, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $017D, $00B5, $00B6, $00B7,
+    $017E, $00B9, $00BA, $00BB, $0152, $0153, $0178, $00BF,
+    $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
+    );
+
+{Eastern European
+}
+  CharCP_1250: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021,
+    $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A,
+    $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7,
+    $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B,
+    $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C,
+    $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
+    $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
+    $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
+    $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
+    $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
+    $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
+    $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
+    $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
+    );
+
+{Cyrillic
+}
+  CharCP_1251: array[128..255] of Word =
+  (
+    $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021,
+    $20AC, $2030, $0409, $2039, $040A, $040C, $040B, $040F,
+    $0452, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $FFFD, $2122, $0459, $203A, $045A, $045C, $045B, $045F,
+    $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7,
+    $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407,
+    $00B0, $00B1, $0406, $0456, $0491, $00B5, $00B6, $00B7,
+    $0451, $2116, $0454, $00BB, $0458, $0405, $0455, $0457,
+    $0410, $0411, $0412, $0413, $0414, $0415, $0416, $0417,
+    $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F,
+    $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427,
+    $0428, $0429, $042A, $042B, $042C, $042D, $042E, $042F,
+    $0430, $0431, $0432, $0433, $0434, $0435, $0436, $0437,
+    $0438, $0439, $043A, $043B, $043C, $043D, $043E, $043F,
+    $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447,
+    $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F
+    );
+
+{Latin-1 (US, Western Europe)
+}
+  CharCP_1252: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
+    $02C6, $2030, $0160, $2039, $0152, $FFFD, $017D, $FFFD,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $02DC, $2122, $0161, $203A, $0153, $FFFD, $017E, $0178,
+    $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
+    $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $00DD, $00DE, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF
+    );
+
+{Greek
+}
+  CharCP_1253: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
+    $FFFD, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $FFFD, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD,
+    $00A0, $0385, $0386, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $FFFD, $00AB, $00AC, $00AD, $00AE, $2015,
+    $00B0, $00B1, $00B2, $00B3, $0384, $00B5, $00B6, $00B7,
+    $0388, $0389, $038A, $00BB, $038C, $00BD, $038E, $038F,
+    $0390, $0391, $0392, $0393, $0394, $0395, $0396, $0397,
+    $0398, $0399, $039A, $039B, $039C, $039D, $039E, $039F,
+    $03A0, $03A1, $FFFD, $03A3, $03A4, $03A5, $03A6, $03A7,
+    $03A8, $03A9, $03AA, $03AB, $03AC, $03AD, $03AE, $03AF,
+    $03B0, $03B1, $03B2, $03B3, $03B4, $03B5, $03B6, $03B7,
+    $03B8, $03B9, $03BA, $03BB, $03BC, $03BD, $03BE, $03BF,
+    $03C0, $03C1, $03C2, $03C3, $03C4, $03C5, $03C6, $03C7,
+    $03C8, $03C9, $03CA, $03CB, $03CC, $03CD, $03CE, $FFFD
+    );
+
+{Turkish
+}
+  CharCP_1254: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
+    $02C6, $2030, $0160, $2039, $0152, $FFFD, $FFFD, $FFFD,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $02DC, $2122, $0161, $203A, $0153, $FFFD, $FFFD, $0178,
+    $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
+    $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
+    $011E, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $0130, $015E, $00DF,
+    $00E0, $00E1, $00E2, $00E3, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, $00EE, $00EF,
+    $011F, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $0131, $015F, $00FF
+    );
+
+{Hebrew
+}
+  CharCP_1255: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
+    $02C6, $2030, $FFFD, $2039, $FFFD, $FFFD, $FFFD, $FFFD,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $02DC, $2122, $FFFD, $203A, $FFFD, $FFFD, $FFFD, $FFFD,
+    $00A0, $00A1, $00A2, $00A3, $20AA, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00D7, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00F7, $00BB, $00BC, $00BD, $00BE, $00BF,
+    $05B0, $05B1, $05B2, $05B3, $05B4, $05B5, $05B6, $05B7,
+    $05B8, $05B9, $FFFD, $05BB, $05BC, $05BD, $05BE, $05BF,
+    $05C0, $05C1, $05C2, $05C3, $05F0, $05F1, $05F2, $05F3,
+    $05F4, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD, $FFFD,
+    $05D0, $05D1, $05D2, $05D3, $05D4, $05D5, $05D6, $05D7,
+    $05D8, $05D9, $05DA, $05DB, $05DC, $05DD, $05DE, $05DF,
+    $05E0, $05E1, $05E2, $05E3, $05E4, $05E5, $05E6, $05E7,
+    $05E8, $05E9, $05EA, $FFFD, $FFFD, $200E, $200F, $FFFD
+    );
+
+{Arabic
+}
+  CharCP_1256: array[128..255] of Word =
+  (
+    $20AC, $067E, $201A, $0192, $201E, $2026, $2020, $2021,
+    $02C6, $2030, $0679, $2039, $0152, $0686, $0698, $0688,
+    $06AF, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $06A9, $2122, $0691, $203A, $0153, $200C, $200D, $06BA,
+    $00A0, $060C, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $06BE, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $061B, $00BB, $00BC, $00BD, $00BE, $061F,
+    $06C1, $0621, $0622, $0623, $0624, $0625, $0626, $0627,
+    $0628, $0629, $062A, $062B, $062C, $062D, $062E, $062F,
+    $0630, $0631, $0632, $0633, $0634, $0635, $0636, $00D7,
+    $0637, $0638, $0639, $063A, $0640, $0641, $0642, $0643,
+    $00E0, $0644, $00E2, $0645, $0646, $0647, $0648, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $0649, $064A, $00EE, $00EF,
+    $064B, $064C, $064D, $064E, $00F4, $064F, $0650, $00F7,
+    $0651, $00F9, $0652, $00FB, $00FC, $200E, $200F, $06D2
+    );
+
+{Baltic
+}
+  CharCP_1257: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021,
+    $FFFD, $2030, $FFFD, $2039, $FFFD, $00A8, $02C7, $00B8,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $FFFD, $2122, $FFFD, $203A, $FFFD, $00AF, $02DB, $FFFD,
+    $00A0, $FFFD, $00A2, $00A3, $00A4, $FFFD, $00A6, $00A7,
+    $00D8, $00A9, $0156, $00AB, $00AC, $00AD, $00AE, $00C6,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00F8, $00B9, $0157, $00BB, $00BC, $00BD, $00BE, $00E6,
+    $0104, $012E, $0100, $0106, $00C4, $00C5, $0118, $0112,
+    $010C, $00C9, $0179, $0116, $0122, $0136, $012A, $013B,
+    $0160, $0143, $0145, $00D3, $014C, $00D5, $00D6, $00D7,
+    $0172, $0141, $015A, $016A, $00DC, $017B, $017D, $00DF,
+    $0105, $012F, $0101, $0107, $00E4, $00E5, $0119, $0113,
+    $010D, $00E9, $017A, $0117, $0123, $0137, $012B, $013C,
+    $0161, $0144, $0146, $00F3, $014D, $00F5, $00F6, $00F7,
+    $0173, $0142, $015B, $016B, $00FC, $017C, $017E, $02D9
+    );
+
+{Vietnamese
+}
+  CharCP_1258: array[128..255] of Word =
+  (
+    $20AC, $FFFD, $201A, $0192, $201E, $2026, $2020, $2021,
+    $02C6, $2030, $FFFD, $2039, $0152, $FFFD, $FFFD, $FFFD,
+    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
+    $02DC, $2122, $FFFD, $203A, $0153, $FFFD, $FFFD, $0178,
+    $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
+    $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF,
+    $00B0, $00B1, $00B2, $00B3, $00B4, $00B5, $00B6, $00B7,
+    $00B8, $00B9, $00BA, $00BB, $00BC, $00BD, $00BE, $00BF,
+    $00C0, $00C1, $00C2, $0102, $00C4, $00C5, $00C6, $00C7,
+    $00C8, $00C9, $00CA, $00CB, $0300, $00CD, $00CE, $00CF,
+    $0110, $00D1, $0309, $00D3, $00D4, $01A0, $00D6, $00D7,
+    $00D8, $00D9, $00DA, $00DB, $00DC, $01AF, $0303, $00DF,
+    $00E0, $00E1, $00E2, $0103, $00E4, $00E5, $00E6, $00E7,
+    $00E8, $00E9, $00EA, $00EB, $0301, $00ED, $00EE, $00EF,
+    $0111, $00F1, $0323, $00F3, $00F4, $01A1, $00F6, $00F7,
+    $00F8, $00F9, $00FA, $00FB, $00FC, $01B0, $20AB, $00FF
+    );
+
+{Cyrillic
+}
+  CharKOI8_R: array[128..255] of Word =
+  (
+    $2500, $2502, $250C, $2510, $2514, $2518, $251C, $2524,
+    $252C, $2534, $253C, $2580, $2584, $2588, $258C, $2590,
+    $2591, $2592, $2593, $2320, $25A0, $2219, $221A, $2248,
+    $2264, $2265, $00A0, $2321, $00B0, $00B2, $00B7, $00F7,
+    $2550, $2551, $2552, $0451, $2553, $2554, $2555, $2556,
+    $2557, $2558, $2559, $255A, $255B, $255C, $255D, $255E,
+    $255F, $2560, $2561, $0401, $2562, $2563, $2564, $2565,
+    $2566, $2567, $2568, $2569, $256A, $256B, $256C, $00A9,
+    $044E, $0430, $0431, $0446, $0434, $0435, $0444, $0433,
+    $0445, $0438, $0439, $043A, $043B, $043C, $043D, $043E,
+    $043F, $044F, $0440, $0441, $0442, $0443, $0436, $0432,
+    $044C, $044B, $0437, $0448, $044D, $0449, $0447, $044A,
+    $042E, $0410, $0411, $0426, $0414, $0415, $0424, $0413,
+    $0425, $0418, $0419, $041A, $041B, $041C, $041D, $041E,
+    $041F, $042F, $0420, $0421, $0422, $0423, $0416, $0412,
+    $042C, $042B, $0417, $0428, $042D, $0429, $0427, $042A
+    );
+
+{Czech (Kamenicky)
+}
+  CharCP_895: array[128..255] of Word =
+  (
+    $010C, $00FC, $00E9, $010F, $00E4, $010E, $0164, $010D,
+    $011B, $011A, $0139, $00CD, $013E, $013A, $00C4, $00C1,
+    $00C9, $017E, $017D, $00F4, $00F6, $00D3, $016F, $00DA,
+    $00FD, $00D6, $00DC, $0160, $013D, $00DD, $0158, $0165,
+    $00E1, $00ED, $00F3, $00FA, $0148, $0147, $016E, $00D4,
+    $0161, $0159, $0155, $0154, $00BC, $00A7, $00AB, $00BB,
+    $2591, $2592, $2593, $2502, $2524, $2561, $2562, $2556,
+    $2555, $2563, $2551, $2557, $255D, $255C, $255B, $2510,
+    $2514, $2534, $252C, $251C, $2500, $253C, $255E, $255F,
+    $255A, $2554, $2569, $2566, $2560, $2550, $256C, $2567,
+    $2568, $2564, $2565, $2559, $2558, $2552, $2553, $256B,
+    $256A, $2518, $250C, $2588, $2584, $258C, $2590, $2580,
+    $03B1, $03B2, $0393, $03C0, $03A3, $03C3, $03BC, $03C4,
+    $03A6, $0398, $03A9, $03B4, $221E, $2205, $03B5, $2229,
+    $2261, $00B1, $2265, $2264, $2320, $2321, $00F7, $2248,
+    $2218, $00B7, $2219, $221A, $207F, $00B2, $25A0, $00A0
+    );
+
+{Eastern European
+}
+  CharCP_852: array[128..255] of Word =
+  (
+    $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7,
+    $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106,
+    $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A,
+    $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D,
+    $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E,
+    $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB,
+    $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A,
+    $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510,
+    $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103,
+    $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4,
+    $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE,
+    $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580,
+    $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161,
+    $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4,
+    $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8,
+    $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0
+    );
+
+{==============================================================================}
+type
+  TIconvChar = record
+    Charset: TMimeChar;
+    CharName: string;
+  end;
+  TIconvArr = array [0..112] of TIconvChar;
+
+const
+  NotFoundChar = '_';
+
+var
+  SetTwo: set of TMimeChar = [UCS_2, UCS_2LE, UTF_7, UTF_7mod];
+  SetFour: set of TMimeChar = [UCS_4, UCS_4LE, UTF_8];
+  SetLE: set of TMimeChar = [UCS_2LE, UCS_4LE];
+
+  IconvArr: TIconvArr;
+
+{==============================================================================}
+function FindIconvID(const Value, Charname: string): Boolean;
+var
+  s: string;
+begin
+  Result := True;
+  //exact match
+  if Value = Charname then
+    Exit;
+  //Value is on begin of charname
+  s := Value + ' ';
+  if s = Copy(Charname, 1, Length(s)) then
+    Exit;
+  //Value is on end of charname
+  s := ' ' + Value;
+  if s = Copy(Charname, Length(Charname) - Length(s) + 1, Length(s)) then
+    Exit;
+  //value is somewhere inside charname
+  if Pos( s + ' ', Charname) > 0 then
+    Exit;
+  Result := False;
+end;
+
+function GetCPFromIconvID(Value: AnsiString): TMimeChar;
+var
+  n: integer;
+begin
+  Result := ISO_8859_1;
+  Value := UpperCase(Value);
+  for n := 0 to High(IconvArr) do
+    if FindIconvID(Value, IconvArr[n].Charname) then
+    begin
+      Result := IconvArr[n].Charset;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+function GetIconvIDFromCP(Value: TMimeChar): AnsiString;
+var
+  n: integer;
+begin
+  Result := 'ISO-8859-1';
+  for n := 0 to High(IconvArr) do
+    if IconvArr[n].Charset = Value then
+    begin
+      Result := Separateleft(IconvArr[n].Charname, ' ');
+      Break;
+    end;
+end;
+
+{==============================================================================}
+function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word;
+var
+  n: integer;
+begin
+  if High(TransformTable) <> 0 then
+    for n := 0 to High(TransformTable) do
+      if not odd(n) then
+        if TransformTable[n] = Value then
+          begin
+            Value := TransformTable[n+1];
+            break;
+          end;
+  Result := Value;
+end;
+
+{==============================================================================}
+procedure CopyArray(const SourceTable: array of Word;
+  var TargetTable: array of Word);
+var
+  n: Integer;
+begin
+  for n := 0 to 127 do
+    TargetTable[n] := SourceTable[n];
+end;
+
+{==============================================================================}
+procedure GetArray(CharSet: TMimeChar; var Result: array of Word);
+begin
+  case CharSet of
+    ISO_8859_2:
+      CopyArray(CharISO_8859_2, Result);
+    ISO_8859_3:
+      CopyArray(CharISO_8859_3, Result);
+    ISO_8859_4:
+      CopyArray(CharISO_8859_4, Result);
+    ISO_8859_5:
+      CopyArray(CharISO_8859_5, Result);
+    ISO_8859_6:
+      CopyArray(CharISO_8859_6, Result);
+    ISO_8859_7:
+      CopyArray(CharISO_8859_7, Result);
+    ISO_8859_8:
+      CopyArray(CharISO_8859_8, Result);
+    ISO_8859_9:
+      CopyArray(CharISO_8859_9, Result);
+    ISO_8859_10:
+      CopyArray(CharISO_8859_10, Result);
+    ISO_8859_13:
+      CopyArray(CharISO_8859_13, Result);
+    ISO_8859_14:
+      CopyArray(CharISO_8859_14, Result);
+    ISO_8859_15:
+      CopyArray(CharISO_8859_15, Result);
+    CP1250:
+      CopyArray(CharCP_1250, Result);
+    CP1251:
+      CopyArray(CharCP_1251, Result);
+    CP1252:
+      CopyArray(CharCP_1252, Result);
+    CP1253:
+      CopyArray(CharCP_1253, Result);
+    CP1254:
+      CopyArray(CharCP_1254, Result);
+    CP1255:
+      CopyArray(CharCP_1255, Result);
+    CP1256:
+      CopyArray(CharCP_1256, Result);
+    CP1257:
+      CopyArray(CharCP_1257, Result);
+    CP1258:
+      CopyArray(CharCP_1258, Result);
+    KOI8_R:
+      CopyArray(CharKOI8_R, Result);
+    CP895:
+      CopyArray(CharCP_895, Result);
+    CP852:
+      CopyArray(CharCP_852, Result);
+  else
+      CopyArray(CharISO_8859_1, Result);
+  end;
+end;
+
+{==============================================================================}
+procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte;
+  var b1, b2, b3, b4: Byte; le: boolean);
+Begin
+  b1 := 0;
+  b2 := 0;
+  b3 := 0;
+  b4 := 0;
+  if Index < 0 then
+    Index := 1;
+  if mb > 4 then
+    mb := 1;
+  if (Index + mb - 1) <= Length(Value) then
+  begin
+    if le then
+      Case mb Of
+        1:
+          b1 := Ord(Value[Index]);
+        2:
+          Begin
+            b1 := Ord(Value[Index]);
+            b2 := Ord(Value[Index + 1]);
+          End;
+        3:
+          Begin
+            b1 := Ord(Value[Index]);
+            b2 := Ord(Value[Index + 1]);
+            b3 := Ord(Value[Index + 2]);
+          End;
+        4:
+          Begin
+            b1 := Ord(Value[Index]);
+            b2 := Ord(Value[Index + 1]);
+            b3 := Ord(Value[Index + 2]);
+            b4 := Ord(Value[Index + 3]);
+          End;
+      end
+    else
+      Case mb Of
+        1:
+          b1 := Ord(Value[Index]);
+        2:
+          Begin
+            b2 := Ord(Value[Index]);
+            b1 := Ord(Value[Index + 1]);
+          End;
+        3:
+          Begin
+            b3 := Ord(Value[Index]);
+            b2 := Ord(Value[Index + 1]);
+            b1 := Ord(Value[Index + 2]);
+          End;
+        4:
+          Begin
+            b4 := Ord(Value[Index]);
+            b3 := Ord(Value[Index + 1]);
+            b2 := Ord(Value[Index + 2]);
+            b1 := Ord(Value[Index + 3]);
+          End;
+      end;
+  end;
+  Inc(Index, mb);
+end;
+
+{==============================================================================}
+function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString;
+begin
+  if mb > 4 then
+    mb := 1;
+  SetLength(Result, mb);
+  if le then
+    case mb Of
+      1:
+        Result[1] := AnsiChar(b1);
+      2:
+        begin
+          Result[1] := AnsiChar(b1);
+          Result[2] := AnsiChar(b2);
+        end;
+      3:
+        begin
+          Result[1] := AnsiChar(b1);
+          Result[2] := AnsiChar(b2);
+          Result[3] := AnsiChar(b3);
+        end;
+      4:
+        begin
+          Result[1] := AnsiChar(b1);
+          Result[2] := AnsiChar(b2);
+          Result[3] := AnsiChar(b3);
+          Result[4] := AnsiChar(b4);
+        end;
+    end
+  else
+    case mb Of
+      1:
+        Result[1] := AnsiChar(b1);
+      2:
+        begin
+          Result[2] := AnsiChar(b1);
+          Result[1] := AnsiChar(b2);
+        end;
+      3:
+        begin
+          Result[3] := AnsiChar(b1);
+          Result[2] := AnsiChar(b2);
+          Result[1] := AnsiChar(b3);
+        end;
+      4:
+        begin
+          Result[4] := AnsiChar(b1);
+          Result[3] := AnsiChar(b2);
+          Result[2] := AnsiChar(b3);
+          Result[1] := AnsiChar(b4);
+        end;
+    end;
+end;
+
+{==============================================================================}
+function UTF8toUCS4(const Value: AnsiString): AnsiString;
+var
+  n, x, ul, m: Integer;
+  s: AnsiString;
+  w1, w2: Word;
+begin
+  Result := '';
+  n := 1;
+  while Length(Value) >= n do
+  begin
+    x := Ord(Value[n]);
+    Inc(n);
+    if x < 128 then
+      Result := Result + WriteMulti(x, 0, 0, 0, 4, false)
+    else
+    begin
+      m := 0;
+      if (x and $E0) = $C0 then
+        m := $1F;
+      if (x and $F0) = $E0 then
+        m := $0F;
+      if (x and $F8) = $F0 then
+        m := $07;
+      if (x and $FC) = $F8 then
+        m := $03;
+      if (x and $FE) = $FC then
+        m := $01;
+      ul := x and m;
+      s := IntToBin(ul, 0);
+      while Length(Value) >= n do
+      begin
+        x := Ord(Value[n]);
+        Inc(n);
+        if (x and $C0) = $80 then
+          s := s + IntToBin(x and $3F, 6)
+        else
+        begin
+          Dec(n);
+          Break;
+        end;
+      end;
+      ul := BinToInt(s);
+      w1 := ul div 65536;
+      w2 := ul mod 65536;
+      Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false);
+    end;
+  end;
+end;
+
+{==============================================================================}
+function UCS4toUTF8(const Value: AnsiString): AnsiString;
+var
+  s, l, k: AnsiString;
+  b1, b2, b3, b4: Byte;
+  n, m, x, y: Integer;
+  b: Byte;
+begin
+  Result := '';
+  n := 1;
+  while Length(Value) >= n do
+  begin
+    ReadMulti(Value, n, 4, b1, b2, b3, b4, false);
+    if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then
+      Result := Result + AnsiChar(b1)
+    else
+    begin
+      x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536;
+      l := IntToBin(x, 0);
+      y := Length(l) div 6;
+      s := '';
+      for m := 1 to y do
+      begin
+        k := Copy(l, Length(l) - 5, 6);
+        l := Copy(l, 1, Length(l) - 6);
+        b := BinToInt(k) or $80;
+        s := AnsiChar(b) + s;
+      end;
+      b := BinToInt(l);
+      case y of
+        5:
+          b := b or $FC;
+        4:
+          b := b or $F8;
+        3:
+          b := b or $F0;
+        2:
+          b := b or $E0;
+        1:
+          b := b or $C0;
+      end;
+      s := AnsiChar(b) + s;
+      Result := Result + s;
+    end;
+  end;
+end;
+
+{==============================================================================}
+function UTF7toUCS2(const Value: AnsiString; Modified: Boolean): AnsiString;
+var
+  n, i: Integer;
+  c: AnsiChar;
+  s, t: AnsiString;
+  shift: AnsiChar;
+  table: String;
+begin
+  Result := '';
+  n := 1;
+  if modified then
+  begin
+    shift := '&';
+    table := TableBase64mod;
+  end
+  else
+  begin
+    shift := '+';
+    table := TableBase64;
+  end;
+  while Length(Value) >= n do
+  begin
+    c := Value[n];
+    Inc(n);
+    if c <> shift then
+      Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2, false)
+    else
+    begin
+      s := '';
+      while Length(Value) >= n do
+      begin
+        c := Value[n];
+        Inc(n);
+        if c = '-' then
+          Break;
+        if (c = '=') or (Pos(c, table) < 1) then
+        begin
+          Dec(n);
+          Break;
+        end;
+        s := s + c;
+      end;
+      if s = '' then
+        s := WriteMulti(Ord(shift), 0, 0, 0, 2, false)
+      else
+      begin
+        if modified then
+          t := DecodeBase64mod(s)
+        else
+          t := DecodeBase64(s);
+        if not odd(length(t)) then
+          s := t
+        else
+        begin //ill-formed sequence
+          t := s;
+          s := WriteMulti(Ord(shift), 0, 0, 0, 2, false);
+          for i := 1 to length(t) do
+            s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2, false);
+        end;
+      end;
+      Result := Result + s;
+    end;
+  end;
+end;
+
+{==============================================================================}
+function UCS2toUTF7(const Value: AnsiString; Modified: Boolean): AnsiString;
+var
+  s: AnsiString;
+  b1, b2, b3, b4: Byte;
+  n, m: Integer;
+  shift: AnsiChar;
+begin
+  Result := '';
+  n := 1;
+  if modified then
+    shift := '&'
+  else
+    shift := '+';
+  while Length(Value) >= n do
+  begin
+    ReadMulti(Value, n, 2, b1, b2, b3, b4, false);
+    if (b2 = 0) and (b1 < 128) then
+      if AnsiChar(b1) = shift then
+        Result := Result + shift + '-'
+      else
+        Result := Result + AnsiChar(b1)
+    else
+    begin
+      s := AnsiChar(b2) + AnsiChar(b1);
+      while Length(Value) >= n do
+      begin
+        ReadMulti(Value, n, 2, b1, b2, b3, b4, false);
+        if (b2 = 0) and (b1 < 128) then
+        begin
+          Dec(n, 2);
+          Break;
+        end;
+        s := s + AnsiChar(b2) + AnsiChar(b1);
+      end;
+      if modified then
+        s := EncodeBase64mod(s)
+      else
+        s := EncodeBase64(s);
+      m := Pos('=', s);
+      if m > 0 then
+        s := Copy(s, 1, m - 1);
+      Result := Result + shift + s + '-';
+    end;
+  end;
+end;
+
+{==============================================================================}
+function CharsetConversion(const Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar): AnsiString;
+begin
+  Result := CharsetConversionEx(Value, CharFrom, CharTo, Replace_None);
+end;
+
+{==============================================================================}
+function CharsetConversionEx(const Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar; const TransformTable: array of Word): AnsiString;
+begin
+  Result := CharsetConversionTrans(Value, CharFrom, CharTo, TransformTable, True);
+end;
+
+{==============================================================================}
+
+function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString;
+var
+  uni: Word;
+  n: Integer;
+  b1, b2, b3, b4: Byte;
+  SourceTable: array[128..255] of Word;
+  mbf: Byte;
+  lef: Boolean;
+  s: AnsiString;
+begin
+  if CharFrom = UTF_8 then
+    s := UTF8toUCS4(Value)
+  else
+    if CharFrom = UTF_7 then
+      s := UTF7toUCS2(Value, False)
+    else
+      if CharFrom = UTF_7mod then
+        s := UTF7toUCS2(Value, True)
+      else
+        s := Value;
+  GetArray(CharFrom, SourceTable);
+  mbf := 1;
+  if CharFrom in SetTwo then
+    mbf := 2;
+  if CharFrom in SetFour then
+    mbf := 4;
+  lef := CharFrom in SetLe;
+  Result := '';
+  n := 1;
+  while Length(s) >= n do
+  begin
+    ReadMulti(s, n, mbf, b1, b2, b3, b4, lef);
+    //handle BOM
+    if (b3 = 0) and (b4 = 0) then
+    begin
+      if (b1 = $FE) and (b2 = $FF) then
+      begin
+        lef := not lef;
+        continue;
+      end;
+      if (b1 = $FF) and (b2 = $FE) then
+        continue;
+    end;
+    if mbf = 1 then
+      if b1 > 127 then
+      begin
+        uni := SourceTable[b1];
+        b1 := Lo(uni);
+        b2 := Hi(uni);
+      end;
+    Result := Result + WriteMulti(b1, b2, b3, b4, 2, False);
+  end;
+end;
+
+function CharsetConversionTrans(Value: AnsiString; CharFrom: TMimeChar;
+  CharTo: TMimeChar; const TransformTable: array of Word; Translit: Boolean): AnsiString;
+var
+  uni: Word;
+  n, m: Integer;
+  b: Byte;
+  b1, b2, b3, b4: Byte;
+  TargetTable: array[128..255] of Word;
+  mbt: Byte;
+  let: Boolean;
+  ucsstring, s, t: AnsiString;
+  cd: iconv_t;
+  f: Boolean;
+  NotNeedTransform: Boolean;
+  FromID, ToID: string;
+begin
+  NotNeedTransform := (High(TransformTable) = 0);
+  if (CharFrom = CharTo) and NotNeedTransform then
+  begin
+    Result := Value;
+    Exit;
+  end;
+  FromID := GetIDFromCP(CharFrom);
+  ToID := GetIDFromCP(CharTo);
+  cd := Iconv_t(-1);
+  //do two-pass conversion. Transform to UCS-2 first.
+  if not DisableIconv then
+    cd := SynaIconvOpenIgnore('UCS-2BE', FromID);
+  try
+    if cd <> iconv_t(-1) then
+      SynaIconv(cd, Value, ucsstring)
+    else
+      ucsstring := InternalToUcs(Value, CharFrom);
+  finally
+    SynaIconvClose(cd);
+  end;
+  //here we allways have ucstring with UCS-2 encoding
+  //second pass... from UCS-2 to target encoding.
+    if not DisableIconv then
+      if translit then
+        cd := SynaIconvOpenTranslit(ToID, 'UCS-2BE')
+      else
+        cd := SynaIconvOpenIgnore(ToID, 'UCS-2BE');
+  try
+    if (cd <> iconv_t(-1)) and NotNeedTransform then
+    begin
+      if CharTo = UTF_7 then
+        ucsstring := ucsstring + #0 + '-';
+      //when transformtable is not needed and Iconv know target charset,
+      //do it fast by one call.
+      SynaIconv(cd, ucsstring, Result);
+      if CharTo = UTF_7 then
+        Delete(Result, Length(Result), 1);
+    end
+    else
+    begin
+      GetArray(CharTo, TargetTable);
+      mbt := 1;
+      if CharTo in SetTwo then
+        mbt := 2;
+      if CharTo in SetFour then
+        mbt := 4;
+      let := CharTo in SetLe;
+      b3 := 0;
+      b4 := 0;
+      Result := '';
+      for n:= 0 to (Length(ucsstring) div 2) - 1 do
+      begin
+        s := Copy(ucsstring, n * 2 + 1, 2);
+        b2 := Ord(s[1]);
+        b1 := Ord(s[2]);
+        uni := b2 * 256 + b1;
+        if not NotNeedTransform then
+        begin
+          uni := ReplaceUnicode(uni, TransformTable);
+          b1 := Lo(uni);
+          b2 := Hi(uni);
+          s[1] := AnsiChar(b2);
+          s[2] := AnsiChar(b1);
+        end;
+        if cd <> iconv_t(-1) then
+        begin
+          if CharTo = UTF_7 then
+            s := s + #0 + '-';
+          SynaIconv(cd, s, t);
+          if CharTo = UTF_7 then
+            Delete(t, Length(t), 1);
+          Result := Result + t;
+        end
+        else
+        begin
+          f := True;
+          if mbt = 1 then
+            if uni > 127 then
+            begin
+              f := False;
+              b := 0;
+              for m := 128 to 255 do
+                if TargetTable[m] = uni then
+                begin
+                  b := m;
+                  f := True;
+                  Break;
+                end;
+              b1 := b;
+              b2 := 0;
+            end
+            else
+              b1 := Lo(uni);
+          if not f then
+            if translit then
+            begin
+              b1 := Ord(NotFoundChar);
+              b2 := 0;
+              f := True;
+            end;
+          if f then
+            Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let)
+        end;
+      end;
+      if cd = iconv_t(-1) then
+      begin
+        if CharTo = UTF_7 then
+          Result := UCS2toUTF7(Result, false);
+        if CharTo = UTF_7mod then
+          Result := UCS2toUTF7(Result, true);
+        if CharTo = UTF_8 then
+          Result := UCS4toUTF8(Result);
+      end;
+    end;
+  finally
+    SynaIconvClose(cd);
+  end;
+end;
+
+{==============================================================================}
+{$IF NOT(DEFINED(MSWINDOWS)) and NOT(DEFINED(ULTIBO))}
+
+function GetCurCP: TMimeChar;
+begin
+  {$IFNDEF FPC}
+  Result := GetCPFromID(nl_langinfo(_NL_CTYPE_CODESET_NAME));
+  {$ELSE}
+  //How to get system codepage without LIBC?
+  Result := UTF_8;
+{ TODO : Waiting for FPC 2.8 solution }
+  {$ENDIF}
+end;
+
+function GetCurOEMCP: TMimeChar;
+begin
+  Result := GetCurCP;
+end;
+
+{$ELSE}
+
+function CPToMimeChar(Value: Integer): TMimeChar;
+begin
+  case Value of
+    437, 850, 20127:
+      Result := ISO_8859_1; //I know, it is not ideal!
+    737:
+      Result := CP737;
+    775:
+      Result := CP775;
+    852:
+      Result := CP852;
+    855:
+      Result := CP855;
+    857:
+      Result := CP857;
+    858:
+      Result := CP858;
+    860:
+      Result := CP860;
+    861:
+      Result := CP861;
+    862:
+      Result := CP862;
+    863:
+      Result := CP863;
+    864:
+      Result := CP864;
+    865:
+      Result := CP865;
+    866:
+      Result := CP866;
+    869:
+      Result := CP869;
+    874:
+      Result := ISO_8859_15;
+    895:
+      Result := CP895;
+    932:
+      Result := CP932;
+    936:
+      Result := CP936;
+    949:
+      Result := CP949;
+    950:
+      Result := CP950;
+    1200:
+      Result := UCS_2LE;
+    1201:
+      Result := UCS_2;
+    1250:
+      Result := CP1250;
+    1251:
+      Result := CP1251;
+    1253:
+      Result := CP1253;
+    1254:
+      Result := CP1254;
+    1255:
+      Result := CP1255;
+    1256:
+      Result := CP1256;
+    1257:
+      Result := CP1257;
+    1258:
+      Result := CP1258;
+    1361:
+      Result := CP1361;
+    10000:
+      Result := MAC;
+    10004:
+      Result := MACAR;
+    10005:
+      Result := MACHEB;
+    10006:
+      Result := MACGR;
+    10007:
+      Result := MACCYR;
+    10010:
+      Result := MACRO;
+    10017:
+      Result := MACUK;
+    10021:
+      Result := MACTH;
+    10029:
+      Result := MACCE;
+    10079:
+      Result := MACICE;
+    10081:
+      Result := MACTU;
+    10082:
+      Result := MACCRO;
+    12000:
+      Result := UCS_4LE;
+    12001:
+      Result := UCS_4;
+    20866:
+      Result := KOI8_R;
+    20932:
+      Result := JIS_X0208;
+    20936:
+      Result := GB2312;
+    21866:
+      Result := KOI8_U;
+    28591:
+      Result := ISO_8859_1;
+    28592:
+      Result := ISO_8859_2;
+    28593:
+      Result := ISO_8859_3;
+    28594:
+      Result := ISO_8859_4;
+    28595:
+      Result := ISO_8859_5;
+    28596, 708:
+      Result := ISO_8859_6;
+    28597:
+      Result := ISO_8859_7;
+    28598, 38598:
+      Result := ISO_8859_8;
+    28599:
+      Result := ISO_8859_9;
+    28605:
+      Result := ISO_8859_15;
+    50220:
+      Result := ISO_2022_JP; //? ISO 2022 Japanese with no halfwidth Katakana
+    50221:
+      Result := ISO_2022_JP1;//? Japanese with halfwidth Katakana
+    50222:
+      Result := ISO_2022_JP2;//? Japanese JIS X 0201-1989
+    50225:
+      Result := ISO_2022_KR;
+    50227:
+      Result := ISO_2022_CN;//? ISO 2022 Simplified Chinese
+    50229:
+      Result := ISO_2022_CNE;//? ISO 2022 Traditional Chinese
+    51932:
+      Result := EUC_JP;
+    51936:
+      Result := GB2312;
+    51949:
+      Result := EUC_KR;
+    52936:
+      Result := HZ;
+    54936:
+      Result := GB18030;
+    65000:
+      Result := UTF_7;
+    65001:
+      Result := UTF_8;
+    0:
+      Result := UCS_2LE;
+  else
+    Result := CP1252;
+  end;
+end;
+
+function GetCurCP: TMimeChar;
+begin
+  Result := CPToMimeChar(GetACP);
+end;
+
+function GetCurOEMCP: TMimeChar;
+begin
+  Result := CPToMimeChar(GetOEMCP);
+end;
+{$ENDIF}
+
+{==============================================================================}
+function NeedCharsetConversion(const Value: AnsiString): Boolean;
+var
+  n: Integer;
+begin
+  Result := False;
+  for n := 1 to Length(Value) do
+    if (Ord(Value[n]) > 127) or (Ord(Value[n]) = 0) then
+    begin
+      Result := True;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar;
+  CharTo: TMimeSetChar): TMimeChar;
+var
+  n: Integer;
+  max: Integer;
+  s, t, u: AnsiString;
+  CharSet: TMimeChar;
+begin
+  Result := ISO_8859_1;
+  s := Copy(Value, 1, 1024);  //max first 1KB for next procedure
+  max := 0;
+  for n := Ord(Low(TMimeChar)) to Ord(High(TMimeChar)) do
+  begin
+    CharSet := TMimeChar(n);
+    if CharSet in CharTo then
+    begin
+      t := CharsetConversionTrans(s, CharFrom, CharSet, Replace_None, False);
+      u := CharsetConversionTrans(t, CharSet, CharFrom, Replace_None, False);
+      if s = u then
+      begin
+        Result := CharSet;
+        Exit;
+      end;
+      if Length(u) > max then
+      begin
+        Result := CharSet;
+        max := Length(u);
+      end;
+    end;
+  end;
+end;
+
+{==============================================================================}
+function GetBOM(Value: TMimeChar): AnsiString;
+begin
+  Result := '';
+  case Value of
+    UCS_2:
+      Result := #$fe + #$ff;
+    UCS_4:
+      Result := #$00 + #$00 + #$fe + #$ff;
+    UCS_2LE:
+      Result := #$ff + #$fe;
+    UCS_4LE:
+      Result := #$ff + #$fe + #$00 + #$00;
+    UTF_8:
+      Result := #$ef + #$bb + #$bf;
+  end;
+end;
+
+{==============================================================================}
+function GetCPFromID(Value: AnsiString): TMimeChar;
+begin
+  Value := UpperCase(Value);
+  if (Pos('KAMENICKY', Value) > 0) or (Pos('895', Value) > 0) then
+    Result := CP895
+  else
+  if Pos('MUTF-7', Value) > 0 then
+    Result := UTF_7mod
+  else
+    Result := GetCPFromIconvID(Value);
+end;
+
+{==============================================================================}
+function GetIDFromCP(Value: TMimeChar): AnsiString;
+begin
+  case Value of
+    CP895:
+      Result := 'CP-895';
+    UTF_7mod:
+      Result := 'mUTF-7';
+  else
+    Result := GetIconvIDFromCP(Value);
+  end;
+end;
+
+{==============================================================================}
+function StringToWide(const Value: AnsiString): WideString;
+var
+  n: integer;
+  x, y: integer;
+begin
+  SetLength(Result, Length(Value) div 2);
+  for n := 1 to Length(Value) div 2 do
+  begin
+    x := Ord(Value[((n-1) * 2) + 1]);
+    y := Ord(Value[((n-1) * 2) + 2]);
+    Result[n] := WideChar(x * 256 + y);
+  end;
+end;
+
+{==============================================================================}
+function WideToString(const Value: WideString): AnsiString;
+var
+  n: integer;
+  x: integer;
+begin
+  SetLength(Result, Length(Value) * 2);
+  for n := 1 to Length(Value) do
+  begin
+    x := Ord(Value[n]);
+    Result[((n-1) * 2) + 1] := AnsiChar(x div 256);
+    Result[((n-1) * 2) + 2] := AnsiChar(x mod 256);
+  end;
+end;
+
+{==============================================================================}
+initialization
+begin
+  IconvArr[0].Charset := ISO_8859_1;
+  IconvArr[0].Charname := 'ISO-8859-1 CP819 IBM819 ISO-IR-100 ISO8859-1 ISO_8859-1 ISO_8859-1:1987 L1 LATIN1 CSISOLATIN1 ISO88591 ISOIR100';
+  IconvArr[1].Charset := UTF_8;
+  IconvArr[1].Charname := 'UTF-8 UTF8';
+  IconvArr[2].Charset := UCS_2;
+  IconvArr[2].Charname := 'ISO-10646-UCS-2 UCS-2 CSUNICODE UCS2';
+  IconvArr[3].Charset := UCS_2;
+  IconvArr[3].Charname := 'UCS-2BE UNICODE-1-1 UNICODEBIG CSUNICODE11 UNICODE11 UCS2BE UCS2-BE';
+  IconvArr[4].Charset := UCS_2LE;
+  IconvArr[4].Charname := 'UCS-2LE UNICODELITTLE UCS2LE UCS2-LE';
+  IconvArr[5].Charset := UCS_4;
+  IconvArr[5].Charname := 'ISO-10646-UCS-4 UCS-4 CSUCS4 UCS4 ISO10646UCS4';
+  IconvArr[6].Charset := UCS_4;
+  IconvArr[6].Charname := 'UCS-4BE UCS4BE UCS4-BE';
+  IconvArr[7].Charset := UCS_2LE;
+  IconvArr[7].Charname := 'UCS-4LE UCS4LE UCS4-LE';
+  IconvArr[8].Charset := UTF_16;
+  IconvArr[8].Charname := 'UTF-16 UTF16';
+  IconvArr[9].Charset := UTF_16;
+  IconvArr[9].Charname := 'UTF-16BE UTF16BE UTF16-BE';
+  IconvArr[10].Charset := UTF_16LE;
+  IconvArr[10].Charname := 'UTF-16LE UTF16LE UTF16-LE';
+  IconvArr[11].Charset := UTF_32;
+  IconvArr[11].Charname := 'UTF-32 UTF32';
+  IconvArr[12].Charset := UTF_32;
+  IconvArr[12].Charname := 'UTF-32BE UTF32BE UTF32-BE';
+  IconvArr[13].Charset := UTF_32;
+  IconvArr[13].Charname := 'UTF-32LE UTF32LE UTF32-LE';
+  IconvArr[14].Charset := UTF_7;
+  IconvArr[14].Charname := 'UNICODE-1-1-UTF-7 UTF-7 CSUNICODE11UTF7 UTF7 UNICODE11UTF7';
+  IconvArr[15].Charset := C99;
+  IconvArr[15].Charname := 'C99';
+  IconvArr[16].Charset := JAVA;
+  IconvArr[16].Charname := 'JAVA';
+  IconvArr[17].Charset := ISO_8859_1;
+  IconvArr[17].Charname := 'US-ASCII ANSI_X3.4-1968 ANSI_X3.4-1986 ASCII CP367 IBM367 ISO-IR-6 ISO646-US ISO_646.IRV:1991 US CSASCII USASCII ISOIR6';
+  IconvArr[18].Charset := ISO_8859_2;
+  IconvArr[18].Charname := 'ISO-8859-2 ISO-IR-101 ISO8859-2 ISO_8859-2 ISO_8859-2:1987 L2 LATIN2 CSISOLATIN2 ISO88592 ISOIR101';
+  IconvArr[19].Charset := ISO_8859_3;
+  IconvArr[19].Charname := 'ISO-8859-3 ISO-IR-109 ISO8859-3 ISO_8859-3 ISO_8859-3:1988 L3 LATIN3 CSISOLATIN3 ISO88593 ISOIR109';
+  IconvArr[20].Charset := ISO_8859_4;
+  IconvArr[20].Charname := 'ISO-8859-4 ISO-IR-110 ISO8859-4 ISO_8859-4 ISO_8859-4:1988 L4 LATIN4 CSISOLATIN4 ISO88594 ISOIR110';
+  IconvArr[21].Charset := ISO_8859_5;
+  IconvArr[21].Charname := 'ISO-8859-5 CYRILLIC ISO-IR-144 ISO8859-5 ISO_8859-5 ISO_8859-5:1988 CSISOLATINCYRILLIC ISOIR144';
+  IconvArr[22].Charset := ISO_8859_6;
+  IconvArr[22].Charname := 'ISO-8859-6 ARABIC ASMO-708 ECMA-114 ISO-IR-127 ISO8859-6 ISO_8859-6 ISO_8859-6:1987 CSISOLATINARABIC ISOIR127';
+  IconvArr[23].Charset := ISO_8859_7;
+  IconvArr[23].Charname := 'ISO-8859-7 ECMA-118 ELOT_928 GREEK GREEK8 ISO-IR-126 ISO8859-7 ISO_8859-7 ISO_8859-7:1987 CSISOLATINGREEK ISOIR126 ECMA118 ELOT928';
+  IconvArr[24].Charset := ISO_8859_8;
+  IconvArr[24].Charname := 'ISO-8859-8 HEBREW ISO_8859-8 ISO-IR-138 ISO8859-8 ISO_8859-8:1988 CSISOLATINHEBREW ISO-8859-8-I ISOIR138';
+  IconvArr[25].Charset := ISO_8859_9;
+  IconvArr[25].Charname := 'ISO-8859-9 ISO-IR-148 ISO8859-9 ISO_8859-9 ISO_8859-9:1989 L5 LATIN5 CSISOLATIN5 ISOIR148';
+  IconvArr[26].Charset := ISO_8859_10;
+  IconvArr[26].Charname := 'ISO-8859-10 ISO-IR-157 ISO8859-10 ISO_8859-10 ISO_8859-10:1992 L6 LATIN6 CSISOLATIN6 ISOIR157';
+  IconvArr[27].Charset := ISO_8859_13;
+  IconvArr[27].Charname := 'ISO-8859-13 ISO-IR-179 ISO8859-13 ISO_8859-13 L7 LATIN7 ISOIR179';
+  IconvArr[28].Charset := ISO_8859_14;
+  IconvArr[28].Charname := 'ISO-8859-14 ISO-CELTIC ISO-IR-199 ISO8859-14 ISO_8859-14 ISO_8859-14:1998 L8 LATIN8 ISOIR199 ISOCELTIC';
+  IconvArr[29].Charset := ISO_8859_15;
+  IconvArr[29].Charname := 'ISO-8859-15 ISO-IR-203 ISO8859-15 ISO_8859-15 ISO_8859-15:1998 ISOIR203';
+  IconvArr[30].Charset := ISO_8859_16;
+  IconvArr[30].Charname := 'ISO-8859-16 ISO-IR-226 ISO8859-16 ISO_8859-16 ISO_8859-16:2000 ISOIR226';
+  IconvArr[31].Charset := KOI8_R;
+  IconvArr[31].Charname := 'KOI8-R CSKOI8R KOI8R';
+  IconvArr[32].Charset := KOI8_U;
+  IconvArr[32].Charname := 'KOI8-U KOI8U';
+  IconvArr[33].Charset := KOI8_RU;
+  IconvArr[33].Charname := 'KOI8-RU KOI8RU';
+  IconvArr[34].Charset := CP1250;
+  IconvArr[34].Charname := 'WINDOWS-1250 CP1250 MS-EE WINDOWS1250 MSEE';
+  IconvArr[35].Charset := CP1251;
+  IconvArr[35].Charname := 'WINDOWS-1251 CP1251 MS-CYRL WINDOWS1251 MSCYRL';
+  IconvArr[36].Charset := CP1252;
+  IconvArr[36].Charname := 'WINDOWS-1252 CP1252 MS-ANSI WINDOWS1252 MSANSI';
+  IconvArr[37].Charset := CP1253;
+  IconvArr[37].Charname := 'WINDOWS-1253 CP1253 MS-GREEK WINDOWS1253 MSGREEK';
+  IconvArr[38].Charset := CP1254;
+  IconvArr[38].Charname := 'WINDOWS-1254 CP1254 MS-TURK WINDOWS1254 MSTURK';
+  IconvArr[39].Charset := CP1255;
+  IconvArr[39].Charname := 'WINDOWS-1255 CP1255 MS-HEBR WINDOWS1255 MSHEBR';
+  IconvArr[40].Charset := CP1256;
+  IconvArr[40].Charname := 'WINDOWS-1256 CP1256 MS-ARAB WINDOWS1256 MSARAB';
+  IconvArr[41].Charset := CP1257;
+  IconvArr[41].Charname := 'WINDOWS-1257 CP1257 WINBALTRIM WINDOWS1257';
+  IconvArr[42].Charset := CP1258;
+  IconvArr[42].Charname := 'WINDOWS-1258 CP1258 WINDOWS1258';
+  IconvArr[43].Charset := ISO_8859_1;
+  IconvArr[43].Charname := '850 CP850 IBM850 CSPC850MULTILINGUAL';
+  IconvArr[44].Charset := CP862;
+  IconvArr[44].Charname := '862 CP862 IBM862 CSPC862LATINHEBREW';
+  IconvArr[45].Charset := CP866;
+  IconvArr[45].Charname := '866 CP866 IBM866 CSIBM866';
+  IconvArr[46].Charset := MAC;
+  IconvArr[46].Charname := 'MAC MACINTOSH MACROMAN CSMACINTOSH';
+  IconvArr[47].Charset := MACCE;
+  IconvArr[47].Charname := 'MACCENTRALEUROPE';
+  IconvArr[48].Charset := MACICE;
+  IconvArr[48].Charname := 'MACICELAND';
+  IconvArr[49].Charset := MACCRO;
+  IconvArr[49].Charname := 'MACCROATIAN';
+  IconvArr[50].Charset := MACRO;
+  IconvArr[50].Charname := 'MACROMANIA';
+  IconvArr[51].Charset := MACCYR;
+  IconvArr[51].Charname := 'MACCYRILLIC';
+  IconvArr[52].Charset := MACUK;
+  IconvArr[52].Charname := 'MACUKRAINE';
+  IconvArr[53].Charset := MACGR;
+  IconvArr[53].Charname := 'MACGREEK';
+  IconvArr[54].Charset := MACTU;
+  IconvArr[54].Charname := 'MACTURKISH';
+  IconvArr[55].Charset := MACHEB;
+  IconvArr[55].Charname := 'MACHEBREW';
+  IconvArr[56].Charset := MACAR;
+  IconvArr[56].Charname := 'MACARABIC';
+  IconvArr[57].Charset := MACTH;
+  IconvArr[57].Charname := 'MACTHAI';
+  IconvArr[58].Charset := ROMAN8;
+  IconvArr[58].Charname := 'HP-ROMAN8 R8 ROMAN8 CSHPROMAN8 HPROMAN8 HP-ROMAN-8 HPROMAN-8';
+  IconvArr[59].Charset := NEXTSTEP;
+  IconvArr[59].Charname := 'NEXTSTEP';
+  IconvArr[60].Charset := ARMASCII;
+  IconvArr[60].Charname := 'ARMSCII-8 ARMSCII8';
+  IconvArr[61].Charset := GEORGIAN_AC;
+  IconvArr[61].Charname := 'GEORGIAN-ACADEMY GEORGIANACADEMY';
+  IconvArr[62].Charset := GEORGIAN_PS;
+  IconvArr[62].Charname := 'GEORGIAN-PS GEORGIANPS';
+  IconvArr[63].Charset := KOI8_T;
+  IconvArr[63].Charname := 'KOI8-T KOI8T';
+  IconvArr[64].Charset := MULELAO;
+  IconvArr[64].Charname := 'MULELAO-1 MULELAO1';
+  IconvArr[65].Charset := CP1133;
+  IconvArr[65].Charname := 'CP1133 IBM-CP1133 IBMCP1133';
+  IconvArr[66].Charset := TIS620;
+  IconvArr[66].Charname := 'TIS-620 ISO-IR-166 TIS620 TIS620-0 TIS620.2529-1 TIS620.2533-0 TIS620.2533-1 ISOIR166';
+  IconvArr[67].Charset := CP874;
+  IconvArr[67].Charname := 'CP874 WINDOWS-874 WINDOWS874';
+  IconvArr[68].Charset := VISCII;
+  IconvArr[68].Charname := 'VISCII VISCII1.1-1 CSVISCII';
+  IconvArr[69].Charset := TCVN;
+  IconvArr[69].Charname := 'TCVN TCVN-5712 TCVN5712-1 TCVN5712-1:1993 TCVN5712';
+  IconvArr[70].Charset := ISO_IR_14;
+  IconvArr[70].Charname := 'ISO-IR-14 ISO646-JP JIS_C6220-1969-RO JP CSISO14JISC6220RO ISOIR14';
+  IconvArr[71].Charset := JIS_X0201;
+  IconvArr[71].Charname := 'JISX0201-1976 JIS_X0201 X0201 CSHALFWIDTHKATAKANA JISX02011976 JISX0201';
+  IconvArr[72].Charset := JIS_X0208;
+  IconvArr[72].Charname := 'ISO-IR-87 JIS0208 JIS_C6226-1983 JIS_X0208 JIS_X0208-1983 JIS_X0208-1990 X0208 CSISO87JISX0208 ISOIR87 JISC6226-1983 JIS-C6226-1983 JIS_C62261983';
+  IconvArr[73].Charset := JIS_X0212;
+  IconvArr[73].Charname := 'ISO-IR-159 JIS_X0212 JIS_X0212-1990 JIS_X0212.1990-0 X0212 CSISO159JISX02121990 ISOIR159';
+  IconvArr[74].Charset := GB1988_80;
+  IconvArr[74].Charname := 'CN GB_1988-80 ISO-IR-57 ISO646-CN CSISO57GB1988 ISOIR57';
+  IconvArr[75].Charset := GB2312_80;
+  IconvArr[75].Charname := 'CHINESE GB_2312-80 ISO-IR-58 CSISO58GB231280 ISOIR58 GB231280 GB2312-80';
+  IconvArr[76].Charset := ISO_IR_165;
+  IconvArr[76].Charname := 'CN-GB-ISOIR165 ISO-IR-165 ISOIR165 CNGBIOSIR165';
+  IconvArr[77].Charset := ISO_IR_149;
+  IconvArr[77].Charname := 'ISO-IR-149 KOREAN KSC_5601 KS_C_5601-1987 KS_C_5601-1989 CSKSC56011987 ISOIR149';
+  IconvArr[78].Charset := EUC_JP;
+  IconvArr[78].Charname := 'EUC-JP EUCJP EXTENDED_UNIX_CODE_PACKED_FORMAT_FOR_JAPANESE CSEUCPKDFMTJAPANESE';
+  IconvArr[79].Charset := SHIFT_JIS;
+  IconvArr[79].Charname := 'SHIFT-JIS MS_KANJI SHIFT_JIS SJIS CSSHIFTJIS SHIFTJIS';
+  IconvArr[80].Charset := CP932;
+  IconvArr[80].Charname := 'CP932';
+  IconvArr[81].Charset := ISO_2022_JP;
+  IconvArr[81].Charname := 'ISO-2022-JP CSISO2022JP ISO2022JP';
+  IconvArr[82].Charset := ISO_2022_JP1;
+  IconvArr[82].Charname := 'ISO-2022-JP-1 ISO-2022-JP1 ISO-2022JP1 ISO2022-JP1 ISO2022JP1';
+  IconvArr[83].Charset := ISO_2022_JP2;
+  IconvArr[83].Charname := 'ISO-2022-JP-2 CSISO2022JP2 ISO-2022-JP2 ISO-2022JP2 ISO2022-JP2 ISO2022JP2';
+  IconvArr[84].Charset := GB2312;
+  IconvArr[84].Charname := 'CN-GB EUC-CN EUCCN GB2312 CSGB2312';
+  IconvArr[85].Charset := CP936;
+  IconvArr[85].Charname := 'CP936 GBK';
+  IconvArr[86].Charset := GB18030;
+  IconvArr[86].Charname := 'GB18030';
+  IconvArr[87].Charset := ISO_2022_CN;
+  IconvArr[87].Charname := 'ISO-2022-CN CSISO2022CN ISO2022CN ISO-2022CN ISO2022-CN';
+  IconvArr[88].Charset := ISO_2022_CNE;
+  IconvArr[88].Charname := 'ISO-2022-CN-EXT ISO2022CNEXT ISO-2022CNEXT ISO-2022-CNEXT ISO2022-CNEXT ISO2022-CN-EXT';
+  IconvArr[89].Charset := HZ;
+  IconvArr[89].Charname := 'HZ HZ-GB-2312 HZGB2312';
+  IconvArr[90].Charset := EUC_TW;
+  IconvArr[90].Charname := 'EUC-TW EUCTW CSEUCTW';
+  IconvArr[91].Charset := BIG5;
+  IconvArr[91].Charname := 'BIG5 BIG-5 BIG-FIVE BIGFIVE CN-BIG5 CSBIG5 CNBIG5';
+  IconvArr[92].Charset := CP950;
+  IconvArr[92].Charname := 'CP950';
+  IconvArr[93].Charset := BIG5_HKSCS;
+  IconvArr[93].Charname := 'BIG5-HKSCS BIG5HKSCS BIG5HKSCS';
+  IconvArr[94].Charset := EUC_KR;
+  IconvArr[94].Charname := 'EUC-KR EUCKR CSEUCKR EUCKR';
+  IconvArr[95].Charset := CP949;
+  IconvArr[95].Charname := 'CP949 UHC';
+  IconvArr[96].Charset := CP1361;
+  IconvArr[96].Charname := 'CP1361 JOHAB';
+  IconvArr[97].Charset := ISO_2022_KR;
+  IconvArr[97].Charname := 'ISO-2022-KR CSISO2022KR ISO2022KR';
+  IconvArr[98].Charset := ISO_8859_1;
+  IconvArr[98].Charname := '437 CP437 IBM437 CSPC8CODEPAGE437';
+  IconvArr[99].Charset := CP737;
+  IconvArr[99].Charname := 'CP737';
+  IconvArr[100].Charset := CP775;
+  IconvArr[100].Charname := 'CP775 IBM775 CSPC775BALTIC';
+  IconvArr[101].Charset := CP852;
+  IconvArr[101].Charname := '852 CP852 IBM852 CSPCP852';
+  IconvArr[102].Charset := CP853;
+  IconvArr[102].Charname := 'CP853';
+  IconvArr[103].Charset := CP855;
+  IconvArr[103].Charname := '855 CP855 IBM855 CSIBM855';
+  IconvArr[104].Charset := CP857;
+  IconvArr[104].Charname := '857 CP857 IBM857 CSIBM857';
+  IconvArr[105].Charset := CP858;
+  IconvArr[105].Charname := 'CP858';
+  IconvArr[106].Charset := CP860;
+  IconvArr[106].Charname := '860 CP860 IBM860 CSIBM860';
+  IconvArr[107].Charset := CP861;
+  IconvArr[107].Charname := '861 CP-IS CP861 IBM861 CSIBM861 CPIS';
+  IconvArr[108].Charset := CP863;
+  IconvArr[108].Charname := '863 CP863 IBM863 CSIBM863';
+  IconvArr[109].Charset := CP864;
+  IconvArr[109].Charname := 'CP864 IBM864 CSIBM864';
+  IconvArr[110].Charset := CP865;
+  IconvArr[110].Charname := '865 CP865 IBM865 CSIBM865';
+  IconvArr[111].Charset := CP869;
+  IconvArr[111].Charname := '869 CP-GR CP869 IBM869 CSIBM869 CPGR';
+  IconvArr[112].Charset := CP1125;
+  IconvArr[112].Charname := 'CP1125';
+end;
+
+end.

synacode.pas

@@ -0,0 +1,1474 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 002.002.003 |
+|==============================================================================|
+| Content: Coding and decoding support                                         |
+|==============================================================================|
+| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2000-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Various encoding and decoding support)}
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+{$TYPEDADDRESS OFF}
+
+{$IFDEF CIL}
+  {$DEFINE SYNACODE_NATIVE}
+{$ENDIF}
+{$IFDEF FPC_BIG_ENDIAN}
+  {$DEFINE SYNACODE_NATIVE}
+{$ENDIF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+  {$WARN SUSPICIOUS_TYPECAST OFF}
+{$ENDIF}
+
+unit synacode;
+
+interface
+
+uses
+  SysUtils;
+
+type
+  TSpecials = TSysCharSet;
+
+const
+  SPACE_CHAR: AnsiChar = #32;
+
+  HMAC_MD5_IPAD_CHAR: AnsiChar = #$36;
+  HMAC_MD5_OPAD_CHAR: AnsiChar = #$5C;
+
+  HMAC_SHA1_IPAD_CHAR: AnsiChar = #$36;
+  HMAC_SHA1_OPAD_CHAR: AnsiChar = #$5C;
+
+  SpecialChar: TSpecials =
+  ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\',
+    '"', '_'];
+  NonAsciiChar: TSpecials =
+  [#0..#31, #127..#255];
+  URLFullSpecialChar: TSpecials =
+  [';', '/', '?', ':', '@', '=', '&', '#', '+'];
+  URLSpecialChar: TSpecials =
+  [#$00..#$20, '<', '>', '"', '%', '{', '}', '|', '\', '^', '[', ']', '`', #$7F..#$FF];
+  TableBase64 =
+    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
+  TableBase64mod =
+    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,=';
+  TableUU =
+    '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';
+  TableXX =
+    '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
+  ReTablebase64 =
+    #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40
+    +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C
+    +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03
+    +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F
+    +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40
+    +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21
+    +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D
+    +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40;
+  ReTableUU =
+    #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C
+    +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18
+    +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24
+    +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30
+    +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C
+    +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40
+    +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40
+    +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40;
+  ReTableXX =
+    #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40
+    +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A
+    +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F
+    +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B
+    +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40
+    +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D
+    +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39
+    +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40;
+
+{:Decodes triplet encoding with a given character delimiter. It is used for
+ decoding quoted-printable or URL encoding.}
+function DecodeTriplet(const Value: String; Delimiter: Char): String;
+
+{:Decodes a string from quoted printable form. (also decodes triplet sequences
+ like '=7F')}
+function DecodeQuotedPrintable(const Value: String): String;
+
+{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')}
+function DecodeURL(const Value: String): String;
+
+{:Performs triplet encoding with a given character delimiter. Used for encoding
+ quoted-printable or URL encoding.}
+function EncodeTriplet(const Value: String; Delimiter: Char;
+  Specials: TSpecials): String;
+
+{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar)
+ are encoded.}
+function EncodeQuotedPrintable(const Value: String): String;
+
+{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and
+ @link(SpecialChar) are encoded.}
+function EncodeSafeQuotedPrintable(const Value: String): String;
+
+{:Encodes a string to URL format. Used for encoding data from a form field in
+ HTTP, etc. (Encodes all critical characters including characters used as URL
+ delimiters ('/',':', etc.)}
+function EncodeURLElement(const Value: String): String;
+
+{:Encodes a string to URL format. Used to encode critical characters in all
+ URLs.}
+function EncodeURL(const Value: String): String;
+
+{:Decode 4to3 encoding with given table. If some element is not found in table,
+ first item from table is used. This is good for buggy coded items by Microsoft
+ Outlook. This software sometimes using wrong table for UUcode, where is used
+ ' ' instead '`'.}
+function Decode4to3(const Value, Table: String): String;
+
+{:Decode 4to3 encoding with given REVERSE table. Using this function with
+reverse table is much faster then @link(Decode4to3). This function is used
+internally for Base64, UU or XX decoding.}
+function Decode4to3Ex(const Value, Table: String): String;
+
+{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.}
+function Encode3to4(const Value, Table: String): String;
+
+{:Decode string from base64 format.}
+function DecodeBase64(const Value: String): String;
+
+{:Encodes a string to base64 format.}
+function EncodeBase64(const Value: String): String;
+
+{:Decode string from modified base64 format. (used in IMAP, for example.)}
+function DecodeBase64mod(const Value: String): String;
+
+{:Encodes a string to  modified base64 format. (used in IMAP, for example.)}
+function EncodeBase64mod(const Value: String): String;
+
+{:Decodes a string from UUcode format.}
+function DecodeUU(const Value: String): String;
+
+{:encode UUcode. it encode only datas, you must also add header and footer for
+ proper encode.}
+function EncodeUU(const Value: String): String;
+
+{:Decodes a string from XXcode format.}
+function DecodeXX(const Value: String): String;
+
+{:decode line with Yenc code. This code is sometimes used in newsgroups.}
+function DecodeYEnc(const Value: String): String;
+
+{:Returns a new CRC32 value after adding a new byte of data.}
+function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
+
+{:return CRC32 from a value string.}
+function Crc32(const Value: String): Integer;
+
+{:Returns a new CRC16 value after adding a new byte of data.}
+function UpdateCrc16(Value: Byte; Crc16: Word): Word;
+
+{:return CRC16 from a value string.}
+function Crc16(const Value: String): Word;
+
+{:Returns a binary string with a RSA-MD5 hashing of "Value" string.}
+function MD5(const Value: String): String;
+
+{:Returns a binary string with HMAC-MD5 hash.}
+function HMAC_MD5(const Text: String; Key: String): String;
+
+{:Returns a binary string with a RSA-MD5 hashing of string what is constructed
+ by repeating "value" until length is "Len".}
+function MD5LongHash(const Value: String; Len: integer): String;
+
+{:Returns a binary string with a SHA-1 hashing of "Value" string.}
+function SHA1(const Value: String): String;
+
+{:Returns a binary string with HMAC-SHA1 hash.}
+function HMAC_SHA1(const Text: String; Key: String): String;
+
+{:Returns a binary string with a SHA-1 hashing of string what is constructed
+ by repeating "value" until length is "Len".}
+function SHA1LongHash(const Value: String; Len: integer): String;
+
+{:Returns a binary string with a RSA-MD4 hashing of "Value" string.}
+function MD4(const Value: String): String;
+
+implementation
+
+const
+
+  Crc32Tab: array[0..255] of Integer = (
+    Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA),
+    Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3),
+    Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988),
+    Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91),
+    Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE),
+    Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7),
+    Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC),
+    Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5),
+    Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172),
+    Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B),
+    Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940),
+    Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59),
+    Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116),
+    Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F),
+    Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924),
+    Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D),
+    Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A),
+    Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433),
+    Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818),
+    Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01),
+    Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E),
+    Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457),
+    Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C),
+    Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65),
+    Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2),
+    Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB),
+    Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0),
+    Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9),
+    Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086),
+    Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F),
+    Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4),
+    Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD),
+    Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A),
+    Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683),
+    Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8),
+    Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1),
+    Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE),
+    Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7),
+    Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC),
+    Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5),
+    Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252),
+    Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B),
+    Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60),
+    Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79),
+    Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236),
+    Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F),
+    Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04),
+    Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D),
+    Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A),
+    Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713),
+    Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38),
+    Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21),
+    Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E),
+    Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777),
+    Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C),
+    Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45),
+    Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2),
+    Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB),
+    Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0),
+    Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9),
+    Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6),
+    Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF),
+    Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94),
+    Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D)
+    );
+
+  Crc16Tab: array[0..255] of Word = (
+    $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF,
+    $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7,
+    $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E,
+    $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876,
+    $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD,
+    $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5,
+    $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C,
+    $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974,
+    $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB,
+    $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3,
+    $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A,
+    $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72,
+    $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9,
+    $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1,
+    $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738,
+    $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70,
+    $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7,
+    $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF,
+    $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036,
+    $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E,
+    $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5,
+    $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD,
+    $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134,
+    $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C,
+    $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3,
+    $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB,
+    $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232,
+    $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A,
+    $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1,
+    $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9,
+    $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330,
+    $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78
+    );
+
+procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer);
+{$IFDEF SYNACODE_NATIVE}
+var
+  n: integer;
+{$ENDIF}
+begin
+  if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then
+    Exit;
+  {$IFDEF SYNACODE_NATIVE}
+  for n := 0 to ((high(ArByte) + 1) div 4) - 1 do
+    ArLong[n] := ArByte[n * 4 + 0]
+      + (ArByte[n * 4 + 1] shl 8)
+      + (ArByte[n * 4 + 2] shl 16)
+      + (ArByte[n * 4 + 3] shl 24);
+  {$ELSE}
+  Move(ArByte[0], ArLong[0], High(ArByte) + 1);
+  {$ENDIF}
+end;
+
+procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte);
+{$IFDEF SYNACODE_NATIVE}
+var
+  n: integer;
+{$ENDIF}
+begin
+  if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then
+    Exit;
+  {$IFDEF SYNACODE_NATIVE}
+  for n := 0 to high(ArLong) do
+  begin
+    ArByte[n * 4 + 0] := ArLong[n] and $000000FF;
+    ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF;
+    ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF;
+    ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF;
+  end;
+  {$ELSE}
+  Move(ArLong[0], ArByte[0], High(ArByte) + 1);
+  {$ENDIF}
+end;
+
+type
+  TMDCtx = record
+    State: array[0..3] of Integer;
+    Count: array[0..1] of Integer;
+    BufAnsiChar: array[0..63] of Byte;
+    BufLong: array[0..15] of Integer;
+  end;
+  TSHA1Ctx= record
+    Hi, Lo: integer;
+    Buffer: array[0..63] of byte;
+    Index: integer;
+    Hash: array[0..4] of Integer;
+    HashByte: array[0..19] of byte;
+  end;
+
+  TMDTransform = procedure(var Buf: array of Integer; const Data: array of Integer);
+
+{==============================================================================}
+
+function DecodeTriplet(const Value: String; Delimiter: Char): String;
+var
+  x, l, lv: Integer;
+  c: Char;
+  b: Byte;
+  bad: Boolean;
+begin
+  lv := Length(Value);
+  SetLength(Result, lv);
+  x := 1;
+  l := 1;
+  while x <= lv do
+  begin
+    c := Value[x];
+    Inc(x);
+    if c <> Delimiter then
+    begin
+      Result[l] := c;
+      Inc(l);
+    end
+    else
+      if x < lv then
+      begin
+        Case Value[x] Of
+          #13:
+            if (Value[x + 1] = #10) then
+              Inc(x, 2)
+            else
+              Inc(x);
+          #10:
+            if (Value[x + 1] = #13) then
+              Inc(x, 2)
+            else
+              Inc(x);
+        else
+          begin
+            bad := False;
+            Case Value[x] Of
+              '0'..'9': b := (Byte(Value[x]) - 48) Shl 4;
+              'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4;
+            else
+              begin
+                b := 0;
+                bad := True;
+              end;
+            end;
+            Case Value[x + 1] Of
+              '0'..'9': b := b Or (Byte(Value[x + 1]) - 48);
+              'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9);
+            else
+              bad := True;
+            end;
+            if bad then
+            begin
+              Result[l] := c;
+              Inc(l);
+            end
+            else
+            begin
+              Inc(x, 2);
+              Result[l] := Char(b);
+              Inc(l);
+            end;
+          end;
+        end;
+      end
+      else
+        break;
+  end;
+  Dec(l);
+  SetLength(Result, l);
+end;
+
+{==============================================================================}
+
+function DecodeQuotedPrintable(const Value: String): String;
+begin
+  Result := DecodeTriplet(Value, '=');
+end;
+
+{==============================================================================}
+
+function DecodeURL(const Value: String): String;
+begin
+  Result := DecodeTriplet(Value, '%');
+end;
+
+{==============================================================================}
+
+function EncodeTriplet(const Value: String; Delimiter: Char;
+  Specials: TSpecials): String;
+var
+  n, l: Integer;
+  s: String;
+  c: Char;
+begin
+  SetLength(Result, Length(Value) * 3);
+  l := 1;
+  for n := 1 to Length(Value) do
+  begin
+    c := Value[n];
+    if CharInSet(c, Specials) then
+    begin
+      Result[l] := Delimiter;
+      Inc(l);
+      s := IntToHex(Ord(c), 2);
+      Result[l] := s[1];
+      Inc(l);
+      Result[l] := s[2];
+      Inc(l);
+    end
+    else
+    begin
+      Result[l] := c;
+      Inc(l);
+    end;
+  end;
+  Dec(l);
+  SetLength(Result, l);
+end;
+
+{==============================================================================}
+
+function EncodeQuotedPrintable(const Value: String): String;
+begin
+  Result := EncodeTriplet(Value, '=',  ['='] + NonAsciiChar);
+end;
+
+{==============================================================================}
+
+function EncodeSafeQuotedPrintable(const Value: String): String;
+begin
+  Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar);
+end;
+
+{==============================================================================}
+
+function EncodeURLElement(const Value: String): String;
+begin
+  Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar);
+end;
+
+{==============================================================================}
+
+function EncodeURL(const Value: String): String;
+begin
+  Result := EncodeTriplet(Value, '%', URLSpecialChar);
+end;
+
+{==============================================================================}
+
+function Decode4to3(const Value, Table: String): String;
+var
+  x, y, n, l: Integer;
+  d: array[0..3] of Byte;
+begin
+  SetLength(Result, Length(Value));
+  x := 1;
+  l := 1;
+  while x <= Length(Value) do
+  begin
+    for n := 0 to 3 do
+    begin
+      if x > Length(Value) then
+        d[n] := 64
+      else
+      begin
+        y := Pos(Value[x], Table);
+        if y < 1 then
+          y := 1;
+        d[n] := y - 1;
+      end;
+      Inc(x);
+    end;
+    Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
+    Inc(l);
+    if d[2] <> 64 then
+    begin
+      Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
+      Inc(l);
+      if d[3] <> 64 then
+      begin
+        Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F));
+        Inc(l);
+      end;
+    end;
+  end;
+  Dec(l);
+  SetLength(Result, l);
+end;
+
+{==============================================================================}
+function Decode4to3Ex(const Value, Table: String): String;
+var
+  x, y, lv: Integer;
+  d: integer;
+  dl: integer;
+  c: byte;
+  p: integer;
+begin
+  lv := Length(Value);
+  SetLength(Result, lv);
+  x := 1;
+  dl := 4;
+  d := 0;
+  p := 1;
+  while x <= lv do
+  begin
+    y := Ord(Value[x]);
+    if y in [33..127] then
+      c := Ord(Table[y - 32])
+    else
+      c := 64;
+    Inc(x);
+    if c > 63 then
+      continue;
+    d := (d shl 6) or c;
+    dec(dl);
+    if dl <> 0 then
+      continue;
+    Result[p] := Char((d shr 16) and $ff);
+    inc(p);
+    Result[p] := Char((d shr 8) and $ff);
+    inc(p);
+    Result[p] := Char(d and $ff);
+    inc(p);
+    d := 0;
+    dl := 4;
+  end;
+  case dl of
+    1:
+      begin
+        d := d shr 2;
+        Result[p] := Char((d shr 8) and $ff);
+        inc(p);
+        Result[p] := Char(d and $ff);
+        inc(p);
+      end;
+    2:
+      begin
+        d := d shr 4;
+        Result[p] := Char(d and $ff);
+        inc(p);
+      end;
+  end;
+  SetLength(Result, p - 1);
+end;
+
+{==============================================================================}
+
+function Encode3to4(const Value, Table: String): String;
+var
+  c: Byte;
+  n, l: Integer;
+  Count: Integer;
+  DOut: array[0..3] of Byte;
+begin
+  setlength(Result, ((Length(Value) + 2) div 3) * 4);
+  l := 1;
+  Count := 1;
+  while Count <= Length(Value) do
+  begin
+    c := Ord(Value[Count]);
+    Inc(Count);
+    DOut[0] := (c and $FC) shr 2;
+    DOut[1] := (c and $03) shl 4;
+    if Count <= Length(Value) then
+    begin
+      c := Ord(Value[Count]);
+      Inc(Count);
+      DOut[1] := DOut[1] + (c and $F0) shr 4;
+      DOut[2] := (c and $0F) shl 2;
+      if Count <= Length(Value) then
+      begin
+        c := Ord(Value[Count]);
+        Inc(Count);
+        DOut[2] := DOut[2] + (c and $C0) shr 6;
+        DOut[3] := (c and $3F);
+      end
+      else
+      begin
+        DOut[3] := $40;
+      end;
+    end
+    else
+    begin
+      DOut[2] := $40;
+      DOut[3] := $40;
+    end;
+    for n := 0 to 3 do
+    begin
+      if (DOut[n] + 1) <= Length(Table) then
+      begin
+        Result[l] := Table[DOut[n] + 1];
+        Inc(l);
+      end;
+    end;
+  end;
+  SetLength(Result, l - 1);
+end;
+
+{==============================================================================}
+
+function DecodeBase64(const Value: String): String;
+begin
+  Result := Decode4to3Ex(Value, ReTableBase64);
+end;
+
+{==============================================================================}
+
+function EncodeBase64(const Value: String): String;
+begin
+  Result := Encode3to4(Value, TableBase64);
+end;
+
+{==============================================================================}
+
+function DecodeBase64mod(const Value: String): String;
+begin
+  Result := Decode4to3(Value, TableBase64mod);
+end;
+
+{==============================================================================}
+
+function EncodeBase64mod(const Value: String): String;
+begin
+  Result := Encode3to4(Value, TableBase64mod);
+end;
+
+{==============================================================================}
+
+function DecodeUU(const Value: String): String;
+var
+  s: String;
+  uut: String;
+  x: Integer;
+begin
+  Result := '';
+  uut := TableUU;
+  s := trim(UpperCase(Value));
+  if s = '' then Exit;
+  if Pos('BEGIN', s) = 1 then
+    Exit;
+  if Pos('END', s) = 1 then
+    Exit;
+  if Pos('TABLE', s) = 1 then
+    Exit; //ignore Table yet (set custom UUT)
+  //begin decoding
+  x := Pos(Value[1], uut) - 1;
+  case (x mod 3) of
+    0: x :=(x div 3)* 4;
+    1: x :=((x div 3) * 4) + 2;
+    2: x :=((x  div 3) * 4) + 3;
+  end;
+  //x - lenght UU line
+  s := Copy(Value, 2, x);
+  if s = '' then
+    Exit;
+  s := s + StringOfChar(SPACE_CHAR, x - length(s));
+  Result := Decode4to3(s, uut);
+end;
+
+{==============================================================================}
+
+function EncodeUU(const Value: String): String;
+begin
+  Result := '';
+  if Length(Value) < Length(TableUU) then
+    Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU);
+end;
+
+{==============================================================================}
+
+function DecodeXX(const Value: String): String;
+var
+  s: String;
+  x: Integer;
+begin
+  Result := '';
+  s := trim(UpperCase(Value));
+  if s = '' then
+    Exit;
+  if Pos('BEGIN', s) = 1 then
+    Exit;
+  if Pos('END', s) = 1 then
+    Exit;
+  //begin decoding
+  x := Pos(Value[1], TableXX) - 1;
+  case (x mod 3) of
+    0: x :=(x div 3)* 4;
+    1: x :=((x div 3) * 4) + 2;
+    2: x :=((x  div 3) * 4) + 3;
+  end;
+  //x - lenght XX line
+  s := Copy(Value, 2, x);
+  if s = '' then
+    Exit;
+  s := s + StringOfChar(SPACE_CHAR, x - length(s));
+  Result := Decode4to3(s, TableXX);
+end;
+
+{==============================================================================}
+
+function DecodeYEnc(const Value: String): String;
+var
+  C : Byte;
+  i: integer;
+begin
+  Result := '';
+  i := 1;
+  while i <= Length(Value) do
+  begin
+    c := Ord(Value[i]);
+    Inc(i);
+    if c = Ord('=') then
+    begin
+      c := Ord(Value[i]);
+      Inc(i);
+      Dec(c, 64);
+    end;
+    Dec(C, 42);
+    Result := Result + Char(C);
+  end;
+end;
+
+{==============================================================================}
+
+function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
+begin
+  Result := (Crc32 shr 8)
+    xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))];
+end;
+
+{==============================================================================}
+
+function Crc32(const Value: String): Integer;
+var
+  n: Integer;
+begin
+  Result := Integer($FFFFFFFF);
+  for n := 1 to Length(Value) do
+    Result := UpdateCrc32(Ord(Value[n]), Result);
+  Result := not Result;
+end;
+
+{==============================================================================}
+
+function UpdateCrc16(Value: Byte; Crc16: Word): Word;
+begin
+  Result := ((Crc16 shr 8) and $00FF) xor
+    crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)];
+end;
+
+{==============================================================================}
+
+function Crc16(const Value: String): Word;
+var
+  n: Integer;
+begin
+  Result := $FFFF;
+  for n := 1 to Length(Value) do
+    Result := UpdateCrc16(Ord(Value[n]), Result);
+end;
+
+{==============================================================================}
+
+procedure MDInit(var MDContext: TMDCtx);
+var
+  n: integer;
+begin
+  MDContext.Count[0] := 0;
+  MDContext.Count[1] := 0;
+  for n := 0 to high(MDContext.BufAnsiChar) do
+    MDContext.BufAnsiChar[n] := 0;
+  for n := 0 to high(MDContext.BufLong) do
+    MDContext.BufLong[n] := 0;
+  MDContext.State[0] := Integer($67452301);
+  MDContext.State[1] := Integer($EFCDAB89);
+  MDContext.State[2] := Integer($98BADCFE);
+  MDContext.State[3] := Integer($10325476);
+end;
+
+procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
+var
+  A, B, C, D: LongInt;
+
+  procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
+  begin
+    Inc(W, (Z xor (X and (Y xor Z))) + Data);
+    W := (W shl S) or (W shr (32 - S));
+    Inc(W, X);
+  end;
+
+  procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
+  begin
+    Inc(W, (Y xor (Z and (X xor Y))) + Data);
+    W := (W shl S) or (W shr (32 - S));
+    Inc(W, X);
+  end;
+
+  procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
+  begin
+    Inc(W, (X xor Y xor Z) + Data);
+    W := (W shl S) or (W shr (32 - S));
+    Inc(W, X);
+  end;
+
+  procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
+  begin
+    Inc(W, (Y xor (X or not Z)) + Data);
+    W := (W shl S) or (W shr (32 - S));
+    Inc(W, X);
+  end;
+begin
+  A := Buf[0];
+  B := Buf[1];
+  C := Buf[2];
+  D := Buf[3];
+
+  Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7);
+  Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12);
+  Round1(C, D, A, B, Data[2] + Longint($242070DB), 17);
+  Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22);
+  Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7);
+  Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12);
+  Round1(C, D, A, B, Data[6] + Longint($A8304613), 17);
+  Round1(B, C, D, A, Data[7] + Longint($FD469501), 22);
+  Round1(A, B, C, D, Data[8] + Longint($698098D8), 7);
+  Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12);
+  Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17);
+  Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22);
+  Round1(A, B, C, D, Data[12] + Longint($6B901122), 7);
+  Round1(D, A, B, C, Data[13] + Longint($FD987193), 12);
+  Round1(C, D, A, B, Data[14] + Longint($A679438E), 17);
+  Round1(B, C, D, A, Data[15] + Longint($49B40821), 22);
+
+  Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5);
+  Round2(D, A, B, C, Data[6] + Longint($C040B340), 9);
+  Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14);
+  Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20);
+  Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5);
+  Round2(D, A, B, C, Data[10] + Longint($02441453), 9);
+  Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14);
+  Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20);
+  Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5);
+  Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9);
+  Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14);
+  Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20);
+  Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5);
+  Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9);
+  Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14);
+  Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20);
+
+  Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4);
+  Round3(D, A, B, C, Data[8] + Longint($8771F681), 11);
+  Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16);
+  Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23);
+  Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4);
+  Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11);
+  Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16);
+  Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23);
+  Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4);
+  Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11);
+  Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16);
+  Round3(B, C, D, A, Data[6] + Longint($04881D05), 23);
+  Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4);
+  Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11);
+  Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16);
+  Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23);
+
+  Round4(A, B, C, D, Data[0] + Longint($F4292244), 6);
+  Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10);
+  Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15);
+  Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21);
+  Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6);
+  Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10);
+  Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15);
+  Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21);
+  Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6);
+  Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10);
+  Round4(C, D, A, B, Data[6] + Longint($A3014314), 15);
+  Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21);
+  Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6);
+  Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10);
+  Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15);
+  Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21);
+
+  Inc(Buf[0], A);
+  Inc(Buf[1], B);
+  Inc(Buf[2], C);
+  Inc(Buf[3], D);
+end;
+
+//fixed by James McAdams
+procedure MDUpdate(var MDContext: TMDCtx; const Data: String; transform: TMDTransform);
+var
+  Index, partLen, InputLen, I: integer;
+{$IFDEF SYNACODE_NATIVE}
+  n: integer;
+{$ENDIF}
+begin
+  InputLen := Length(Data);
+  with MDContext do
+  begin
+    Index := (Count[0] shr 3) and $3F;
+    Inc(Count[0], InputLen shl 3);
+    if Count[0] < (InputLen shl 3) then
+      Inc(Count[1]);
+    Inc(Count[1], InputLen shr 29);
+    partLen := 64 - Index;
+    if InputLen >= partLen then
+    begin
+      ArrLongToByte(BufLong, BufAnsiChar);
+      {$IFDEF SYNACODE_NATIVE}
+      for n := 1 to partLen do
+        BufAnsiChar[index - 1 + n] := Ord(Data[n]);
+      {$ELSE}
+      Move(Data[1], BufAnsiChar[Index], partLen);
+      {$ENDIF}
+      ArrByteToLong(BufAnsiChar, BufLong);
+      Transform(State, Buflong);
+      I := partLen;
+  		while I + 63 < InputLen do
+      begin
+        ArrLongToByte(BufLong, BufAnsiChar);
+        {$IFDEF SYNACODE_NATIVE}
+        for n := 1 to 64 do
+          BufAnsiChar[n - 1] := Ord(Data[i + n]);
+        {$ELSE}
+        Move(Data[I+1], BufAnsiChar, 64);
+        {$ENDIF}
+        ArrByteToLong(BufAnsiChar, BufLong);
+        Transform(State, Buflong);
+	  	  inc(I, 64);
+		  end;
+      Index := 0;
+    end
+    else
+      I := 0;
+    ArrLongToByte(BufLong, BufAnsiChar);
+    {$IFDEF SYNACODE_NATIVE}
+    for n := 1 to InputLen-I do
+      BufAnsiChar[Index + n - 1] := Ord(Data[i + n]);
+    {$ELSE}
+    Move(Data[I+1], BufAnsiChar[Index], InputLen-I);
+    {$ENDIF}
+    ArrByteToLong(BufAnsiChar, BufLong);
+  end
+end;
+
+function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): String;
+var
+  Cnt: Word;
+  P: Byte;
+  digest: array[0..15] of Byte;
+  i: Integer;
+  n: integer;
+begin
+  for I := 0 to 15 do
+    Digest[I] := I + 1;
+  with MDContext do
+  begin
+    Cnt := (Count[0] shr 3) and $3F;
+    P := Cnt;
+    BufAnsiChar[P] := $80;
+    Inc(P);
+    Cnt := 64 - 1 - Cnt;
+    if Cnt < 8 then
+    begin
+      for n := 0 to cnt - 1 do
+        BufAnsiChar[P + n] := 0;
+      ArrByteToLong(BufAnsiChar, BufLong);
+//      FillChar(BufAnsiChar[P], Cnt, #0);
+      Transform(State, BufLong);
+      ArrLongToByte(BufLong, BufAnsiChar);
+      for n := 0 to 55 do
+        BufAnsiChar[n] := 0;
+      ArrByteToLong(BufAnsiChar, BufLong);
+//      FillChar(BufAnsiChar, 56, #0);
+    end
+    else
+    begin
+      for n := 0 to Cnt - 8 - 1 do
+        BufAnsiChar[p + n] := 0;
+      ArrByteToLong(BufAnsiChar, BufLong);
+//      FillChar(BufAnsiChar[P], Cnt - 8, #0);
+    end;
+    BufLong[14] := Count[0];
+    BufLong[15] := Count[1];
+    Transform(State, BufLong);
+    ArrLongToByte(State, Digest);
+//    Move(State, Digest, 16);
+    Result := '';
+    for i := 0 to 15 do
+      Result := Result + Char(digest[i]);
+  end;
+//  FillChar(MD5Context, SizeOf(TMD5Ctx), #0)
+end;
+
+{==============================================================================}
+
+function MD5(const Value: String): String;
+var
+  MDContext: TMDCtx;
+begin
+  MDInit(MDContext);
+  MDUpdate(MDContext, Value, @MD5Transform);
+  Result := MDFinal(MDContext, @MD5Transform);
+end;
+
+{==============================================================================}
+
+function HMAC_MD5(const Text: String; Key: String): String;
+var
+  ipad, opad, s: String;
+  n: Integer;
+  MDContext: TMDCtx;
+begin
+  if Length(Key) > 64 then
+    Key := md5(Key);
+  ipad := StringOfChar(HMAC_MD5_IPAD_CHAR, 64);
+  opad := StringOfChar(HMAC_MD5_OPAD_CHAR, 64);
+  for n := 1 to Length(Key) do
+  begin
+    ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n]));
+    opad[n] := Char(Byte(opad[n]) xor Byte(Key[n]));
+  end;
+  MDInit(MDContext);
+  MDUpdate(MDContext, ipad, @MD5Transform);
+  MDUpdate(MDContext, Text, @MD5Transform);
+  s := MDFinal(MDContext, @MD5Transform);
+  MDInit(MDContext);
+  MDUpdate(MDContext, opad, @MD5Transform);
+  MDUpdate(MDContext, s, @MD5Transform);
+  Result := MDFinal(MDContext, @MD5Transform);
+end;
+
+{==============================================================================}
+
+function MD5LongHash(const Value: String; Len: integer): String;
+var
+  cnt, rest: integer;
+  l: integer;
+  n: integer;
+  MDContext: TMDCtx;
+begin
+  l := length(Value);
+  cnt := Len div l;
+  rest := Len mod l;
+  MDInit(MDContext);
+  for n := 1 to cnt do
+    MDUpdate(MDContext, Value, @MD5Transform);
+  if rest > 0 then
+    MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform);
+  Result := MDFinal(MDContext, @MD5Transform);
+end;
+
+{==============================================================================}
+// SHA1 is based on sources by Dave Barton ([email protected])
+
+procedure SHA1init( var SHA1Context: TSHA1Ctx );
+var
+  n: integer;
+begin
+  SHA1Context.Hi := 0;
+  SHA1Context.Lo := 0;
+  SHA1Context.Index := 0;
+  for n := 0 to High(SHA1Context.Buffer) do
+    SHA1Context.Buffer[n] := 0;
+  for n := 0 to High(SHA1Context.HashByte) do
+    SHA1Context.HashByte[n] := 0;
+//  FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0);
+  SHA1Context.Hash[0] := integer($67452301);
+  SHA1Context.Hash[1] := integer($EFCDAB89);
+  SHA1Context.Hash[2] := integer($98BADCFE);
+  SHA1Context.Hash[3] := integer($10325476);
+  SHA1Context.Hash[4] := integer($C3D2E1F0);
+end;
+
+//******************************************************************************
+function RB(A: integer): integer;
+begin
+  Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24);
+end;
+
+procedure SHA1Compress(var Data: TSHA1Ctx);
+var
+  A, B, C, D, E, T: integer;
+  W: array[0..79] of integer;
+  i: integer;
+  n: integer;
+
+  function F1(x, y, z: integer): integer;
+  begin
+    Result := z xor (x and (y xor z));
+  end;
+  function F2(x, y, z: integer): integer;
+  begin
+    Result := x xor y xor z;
+  end;
+  function F3(x, y, z: integer): integer;
+  begin
+    Result := (x and y) or (z and (x or y));
+  end;
+  function LRot32(X: integer; c: integer): integer;
+  begin
+    result := (x shl c) or (x shr (32 - c));
+  end;
+begin
+  ArrByteToLong(Data.Buffer, W);
+//  Move(Data.Buffer, W, Sizeof(Data.Buffer));
+  for i := 0 to 15 do
+    W[i] := RB(W[i]);
+  for i := 16 to 79 do
+    W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1);
+  A := Data.Hash[0];
+  B := Data.Hash[1];
+  C := Data.Hash[2];
+  D := Data.Hash[3];
+  E := Data.Hash[4];
+  for i := 0 to 19 do
+  begin
+    T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999);
+    E := D;
+    D := C;
+    C := LRot32(B, 30);
+    B := A;
+    A := T;
+  end;
+  for i := 20 to 39 do
+  begin
+    T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1);
+    E := D;
+    D := C;
+    C := LRot32(B, 30);
+    B := A;
+    A := T;
+  end;
+  for i := 40 to 59 do
+  begin
+    T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC);
+    E := D;
+    D := C;
+    C := LRot32(B, 30);
+    B := A;
+    A := T;
+  end;
+  for i := 60 to 79 do
+  begin
+    T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6);
+    E := D;
+    D := C;
+    C := LRot32(B, 30);
+    B := A;
+    A := T;
+  end;
+  Data.Hash[0] := Data.Hash[0] + A;
+  Data.Hash[1] := Data.Hash[1] + B;
+  Data.Hash[2] := Data.Hash[2] + C;
+  Data.Hash[3] := Data.Hash[3] + D;
+  Data.Hash[4] := Data.Hash[4] + E;
+  for n := 0 to high(w) do
+    w[n] := 0;
+//  FillChar(W, Sizeof(W), 0);
+  for n := 0 to high(Data.Buffer) do
+    Data.Buffer[n] := 0;
+//  FillChar(Data.Buffer, Sizeof(Data.Buffer), 0);
+end;
+
+//******************************************************************************
+procedure SHA1Update(var Context: TSHA1Ctx; const Data: String);
+var
+  Len: integer;
+  n: integer;
+  i, k: integer;
+begin
+  Len := Length(data);
+  for k := 0 to 7 do
+  begin
+    i := Context.Lo;
+    Inc(Context.Lo, Len);
+    if Context.Lo < i then
+      Inc(Context.Hi);
+  end;
+  for n := 1 to len do
+  begin
+    Context.Buffer[Context.Index] := byte(Data[n]);
+    Inc(Context.Index);
+    if Context.Index = 64 then
+    begin
+      Context.Index := 0;
+      SHA1Compress(Context);
+    end;
+  end;
+end;
+
+//******************************************************************************
+function SHA1Final(var Context: TSHA1Ctx): String;
+type
+  Pinteger = ^integer;
+var
+  i: integer;
+  procedure ItoArr(var Ar: Array of byte; I, value: Integer);
+  begin
+    Ar[i + 0] := Value and $000000FF;
+    Ar[i + 1] := (Value shr 8) and $000000FF;
+    Ar[i + 2] := (Value shr 16) and $000000FF;
+    Ar[i + 3] := (Value shr 24) and $000000FF;
+  end;
+begin
+  Context.Buffer[Context.Index] := $80;
+  if Context.Index >= 56 then
+    SHA1Compress(Context);
+  ItoArr(Context.Buffer, 56, RB(Context.Hi));
+  ItoArr(Context.Buffer, 60, RB(Context.Lo));
+//  Pinteger(@Context.Buffer[56])^ := RB(Context.Hi);
+//  Pinteger(@Context.Buffer[60])^ := RB(Context.Lo);
+  SHA1Compress(Context);
+  Context.Hash[0] := RB(Context.Hash[0]);
+  Context.Hash[1] := RB(Context.Hash[1]);
+  Context.Hash[2] := RB(Context.Hash[2]);
+  Context.Hash[3] := RB(Context.Hash[3]);
+  Context.Hash[4] := RB(Context.Hash[4]);
+  ArrLongToByte(Context.Hash, Context.HashByte);
+  Result := '';
+  for i := 0 to 19 do
+    Result := Result + Char(Context.HashByte[i]);
+end;
+
+function SHA1(const Value: String): String;
+var
+  SHA1Context: TSHA1Ctx;
+begin
+  SHA1Init(SHA1Context);
+  SHA1Update(SHA1Context, Value);
+  Result := SHA1Final(SHA1Context);
+end;
+
+{==============================================================================}
+
+function HMAC_SHA1(const Text: String; Key: String): String;
+var
+  ipad, opad, s: String;
+  n: Integer;
+  SHA1Context: TSHA1Ctx;
+begin
+  if Length(Key) > 64 then
+    Key := SHA1(Key);
+  ipad := StringOfChar(HMAC_SHA1_IPAD_CHAR, 64);
+  opad := StringOfChar(HMAC_SHA1_OPAD_CHAR, 64);
+  for n := 1 to Length(Key) do
+  begin
+    ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n]));
+    opad[n] := Char(Byte(opad[n]) xor Byte(Key[n]));
+  end;
+  SHA1Init(SHA1Context);
+  SHA1Update(SHA1Context, ipad);
+  SHA1Update(SHA1Context, Text);
+  s := SHA1Final(SHA1Context);
+  SHA1Init(SHA1Context);
+  SHA1Update(SHA1Context, opad);
+  SHA1Update(SHA1Context, s);
+  Result := SHA1Final(SHA1Context);
+end;
+
+{==============================================================================}
+
+function SHA1LongHash(const Value: String; Len: integer): String;
+var
+  cnt, rest: integer;
+  l: integer;
+  n: integer;
+  SHA1Context: TSHA1Ctx;
+begin
+  l := length(Value);
+  cnt := Len div l;
+  rest := Len mod l;
+  SHA1Init(SHA1Context);
+  for n := 1 to cnt do
+    SHA1Update(SHA1Context, Value);
+  if rest > 0 then
+    SHA1Update(SHA1Context, Copy(Value, 1, rest));
+  Result := SHA1Final(SHA1Context);
+end;
+
+{==============================================================================}
+
+procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt);
+var
+  A, B, C, D: LongInt;
+  function LRot32(a, b: longint): longint;
+  begin
+    Result:= (a shl b) or (a shr (32 - b));
+  end;
+begin
+  A := Buf[0];
+  B := Buf[1];
+  C := Buf[2];
+  D := Buf[3];
+
+  A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3);
+  D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7);
+  C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11);
+  B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19);
+  A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3);
+  D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7);
+  C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11);
+  B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19);
+  A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3);
+  D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7);
+  C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11);
+  B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19);
+  A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3);
+  D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7);
+  C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11);
+  B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19);
+
+  A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3);
+  D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5);
+  C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9);
+  B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13);
+  A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3);
+  D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5);
+  C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9);
+  B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13);
+  A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3);
+  D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5);
+  C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9);
+  B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13);
+  A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3);
+  D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5);
+  C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9);
+  B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13);
+
+  A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3);
+  D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9);
+  C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11);
+  B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15);
+  A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3);
+  D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9);
+  C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11);
+  B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15);
+  A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3);
+  D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9);
+  C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11);
+  B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15);
+  A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3);
+  D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9);
+  C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11);
+  B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15);
+
+  Inc(Buf[0], A);
+  Inc(Buf[1], B);
+  Inc(Buf[2], C);
+  Inc(Buf[3], D);
+end;
+
+{==============================================================================}
+
+function MD4(const Value: String): String;
+var
+  MDContext: TMDCtx;
+begin
+  MDInit(MDContext);
+  MDUpdate(MDContext, Value, @MD4Transform);
+  Result := MDFinal(MDContext, @MD4Transform);
+end;
+
+{==============================================================================}
+
+
+end.

synacrypt.pas

@@ -0,0 +1,2412 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.000 |
+|==============================================================================|
+| Content: Encryption support                                                  |
+|==============================================================================|
+| Copyright (c)2007-2011, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2007-2011.                |
+| All Rights Reserved.                                                         |
+| Based on work of David Barton and Eric Young                                 |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Encryption support)
+
+Implemented are DES and 3DES encryption/decryption by ECB, CBC, CFB-8bit,
+ CFB-block, OFB and CTR methods.
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit synacrypt;
+
+interface
+
+uses
+  SysUtils, Classes, synautil, synafpc;
+
+type
+  {:@abstract(Implementation of common routines block ciphers (dafault size is 64-bits))
+
+   Do not use this class directly, use descendants only!}
+  TSynaBlockCipher= class(TObject)
+  protected
+    procedure InitKey(Key: AnsiString); virtual;
+    function GetSize: byte; virtual;
+  private
+    IV, CV: AnsiString;
+    procedure IncCounter;
+  public
+    {:Sets the IV to Value and performs a reset}
+    procedure SetIV(const Value: AnsiString); virtual;
+    {:Returns the current chaining information, not the actual IV}
+    function GetIV: AnsiString; virtual;
+    {:Reset any stored chaining information}
+    procedure Reset; virtual;
+    {:Encrypt a 64-bit block of data using the ECB method of encryption}
+    function EncryptECB(const InData: AnsiString): AnsiString; virtual;
+    {:Decrypt a 64-bit block of data using the ECB method of decryption}
+    function DecryptECB(const InData: AnsiString): AnsiString; virtual;
+    {:Encrypt data using the CBC method of encryption}
+    function EncryptCBC(const Indata: AnsiString): AnsiString; virtual;
+    {:Decrypt data using the CBC method of decryption}
+    function DecryptCBC(const Indata: AnsiString): AnsiString; virtual;
+    {:Encrypt data using the CFB (8 bit) method of encryption}
+    function EncryptCFB8bit(const Indata: AnsiString): AnsiString; virtual;
+    {:Decrypt data using the CFB (8 bit) method of decryption}
+    function DecryptCFB8bit(const Indata: AnsiString): AnsiString; virtual;
+    {:Encrypt data using the CFB (block) method of encryption}
+    function EncryptCFBblock(const Indata: AnsiString): AnsiString; virtual;
+    {:Decrypt data using the CFB (block) method of decryption}
+    function DecryptCFBblock(const Indata: AnsiString): AnsiString; virtual;
+    {:Encrypt data using the OFB method of encryption}
+    function EncryptOFB(const Indata: AnsiString): AnsiString; virtual;
+    {:Decrypt data using the OFB method of decryption}
+    function DecryptOFB(const Indata: AnsiString): AnsiString; virtual;
+    {:Encrypt data using the CTR method of encryption}
+    function EncryptCTR(const Indata: AnsiString): AnsiString; virtual;
+    {:Decrypt data using the CTR method of decryption}
+    function DecryptCTR(const Indata: AnsiString): AnsiString; virtual;
+    {:Create a encryptor/decryptor instance and initialize it by the Key.}
+    constructor Create(Key: AnsiString);
+  end;
+
+  {:@abstract(Datatype for holding one DES key data)
+
+    This data type is used internally.}
+  TDesKeyData = array[0..31] of integer;
+
+  {:@abstract(Implementation of common routines for DES encryption)
+
+   Do not use this class directly, use descendants only!}
+  TSynaCustomDes = class(TSynaBlockcipher)
+  protected
+    procedure DoInit(KeyB: AnsiString; var KeyData: TDesKeyData);
+    function EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
+    function DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
+  end;
+
+  {:@abstract(Implementation of DES encryption)}
+  TSynaDes= class(TSynaCustomDes)
+  protected
+    KeyData: TDesKeyData;
+    procedure InitKey(Key: AnsiString); override;
+  public
+    {:Encrypt a 64-bit block of data using the ECB method of encryption}
+    function EncryptECB(const InData: AnsiString): AnsiString; override;
+    {:Decrypt a 64-bit block of data using the ECB method of decryption}
+    function DecryptECB(const InData: AnsiString): AnsiString; override;
+  end;
+
+  {:@abstract(Implementation of 3DES encryption)}
+  TSyna3Des= class(TSynaCustomDes)
+  protected
+    KeyData: array[0..2] of TDesKeyData;
+    procedure InitKey(Key: AnsiString); override;
+  public
+    {:Encrypt a 64-bit block of data using the ECB method of encryption}
+    function EncryptECB(const InData: AnsiString): AnsiString; override;
+    {:Decrypt a 64-bit block of data using the ECB method of decryption}
+    function DecryptECB(const InData: AnsiString): AnsiString; override;
+  end;
+
+const
+  BC = 4;
+  MAXROUNDS = 14;
+type
+  {:@abstract(Implementation of AES encryption)}
+  TSynaAes= class(TSynaBlockcipher)
+  protected
+    numrounds: longword;
+    rk, drk: array[0..MAXROUNDS,0..7] of longword;
+    procedure InitKey(Key: AnsiString); override;
+    function GetSize: byte; override;
+  public
+    {:Encrypt a 128-bit block of data using the ECB method of encryption}
+    function EncryptECB(const InData: AnsiString): AnsiString; override;
+    {:Decrypt a 128-bit block of data using the ECB method of decryption}
+    function DecryptECB(const InData: AnsiString): AnsiString; override;
+  end;
+
+{:Call internal test of all DES encryptions. Returns @true if all is OK.}
+function TestDes: boolean;
+{:Call internal test of all 3DES encryptions. Returns @true if all is OK.}
+function Test3Des: boolean;
+{:Call internal test of all AES encryptions. Returns @true if all is OK.}
+function TestAes: boolean;
+
+{==============================================================================}
+implementation
+
+//DES consts
+const
+  shifts2: array[0..15]of byte=
+    (0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0);
+
+  des_skb: array[0..7,0..63]of integer=(
+    (
+    (* for C bits (numbered as per FIPS 46) 1 2 3 4 5 6 *)
+    integer($00000000),integer($00000010),integer($20000000),integer($20000010),
+    integer($00010000),integer($00010010),integer($20010000),integer($20010010),
+    integer($00000800),integer($00000810),integer($20000800),integer($20000810),
+    integer($00010800),integer($00010810),integer($20010800),integer($20010810),
+    integer($00000020),integer($00000030),integer($20000020),integer($20000030),
+    integer($00010020),integer($00010030),integer($20010020),integer($20010030),
+    integer($00000820),integer($00000830),integer($20000820),integer($20000830),
+    integer($00010820),integer($00010830),integer($20010820),integer($20010830),
+    integer($00080000),integer($00080010),integer($20080000),integer($20080010),
+    integer($00090000),integer($00090010),integer($20090000),integer($20090010),
+    integer($00080800),integer($00080810),integer($20080800),integer($20080810),
+    integer($00090800),integer($00090810),integer($20090800),integer($20090810),
+    integer($00080020),integer($00080030),integer($20080020),integer($20080030),
+    integer($00090020),integer($00090030),integer($20090020),integer($20090030),
+    integer($00080820),integer($00080830),integer($20080820),integer($20080830),
+    integer($00090820),integer($00090830),integer($20090820),integer($20090830)
+    ),(
+    (* for C bits (numbered as per FIPS 46) 7 8 10 11 12 13 *)
+    integer($00000000),integer($02000000),integer($00002000),integer($02002000),
+    integer($00200000),integer($02200000),integer($00202000),integer($02202000),
+    integer($00000004),integer($02000004),integer($00002004),integer($02002004),
+    integer($00200004),integer($02200004),integer($00202004),integer($02202004),
+    integer($00000400),integer($02000400),integer($00002400),integer($02002400),
+    integer($00200400),integer($02200400),integer($00202400),integer($02202400),
+    integer($00000404),integer($02000404),integer($00002404),integer($02002404),
+    integer($00200404),integer($02200404),integer($00202404),integer($02202404),
+    integer($10000000),integer($12000000),integer($10002000),integer($12002000),
+    integer($10200000),integer($12200000),integer($10202000),integer($12202000),
+    integer($10000004),integer($12000004),integer($10002004),integer($12002004),
+    integer($10200004),integer($12200004),integer($10202004),integer($12202004),
+    integer($10000400),integer($12000400),integer($10002400),integer($12002400),
+    integer($10200400),integer($12200400),integer($10202400),integer($12202400),
+    integer($10000404),integer($12000404),integer($10002404),integer($12002404),
+    integer($10200404),integer($12200404),integer($10202404),integer($12202404)
+    ),(
+    (* for C bits (numbered as per FIPS 46) 14 15 16 17 19 20 *)
+    integer($00000000),integer($00000001),integer($00040000),integer($00040001),
+    integer($01000000),integer($01000001),integer($01040000),integer($01040001),
+    integer($00000002),integer($00000003),integer($00040002),integer($00040003),
+    integer($01000002),integer($01000003),integer($01040002),integer($01040003),
+    integer($00000200),integer($00000201),integer($00040200),integer($00040201),
+    integer($01000200),integer($01000201),integer($01040200),integer($01040201),
+    integer($00000202),integer($00000203),integer($00040202),integer($00040203),
+    integer($01000202),integer($01000203),integer($01040202),integer($01040203),
+    integer($08000000),integer($08000001),integer($08040000),integer($08040001),
+    integer($09000000),integer($09000001),integer($09040000),integer($09040001),
+    integer($08000002),integer($08000003),integer($08040002),integer($08040003),
+    integer($09000002),integer($09000003),integer($09040002),integer($09040003),
+    integer($08000200),integer($08000201),integer($08040200),integer($08040201),
+    integer($09000200),integer($09000201),integer($09040200),integer($09040201),
+    integer($08000202),integer($08000203),integer($08040202),integer($08040203),
+    integer($09000202),integer($09000203),integer($09040202),integer($09040203)
+    ),(
+    (* for C bits (numbered as per FIPS 46) 21 23 24 26 27 28 *)
+    integer($00000000),integer($00100000),integer($00000100),integer($00100100),
+    integer($00000008),integer($00100008),integer($00000108),integer($00100108),
+    integer($00001000),integer($00101000),integer($00001100),integer($00101100),
+    integer($00001008),integer($00101008),integer($00001108),integer($00101108),
+    integer($04000000),integer($04100000),integer($04000100),integer($04100100),
+    integer($04000008),integer($04100008),integer($04000108),integer($04100108),
+    integer($04001000),integer($04101000),integer($04001100),integer($04101100),
+    integer($04001008),integer($04101008),integer($04001108),integer($04101108),
+    integer($00020000),integer($00120000),integer($00020100),integer($00120100),
+    integer($00020008),integer($00120008),integer($00020108),integer($00120108),
+    integer($00021000),integer($00121000),integer($00021100),integer($00121100),
+    integer($00021008),integer($00121008),integer($00021108),integer($00121108),
+    integer($04020000),integer($04120000),integer($04020100),integer($04120100),
+    integer($04020008),integer($04120008),integer($04020108),integer($04120108),
+    integer($04021000),integer($04121000),integer($04021100),integer($04121100),
+    integer($04021008),integer($04121008),integer($04021108),integer($04121108)
+    ),(
+    (* for D bits (numbered as per FIPS 46) 1 2 3 4 5 6 *)
+    integer($00000000),integer($10000000),integer($00010000),integer($10010000),
+    integer($00000004),integer($10000004),integer($00010004),integer($10010004),
+    integer($20000000),integer($30000000),integer($20010000),integer($30010000),
+    integer($20000004),integer($30000004),integer($20010004),integer($30010004),
+    integer($00100000),integer($10100000),integer($00110000),integer($10110000),
+    integer($00100004),integer($10100004),integer($00110004),integer($10110004),
+    integer($20100000),integer($30100000),integer($20110000),integer($30110000),
+    integer($20100004),integer($30100004),integer($20110004),integer($30110004),
+    integer($00001000),integer($10001000),integer($00011000),integer($10011000),
+    integer($00001004),integer($10001004),integer($00011004),integer($10011004),
+    integer($20001000),integer($30001000),integer($20011000),integer($30011000),
+    integer($20001004),integer($30001004),integer($20011004),integer($30011004),
+    integer($00101000),integer($10101000),integer($00111000),integer($10111000),
+    integer($00101004),integer($10101004),integer($00111004),integer($10111004),
+    integer($20101000),integer($30101000),integer($20111000),integer($30111000),
+    integer($20101004),integer($30101004),integer($20111004),integer($30111004)
+    ),(
+    (* for D bits (numbered as per FIPS 46) 8 9 11 12 13 14 *)
+    integer($00000000),integer($08000000),integer($00000008),integer($08000008),
+    integer($00000400),integer($08000400),integer($00000408),integer($08000408),
+    integer($00020000),integer($08020000),integer($00020008),integer($08020008),
+    integer($00020400),integer($08020400),integer($00020408),integer($08020408),
+    integer($00000001),integer($08000001),integer($00000009),integer($08000009),
+    integer($00000401),integer($08000401),integer($00000409),integer($08000409),
+    integer($00020001),integer($08020001),integer($00020009),integer($08020009),
+    integer($00020401),integer($08020401),integer($00020409),integer($08020409),
+    integer($02000000),integer($0A000000),integer($02000008),integer($0A000008),
+    integer($02000400),integer($0A000400),integer($02000408),integer($0A000408),
+    integer($02020000),integer($0A020000),integer($02020008),integer($0A020008),
+    integer($02020400),integer($0A020400),integer($02020408),integer($0A020408),
+    integer($02000001),integer($0A000001),integer($02000009),integer($0A000009),
+    integer($02000401),integer($0A000401),integer($02000409),integer($0A000409),
+    integer($02020001),integer($0A020001),integer($02020009),integer($0A020009),
+    integer($02020401),integer($0A020401),integer($02020409),integer($0A020409)
+    ),(
+    (* for D bits (numbered as per FIPS 46) 16 17 18 19 20 21 *)
+    integer($00000000),integer($00000100),integer($00080000),integer($00080100),
+    integer($01000000),integer($01000100),integer($01080000),integer($01080100),
+    integer($00000010),integer($00000110),integer($00080010),integer($00080110),
+    integer($01000010),integer($01000110),integer($01080010),integer($01080110),
+    integer($00200000),integer($00200100),integer($00280000),integer($00280100),
+    integer($01200000),integer($01200100),integer($01280000),integer($01280100),
+    integer($00200010),integer($00200110),integer($00280010),integer($00280110),
+    integer($01200010),integer($01200110),integer($01280010),integer($01280110),
+    integer($00000200),integer($00000300),integer($00080200),integer($00080300),
+    integer($01000200),integer($01000300),integer($01080200),integer($01080300),
+    integer($00000210),integer($00000310),integer($00080210),integer($00080310),
+    integer($01000210),integer($01000310),integer($01080210),integer($01080310),
+    integer($00200200),integer($00200300),integer($00280200),integer($00280300),
+    integer($01200200),integer($01200300),integer($01280200),integer($01280300),
+    integer($00200210),integer($00200310),integer($00280210),integer($00280310),
+    integer($01200210),integer($01200310),integer($01280210),integer($01280310)
+    ),(
+    (* for D bits (numbered as per FIPS 46) 22 23 24 25 27 28 *)
+    integer($00000000),integer($04000000),integer($00040000),integer($04040000),
+    integer($00000002),integer($04000002),integer($00040002),integer($04040002),
+    integer($00002000),integer($04002000),integer($00042000),integer($04042000),
+    integer($00002002),integer($04002002),integer($00042002),integer($04042002),
+    integer($00000020),integer($04000020),integer($00040020),integer($04040020),
+    integer($00000022),integer($04000022),integer($00040022),integer($04040022),
+    integer($00002020),integer($04002020),integer($00042020),integer($04042020),
+    integer($00002022),integer($04002022),integer($00042022),integer($04042022),
+    integer($00000800),integer($04000800),integer($00040800),integer($04040800),
+    integer($00000802),integer($04000802),integer($00040802),integer($04040802),
+    integer($00002800),integer($04002800),integer($00042800),integer($04042800),
+    integer($00002802),integer($04002802),integer($00042802),integer($04042802),
+    integer($00000820),integer($04000820),integer($00040820),integer($04040820),
+    integer($00000822),integer($04000822),integer($00040822),integer($04040822),
+    integer($00002820),integer($04002820),integer($00042820),integer($04042820),
+    integer($00002822),integer($04002822),integer($00042822),integer($04042822)
+    ));
+
+  des_sptrans: array[0..7,0..63] of integer=(
+    (
+    (* nibble 0 *)
+    integer($02080800), integer($00080000), integer($02000002), integer($02080802),
+    integer($02000000), integer($00080802), integer($00080002), integer($02000002),
+    integer($00080802), integer($02080800), integer($02080000), integer($00000802),
+    integer($02000802), integer($02000000), integer($00000000), integer($00080002),
+    integer($00080000), integer($00000002), integer($02000800), integer($00080800),
+    integer($02080802), integer($02080000), integer($00000802), integer($02000800),
+    integer($00000002), integer($00000800), integer($00080800), integer($02080002),
+    integer($00000800), integer($02000802), integer($02080002), integer($00000000),
+    integer($00000000), integer($02080802), integer($02000800), integer($00080002),
+    integer($02080800), integer($00080000), integer($00000802), integer($02000800),
+    integer($02080002), integer($00000800), integer($00080800), integer($02000002),
+    integer($00080802), integer($00000002), integer($02000002), integer($02080000),
+    integer($02080802), integer($00080800), integer($02080000), integer($02000802),
+    integer($02000000), integer($00000802), integer($00080002), integer($00000000),
+    integer($00080000), integer($02000000), integer($02000802), integer($02080800),
+    integer($00000002), integer($02080002), integer($00000800), integer($00080802)
+    ),(
+    (* nibble 1 *)
+    integer($40108010), integer($00000000), integer($00108000), integer($40100000),
+    integer($40000010), integer($00008010), integer($40008000), integer($00108000),
+    integer($00008000), integer($40100010), integer($00000010), integer($40008000),
+    integer($00100010), integer($40108000), integer($40100000), integer($00000010),
+    integer($00100000), integer($40008010), integer($40100010), integer($00008000),
+    integer($00108010), integer($40000000), integer($00000000), integer($00100010),
+    integer($40008010), integer($00108010), integer($40108000), integer($40000010),
+    integer($40000000), integer($00100000), integer($00008010), integer($40108010),
+    integer($00100010), integer($40108000), integer($40008000), integer($00108010),
+    integer($40108010), integer($00100010), integer($40000010), integer($00000000),
+    integer($40000000), integer($00008010), integer($00100000), integer($40100010),
+    integer($00008000), integer($40000000), integer($00108010), integer($40008010),
+    integer($40108000), integer($00008000), integer($00000000), integer($40000010),
+    integer($00000010), integer($40108010), integer($00108000), integer($40100000),
+    integer($40100010), integer($00100000), integer($00008010), integer($40008000),
+    integer($40008010), integer($00000010), integer($40100000), integer($00108000)
+    ),(
+    (* nibble 2 *)
+    integer($04000001), integer($04040100), integer($00000100), integer($04000101),
+    integer($00040001), integer($04000000), integer($04000101), integer($00040100),
+    integer($04000100), integer($00040000), integer($04040000), integer($00000001),
+    integer($04040101), integer($00000101), integer($00000001), integer($04040001),
+    integer($00000000), integer($00040001), integer($04040100), integer($00000100),
+    integer($00000101), integer($04040101), integer($00040000), integer($04000001),
+    integer($04040001), integer($04000100), integer($00040101), integer($04040000),
+    integer($00040100), integer($00000000), integer($04000000), integer($00040101),
+    integer($04040100), integer($00000100), integer($00000001), integer($00040000),
+    integer($00000101), integer($00040001), integer($04040000), integer($04000101),
+    integer($00000000), integer($04040100), integer($00040100), integer($04040001),
+    integer($00040001), integer($04000000), integer($04040101), integer($00000001),
+    integer($00040101), integer($04000001), integer($04000000), integer($04040101),
+    integer($00040000), integer($04000100), integer($04000101), integer($00040100),
+    integer($04000100), integer($00000000), integer($04040001), integer($00000101),
+    integer($04000001), integer($00040101), integer($00000100), integer($04040000)
+    ),(
+    (* nibble 3 *)
+    integer($00401008), integer($10001000), integer($00000008), integer($10401008),
+    integer($00000000), integer($10400000), integer($10001008), integer($00400008),
+    integer($10401000), integer($10000008), integer($10000000), integer($00001008),
+    integer($10000008), integer($00401008), integer($00400000), integer($10000000),
+    integer($10400008), integer($00401000), integer($00001000), integer($00000008),
+    integer($00401000), integer($10001008), integer($10400000), integer($00001000),
+    integer($00001008), integer($00000000), integer($00400008), integer($10401000),
+    integer($10001000), integer($10400008), integer($10401008), integer($00400000),
+    integer($10400008), integer($00001008), integer($00400000), integer($10000008),
+    integer($00401000), integer($10001000), integer($00000008), integer($10400000),
+    integer($10001008), integer($00000000), integer($00001000), integer($00400008),
+    integer($00000000), integer($10400008), integer($10401000), integer($00001000),
+    integer($10000000), integer($10401008), integer($00401008), integer($00400000),
+    integer($10401008), integer($00000008), integer($10001000), integer($00401008),
+    integer($00400008), integer($00401000), integer($10400000), integer($10001008),
+    integer($00001008), integer($10000000), integer($10000008), integer($10401000)
+    ),(
+    (* nibble 4 *)
+    integer($08000000), integer($00010000), integer($00000400), integer($08010420),
+    integer($08010020), integer($08000400), integer($00010420), integer($08010000),
+    integer($00010000), integer($00000020), integer($08000020), integer($00010400),
+    integer($08000420), integer($08010020), integer($08010400), integer($00000000),
+    integer($00010400), integer($08000000), integer($00010020), integer($00000420),
+    integer($08000400), integer($00010420), integer($00000000), integer($08000020),
+    integer($00000020), integer($08000420), integer($08010420), integer($00010020),
+    integer($08010000), integer($00000400), integer($00000420), integer($08010400),
+    integer($08010400), integer($08000420), integer($00010020), integer($08010000),
+    integer($00010000), integer($00000020), integer($08000020), integer($08000400),
+    integer($08000000), integer($00010400), integer($08010420), integer($00000000),
+    integer($00010420), integer($08000000), integer($00000400), integer($00010020),
+    integer($08000420), integer($00000400), integer($00000000), integer($08010420),
+    integer($08010020), integer($08010400), integer($00000420), integer($00010000),
+    integer($00010400), integer($08010020), integer($08000400), integer($00000420),
+    integer($00000020), integer($00010420), integer($08010000), integer($08000020)
+    ),(
+    (* nibble 5 *)
+    integer($80000040), integer($00200040), integer($00000000), integer($80202000),
+    integer($00200040), integer($00002000), integer($80002040), integer($00200000),
+    integer($00002040), integer($80202040), integer($00202000), integer($80000000),
+    integer($80002000), integer($80000040), integer($80200000), integer($00202040),
+    integer($00200000), integer($80002040), integer($80200040), integer($00000000),
+    integer($00002000), integer($00000040), integer($80202000), integer($80200040),
+    integer($80202040), integer($80200000), integer($80000000), integer($00002040),
+    integer($00000040), integer($00202000), integer($00202040), integer($80002000),
+    integer($00002040), integer($80000000), integer($80002000), integer($00202040),
+    integer($80202000), integer($00200040), integer($00000000), integer($80002000),
+    integer($80000000), integer($00002000), integer($80200040), integer($00200000),
+    integer($00200040), integer($80202040), integer($00202000), integer($00000040),
+    integer($80202040), integer($00202000), integer($00200000), integer($80002040),
+    integer($80000040), integer($80200000), integer($00202040), integer($00000000),
+    integer($00002000), integer($80000040), integer($80002040), integer($80202000),
+    integer($80200000), integer($00002040), integer($00000040), integer($80200040)
+    ),(
+    (* nibble 6 *)
+    integer($00004000), integer($00000200), integer($01000200), integer($01000004),
+    integer($01004204), integer($00004004), integer($00004200), integer($00000000),
+    integer($01000000), integer($01000204), integer($00000204), integer($01004000),
+    integer($00000004), integer($01004200), integer($01004000), integer($00000204),
+    integer($01000204), integer($00004000), integer($00004004), integer($01004204),
+    integer($00000000), integer($01000200), integer($01000004), integer($00004200),
+    integer($01004004), integer($00004204), integer($01004200), integer($00000004),
+    integer($00004204), integer($01004004), integer($00000200), integer($01000000),
+    integer($00004204), integer($01004000), integer($01004004), integer($00000204),
+    integer($00004000), integer($00000200), integer($01000000), integer($01004004),
+    integer($01000204), integer($00004204), integer($00004200), integer($00000000),
+    integer($00000200), integer($01000004), integer($00000004), integer($01000200),
+    integer($00000000), integer($01000204), integer($01000200), integer($00004200),
+    integer($00000204), integer($00004000), integer($01004204), integer($01000000),
+    integer($01004200), integer($00000004), integer($00004004), integer($01004204),
+    integer($01000004), integer($01004200), integer($01004000), integer($00004004)
+    ),(
+    (* nibble 7 *)
+    integer($20800080), integer($20820000), integer($00020080), integer($00000000),
+    integer($20020000), integer($00800080), integer($20800000), integer($20820080),
+    integer($00000080), integer($20000000), integer($00820000), integer($00020080),
+    integer($00820080), integer($20020080), integer($20000080), integer($20800000),
+    integer($00020000), integer($00820080), integer($00800080), integer($20020000),
+    integer($20820080), integer($20000080), integer($00000000), integer($00820000),
+    integer($20000000), integer($00800000), integer($20020080), integer($20800080),
+    integer($00800000), integer($00020000), integer($20820000), integer($00000080),
+    integer($00800000), integer($00020000), integer($20000080), integer($20820080),
+    integer($00020080), integer($20000000), integer($00000000), integer($00820000),
+    integer($20800080), integer($20020080), integer($20020000), integer($00800080),
+    integer($20820000), integer($00000080), integer($00800080), integer($20020000),
+    integer($20820080), integer($00800000), integer($20800000), integer($20000080),
+    integer($00820000), integer($00020080), integer($20020080), integer($20800000),
+    integer($00000080), integer($20820000), integer($00820080), integer($00000000),
+    integer($20000000), integer($20800080), integer($00020000), integer($00820080)
+    ));
+
+//AES consts
+const
+  MAXBC= 8;
+  MAXKC= 8;
+
+  S: array[0..255] of byte= (
+     99, 124, 119, 123, 242, 107, 111, 197,  48,   1, 103,  43, 254, 215, 171, 118,
+    202, 130, 201, 125, 250,  89,  71, 240, 173, 212, 162, 175, 156, 164, 114, 192,
+    183, 253, 147,  38,  54,  63, 247, 204,  52, 165, 229, 241, 113, 216,  49,  21,
+      4, 199,  35, 195,  24, 150,   5, 154,   7,  18, 128, 226, 235,  39, 178, 117,
+      9, 131,  44,  26,  27, 110,  90, 160,  82,  59, 214, 179,  41, 227,  47, 132,
+     83, 209,   0, 237,  32, 252, 177,  91, 106, 203, 190,  57,  74,  76,  88, 207, 
+    208, 239, 170, 251,  67,  77,  51, 133,  69, 249,   2, 127,  80,  60, 159, 168, 
+     81, 163,  64, 143, 146, 157,  56, 245, 188, 182, 218,  33,  16, 255, 243, 210, 
+    205,  12,  19, 236,  95, 151,  68,  23, 196, 167, 126,  61, 100,  93,  25, 115, 
+     96, 129,  79, 220,  34,  42, 144, 136,  70, 238, 184,  20, 222,  94,  11, 219, 
+    224,  50,  58,  10,  73,   6,  36,  92, 194, 211, 172,  98, 145, 149, 228, 121, 
+    231, 200,  55, 109, 141, 213,  78, 169, 108,  86, 244, 234, 101, 122, 174,   8, 
+    186, 120,  37,  46,  28, 166, 180, 198, 232, 221, 116,  31,  75, 189, 139, 138,
+    112,  62, 181, 102,  72,   3, 246,  14,  97,  53,  87, 185, 134, 193,  29, 158,
+    225, 248, 152,  17, 105, 217, 142, 148, 155,  30, 135, 233, 206,  85,  40, 223,
+    140, 161, 137,  13, 191, 230,  66, 104,  65, 153,  45,  15, 176,  84, 187,  22);
+  T1: array[0..255,0..3] of byte= (
+    ($c6,$63,$63,$a5), ($f8,$7c,$7c,$84), ($ee,$77,$77,$99), ($f6,$7b,$7b,$8d), 
+    ($ff,$f2,$f2,$0d), ($d6,$6b,$6b,$bd), ($de,$6f,$6f,$b1), ($91,$c5,$c5,$54),
+    ($60,$30,$30,$50), ($02,$01,$01,$03), ($ce,$67,$67,$a9), ($56,$2b,$2b,$7d),
+    ($e7,$fe,$fe,$19), ($b5,$d7,$d7,$62), ($4d,$ab,$ab,$e6), ($ec,$76,$76,$9a),
+    ($8f,$ca,$ca,$45), ($1f,$82,$82,$9d), ($89,$c9,$c9,$40), ($fa,$7d,$7d,$87),
+    ($ef,$fa,$fa,$15), ($b2,$59,$59,$eb), ($8e,$47,$47,$c9), ($fb,$f0,$f0,$0b), 
+    ($41,$ad,$ad,$ec), ($b3,$d4,$d4,$67), ($5f,$a2,$a2,$fd), ($45,$af,$af,$ea), 
+    ($23,$9c,$9c,$bf), ($53,$a4,$a4,$f7), ($e4,$72,$72,$96), ($9b,$c0,$c0,$5b), 
+    ($75,$b7,$b7,$c2), ($e1,$fd,$fd,$1c), ($3d,$93,$93,$ae), ($4c,$26,$26,$6a),
+    ($6c,$36,$36,$5a), ($7e,$3f,$3f,$41), ($f5,$f7,$f7,$02), ($83,$cc,$cc,$4f), 
+    ($68,$34,$34,$5c), ($51,$a5,$a5,$f4), ($d1,$e5,$e5,$34), ($f9,$f1,$f1,$08), 
+    ($e2,$71,$71,$93), ($ab,$d8,$d8,$73), ($62,$31,$31,$53), ($2a,$15,$15,$3f),
+    ($08,$04,$04,$0c), ($95,$c7,$c7,$52), ($46,$23,$23,$65), ($9d,$c3,$c3,$5e), 
+    ($30,$18,$18,$28), ($37,$96,$96,$a1), ($0a,$05,$05,$0f), ($2f,$9a,$9a,$b5),
+    ($0e,$07,$07,$09), ($24,$12,$12,$36), ($1b,$80,$80,$9b), ($df,$e2,$e2,$3d), 
+    ($cd,$eb,$eb,$26), ($4e,$27,$27,$69), ($7f,$b2,$b2,$cd), ($ea,$75,$75,$9f),
+    ($12,$09,$09,$1b), ($1d,$83,$83,$9e), ($58,$2c,$2c,$74), ($34,$1a,$1a,$2e), 
+    ($36,$1b,$1b,$2d), ($dc,$6e,$6e,$b2), ($b4,$5a,$5a,$ee), ($5b,$a0,$a0,$fb), 
+    ($a4,$52,$52,$f6), ($76,$3b,$3b,$4d), ($b7,$d6,$d6,$61), ($7d,$b3,$b3,$ce),
+    ($52,$29,$29,$7b), ($dd,$e3,$e3,$3e), ($5e,$2f,$2f,$71), ($13,$84,$84,$97), 
+    ($a6,$53,$53,$f5), ($b9,$d1,$d1,$68), ($00,$00,$00,$00), ($c1,$ed,$ed,$2c), 
+    ($40,$20,$20,$60), ($e3,$fc,$fc,$1f), ($79,$b1,$b1,$c8), ($b6,$5b,$5b,$ed), 
+    ($d4,$6a,$6a,$be), ($8d,$cb,$cb,$46), ($67,$be,$be,$d9), ($72,$39,$39,$4b), 
+    ($94,$4a,$4a,$de), ($98,$4c,$4c,$d4), ($b0,$58,$58,$e8), ($85,$cf,$cf,$4a), 
+    ($bb,$d0,$d0,$6b), ($c5,$ef,$ef,$2a), ($4f,$aa,$aa,$e5), ($ed,$fb,$fb,$16),
+    ($86,$43,$43,$c5), ($9a,$4d,$4d,$d7), ($66,$33,$33,$55), ($11,$85,$85,$94), 
+    ($8a,$45,$45,$cf), ($e9,$f9,$f9,$10), ($04,$02,$02,$06), ($fe,$7f,$7f,$81), 
+    ($a0,$50,$50,$f0), ($78,$3c,$3c,$44), ($25,$9f,$9f,$ba), ($4b,$a8,$a8,$e3), 
+    ($a2,$51,$51,$f3), ($5d,$a3,$a3,$fe), ($80,$40,$40,$c0), ($05,$8f,$8f,$8a),
+    ($3f,$92,$92,$ad), ($21,$9d,$9d,$bc), ($70,$38,$38,$48), ($f1,$f5,$f5,$04), 
+    ($63,$bc,$bc,$df), ($77,$b6,$b6,$c1), ($af,$da,$da,$75), ($42,$21,$21,$63), 
+    ($20,$10,$10,$30), ($e5,$ff,$ff,$1a), ($fd,$f3,$f3,$0e), ($bf,$d2,$d2,$6d), 
+    ($81,$cd,$cd,$4c), ($18,$0c,$0c,$14), ($26,$13,$13,$35), ($c3,$ec,$ec,$2f), 
+    ($be,$5f,$5f,$e1), ($35,$97,$97,$a2), ($88,$44,$44,$cc), ($2e,$17,$17,$39), 
+    ($93,$c4,$c4,$57), ($55,$a7,$a7,$f2), ($fc,$7e,$7e,$82), ($7a,$3d,$3d,$47), 
+    ($c8,$64,$64,$ac), ($ba,$5d,$5d,$e7), ($32,$19,$19,$2b), ($e6,$73,$73,$95), 
+    ($c0,$60,$60,$a0), ($19,$81,$81,$98), ($9e,$4f,$4f,$d1), ($a3,$dc,$dc,$7f),
+    ($44,$22,$22,$66), ($54,$2a,$2a,$7e), ($3b,$90,$90,$ab), ($0b,$88,$88,$83),
+    ($8c,$46,$46,$ca), ($c7,$ee,$ee,$29), ($6b,$b8,$b8,$d3), ($28,$14,$14,$3c), 
+    ($a7,$de,$de,$79), ($bc,$5e,$5e,$e2), ($16,$0b,$0b,$1d), ($ad,$db,$db,$76), 
+    ($db,$e0,$e0,$3b), ($64,$32,$32,$56), ($74,$3a,$3a,$4e), ($14,$0a,$0a,$1e), 
+    ($92,$49,$49,$db), ($0c,$06,$06,$0a), ($48,$24,$24,$6c), ($b8,$5c,$5c,$e4),
+    ($9f,$c2,$c2,$5d), ($bd,$d3,$d3,$6e), ($43,$ac,$ac,$ef), ($c4,$62,$62,$a6), 
+    ($39,$91,$91,$a8), ($31,$95,$95,$a4), ($d3,$e4,$e4,$37), ($f2,$79,$79,$8b), 
+    ($d5,$e7,$e7,$32), ($8b,$c8,$c8,$43), ($6e,$37,$37,$59), ($da,$6d,$6d,$b7),
+    ($01,$8d,$8d,$8c), ($b1,$d5,$d5,$64), ($9c,$4e,$4e,$d2), ($49,$a9,$a9,$e0), 
+    ($d8,$6c,$6c,$b4), ($ac,$56,$56,$fa), ($f3,$f4,$f4,$07), ($cf,$ea,$ea,$25), 
+    ($ca,$65,$65,$af), ($f4,$7a,$7a,$8e), ($47,$ae,$ae,$e9), ($10,$08,$08,$18), 
+    ($6f,$ba,$ba,$d5), ($f0,$78,$78,$88), ($4a,$25,$25,$6f), ($5c,$2e,$2e,$72),
+    ($38,$1c,$1c,$24), ($57,$a6,$a6,$f1), ($73,$b4,$b4,$c7), ($97,$c6,$c6,$51), 
+    ($cb,$e8,$e8,$23), ($a1,$dd,$dd,$7c), ($e8,$74,$74,$9c), ($3e,$1f,$1f,$21), 
+    ($96,$4b,$4b,$dd), ($61,$bd,$bd,$dc), ($0d,$8b,$8b,$86), ($0f,$8a,$8a,$85), 
+    ($e0,$70,$70,$90), ($7c,$3e,$3e,$42), ($71,$b5,$b5,$c4), ($cc,$66,$66,$aa), 
+    ($90,$48,$48,$d8), ($06,$03,$03,$05), ($f7,$f6,$f6,$01), ($1c,$0e,$0e,$12), 
+    ($c2,$61,$61,$a3), ($6a,$35,$35,$5f), ($ae,$57,$57,$f9), ($69,$b9,$b9,$d0), 
+    ($17,$86,$86,$91), ($99,$c1,$c1,$58), ($3a,$1d,$1d,$27), ($27,$9e,$9e,$b9), 
+    ($d9,$e1,$e1,$38), ($eb,$f8,$f8,$13), ($2b,$98,$98,$b3), ($22,$11,$11,$33), 
+    ($d2,$69,$69,$bb), ($a9,$d9,$d9,$70), ($07,$8e,$8e,$89), ($33,$94,$94,$a7), 
+    ($2d,$9b,$9b,$b6), ($3c,$1e,$1e,$22), ($15,$87,$87,$92), ($c9,$e9,$e9,$20), 
+    ($87,$ce,$ce,$49), ($aa,$55,$55,$ff), ($50,$28,$28,$78), ($a5,$df,$df,$7a),
+    ($03,$8c,$8c,$8f), ($59,$a1,$a1,$f8), ($09,$89,$89,$80), ($1a,$0d,$0d,$17), 
+    ($65,$bf,$bf,$da), ($d7,$e6,$e6,$31), ($84,$42,$42,$c6), ($d0,$68,$68,$b8),
+    ($82,$41,$41,$c3), ($29,$99,$99,$b0), ($5a,$2d,$2d,$77), ($1e,$0f,$0f,$11), 
+    ($7b,$b0,$b0,$cb), ($a8,$54,$54,$fc), ($6d,$bb,$bb,$d6), ($2c,$16,$16,$3a));
+ T2: array[0..255,0..3] of byte= (
+    ($a5,$c6,$63,$63), ($84,$f8,$7c,$7c), ($99,$ee,$77,$77), ($8d,$f6,$7b,$7b),
+    ($0d,$ff,$f2,$f2), ($bd,$d6,$6b,$6b), ($b1,$de,$6f,$6f), ($54,$91,$c5,$c5),
+    ($50,$60,$30,$30), ($03,$02,$01,$01), ($a9,$ce,$67,$67), ($7d,$56,$2b,$2b),
+    ($19,$e7,$fe,$fe), ($62,$b5,$d7,$d7), ($e6,$4d,$ab,$ab), ($9a,$ec,$76,$76),
+    ($45,$8f,$ca,$ca), ($9d,$1f,$82,$82), ($40,$89,$c9,$c9), ($87,$fa,$7d,$7d),
+    ($15,$ef,$fa,$fa), ($eb,$b2,$59,$59), ($c9,$8e,$47,$47), ($0b,$fb,$f0,$f0),
+    ($ec,$41,$ad,$ad), ($67,$b3,$d4,$d4), ($fd,$5f,$a2,$a2), ($ea,$45,$af,$af),
+    ($bf,$23,$9c,$9c), ($f7,$53,$a4,$a4), ($96,$e4,$72,$72), ($5b,$9b,$c0,$c0),
+    ($c2,$75,$b7,$b7), ($1c,$e1,$fd,$fd), ($ae,$3d,$93,$93), ($6a,$4c,$26,$26),
+    ($5a,$6c,$36,$36), ($41,$7e,$3f,$3f), ($02,$f5,$f7,$f7), ($4f,$83,$cc,$cc),
+    ($5c,$68,$34,$34), ($f4,$51,$a5,$a5), ($34,$d1,$e5,$e5), ($08,$f9,$f1,$f1),
+    ($93,$e2,$71,$71), ($73,$ab,$d8,$d8), ($53,$62,$31,$31), ($3f,$2a,$15,$15), 
+    ($0c,$08,$04,$04), ($52,$95,$c7,$c7), ($65,$46,$23,$23), ($5e,$9d,$c3,$c3),
+    ($28,$30,$18,$18), ($a1,$37,$96,$96), ($0f,$0a,$05,$05), ($b5,$2f,$9a,$9a),
+    ($09,$0e,$07,$07), ($36,$24,$12,$12), ($9b,$1b,$80,$80), ($3d,$df,$e2,$e2), 
+    ($26,$cd,$eb,$eb), ($69,$4e,$27,$27), ($cd,$7f,$b2,$b2), ($9f,$ea,$75,$75),
+    ($1b,$12,$09,$09), ($9e,$1d,$83,$83), ($74,$58,$2c,$2c), ($2e,$34,$1a,$1a),
+    ($2d,$36,$1b,$1b), ($b2,$dc,$6e,$6e), ($ee,$b4,$5a,$5a), ($fb,$5b,$a0,$a0),
+    ($f6,$a4,$52,$52), ($4d,$76,$3b,$3b), ($61,$b7,$d6,$d6), ($ce,$7d,$b3,$b3),
+    ($7b,$52,$29,$29), ($3e,$dd,$e3,$e3), ($71,$5e,$2f,$2f), ($97,$13,$84,$84), 
+    ($f5,$a6,$53,$53), ($68,$b9,$d1,$d1), ($00,$00,$00,$00), ($2c,$c1,$ed,$ed), 
+    ($60,$40,$20,$20), ($1f,$e3,$fc,$fc), ($c8,$79,$b1,$b1), ($ed,$b6,$5b,$5b),
+    ($be,$d4,$6a,$6a), ($46,$8d,$cb,$cb), ($d9,$67,$be,$be), ($4b,$72,$39,$39), 
+    ($de,$94,$4a,$4a), ($d4,$98,$4c,$4c), ($e8,$b0,$58,$58), ($4a,$85,$cf,$cf),
+    ($6b,$bb,$d0,$d0), ($2a,$c5,$ef,$ef), ($e5,$4f,$aa,$aa), ($16,$ed,$fb,$fb),
+    ($c5,$86,$43,$43), ($d7,$9a,$4d,$4d), ($55,$66,$33,$33), ($94,$11,$85,$85), 
+    ($cf,$8a,$45,$45), ($10,$e9,$f9,$f9), ($06,$04,$02,$02), ($81,$fe,$7f,$7f), 
+    ($f0,$a0,$50,$50), ($44,$78,$3c,$3c), ($ba,$25,$9f,$9f), ($e3,$4b,$a8,$a8),
+    ($f3,$a2,$51,$51), ($fe,$5d,$a3,$a3), ($c0,$80,$40,$40), ($8a,$05,$8f,$8f),
+    ($ad,$3f,$92,$92), ($bc,$21,$9d,$9d), ($48,$70,$38,$38), ($04,$f1,$f5,$f5),
+    ($df,$63,$bc,$bc), ($c1,$77,$b6,$b6), ($75,$af,$da,$da), ($63,$42,$21,$21),
+    ($30,$20,$10,$10), ($1a,$e5,$ff,$ff), ($0e,$fd,$f3,$f3), ($6d,$bf,$d2,$d2), 
+    ($4c,$81,$cd,$cd), ($14,$18,$0c,$0c), ($35,$26,$13,$13), ($2f,$c3,$ec,$ec),
+    ($e1,$be,$5f,$5f), ($a2,$35,$97,$97), ($cc,$88,$44,$44), ($39,$2e,$17,$17),
+    ($57,$93,$c4,$c4), ($f2,$55,$a7,$a7), ($82,$fc,$7e,$7e), ($47,$7a,$3d,$3d), 
+    ($ac,$c8,$64,$64), ($e7,$ba,$5d,$5d), ($2b,$32,$19,$19), ($95,$e6,$73,$73), 
+    ($a0,$c0,$60,$60), ($98,$19,$81,$81), ($d1,$9e,$4f,$4f), ($7f,$a3,$dc,$dc),
+    ($66,$44,$22,$22), ($7e,$54,$2a,$2a), ($ab,$3b,$90,$90), ($83,$0b,$88,$88), 
+    ($ca,$8c,$46,$46), ($29,$c7,$ee,$ee), ($d3,$6b,$b8,$b8), ($3c,$28,$14,$14),
+    ($79,$a7,$de,$de), ($e2,$bc,$5e,$5e), ($1d,$16,$0b,$0b), ($76,$ad,$db,$db),
+    ($3b,$db,$e0,$e0), ($56,$64,$32,$32), ($4e,$74,$3a,$3a), ($1e,$14,$0a,$0a),
+    ($db,$92,$49,$49), ($0a,$0c,$06,$06), ($6c,$48,$24,$24), ($e4,$b8,$5c,$5c),
+    ($5d,$9f,$c2,$c2), ($6e,$bd,$d3,$d3), ($ef,$43,$ac,$ac), ($a6,$c4,$62,$62),
+    ($a8,$39,$91,$91), ($a4,$31,$95,$95), ($37,$d3,$e4,$e4), ($8b,$f2,$79,$79),
+    ($32,$d5,$e7,$e7), ($43,$8b,$c8,$c8), ($59,$6e,$37,$37), ($b7,$da,$6d,$6d), 
+    ($8c,$01,$8d,$8d), ($64,$b1,$d5,$d5), ($d2,$9c,$4e,$4e), ($e0,$49,$a9,$a9),
+    ($b4,$d8,$6c,$6c), ($fa,$ac,$56,$56), ($07,$f3,$f4,$f4), ($25,$cf,$ea,$ea),
+    ($af,$ca,$65,$65), ($8e,$f4,$7a,$7a), ($e9,$47,$ae,$ae), ($18,$10,$08,$08),
+    ($d5,$6f,$ba,$ba), ($88,$f0,$78,$78), ($6f,$4a,$25,$25), ($72,$5c,$2e,$2e),
+    ($24,$38,$1c,$1c), ($f1,$57,$a6,$a6), ($c7,$73,$b4,$b4), ($51,$97,$c6,$c6),
+    ($23,$cb,$e8,$e8), ($7c,$a1,$dd,$dd), ($9c,$e8,$74,$74), ($21,$3e,$1f,$1f),
+    ($dd,$96,$4b,$4b), ($dc,$61,$bd,$bd), ($86,$0d,$8b,$8b), ($85,$0f,$8a,$8a),
+    ($90,$e0,$70,$70), ($42,$7c,$3e,$3e), ($c4,$71,$b5,$b5), ($aa,$cc,$66,$66),
+    ($d8,$90,$48,$48), ($05,$06,$03,$03), ($01,$f7,$f6,$f6), ($12,$1c,$0e,$0e),
+    ($a3,$c2,$61,$61), ($5f,$6a,$35,$35), ($f9,$ae,$57,$57), ($d0,$69,$b9,$b9),
+    ($91,$17,$86,$86), ($58,$99,$c1,$c1), ($27,$3a,$1d,$1d), ($b9,$27,$9e,$9e),
+    ($38,$d9,$e1,$e1), ($13,$eb,$f8,$f8), ($b3,$2b,$98,$98), ($33,$22,$11,$11),
+    ($bb,$d2,$69,$69), ($70,$a9,$d9,$d9), ($89,$07,$8e,$8e), ($a7,$33,$94,$94),
+    ($b6,$2d,$9b,$9b), ($22,$3c,$1e,$1e), ($92,$15,$87,$87), ($20,$c9,$e9,$e9),
+    ($49,$87,$ce,$ce), ($ff,$aa,$55,$55), ($78,$50,$28,$28), ($7a,$a5,$df,$df),
+    ($8f,$03,$8c,$8c), ($f8,$59,$a1,$a1), ($80,$09,$89,$89), ($17,$1a,$0d,$0d),
+    ($da,$65,$bf,$bf), ($31,$d7,$e6,$e6), ($c6,$84,$42,$42), ($b8,$d0,$68,$68),
+    ($c3,$82,$41,$41), ($b0,$29,$99,$99), ($77,$5a,$2d,$2d), ($11,$1e,$0f,$0f),
+    ($cb,$7b,$b0,$b0), ($fc,$a8,$54,$54), ($d6,$6d,$bb,$bb), ($3a,$2c,$16,$16));
+  T3: array[0..255,0..3] of byte= (
+    ($63,$a5,$c6,$63), ($7c,$84,$f8,$7c), ($77,$99,$ee,$77), ($7b,$8d,$f6,$7b),
+    ($f2,$0d,$ff,$f2), ($6b,$bd,$d6,$6b), ($6f,$b1,$de,$6f), ($c5,$54,$91,$c5),
+    ($30,$50,$60,$30), ($01,$03,$02,$01), ($67,$a9,$ce,$67), ($2b,$7d,$56,$2b),
+    ($fe,$19,$e7,$fe), ($d7,$62,$b5,$d7), ($ab,$e6,$4d,$ab), ($76,$9a,$ec,$76),
+    ($ca,$45,$8f,$ca), ($82,$9d,$1f,$82), ($c9,$40,$89,$c9), ($7d,$87,$fa,$7d),
+    ($fa,$15,$ef,$fa), ($59,$eb,$b2,$59), ($47,$c9,$8e,$47), ($f0,$0b,$fb,$f0),
+    ($ad,$ec,$41,$ad), ($d4,$67,$b3,$d4), ($a2,$fd,$5f,$a2), ($af,$ea,$45,$af),
+    ($9c,$bf,$23,$9c), ($a4,$f7,$53,$a4), ($72,$96,$e4,$72), ($c0,$5b,$9b,$c0),
+    ($b7,$c2,$75,$b7), ($fd,$1c,$e1,$fd), ($93,$ae,$3d,$93), ($26,$6a,$4c,$26), 
+    ($36,$5a,$6c,$36), ($3f,$41,$7e,$3f), ($f7,$02,$f5,$f7), ($cc,$4f,$83,$cc),
+    ($34,$5c,$68,$34), ($a5,$f4,$51,$a5), ($e5,$34,$d1,$e5), ($f1,$08,$f9,$f1), 
+    ($71,$93,$e2,$71), ($d8,$73,$ab,$d8), ($31,$53,$62,$31), ($15,$3f,$2a,$15),
+    ($04,$0c,$08,$04), ($c7,$52,$95,$c7), ($23,$65,$46,$23), ($c3,$5e,$9d,$c3), 
+    ($18,$28,$30,$18), ($96,$a1,$37,$96), ($05,$0f,$0a,$05), ($9a,$b5,$2f,$9a), 
+    ($07,$09,$0e,$07), ($12,$36,$24,$12), ($80,$9b,$1b,$80), ($e2,$3d,$df,$e2), 
+    ($eb,$26,$cd,$eb), ($27,$69,$4e,$27), ($b2,$cd,$7f,$b2), ($75,$9f,$ea,$75),
+    ($09,$1b,$12,$09), ($83,$9e,$1d,$83), ($2c,$74,$58,$2c), ($1a,$2e,$34,$1a), 
+    ($1b,$2d,$36,$1b), ($6e,$b2,$dc,$6e), ($5a,$ee,$b4,$5a), ($a0,$fb,$5b,$a0), 
+    ($52,$f6,$a4,$52), ($3b,$4d,$76,$3b), ($d6,$61,$b7,$d6), ($b3,$ce,$7d,$b3),
+    ($29,$7b,$52,$29), ($e3,$3e,$dd,$e3), ($2f,$71,$5e,$2f), ($84,$97,$13,$84), 
+    ($53,$f5,$a6,$53), ($d1,$68,$b9,$d1), ($00,$00,$00,$00), ($ed,$2c,$c1,$ed),
+    ($20,$60,$40,$20), ($fc,$1f,$e3,$fc), ($b1,$c8,$79,$b1), ($5b,$ed,$b6,$5b), 
+    ($6a,$be,$d4,$6a), ($cb,$46,$8d,$cb), ($be,$d9,$67,$be), ($39,$4b,$72,$39), 
+    ($4a,$de,$94,$4a), ($4c,$d4,$98,$4c), ($58,$e8,$b0,$58), ($cf,$4a,$85,$cf),
+    ($d0,$6b,$bb,$d0), ($ef,$2a,$c5,$ef), ($aa,$e5,$4f,$aa), ($fb,$16,$ed,$fb), 
+    ($43,$c5,$86,$43), ($4d,$d7,$9a,$4d), ($33,$55,$66,$33), ($85,$94,$11,$85), 
+    ($45,$cf,$8a,$45), ($f9,$10,$e9,$f9), ($02,$06,$04,$02), ($7f,$81,$fe,$7f), 
+    ($50,$f0,$a0,$50), ($3c,$44,$78,$3c), ($9f,$ba,$25,$9f), ($a8,$e3,$4b,$a8),
+    ($51,$f3,$a2,$51), ($a3,$fe,$5d,$a3), ($40,$c0,$80,$40), ($8f,$8a,$05,$8f), 
+    ($92,$ad,$3f,$92), ($9d,$bc,$21,$9d), ($38,$48,$70,$38), ($f5,$04,$f1,$f5), 
+    ($bc,$df,$63,$bc), ($b6,$c1,$77,$b6), ($da,$75,$af,$da), ($21,$63,$42,$21),
+    ($10,$30,$20,$10), ($ff,$1a,$e5,$ff), ($f3,$0e,$fd,$f3), ($d2,$6d,$bf,$d2), 
+    ($cd,$4c,$81,$cd), ($0c,$14,$18,$0c), ($13,$35,$26,$13), ($ec,$2f,$c3,$ec), 
+    ($5f,$e1,$be,$5f), ($97,$a2,$35,$97), ($44,$cc,$88,$44), ($17,$39,$2e,$17), 
+    ($c4,$57,$93,$c4), ($a7,$f2,$55,$a7), ($7e,$82,$fc,$7e), ($3d,$47,$7a,$3d),
+    ($64,$ac,$c8,$64), ($5d,$e7,$ba,$5d), ($19,$2b,$32,$19), ($73,$95,$e6,$73), 
+    ($60,$a0,$c0,$60), ($81,$98,$19,$81), ($4f,$d1,$9e,$4f), ($dc,$7f,$a3,$dc), 
+    ($22,$66,$44,$22), ($2a,$7e,$54,$2a), ($90,$ab,$3b,$90), ($88,$83,$0b,$88),
+    ($46,$ca,$8c,$46), ($ee,$29,$c7,$ee), ($b8,$d3,$6b,$b8), ($14,$3c,$28,$14), 
+    ($de,$79,$a7,$de), ($5e,$e2,$bc,$5e), ($0b,$1d,$16,$0b), ($db,$76,$ad,$db), 
+    ($e0,$3b,$db,$e0), ($32,$56,$64,$32), ($3a,$4e,$74,$3a), ($0a,$1e,$14,$0a), 
+    ($49,$db,$92,$49), ($06,$0a,$0c,$06), ($24,$6c,$48,$24), ($5c,$e4,$b8,$5c),
+    ($c2,$5d,$9f,$c2), ($d3,$6e,$bd,$d3), ($ac,$ef,$43,$ac), ($62,$a6,$c4,$62), 
+    ($91,$a8,$39,$91), ($95,$a4,$31,$95), ($e4,$37,$d3,$e4), ($79,$8b,$f2,$79),
+    ($e7,$32,$d5,$e7), ($c8,$43,$8b,$c8), ($37,$59,$6e,$37), ($6d,$b7,$da,$6d), 
+    ($8d,$8c,$01,$8d), ($d5,$64,$b1,$d5), ($4e,$d2,$9c,$4e), ($a9,$e0,$49,$a9), 
+    ($6c,$b4,$d8,$6c), ($56,$fa,$ac,$56), ($f4,$07,$f3,$f4), ($ea,$25,$cf,$ea),
+    ($65,$af,$ca,$65), ($7a,$8e,$f4,$7a), ($ae,$e9,$47,$ae), ($08,$18,$10,$08), 
+    ($ba,$d5,$6f,$ba), ($78,$88,$f0,$78), ($25,$6f,$4a,$25), ($2e,$72,$5c,$2e), 
+    ($1c,$24,$38,$1c), ($a6,$f1,$57,$a6), ($b4,$c7,$73,$b4), ($c6,$51,$97,$c6), 
+    ($e8,$23,$cb,$e8), ($dd,$7c,$a1,$dd), ($74,$9c,$e8,$74), ($1f,$21,$3e,$1f),
+    ($4b,$dd,$96,$4b), ($bd,$dc,$61,$bd), ($8b,$86,$0d,$8b), ($8a,$85,$0f,$8a), 
+    ($70,$90,$e0,$70), ($3e,$42,$7c,$3e), ($b5,$c4,$71,$b5), ($66,$aa,$cc,$66), 
+    ($48,$d8,$90,$48), ($03,$05,$06,$03), ($f6,$01,$f7,$f6), ($0e,$12,$1c,$0e), 
+    ($61,$a3,$c2,$61), ($35,$5f,$6a,$35), ($57,$f9,$ae,$57), ($b9,$d0,$69,$b9), 
+    ($86,$91,$17,$86), ($c1,$58,$99,$c1), ($1d,$27,$3a,$1d), ($9e,$b9,$27,$9e), 
+    ($e1,$38,$d9,$e1), ($f8,$13,$eb,$f8), ($98,$b3,$2b,$98), ($11,$33,$22,$11), 
+    ($69,$bb,$d2,$69), ($d9,$70,$a9,$d9), ($8e,$89,$07,$8e), ($94,$a7,$33,$94),
+    ($9b,$b6,$2d,$9b), ($1e,$22,$3c,$1e), ($87,$92,$15,$87), ($e9,$20,$c9,$e9), 
+    ($ce,$49,$87,$ce), ($55,$ff,$aa,$55), ($28,$78,$50,$28), ($df,$7a,$a5,$df), 
+    ($8c,$8f,$03,$8c), ($a1,$f8,$59,$a1), ($89,$80,$09,$89), ($0d,$17,$1a,$0d), 
+    ($bf,$da,$65,$bf), ($e6,$31,$d7,$e6), ($42,$c6,$84,$42), ($68,$b8,$d0,$68), 
+    ($41,$c3,$82,$41), ($99,$b0,$29,$99), ($2d,$77,$5a,$2d), ($0f,$11,$1e,$0f), 
+    ($b0,$cb,$7b,$b0), ($54,$fc,$a8,$54), ($bb,$d6,$6d,$bb), ($16,$3a,$2c,$16));
+  T4: array[0..255,0..3] of byte= (
+    ($63,$63,$a5,$c6), ($7c,$7c,$84,$f8), ($77,$77,$99,$ee), ($7b,$7b,$8d,$f6),
+    ($f2,$f2,$0d,$ff), ($6b,$6b,$bd,$d6), ($6f,$6f,$b1,$de), ($c5,$c5,$54,$91),
+    ($30,$30,$50,$60), ($01,$01,$03,$02), ($67,$67,$a9,$ce), ($2b,$2b,$7d,$56),
+    ($fe,$fe,$19,$e7), ($d7,$d7,$62,$b5), ($ab,$ab,$e6,$4d), ($76,$76,$9a,$ec), 
+    ($ca,$ca,$45,$8f), ($82,$82,$9d,$1f), ($c9,$c9,$40,$89), ($7d,$7d,$87,$fa), 
+    ($fa,$fa,$15,$ef), ($59,$59,$eb,$b2), ($47,$47,$c9,$8e), ($f0,$f0,$0b,$fb), 
+    ($ad,$ad,$ec,$41), ($d4,$d4,$67,$b3), ($a2,$a2,$fd,$5f), ($af,$af,$ea,$45), 
+    ($9c,$9c,$bf,$23), ($a4,$a4,$f7,$53), ($72,$72,$96,$e4), ($c0,$c0,$5b,$9b), 
+    ($b7,$b7,$c2,$75), ($fd,$fd,$1c,$e1), ($93,$93,$ae,$3d), ($26,$26,$6a,$4c),
+    ($36,$36,$5a,$6c), ($3f,$3f,$41,$7e), ($f7,$f7,$02,$f5), ($cc,$cc,$4f,$83), 
+    ($34,$34,$5c,$68), ($a5,$a5,$f4,$51), ($e5,$e5,$34,$d1), ($f1,$f1,$08,$f9), 
+    ($71,$71,$93,$e2), ($d8,$d8,$73,$ab), ($31,$31,$53,$62), ($15,$15,$3f,$2a), 
+    ($04,$04,$0c,$08), ($c7,$c7,$52,$95), ($23,$23,$65,$46), ($c3,$c3,$5e,$9d), 
+    ($18,$18,$28,$30), ($96,$96,$a1,$37), ($05,$05,$0f,$0a), ($9a,$9a,$b5,$2f),
+    ($07,$07,$09,$0e), ($12,$12,$36,$24), ($80,$80,$9b,$1b), ($e2,$e2,$3d,$df), 
+    ($eb,$eb,$26,$cd), ($27,$27,$69,$4e), ($b2,$b2,$cd,$7f), ($75,$75,$9f,$ea), 
+    ($09,$09,$1b,$12), ($83,$83,$9e,$1d), ($2c,$2c,$74,$58), ($1a,$1a,$2e,$34), 
+    ($1b,$1b,$2d,$36), ($6e,$6e,$b2,$dc), ($5a,$5a,$ee,$b4), ($a0,$a0,$fb,$5b), 
+    ($52,$52,$f6,$a4), ($3b,$3b,$4d,$76), ($d6,$d6,$61,$b7), ($b3,$b3,$ce,$7d),
+    ($29,$29,$7b,$52), ($e3,$e3,$3e,$dd), ($2f,$2f,$71,$5e), ($84,$84,$97,$13), 
+    ($53,$53,$f5,$a6), ($d1,$d1,$68,$b9), ($00,$00,$00,$00), ($ed,$ed,$2c,$c1), 
+    ($20,$20,$60,$40), ($fc,$fc,$1f,$e3), ($b1,$b1,$c8,$79), ($5b,$5b,$ed,$b6), 
+    ($6a,$6a,$be,$d4), ($cb,$cb,$46,$8d), ($be,$be,$d9,$67), ($39,$39,$4b,$72), 
+    ($4a,$4a,$de,$94), ($4c,$4c,$d4,$98), ($58,$58,$e8,$b0), ($cf,$cf,$4a,$85),
+    ($d0,$d0,$6b,$bb), ($ef,$ef,$2a,$c5), ($aa,$aa,$e5,$4f), ($fb,$fb,$16,$ed),
+    ($43,$43,$c5,$86), ($4d,$4d,$d7,$9a), ($33,$33,$55,$66), ($85,$85,$94,$11), 
+    ($45,$45,$cf,$8a), ($f9,$f9,$10,$e9), ($02,$02,$06,$04), ($7f,$7f,$81,$fe), 
+    ($50,$50,$f0,$a0), ($3c,$3c,$44,$78), ($9f,$9f,$ba,$25), ($a8,$a8,$e3,$4b), 
+    ($51,$51,$f3,$a2), ($a3,$a3,$fe,$5d), ($40,$40,$c0,$80), ($8f,$8f,$8a,$05),
+    ($92,$92,$ad,$3f), ($9d,$9d,$bc,$21), ($38,$38,$48,$70), ($f5,$f5,$04,$f1), 
+    ($bc,$bc,$df,$63), ($b6,$b6,$c1,$77), ($da,$da,$75,$af), ($21,$21,$63,$42), 
+    ($10,$10,$30,$20), ($ff,$ff,$1a,$e5), ($f3,$f3,$0e,$fd), ($d2,$d2,$6d,$bf),
+    ($cd,$cd,$4c,$81), ($0c,$0c,$14,$18), ($13,$13,$35,$26), ($ec,$ec,$2f,$c3), 
+    ($5f,$5f,$e1,$be), ($97,$97,$a2,$35), ($44,$44,$cc,$88), ($17,$17,$39,$2e), 
+    ($c4,$c4,$57,$93), ($a7,$a7,$f2,$55), ($7e,$7e,$82,$fc), ($3d,$3d,$47,$7a), 
+    ($64,$64,$ac,$c8), ($5d,$5d,$e7,$ba), ($19,$19,$2b,$32), ($73,$73,$95,$e6), 
+    ($60,$60,$a0,$c0), ($81,$81,$98,$19), ($4f,$4f,$d1,$9e), ($dc,$dc,$7f,$a3),
+    ($22,$22,$66,$44), ($2a,$2a,$7e,$54), ($90,$90,$ab,$3b), ($88,$88,$83,$0b), 
+    ($46,$46,$ca,$8c), ($ee,$ee,$29,$c7), ($b8,$b8,$d3,$6b), ($14,$14,$3c,$28), 
+    ($de,$de,$79,$a7), ($5e,$5e,$e2,$bc), ($0b,$0b,$1d,$16), ($db,$db,$76,$ad), 
+    ($e0,$e0,$3b,$db), ($32,$32,$56,$64), ($3a,$3a,$4e,$74), ($0a,$0a,$1e,$14), 
+    ($49,$49,$db,$92), ($06,$06,$0a,$0c), ($24,$24,$6c,$48), ($5c,$5c,$e4,$b8),
+    ($c2,$c2,$5d,$9f), ($d3,$d3,$6e,$bd), ($ac,$ac,$ef,$43), ($62,$62,$a6,$c4), 
+    ($91,$91,$a8,$39), ($95,$95,$a4,$31), ($e4,$e4,$37,$d3), ($79,$79,$8b,$f2), 
+    ($e7,$e7,$32,$d5), ($c8,$c8,$43,$8b), ($37,$37,$59,$6e), ($6d,$6d,$b7,$da), 
+    ($8d,$8d,$8c,$01), ($d5,$d5,$64,$b1), ($4e,$4e,$d2,$9c), ($a9,$a9,$e0,$49), 
+    ($6c,$6c,$b4,$d8), ($56,$56,$fa,$ac), ($f4,$f4,$07,$f3), ($ea,$ea,$25,$cf),
+    ($65,$65,$af,$ca), ($7a,$7a,$8e,$f4), ($ae,$ae,$e9,$47), ($08,$08,$18,$10),
+    ($ba,$ba,$d5,$6f), ($78,$78,$88,$f0), ($25,$25,$6f,$4a), ($2e,$2e,$72,$5c), 
+    ($1c,$1c,$24,$38), ($a6,$a6,$f1,$57), ($b4,$b4,$c7,$73), ($c6,$c6,$51,$97), 
+    ($e8,$e8,$23,$cb), ($dd,$dd,$7c,$a1), ($74,$74,$9c,$e8), ($1f,$1f,$21,$3e),
+    ($4b,$4b,$dd,$96), ($bd,$bd,$dc,$61), ($8b,$8b,$86,$0d), ($8a,$8a,$85,$0f), 
+    ($70,$70,$90,$e0), ($3e,$3e,$42,$7c), ($b5,$b5,$c4,$71), ($66,$66,$aa,$cc), 
+    ($48,$48,$d8,$90), ($03,$03,$05,$06), ($f6,$f6,$01,$f7), ($0e,$0e,$12,$1c), 
+    ($61,$61,$a3,$c2), ($35,$35,$5f,$6a), ($57,$57,$f9,$ae), ($b9,$b9,$d0,$69),
+    ($86,$86,$91,$17), ($c1,$c1,$58,$99), ($1d,$1d,$27,$3a), ($9e,$9e,$b9,$27), 
+    ($e1,$e1,$38,$d9), ($f8,$f8,$13,$eb), ($98,$98,$b3,$2b), ($11,$11,$33,$22), 
+    ($69,$69,$bb,$d2), ($d9,$d9,$70,$a9), ($8e,$8e,$89,$07), ($94,$94,$a7,$33), 
+    ($9b,$9b,$b6,$2d), ($1e,$1e,$22,$3c), ($87,$87,$92,$15), ($e9,$e9,$20,$c9), 
+    ($ce,$ce,$49,$87), ($55,$55,$ff,$aa), ($28,$28,$78,$50), ($df,$df,$7a,$a5),
+    ($8c,$8c,$8f,$03), ($a1,$a1,$f8,$59), ($89,$89,$80,$09), ($0d,$0d,$17,$1a),
+    ($bf,$bf,$da,$65), ($e6,$e6,$31,$d7), ($42,$42,$c6,$84), ($68,$68,$b8,$d0), 
+    ($41,$41,$c3,$82), ($99,$99,$b0,$29), ($2d,$2d,$77,$5a), ($0f,$0f,$11,$1e), 
+    ($b0,$b0,$cb,$7b), ($54,$54,$fc,$a8), ($bb,$bb,$d6,$6d), ($16,$16,$3a,$2c));
+  T5: array[0..255,0..3] of byte= (
+    ($51,$f4,$a7,$50), ($7e,$41,$65,$53), ($1a,$17,$a4,$c3), ($3a,$27,$5e,$96),
+    ($3b,$ab,$6b,$cb), ($1f,$9d,$45,$f1), ($ac,$fa,$58,$ab), ($4b,$e3,$03,$93),
+    ($20,$30,$fa,$55), ($ad,$76,$6d,$f6), ($88,$cc,$76,$91), ($f5,$02,$4c,$25),
+    ($4f,$e5,$d7,$fc), ($c5,$2a,$cb,$d7), ($26,$35,$44,$80), ($b5,$62,$a3,$8f), 
+    ($de,$b1,$5a,$49), ($25,$ba,$1b,$67), ($45,$ea,$0e,$98), ($5d,$fe,$c0,$e1), 
+    ($c3,$2f,$75,$02), ($81,$4c,$f0,$12), ($8d,$46,$97,$a3), ($6b,$d3,$f9,$c6),
+    ($03,$8f,$5f,$e7), ($15,$92,$9c,$95), ($bf,$6d,$7a,$eb), ($95,$52,$59,$da), 
+    ($d4,$be,$83,$2d), ($58,$74,$21,$d3), ($49,$e0,$69,$29), ($8e,$c9,$c8,$44), 
+    ($75,$c2,$89,$6a), ($f4,$8e,$79,$78), ($99,$58,$3e,$6b), ($27,$b9,$71,$dd), 
+    ($be,$e1,$4f,$b6), ($f0,$88,$ad,$17), ($c9,$20,$ac,$66), ($7d,$ce,$3a,$b4), 
+    ($63,$df,$4a,$18), ($e5,$1a,$31,$82), ($97,$51,$33,$60), ($62,$53,$7f,$45), 
+    ($b1,$64,$77,$e0), ($bb,$6b,$ae,$84), ($fe,$81,$a0,$1c), ($f9,$08,$2b,$94),
+    ($70,$48,$68,$58), ($8f,$45,$fd,$19), ($94,$de,$6c,$87), ($52,$7b,$f8,$b7),
+    ($ab,$73,$d3,$23), ($72,$4b,$02,$e2), ($e3,$1f,$8f,$57), ($66,$55,$ab,$2a), 
+    ($b2,$eb,$28,$07), ($2f,$b5,$c2,$03), ($86,$c5,$7b,$9a), ($d3,$37,$08,$a5), 
+    ($30,$28,$87,$f2), ($23,$bf,$a5,$b2), ($02,$03,$6a,$ba), ($ed,$16,$82,$5c),
+    ($8a,$cf,$1c,$2b), ($a7,$79,$b4,$92), ($f3,$07,$f2,$f0), ($4e,$69,$e2,$a1), 
+    ($65,$da,$f4,$cd), ($06,$05,$be,$d5), ($d1,$34,$62,$1f), ($c4,$a6,$fe,$8a),
+    ($34,$2e,$53,$9d), ($a2,$f3,$55,$a0), ($05,$8a,$e1,$32), ($a4,$f6,$eb,$75),
+    ($0b,$83,$ec,$39), ($40,$60,$ef,$aa), ($5e,$71,$9f,$06), ($bd,$6e,$10,$51), 
+    ($3e,$21,$8a,$f9), ($96,$dd,$06,$3d), ($dd,$3e,$05,$ae), ($4d,$e6,$bd,$46), 
+    ($91,$54,$8d,$b5), ($71,$c4,$5d,$05), ($04,$06,$d4,$6f), ($60,$50,$15,$ff), 
+    ($19,$98,$fb,$24), ($d6,$bd,$e9,$97), ($89,$40,$43,$cc), ($67,$d9,$9e,$77),
+    ($b0,$e8,$42,$bd), ($07,$89,$8b,$88), ($e7,$19,$5b,$38), ($79,$c8,$ee,$db),
+    ($a1,$7c,$0a,$47), ($7c,$42,$0f,$e9), ($f8,$84,$1e,$c9), ($00,$00,$00,$00), 
+    ($09,$80,$86,$83), ($32,$2b,$ed,$48), ($1e,$11,$70,$ac), ($6c,$5a,$72,$4e), 
+    ($fd,$0e,$ff,$fb), ($0f,$85,$38,$56), ($3d,$ae,$d5,$1e), ($36,$2d,$39,$27), 
+    ($0a,$0f,$d9,$64), ($68,$5c,$a6,$21), ($9b,$5b,$54,$d1), ($24,$36,$2e,$3a), 
+    ($0c,$0a,$67,$b1), ($93,$57,$e7,$0f), ($b4,$ee,$96,$d2), ($1b,$9b,$91,$9e),
+    ($80,$c0,$c5,$4f), ($61,$dc,$20,$a2), ($5a,$77,$4b,$69), ($1c,$12,$1a,$16), 
+    ($e2,$93,$ba,$0a), ($c0,$a0,$2a,$e5), ($3c,$22,$e0,$43), ($12,$1b,$17,$1d), 
+    ($0e,$09,$0d,$0b), ($f2,$8b,$c7,$ad), ($2d,$b6,$a8,$b9), ($14,$1e,$a9,$c8), 
+    ($57,$f1,$19,$85), ($af,$75,$07,$4c), ($ee,$99,$dd,$bb), ($a3,$7f,$60,$fd),
+    ($f7,$01,$26,$9f), ($5c,$72,$f5,$bc), ($44,$66,$3b,$c5), ($5b,$fb,$7e,$34), 
+    ($8b,$43,$29,$76), ($cb,$23,$c6,$dc), ($b6,$ed,$fc,$68), ($b8,$e4,$f1,$63), 
+    ($d7,$31,$dc,$ca), ($42,$63,$85,$10), ($13,$97,$22,$40), ($84,$c6,$11,$20),
+    ($85,$4a,$24,$7d), ($d2,$bb,$3d,$f8), ($ae,$f9,$32,$11), ($c7,$29,$a1,$6d), 
+    ($1d,$9e,$2f,$4b), ($dc,$b2,$30,$f3), ($0d,$86,$52,$ec), ($77,$c1,$e3,$d0),
+    ($2b,$b3,$16,$6c), ($a9,$70,$b9,$99), ($11,$94,$48,$fa), ($47,$e9,$64,$22),
+    ($a8,$fc,$8c,$c4), ($a0,$f0,$3f,$1a), ($56,$7d,$2c,$d8), ($22,$33,$90,$ef), 
+    ($87,$49,$4e,$c7), ($d9,$38,$d1,$c1), ($8c,$ca,$a2,$fe), ($98,$d4,$0b,$36),
+    ($a6,$f5,$81,$cf), ($a5,$7a,$de,$28), ($da,$b7,$8e,$26), ($3f,$ad,$bf,$a4),
+    ($2c,$3a,$9d,$e4), ($50,$78,$92,$0d), ($6a,$5f,$cc,$9b), ($54,$7e,$46,$62), 
+    ($f6,$8d,$13,$c2), ($90,$d8,$b8,$e8), ($2e,$39,$f7,$5e), ($82,$c3,$af,$f5), 
+    ($9f,$5d,$80,$be), ($69,$d0,$93,$7c), ($6f,$d5,$2d,$a9), ($cf,$25,$12,$b3), 
+    ($c8,$ac,$99,$3b), ($10,$18,$7d,$a7), ($e8,$9c,$63,$6e), ($db,$3b,$bb,$7b),
+    ($cd,$26,$78,$09), ($6e,$59,$18,$f4), ($ec,$9a,$b7,$01), ($83,$4f,$9a,$a8),
+    ($e6,$95,$6e,$65), ($aa,$ff,$e6,$7e), ($21,$bc,$cf,$08), ($ef,$15,$e8,$e6), 
+    ($ba,$e7,$9b,$d9), ($4a,$6f,$36,$ce), ($ea,$9f,$09,$d4), ($29,$b0,$7c,$d6), 
+    ($31,$a4,$b2,$af), ($2a,$3f,$23,$31), ($c6,$a5,$94,$30), ($35,$a2,$66,$c0), 
+    ($74,$4e,$bc,$37), ($fc,$82,$ca,$a6), ($e0,$90,$d0,$b0), ($33,$a7,$d8,$15), 
+    ($f1,$04,$98,$4a), ($41,$ec,$da,$f7), ($7f,$cd,$50,$0e), ($17,$91,$f6,$2f),
+    ($76,$4d,$d6,$8d), ($43,$ef,$b0,$4d), ($cc,$aa,$4d,$54), ($e4,$96,$04,$df), 
+    ($9e,$d1,$b5,$e3), ($4c,$6a,$88,$1b), ($c1,$2c,$1f,$b8), ($46,$65,$51,$7f), 
+    ($9d,$5e,$ea,$04), ($01,$8c,$35,$5d), ($fa,$87,$74,$73), ($fb,$0b,$41,$2e), 
+    ($b3,$67,$1d,$5a), ($92,$db,$d2,$52), ($e9,$10,$56,$33), ($6d,$d6,$47,$13), 
+    ($9a,$d7,$61,$8c), ($37,$a1,$0c,$7a), ($59,$f8,$14,$8e), ($eb,$13,$3c,$89), 
+    ($ce,$a9,$27,$ee), ($b7,$61,$c9,$35), ($e1,$1c,$e5,$ed), ($7a,$47,$b1,$3c), 
+    ($9c,$d2,$df,$59), ($55,$f2,$73,$3f), ($18,$14,$ce,$79), ($73,$c7,$37,$bf),
+    ($53,$f7,$cd,$ea), ($5f,$fd,$aa,$5b), ($df,$3d,$6f,$14), ($78,$44,$db,$86), 
+    ($ca,$af,$f3,$81), ($b9,$68,$c4,$3e), ($38,$24,$34,$2c), ($c2,$a3,$40,$5f),
+    ($16,$1d,$c3,$72), ($bc,$e2,$25,$0c), ($28,$3c,$49,$8b), ($ff,$0d,$95,$41),
+    ($39,$a8,$01,$71), ($08,$0c,$b3,$de), ($d8,$b4,$e4,$9c), ($64,$56,$c1,$90),
+    ($7b,$cb,$84,$61), ($d5,$32,$b6,$70), ($48,$6c,$5c,$74), ($d0,$b8,$57,$42));
+  T6: array[0..255,0..3] of byte= (
+    ($50,$51,$f4,$a7), ($53,$7e,$41,$65), ($c3,$1a,$17,$a4), ($96,$3a,$27,$5e),
+    ($cb,$3b,$ab,$6b), ($f1,$1f,$9d,$45), ($ab,$ac,$fa,$58), ($93,$4b,$e3,$03),
+    ($55,$20,$30,$fa), ($f6,$ad,$76,$6d), ($91,$88,$cc,$76), ($25,$f5,$02,$4c),
+    ($fc,$4f,$e5,$d7), ($d7,$c5,$2a,$cb), ($80,$26,$35,$44), ($8f,$b5,$62,$a3), 
+    ($49,$de,$b1,$5a), ($67,$25,$ba,$1b), ($98,$45,$ea,$0e), ($e1,$5d,$fe,$c0), 
+    ($02,$c3,$2f,$75), ($12,$81,$4c,$f0), ($a3,$8d,$46,$97), ($c6,$6b,$d3,$f9), 
+    ($e7,$03,$8f,$5f), ($95,$15,$92,$9c), ($eb,$bf,$6d,$7a), ($da,$95,$52,$59), 
+    ($2d,$d4,$be,$83), ($d3,$58,$74,$21), ($29,$49,$e0,$69), ($44,$8e,$c9,$c8), 
+    ($6a,$75,$c2,$89), ($78,$f4,$8e,$79), ($6b,$99,$58,$3e), ($dd,$27,$b9,$71), 
+    ($b6,$be,$e1,$4f), ($17,$f0,$88,$ad), ($66,$c9,$20,$ac), ($b4,$7d,$ce,$3a),
+    ($18,$63,$df,$4a), ($82,$e5,$1a,$31), ($60,$97,$51,$33), ($45,$62,$53,$7f), 
+    ($e0,$b1,$64,$77), ($84,$bb,$6b,$ae), ($1c,$fe,$81,$a0), ($94,$f9,$08,$2b), 
+    ($58,$70,$48,$68), ($19,$8f,$45,$fd), ($87,$94,$de,$6c), ($b7,$52,$7b,$f8), 
+    ($23,$ab,$73,$d3), ($e2,$72,$4b,$02), ($57,$e3,$1f,$8f), ($2a,$66,$55,$ab), 
+    ($07,$b2,$eb,$28), ($03,$2f,$b5,$c2), ($9a,$86,$c5,$7b), ($a5,$d3,$37,$08), 
+    ($f2,$30,$28,$87), ($b2,$23,$bf,$a5), ($ba,$02,$03,$6a), ($5c,$ed,$16,$82), 
+    ($2b,$8a,$cf,$1c), ($92,$a7,$79,$b4), ($f0,$f3,$07,$f2), ($a1,$4e,$69,$e2),
+    ($cd,$65,$da,$f4), ($d5,$06,$05,$be), ($1f,$d1,$34,$62), ($8a,$c4,$a6,$fe),
+    ($9d,$34,$2e,$53), ($a0,$a2,$f3,$55), ($32,$05,$8a,$e1), ($75,$a4,$f6,$eb),
+    ($39,$0b,$83,$ec), ($aa,$40,$60,$ef), ($06,$5e,$71,$9f), ($51,$bd,$6e,$10), 
+    ($f9,$3e,$21,$8a), ($3d,$96,$dd,$06), ($ae,$dd,$3e,$05), ($46,$4d,$e6,$bd), 
+    ($b5,$91,$54,$8d), ($05,$71,$c4,$5d), ($6f,$04,$06,$d4), ($ff,$60,$50,$15), 
+    ($24,$19,$98,$fb), ($97,$d6,$bd,$e9), ($cc,$89,$40,$43), ($77,$67,$d9,$9e),
+    ($bd,$b0,$e8,$42), ($88,$07,$89,$8b), ($38,$e7,$19,$5b), ($db,$79,$c8,$ee),
+    ($47,$a1,$7c,$0a), ($e9,$7c,$42,$0f), ($c9,$f8,$84,$1e), ($00,$00,$00,$00),
+    ($83,$09,$80,$86), ($48,$32,$2b,$ed), ($ac,$1e,$11,$70), ($4e,$6c,$5a,$72), 
+    ($fb,$fd,$0e,$ff), ($56,$0f,$85,$38), ($1e,$3d,$ae,$d5), ($27,$36,$2d,$39), 
+    ($64,$0a,$0f,$d9), ($21,$68,$5c,$a6), ($d1,$9b,$5b,$54), ($3a,$24,$36,$2e), 
+    ($b1,$0c,$0a,$67), ($0f,$93,$57,$e7), ($d2,$b4,$ee,$96), ($9e,$1b,$9b,$91),
+    ($4f,$80,$c0,$c5), ($a2,$61,$dc,$20), ($69,$5a,$77,$4b), ($16,$1c,$12,$1a), 
+    ($0a,$e2,$93,$ba), ($e5,$c0,$a0,$2a), ($43,$3c,$22,$e0), ($1d,$12,$1b,$17), 
+    ($0b,$0e,$09,$0d), ($ad,$f2,$8b,$c7), ($b9,$2d,$b6,$a8), ($c8,$14,$1e,$a9), 
+    ($85,$57,$f1,$19), ($4c,$af,$75,$07), ($bb,$ee,$99,$dd), ($fd,$a3,$7f,$60),
+    ($9f,$f7,$01,$26), ($bc,$5c,$72,$f5), ($c5,$44,$66,$3b), ($34,$5b,$fb,$7e),
+    ($76,$8b,$43,$29), ($dc,$cb,$23,$c6), ($68,$b6,$ed,$fc), ($63,$b8,$e4,$f1), 
+    ($ca,$d7,$31,$dc), ($10,$42,$63,$85), ($40,$13,$97,$22), ($20,$84,$c6,$11), 
+    ($7d,$85,$4a,$24), ($f8,$d2,$bb,$3d), ($11,$ae,$f9,$32), ($6d,$c7,$29,$a1), 
+    ($4b,$1d,$9e,$2f), ($f3,$dc,$b2,$30), ($ec,$0d,$86,$52), ($d0,$77,$c1,$e3), 
+    ($6c,$2b,$b3,$16), ($99,$a9,$70,$b9), ($fa,$11,$94,$48), ($22,$47,$e9,$64), 
+    ($c4,$a8,$fc,$8c), ($1a,$a0,$f0,$3f), ($d8,$56,$7d,$2c), ($ef,$22,$33,$90),
+    ($c7,$87,$49,$4e), ($c1,$d9,$38,$d1), ($fe,$8c,$ca,$a2), ($36,$98,$d4,$0b),
+    ($cf,$a6,$f5,$81), ($28,$a5,$7a,$de), ($26,$da,$b7,$8e), ($a4,$3f,$ad,$bf),
+    ($e4,$2c,$3a,$9d), ($0d,$50,$78,$92), ($9b,$6a,$5f,$cc), ($62,$54,$7e,$46), 
+    ($c2,$f6,$8d,$13), ($e8,$90,$d8,$b8), ($5e,$2e,$39,$f7), ($f5,$82,$c3,$af), 
+    ($be,$9f,$5d,$80), ($7c,$69,$d0,$93), ($a9,$6f,$d5,$2d), ($b3,$cf,$25,$12), 
+    ($3b,$c8,$ac,$99), ($a7,$10,$18,$7d), ($6e,$e8,$9c,$63), ($7b,$db,$3b,$bb),
+    ($09,$cd,$26,$78), ($f4,$6e,$59,$18), ($01,$ec,$9a,$b7), ($a8,$83,$4f,$9a),
+    ($65,$e6,$95,$6e), ($7e,$aa,$ff,$e6), ($08,$21,$bc,$cf), ($e6,$ef,$15,$e8),
+    ($d9,$ba,$e7,$9b), ($ce,$4a,$6f,$36), ($d4,$ea,$9f,$09), ($d6,$29,$b0,$7c),
+    ($af,$31,$a4,$b2), ($31,$2a,$3f,$23), ($30,$c6,$a5,$94), ($c0,$35,$a2,$66),
+    ($37,$74,$4e,$bc), ($a6,$fc,$82,$ca), ($b0,$e0,$90,$d0), ($15,$33,$a7,$d8),
+    ($4a,$f1,$04,$98), ($f7,$41,$ec,$da), ($0e,$7f,$cd,$50), ($2f,$17,$91,$f6),
+    ($8d,$76,$4d,$d6), ($4d,$43,$ef,$b0), ($54,$cc,$aa,$4d), ($df,$e4,$96,$04),
+    ($e3,$9e,$d1,$b5), ($1b,$4c,$6a,$88), ($b8,$c1,$2c,$1f), ($7f,$46,$65,$51),
+    ($04,$9d,$5e,$ea), ($5d,$01,$8c,$35), ($73,$fa,$87,$74), ($2e,$fb,$0b,$41),
+    ($5a,$b3,$67,$1d), ($52,$92,$db,$d2), ($33,$e9,$10,$56), ($13,$6d,$d6,$47),
+    ($8c,$9a,$d7,$61), ($7a,$37,$a1,$0c), ($8e,$59,$f8,$14), ($89,$eb,$13,$3c),
+    ($ee,$ce,$a9,$27), ($35,$b7,$61,$c9), ($ed,$e1,$1c,$e5), ($3c,$7a,$47,$b1),
+    ($59,$9c,$d2,$df), ($3f,$55,$f2,$73), ($79,$18,$14,$ce), ($bf,$73,$c7,$37),
+    ($ea,$53,$f7,$cd), ($5b,$5f,$fd,$aa), ($14,$df,$3d,$6f), ($86,$78,$44,$db),
+    ($81,$ca,$af,$f3), ($3e,$b9,$68,$c4), ($2c,$38,$24,$34), ($5f,$c2,$a3,$40),
+    ($72,$16,$1d,$c3), ($0c,$bc,$e2,$25), ($8b,$28,$3c,$49), ($41,$ff,$0d,$95),
+    ($71,$39,$a8,$01), ($de,$08,$0c,$b3), ($9c,$d8,$b4,$e4), ($90,$64,$56,$c1),
+    ($61,$7b,$cb,$84), ($70,$d5,$32,$b6), ($74,$48,$6c,$5c), ($42,$d0,$b8,$57));
+  T7: array[0..255,0..3] of byte= (
+    ($a7,$50,$51,$f4), ($65,$53,$7e,$41), ($a4,$c3,$1a,$17), ($5e,$96,$3a,$27),
+    ($6b,$cb,$3b,$ab), ($45,$f1,$1f,$9d), ($58,$ab,$ac,$fa), ($03,$93,$4b,$e3),
+    ($fa,$55,$20,$30), ($6d,$f6,$ad,$76), ($76,$91,$88,$cc), ($4c,$25,$f5,$02),
+    ($d7,$fc,$4f,$e5), ($cb,$d7,$c5,$2a), ($44,$80,$26,$35), ($a3,$8f,$b5,$62),
+    ($5a,$49,$de,$b1), ($1b,$67,$25,$ba), ($0e,$98,$45,$ea), ($c0,$e1,$5d,$fe),
+    ($75,$02,$c3,$2f), ($f0,$12,$81,$4c), ($97,$a3,$8d,$46), ($f9,$c6,$6b,$d3),
+    ($5f,$e7,$03,$8f), ($9c,$95,$15,$92), ($7a,$eb,$bf,$6d), ($59,$da,$95,$52),
+    ($83,$2d,$d4,$be), ($21,$d3,$58,$74), ($69,$29,$49,$e0), ($c8,$44,$8e,$c9),
+    ($89,$6a,$75,$c2), ($79,$78,$f4,$8e), ($3e,$6b,$99,$58), ($71,$dd,$27,$b9), 
+    ($4f,$b6,$be,$e1), ($ad,$17,$f0,$88), ($ac,$66,$c9,$20), ($3a,$b4,$7d,$ce), 
+    ($4a,$18,$63,$df), ($31,$82,$e5,$1a), ($33,$60,$97,$51), ($7f,$45,$62,$53), 
+    ($77,$e0,$b1,$64), ($ae,$84,$bb,$6b), ($a0,$1c,$fe,$81), ($2b,$94,$f9,$08),
+    ($68,$58,$70,$48), ($fd,$19,$8f,$45), ($6c,$87,$94,$de), ($f8,$b7,$52,$7b), 
+    ($d3,$23,$ab,$73), ($02,$e2,$72,$4b), ($8f,$57,$e3,$1f), ($ab,$2a,$66,$55),
+    ($28,$07,$b2,$eb), ($c2,$03,$2f,$b5), ($7b,$9a,$86,$c5), ($08,$a5,$d3,$37), 
+    ($87,$f2,$30,$28), ($a5,$b2,$23,$bf), ($6a,$ba,$02,$03), ($82,$5c,$ed,$16),
+    ($1c,$2b,$8a,$cf), ($b4,$92,$a7,$79), ($f2,$f0,$f3,$07), ($e2,$a1,$4e,$69), 
+    ($f4,$cd,$65,$da), ($be,$d5,$06,$05), ($62,$1f,$d1,$34), ($fe,$8a,$c4,$a6), 
+    ($53,$9d,$34,$2e), ($55,$a0,$a2,$f3), ($e1,$32,$05,$8a), ($eb,$75,$a4,$f6),
+    ($ec,$39,$0b,$83), ($ef,$aa,$40,$60), ($9f,$06,$5e,$71), ($10,$51,$bd,$6e),
+    ($8a,$f9,$3e,$21), ($06,$3d,$96,$dd), ($05,$ae,$dd,$3e), ($bd,$46,$4d,$e6),
+    ($8d,$b5,$91,$54), ($5d,$05,$71,$c4), ($d4,$6f,$04,$06), ($15,$ff,$60,$50), 
+    ($fb,$24,$19,$98), ($e9,$97,$d6,$bd), ($43,$cc,$89,$40), ($9e,$77,$67,$d9), 
+    ($42,$bd,$b0,$e8), ($8b,$88,$07,$89), ($5b,$38,$e7,$19), ($ee,$db,$79,$c8),
+    ($0a,$47,$a1,$7c), ($0f,$e9,$7c,$42), ($1e,$c9,$f8,$84), ($00,$00,$00,$00), 
+    ($86,$83,$09,$80), ($ed,$48,$32,$2b), ($70,$ac,$1e,$11), ($72,$4e,$6c,$5a), 
+    ($ff,$fb,$fd,$0e), ($38,$56,$0f,$85), ($d5,$1e,$3d,$ae), ($39,$27,$36,$2d), 
+    ($d9,$64,$0a,$0f), ($a6,$21,$68,$5c), ($54,$d1,$9b,$5b), ($2e,$3a,$24,$36), 
+    ($67,$b1,$0c,$0a), ($e7,$0f,$93,$57), ($96,$d2,$b4,$ee), ($91,$9e,$1b,$9b), 
+    ($c5,$4f,$80,$c0), ($20,$a2,$61,$dc), ($4b,$69,$5a,$77), ($1a,$16,$1c,$12), 
+    ($ba,$0a,$e2,$93), ($2a,$e5,$c0,$a0), ($e0,$43,$3c,$22), ($17,$1d,$12,$1b), 
+    ($0d,$0b,$0e,$09), ($c7,$ad,$f2,$8b), ($a8,$b9,$2d,$b6), ($a9,$c8,$14,$1e), 
+    ($19,$85,$57,$f1), ($07,$4c,$af,$75), ($dd,$bb,$ee,$99), ($60,$fd,$a3,$7f), 
+    ($26,$9f,$f7,$01), ($f5,$bc,$5c,$72), ($3b,$c5,$44,$66), ($7e,$34,$5b,$fb), 
+    ($29,$76,$8b,$43), ($c6,$dc,$cb,$23), ($fc,$68,$b6,$ed), ($f1,$63,$b8,$e4),
+    ($dc,$ca,$d7,$31), ($85,$10,$42,$63), ($22,$40,$13,$97), ($11,$20,$84,$c6), 
+    ($24,$7d,$85,$4a), ($3d,$f8,$d2,$bb), ($32,$11,$ae,$f9), ($a1,$6d,$c7,$29),
+    ($2f,$4b,$1d,$9e), ($30,$f3,$dc,$b2), ($52,$ec,$0d,$86), ($e3,$d0,$77,$c1),
+    ($16,$6c,$2b,$b3), ($b9,$99,$a9,$70), ($48,$fa,$11,$94), ($64,$22,$47,$e9), 
+    ($8c,$c4,$a8,$fc), ($3f,$1a,$a0,$f0), ($2c,$d8,$56,$7d), ($90,$ef,$22,$33), 
+    ($4e,$c7,$87,$49), ($d1,$c1,$d9,$38), ($a2,$fe,$8c,$ca), ($0b,$36,$98,$d4), 
+    ($81,$cf,$a6,$f5), ($de,$28,$a5,$7a), ($8e,$26,$da,$b7), ($bf,$a4,$3f,$ad),
+    ($9d,$e4,$2c,$3a), ($92,$0d,$50,$78), ($cc,$9b,$6a,$5f), ($46,$62,$54,$7e),
+    ($13,$c2,$f6,$8d), ($b8,$e8,$90,$d8), ($f7,$5e,$2e,$39), ($af,$f5,$82,$c3),
+    ($80,$be,$9f,$5d), ($93,$7c,$69,$d0), ($2d,$a9,$6f,$d5), ($12,$b3,$cf,$25),
+    ($99,$3b,$c8,$ac), ($7d,$a7,$10,$18), ($63,$6e,$e8,$9c), ($bb,$7b,$db,$3b),
+    ($78,$09,$cd,$26), ($18,$f4,$6e,$59), ($b7,$01,$ec,$9a), ($9a,$a8,$83,$4f),
+    ($6e,$65,$e6,$95), ($e6,$7e,$aa,$ff), ($cf,$08,$21,$bc), ($e8,$e6,$ef,$15), 
+    ($9b,$d9,$ba,$e7), ($36,$ce,$4a,$6f), ($09,$d4,$ea,$9f), ($7c,$d6,$29,$b0), 
+    ($b2,$af,$31,$a4), ($23,$31,$2a,$3f), ($94,$30,$c6,$a5), ($66,$c0,$35,$a2),
+    ($bc,$37,$74,$4e), ($ca,$a6,$fc,$82), ($d0,$b0,$e0,$90), ($d8,$15,$33,$a7), 
+    ($98,$4a,$f1,$04), ($da,$f7,$41,$ec), ($50,$0e,$7f,$cd), ($f6,$2f,$17,$91),
+    ($d6,$8d,$76,$4d), ($b0,$4d,$43,$ef), ($4d,$54,$cc,$aa), ($04,$df,$e4,$96),
+    ($b5,$e3,$9e,$d1), ($88,$1b,$4c,$6a), ($1f,$b8,$c1,$2c), ($51,$7f,$46,$65), 
+    ($ea,$04,$9d,$5e), ($35,$5d,$01,$8c), ($74,$73,$fa,$87), ($41,$2e,$fb,$0b), 
+    ($1d,$5a,$b3,$67), ($d2,$52,$92,$db), ($56,$33,$e9,$10), ($47,$13,$6d,$d6),
+    ($61,$8c,$9a,$d7), ($0c,$7a,$37,$a1), ($14,$8e,$59,$f8), ($3c,$89,$eb,$13), 
+    ($27,$ee,$ce,$a9), ($c9,$35,$b7,$61), ($e5,$ed,$e1,$1c), ($b1,$3c,$7a,$47),
+    ($df,$59,$9c,$d2), ($73,$3f,$55,$f2), ($ce,$79,$18,$14), ($37,$bf,$73,$c7),
+    ($cd,$ea,$53,$f7), ($aa,$5b,$5f,$fd), ($6f,$14,$df,$3d), ($db,$86,$78,$44),
+    ($f3,$81,$ca,$af), ($c4,$3e,$b9,$68), ($34,$2c,$38,$24), ($40,$5f,$c2,$a3),
+    ($c3,$72,$16,$1d), ($25,$0c,$bc,$e2), ($49,$8b,$28,$3c), ($95,$41,$ff,$0d),
+    ($01,$71,$39,$a8), ($b3,$de,$08,$0c), ($e4,$9c,$d8,$b4), ($c1,$90,$64,$56),
+    ($84,$61,$7b,$cb), ($b6,$70,$d5,$32), ($5c,$74,$48,$6c), ($57,$42,$d0,$b8));
+  T8: array[0..255,0..3] of byte= (
+    ($f4,$a7,$50,$51), ($41,$65,$53,$7e), ($17,$a4,$c3,$1a), ($27,$5e,$96,$3a),
+    ($ab,$6b,$cb,$3b), ($9d,$45,$f1,$1f), ($fa,$58,$ab,$ac), ($e3,$03,$93,$4b),
+    ($30,$fa,$55,$20), ($76,$6d,$f6,$ad), ($cc,$76,$91,$88), ($02,$4c,$25,$f5),
+    ($e5,$d7,$fc,$4f), ($2a,$cb,$d7,$c5), ($35,$44,$80,$26), ($62,$a3,$8f,$b5), 
+    ($b1,$5a,$49,$de), ($ba,$1b,$67,$25), ($ea,$0e,$98,$45), ($fe,$c0,$e1,$5d), 
+    ($2f,$75,$02,$c3), ($4c,$f0,$12,$81), ($46,$97,$a3,$8d), ($d3,$f9,$c6,$6b), 
+    ($8f,$5f,$e7,$03), ($92,$9c,$95,$15), ($6d,$7a,$eb,$bf), ($52,$59,$da,$95), 
+    ($be,$83,$2d,$d4), ($74,$21,$d3,$58), ($e0,$69,$29,$49), ($c9,$c8,$44,$8e),
+    ($c2,$89,$6a,$75), ($8e,$79,$78,$f4), ($58,$3e,$6b,$99), ($b9,$71,$dd,$27), 
+    ($e1,$4f,$b6,$be), ($88,$ad,$17,$f0), ($20,$ac,$66,$c9), ($ce,$3a,$b4,$7d), 
+    ($df,$4a,$18,$63), ($1a,$31,$82,$e5), ($51,$33,$60,$97), ($53,$7f,$45,$62), 
+    ($64,$77,$e0,$b1), ($6b,$ae,$84,$bb), ($81,$a0,$1c,$fe), ($08,$2b,$94,$f9), 
+    ($48,$68,$58,$70), ($45,$fd,$19,$8f), ($de,$6c,$87,$94), ($7b,$f8,$b7,$52), 
+    ($73,$d3,$23,$ab), ($4b,$02,$e2,$72), ($1f,$8f,$57,$e3), ($55,$ab,$2a,$66), 
+    ($eb,$28,$07,$b2), ($b5,$c2,$03,$2f), ($c5,$7b,$9a,$86), ($37,$08,$a5,$d3),
+    ($28,$87,$f2,$30), ($bf,$a5,$b2,$23), ($03,$6a,$ba,$02), ($16,$82,$5c,$ed), 
+    ($cf,$1c,$2b,$8a), ($79,$b4,$92,$a7), ($07,$f2,$f0,$f3), ($69,$e2,$a1,$4e), 
+    ($da,$f4,$cd,$65), ($05,$be,$d5,$06), ($34,$62,$1f,$d1), ($a6,$fe,$8a,$c4),
+    ($2e,$53,$9d,$34), ($f3,$55,$a0,$a2), ($8a,$e1,$32,$05), ($f6,$eb,$75,$a4),
+    ($83,$ec,$39,$0b), ($60,$ef,$aa,$40), ($71,$9f,$06,$5e), ($6e,$10,$51,$bd), 
+    ($21,$8a,$f9,$3e), ($dd,$06,$3d,$96), ($3e,$05,$ae,$dd), ($e6,$bd,$46,$4d), 
+    ($54,$8d,$b5,$91), ($c4,$5d,$05,$71), ($06,$d4,$6f,$04), ($50,$15,$ff,$60),
+    ($98,$fb,$24,$19), ($bd,$e9,$97,$d6), ($40,$43,$cc,$89), ($d9,$9e,$77,$67), 
+    ($e8,$42,$bd,$b0), ($89,$8b,$88,$07), ($19,$5b,$38,$e7), ($c8,$ee,$db,$79),
+    ($7c,$0a,$47,$a1), ($42,$0f,$e9,$7c), ($84,$1e,$c9,$f8), ($00,$00,$00,$00),
+    ($80,$86,$83,$09), ($2b,$ed,$48,$32), ($11,$70,$ac,$1e), ($5a,$72,$4e,$6c), 
+    ($0e,$ff,$fb,$fd), ($85,$38,$56,$0f), ($ae,$d5,$1e,$3d), ($2d,$39,$27,$36), 
+    ($0f,$d9,$64,$0a), ($5c,$a6,$21,$68), ($5b,$54,$d1,$9b), ($36,$2e,$3a,$24), 
+    ($0a,$67,$b1,$0c), ($57,$e7,$0f,$93), ($ee,$96,$d2,$b4), ($9b,$91,$9e,$1b),
+    ($c0,$c5,$4f,$80), ($dc,$20,$a2,$61), ($77,$4b,$69,$5a), ($12,$1a,$16,$1c), 
+    ($93,$ba,$0a,$e2), ($a0,$2a,$e5,$c0), ($22,$e0,$43,$3c), ($1b,$17,$1d,$12), 
+    ($09,$0d,$0b,$0e), ($8b,$c7,$ad,$f2), ($b6,$a8,$b9,$2d), ($1e,$a9,$c8,$14), 
+    ($f1,$19,$85,$57), ($75,$07,$4c,$af), ($99,$dd,$bb,$ee), ($7f,$60,$fd,$a3), 
+    ($01,$26,$9f,$f7), ($72,$f5,$bc,$5c), ($66,$3b,$c5,$44), ($fb,$7e,$34,$5b), 
+    ($43,$29,$76,$8b), ($23,$c6,$dc,$cb), ($ed,$fc,$68,$b6), ($e4,$f1,$63,$b8), 
+    ($31,$dc,$ca,$d7), ($63,$85,$10,$42), ($97,$22,$40,$13), ($c6,$11,$20,$84),
+    ($4a,$24,$7d,$85), ($bb,$3d,$f8,$d2), ($f9,$32,$11,$ae), ($29,$a1,$6d,$c7), 
+    ($9e,$2f,$4b,$1d), ($b2,$30,$f3,$dc), ($86,$52,$ec,$0d), ($c1,$e3,$d0,$77), 
+    ($b3,$16,$6c,$2b), ($70,$b9,$99,$a9), ($94,$48,$fa,$11), ($e9,$64,$22,$47), 
+    ($fc,$8c,$c4,$a8), ($f0,$3f,$1a,$a0), ($7d,$2c,$d8,$56), ($33,$90,$ef,$22), 
+    ($49,$4e,$c7,$87), ($38,$d1,$c1,$d9), ($ca,$a2,$fe,$8c), ($d4,$0b,$36,$98),
+    ($f5,$81,$cf,$a6), ($7a,$de,$28,$a5), ($b7,$8e,$26,$da), ($ad,$bf,$a4,$3f),
+    ($3a,$9d,$e4,$2c), ($78,$92,$0d,$50), ($5f,$cc,$9b,$6a), ($7e,$46,$62,$54),
+    ($8d,$13,$c2,$f6), ($d8,$b8,$e8,$90), ($39,$f7,$5e,$2e), ($c3,$af,$f5,$82), 
+    ($5d,$80,$be,$9f), ($d0,$93,$7c,$69), ($d5,$2d,$a9,$6f), ($25,$12,$b3,$cf),
+    ($ac,$99,$3b,$c8), ($18,$7d,$a7,$10), ($9c,$63,$6e,$e8), ($3b,$bb,$7b,$db), 
+    ($26,$78,$09,$cd), ($59,$18,$f4,$6e), ($9a,$b7,$01,$ec), ($4f,$9a,$a8,$83),
+    ($95,$6e,$65,$e6), ($ff,$e6,$7e,$aa), ($bc,$cf,$08,$21), ($15,$e8,$e6,$ef),
+    ($e7,$9b,$d9,$ba), ($6f,$36,$ce,$4a), ($9f,$09,$d4,$ea), ($b0,$7c,$d6,$29), 
+    ($a4,$b2,$af,$31), ($3f,$23,$31,$2a), ($a5,$94,$30,$c6), ($a2,$66,$c0,$35),
+    ($4e,$bc,$37,$74), ($82,$ca,$a6,$fc), ($90,$d0,$b0,$e0), ($a7,$d8,$15,$33),
+    ($04,$98,$4a,$f1), ($ec,$da,$f7,$41), ($cd,$50,$0e,$7f), ($91,$f6,$2f,$17),
+    ($4d,$d6,$8d,$76), ($ef,$b0,$4d,$43), ($aa,$4d,$54,$cc), ($96,$04,$df,$e4),
+    ($d1,$b5,$e3,$9e), ($6a,$88,$1b,$4c), ($2c,$1f,$b8,$c1), ($65,$51,$7f,$46), 
+    ($5e,$ea,$04,$9d), ($8c,$35,$5d,$01), ($87,$74,$73,$fa), ($0b,$41,$2e,$fb),
+    ($67,$1d,$5a,$b3), ($db,$d2,$52,$92), ($10,$56,$33,$e9), ($d6,$47,$13,$6d),
+    ($d7,$61,$8c,$9a), ($a1,$0c,$7a,$37), ($f8,$14,$8e,$59), ($13,$3c,$89,$eb), 
+    ($a9,$27,$ee,$ce), ($61,$c9,$35,$b7), ($1c,$e5,$ed,$e1), ($47,$b1,$3c,$7a),
+    ($d2,$df,$59,$9c), ($f2,$73,$3f,$55), ($14,$ce,$79,$18), ($c7,$37,$bf,$73),
+    ($f7,$cd,$ea,$53), ($fd,$aa,$5b,$5f), ($3d,$6f,$14,$df), ($44,$db,$86,$78),
+    ($af,$f3,$81,$ca), ($68,$c4,$3e,$b9), ($24,$34,$2c,$38), ($a3,$40,$5f,$c2),
+    ($1d,$c3,$72,$16), ($e2,$25,$0c,$bc), ($3c,$49,$8b,$28), ($0d,$95,$41,$ff),
+    ($a8,$01,$71,$39), ($0c,$b3,$de,$08), ($b4,$e4,$9c,$d8), ($56,$c1,$90,$64),
+    ($cb,$84,$61,$7b), ($32,$b6,$70,$d5), ($6c,$5c,$74,$48), ($b8,$57,$42,$d0));
+  S5: array[0..255] of byte= (
+    $52,$09,$6a,$d5,
+    $30,$36,$a5,$38,
+    $bf,$40,$a3,$9e,
+    $81,$f3,$d7,$fb,
+    $7c,$e3,$39,$82,
+    $9b,$2f,$ff,$87,
+    $34,$8e,$43,$44,
+    $c4,$de,$e9,$cb,
+    $54,$7b,$94,$32,
+    $a6,$c2,$23,$3d,
+    $ee,$4c,$95,$0b,
+    $42,$fa,$c3,$4e,
+    $08,$2e,$a1,$66,
+    $28,$d9,$24,$b2,
+    $76,$5b,$a2,$49,
+    $6d,$8b,$d1,$25,
+    $72,$f8,$f6,$64,
+    $86,$68,$98,$16,
+    $d4,$a4,$5c,$cc,
+    $5d,$65,$b6,$92,
+    $6c,$70,$48,$50,
+    $fd,$ed,$b9,$da,
+    $5e,$15,$46,$57,
+    $a7,$8d,$9d,$84,
+    $90,$d8,$ab,$00,
+    $8c,$bc,$d3,$0a,
+    $f7,$e4,$58,$05,
+    $b8,$b3,$45,$06,
+    $d0,$2c,$1e,$8f,
+    $ca,$3f,$0f,$02,
+    $c1,$af,$bd,$03,
+    $01,$13,$8a,$6b,
+    $3a,$91,$11,$41,
+    $4f,$67,$dc,$ea,
+    $97,$f2,$cf,$ce,
+    $f0,$b4,$e6,$73,
+    $96,$ac,$74,$22,
+    $e7,$ad,$35,$85,
+    $e2,$f9,$37,$e8,
+    $1c,$75,$df,$6e,
+    $47,$f1,$1a,$71,
+    $1d,$29,$c5,$89,
+    $6f,$b7,$62,$0e,
+    $aa,$18,$be,$1b,
+    $fc,$56,$3e,$4b,
+    $c6,$d2,$79,$20,
+    $9a,$db,$c0,$fe,
+    $78,$cd,$5a,$f4,
+    $1f,$dd,$a8,$33,
+    $88,$07,$c7,$31,
+    $b1,$12,$10,$59,
+    $27,$80,$ec,$5f,
+    $60,$51,$7f,$a9,
+    $19,$b5,$4a,$0d,
+    $2d,$e5,$7a,$9f,
+    $93,$c9,$9c,$ef,
+    $a0,$e0,$3b,$4d,
+    $ae,$2a,$f5,$b0,
+    $c8,$eb,$bb,$3c,
+    $83,$53,$99,$61,
+    $17,$2b,$04,$7e,
+    $ba,$77,$d6,$26,
+    $e1,$69,$14,$63,
+    $55,$21,$0c,$7d);
+  U1: array[0..255,0..3] of byte= (
+    ($00,$00,$00,$00), ($0e,$09,$0d,$0b), ($1c,$12,$1a,$16), ($12,$1b,$17,$1d),
+    ($38,$24,$34,$2c), ($36,$2d,$39,$27), ($24,$36,$2e,$3a), ($2a,$3f,$23,$31),
+    ($70,$48,$68,$58), ($7e,$41,$65,$53), ($6c,$5a,$72,$4e), ($62,$53,$7f,$45),
+    ($48,$6c,$5c,$74), ($46,$65,$51,$7f), ($54,$7e,$46,$62), ($5a,$77,$4b,$69),
+    ($e0,$90,$d0,$b0), ($ee,$99,$dd,$bb), ($fc,$82,$ca,$a6), ($f2,$8b,$c7,$ad),
+    ($d8,$b4,$e4,$9c), ($d6,$bd,$e9,$97), ($c4,$a6,$fe,$8a), ($ca,$af,$f3,$81), 
+    ($90,$d8,$b8,$e8), ($9e,$d1,$b5,$e3), ($8c,$ca,$a2,$fe), ($82,$c3,$af,$f5),
+    ($a8,$fc,$8c,$c4), ($a6,$f5,$81,$cf), ($b4,$ee,$96,$d2), ($ba,$e7,$9b,$d9),
+    ($db,$3b,$bb,$7b), ($d5,$32,$b6,$70), ($c7,$29,$a1,$6d), ($c9,$20,$ac,$66),
+    ($e3,$1f,$8f,$57), ($ed,$16,$82,$5c), ($ff,$0d,$95,$41), ($f1,$04,$98,$4a),
+    ($ab,$73,$d3,$23), ($a5,$7a,$de,$28), ($b7,$61,$c9,$35), ($b9,$68,$c4,$3e),
+    ($93,$57,$e7,$0f), ($9d,$5e,$ea,$04), ($8f,$45,$fd,$19), ($81,$4c,$f0,$12),
+    ($3b,$ab,$6b,$cb), ($35,$a2,$66,$c0), ($27,$b9,$71,$dd), ($29,$b0,$7c,$d6),
+    ($03,$8f,$5f,$e7), ($0d,$86,$52,$ec), ($1f,$9d,$45,$f1), ($11,$94,$48,$fa),
+    ($4b,$e3,$03,$93), ($45,$ea,$0e,$98), ($57,$f1,$19,$85), ($59,$f8,$14,$8e),
+    ($73,$c7,$37,$bf), ($7d,$ce,$3a,$b4), ($6f,$d5,$2d,$a9), ($61,$dc,$20,$a2),
+    ($ad,$76,$6d,$f6), ($a3,$7f,$60,$fd), ($b1,$64,$77,$e0), ($bf,$6d,$7a,$eb),
+    ($95,$52,$59,$da), ($9b,$5b,$54,$d1), ($89,$40,$43,$cc), ($87,$49,$4e,$c7),
+    ($dd,$3e,$05,$ae), ($d3,$37,$08,$a5), ($c1,$2c,$1f,$b8), ($cf,$25,$12,$b3),
+    ($e5,$1a,$31,$82), ($eb,$13,$3c,$89), ($f9,$08,$2b,$94), ($f7,$01,$26,$9f),
+    ($4d,$e6,$bd,$46), ($43,$ef,$b0,$4d), ($51,$f4,$a7,$50), ($5f,$fd,$aa,$5b),
+    ($75,$c2,$89,$6a), ($7b,$cb,$84,$61), ($69,$d0,$93,$7c), ($67,$d9,$9e,$77), 
+    ($3d,$ae,$d5,$1e), ($33,$a7,$d8,$15), ($21,$bc,$cf,$08), ($2f,$b5,$c2,$03),
+    ($05,$8a,$e1,$32), ($0b,$83,$ec,$39), ($19,$98,$fb,$24), ($17,$91,$f6,$2f),
+    ($76,$4d,$d6,$8d), ($78,$44,$db,$86), ($6a,$5f,$cc,$9b), ($64,$56,$c1,$90),
+    ($4e,$69,$e2,$a1), ($40,$60,$ef,$aa), ($52,$7b,$f8,$b7), ($5c,$72,$f5,$bc),
+    ($06,$05,$be,$d5), ($08,$0c,$b3,$de), ($1a,$17,$a4,$c3), ($14,$1e,$a9,$c8), 
+    ($3e,$21,$8a,$f9), ($30,$28,$87,$f2), ($22,$33,$90,$ef), ($2c,$3a,$9d,$e4), 
+    ($96,$dd,$06,$3d), ($98,$d4,$0b,$36), ($8a,$cf,$1c,$2b), ($84,$c6,$11,$20),
+    ($ae,$f9,$32,$11), ($a0,$f0,$3f,$1a), ($b2,$eb,$28,$07), ($bc,$e2,$25,$0c),
+    ($e6,$95,$6e,$65), ($e8,$9c,$63,$6e), ($fa,$87,$74,$73), ($f4,$8e,$79,$78), 
+    ($de,$b1,$5a,$49), ($d0,$b8,$57,$42), ($c2,$a3,$40,$5f), ($cc,$aa,$4d,$54),
+    ($41,$ec,$da,$f7), ($4f,$e5,$d7,$fc), ($5d,$fe,$c0,$e1), ($53,$f7,$cd,$ea),
+    ($79,$c8,$ee,$db), ($77,$c1,$e3,$d0), ($65,$da,$f4,$cd), ($6b,$d3,$f9,$c6), 
+    ($31,$a4,$b2,$af), ($3f,$ad,$bf,$a4), ($2d,$b6,$a8,$b9), ($23,$bf,$a5,$b2), 
+    ($09,$80,$86,$83), ($07,$89,$8b,$88), ($15,$92,$9c,$95), ($1b,$9b,$91,$9e), 
+    ($a1,$7c,$0a,$47), ($af,$75,$07,$4c), ($bd,$6e,$10,$51), ($b3,$67,$1d,$5a), 
+    ($99,$58,$3e,$6b), ($97,$51,$33,$60), ($85,$4a,$24,$7d), ($8b,$43,$29,$76),
+    ($d1,$34,$62,$1f), ($df,$3d,$6f,$14), ($cd,$26,$78,$09), ($c3,$2f,$75,$02), 
+    ($e9,$10,$56,$33), ($e7,$19,$5b,$38), ($f5,$02,$4c,$25), ($fb,$0b,$41,$2e), 
+    ($9a,$d7,$61,$8c), ($94,$de,$6c,$87), ($86,$c5,$7b,$9a), ($88,$cc,$76,$91),
+    ($a2,$f3,$55,$a0), ($ac,$fa,$58,$ab), ($be,$e1,$4f,$b6), ($b0,$e8,$42,$bd),
+    ($ea,$9f,$09,$d4), ($e4,$96,$04,$df), ($f6,$8d,$13,$c2), ($f8,$84,$1e,$c9), 
+    ($d2,$bb,$3d,$f8), ($dc,$b2,$30,$f3), ($ce,$a9,$27,$ee), ($c0,$a0,$2a,$e5), 
+    ($7a,$47,$b1,$3c), ($74,$4e,$bc,$37), ($66,$55,$ab,$2a), ($68,$5c,$a6,$21), 
+    ($42,$63,$85,$10), ($4c,$6a,$88,$1b), ($5e,$71,$9f,$06), ($50,$78,$92,$0d),
+    ($0a,$0f,$d9,$64), ($04,$06,$d4,$6f), ($16,$1d,$c3,$72), ($18,$14,$ce,$79),
+    ($32,$2b,$ed,$48), ($3c,$22,$e0,$43), ($2e,$39,$f7,$5e), ($20,$30,$fa,$55),
+    ($ec,$9a,$b7,$01), ($e2,$93,$ba,$0a), ($f0,$88,$ad,$17), ($fe,$81,$a0,$1c),
+    ($d4,$be,$83,$2d), ($da,$b7,$8e,$26), ($c8,$ac,$99,$3b), ($c6,$a5,$94,$30), 
+    ($9c,$d2,$df,$59), ($92,$db,$d2,$52), ($80,$c0,$c5,$4f), ($8e,$c9,$c8,$44),
+    ($a4,$f6,$eb,$75), ($aa,$ff,$e6,$7e), ($b8,$e4,$f1,$63), ($b6,$ed,$fc,$68), 
+    ($0c,$0a,$67,$b1), ($02,$03,$6a,$ba), ($10,$18,$7d,$a7), ($1e,$11,$70,$ac),
+    ($34,$2e,$53,$9d), ($3a,$27,$5e,$96), ($28,$3c,$49,$8b), ($26,$35,$44,$80), 
+    ($7c,$42,$0f,$e9), ($72,$4b,$02,$e2), ($60,$50,$15,$ff), ($6e,$59,$18,$f4),
+    ($44,$66,$3b,$c5), ($4a,$6f,$36,$ce), ($58,$74,$21,$d3), ($56,$7d,$2c,$d8),
+    ($37,$a1,$0c,$7a), ($39,$a8,$01,$71), ($2b,$b3,$16,$6c), ($25,$ba,$1b,$67), 
+    ($0f,$85,$38,$56), ($01,$8c,$35,$5d), ($13,$97,$22,$40), ($1d,$9e,$2f,$4b),
+    ($47,$e9,$64,$22), ($49,$e0,$69,$29), ($5b,$fb,$7e,$34), ($55,$f2,$73,$3f),
+    ($7f,$cd,$50,$0e), ($71,$c4,$5d,$05), ($63,$df,$4a,$18), ($6d,$d6,$47,$13),
+    ($d7,$31,$dc,$ca), ($d9,$38,$d1,$c1), ($cb,$23,$c6,$dc), ($c5,$2a,$cb,$d7),
+    ($ef,$15,$e8,$e6), ($e1,$1c,$e5,$ed), ($f3,$07,$f2,$f0), ($fd,$0e,$ff,$fb),
+    ($a7,$79,$b4,$92), ($a9,$70,$b9,$99), ($bb,$6b,$ae,$84), ($b5,$62,$a3,$8f),
+    ($9f,$5d,$80,$be), ($91,$54,$8d,$b5), ($83,$4f,$9a,$a8), ($8d,$46,$97,$a3));
+  U2: array[0..255,0..3] of byte= (
+    ($00,$00,$00,$00), ($0b,$0e,$09,$0d), ($16,$1c,$12,$1a), ($1d,$12,$1b,$17),
+    ($2c,$38,$24,$34), ($27,$36,$2d,$39), ($3a,$24,$36,$2e), ($31,$2a,$3f,$23),
+    ($58,$70,$48,$68), ($53,$7e,$41,$65), ($4e,$6c,$5a,$72), ($45,$62,$53,$7f),
+    ($74,$48,$6c,$5c), ($7f,$46,$65,$51), ($62,$54,$7e,$46), ($69,$5a,$77,$4b),
+    ($b0,$e0,$90,$d0), ($bb,$ee,$99,$dd), ($a6,$fc,$82,$ca), ($ad,$f2,$8b,$c7),
+    ($9c,$d8,$b4,$e4), ($97,$d6,$bd,$e9), ($8a,$c4,$a6,$fe), ($81,$ca,$af,$f3),
+    ($e8,$90,$d8,$b8), ($e3,$9e,$d1,$b5), ($fe,$8c,$ca,$a2), ($f5,$82,$c3,$af), 
+    ($c4,$a8,$fc,$8c), ($cf,$a6,$f5,$81), ($d2,$b4,$ee,$96), ($d9,$ba,$e7,$9b), 
+    ($7b,$db,$3b,$bb), ($70,$d5,$32,$b6), ($6d,$c7,$29,$a1), ($66,$c9,$20,$ac),
+    ($57,$e3,$1f,$8f), ($5c,$ed,$16,$82), ($41,$ff,$0d,$95), ($4a,$f1,$04,$98), 
+    ($23,$ab,$73,$d3), ($28,$a5,$7a,$de), ($35,$b7,$61,$c9), ($3e,$b9,$68,$c4), 
+    ($0f,$93,$57,$e7), ($04,$9d,$5e,$ea), ($19,$8f,$45,$fd), ($12,$81,$4c,$f0),
+    ($cb,$3b,$ab,$6b), ($c0,$35,$a2,$66), ($dd,$27,$b9,$71), ($d6,$29,$b0,$7c),
+    ($e7,$03,$8f,$5f), ($ec,$0d,$86,$52), ($f1,$1f,$9d,$45), ($fa,$11,$94,$48),
+    ($93,$4b,$e3,$03), ($98,$45,$ea,$0e), ($85,$57,$f1,$19), ($8e,$59,$f8,$14), 
+    ($bf,$73,$c7,$37), ($b4,$7d,$ce,$3a), ($a9,$6f,$d5,$2d), ($a2,$61,$dc,$20),
+    ($f6,$ad,$76,$6d), ($fd,$a3,$7f,$60), ($e0,$b1,$64,$77), ($eb,$bf,$6d,$7a),
+    ($da,$95,$52,$59), ($d1,$9b,$5b,$54), ($cc,$89,$40,$43), ($c7,$87,$49,$4e), 
+    ($ae,$dd,$3e,$05), ($a5,$d3,$37,$08), ($b8,$c1,$2c,$1f), ($b3,$cf,$25,$12),
+    ($82,$e5,$1a,$31), ($89,$eb,$13,$3c), ($94,$f9,$08,$2b), ($9f,$f7,$01,$26), 
+    ($46,$4d,$e6,$bd), ($4d,$43,$ef,$b0), ($50,$51,$f4,$a7), ($5b,$5f,$fd,$aa), 
+    ($6a,$75,$c2,$89), ($61,$7b,$cb,$84), ($7c,$69,$d0,$93), ($77,$67,$d9,$9e), 
+    ($1e,$3d,$ae,$d5), ($15,$33,$a7,$d8), ($08,$21,$bc,$cf), ($03,$2f,$b5,$c2), 
+    ($32,$05,$8a,$e1), ($39,$0b,$83,$ec), ($24,$19,$98,$fb), ($2f,$17,$91,$f6),
+    ($8d,$76,$4d,$d6), ($86,$78,$44,$db), ($9b,$6a,$5f,$cc), ($90,$64,$56,$c1),
+    ($a1,$4e,$69,$e2), ($aa,$40,$60,$ef), ($b7,$52,$7b,$f8), ($bc,$5c,$72,$f5), 
+    ($d5,$06,$05,$be), ($de,$08,$0c,$b3), ($c3,$1a,$17,$a4), ($c8,$14,$1e,$a9), 
+    ($f9,$3e,$21,$8a), ($f2,$30,$28,$87), ($ef,$22,$33,$90), ($e4,$2c,$3a,$9d),
+    ($3d,$96,$dd,$06), ($36,$98,$d4,$0b), ($2b,$8a,$cf,$1c), ($20,$84,$c6,$11), 
+    ($11,$ae,$f9,$32), ($1a,$a0,$f0,$3f), ($07,$b2,$eb,$28), ($0c,$bc,$e2,$25), 
+    ($65,$e6,$95,$6e), ($6e,$e8,$9c,$63), ($73,$fa,$87,$74), ($78,$f4,$8e,$79), 
+    ($49,$de,$b1,$5a), ($42,$d0,$b8,$57), ($5f,$c2,$a3,$40), ($54,$cc,$aa,$4d),
+    ($f7,$41,$ec,$da), ($fc,$4f,$e5,$d7), ($e1,$5d,$fe,$c0), ($ea,$53,$f7,$cd), 
+    ($db,$79,$c8,$ee), ($d0,$77,$c1,$e3), ($cd,$65,$da,$f4), ($c6,$6b,$d3,$f9), 
+    ($af,$31,$a4,$b2), ($a4,$3f,$ad,$bf), ($b9,$2d,$b6,$a8), ($b2,$23,$bf,$a5), 
+    ($83,$09,$80,$86), ($88,$07,$89,$8b), ($95,$15,$92,$9c), ($9e,$1b,$9b,$91),
+    ($47,$a1,$7c,$0a), ($4c,$af,$75,$07), ($51,$bd,$6e,$10), ($5a,$b3,$67,$1d),
+    ($6b,$99,$58,$3e), ($60,$97,$51,$33), ($7d,$85,$4a,$24), ($76,$8b,$43,$29),
+    ($1f,$d1,$34,$62), ($14,$df,$3d,$6f), ($09,$cd,$26,$78), ($02,$c3,$2f,$75),
+    ($33,$e9,$10,$56), ($38,$e7,$19,$5b), ($25,$f5,$02,$4c), ($2e,$fb,$0b,$41),
+    ($8c,$9a,$d7,$61), ($87,$94,$de,$6c), ($9a,$86,$c5,$7b), ($91,$88,$cc,$76), 
+    ($a0,$a2,$f3,$55), ($ab,$ac,$fa,$58), ($b6,$be,$e1,$4f), ($bd,$b0,$e8,$42),
+    ($d4,$ea,$9f,$09), ($df,$e4,$96,$04), ($c2,$f6,$8d,$13), ($c9,$f8,$84,$1e), 
+    ($f8,$d2,$bb,$3d), ($f3,$dc,$b2,$30), ($ee,$ce,$a9,$27), ($e5,$c0,$a0,$2a), 
+    ($3c,$7a,$47,$b1), ($37,$74,$4e,$bc), ($2a,$66,$55,$ab), ($21,$68,$5c,$a6),
+    ($10,$42,$63,$85), ($1b,$4c,$6a,$88), ($06,$5e,$71,$9f), ($0d,$50,$78,$92), 
+    ($64,$0a,$0f,$d9), ($6f,$04,$06,$d4), ($72,$16,$1d,$c3), ($79,$18,$14,$ce),
+    ($48,$32,$2b,$ed), ($43,$3c,$22,$e0), ($5e,$2e,$39,$f7), ($55,$20,$30,$fa),
+    ($01,$ec,$9a,$b7), ($0a,$e2,$93,$ba), ($17,$f0,$88,$ad), ($1c,$fe,$81,$a0), 
+    ($2d,$d4,$be,$83), ($26,$da,$b7,$8e), ($3b,$c8,$ac,$99), ($30,$c6,$a5,$94), 
+    ($59,$9c,$d2,$df), ($52,$92,$db,$d2), ($4f,$80,$c0,$c5), ($44,$8e,$c9,$c8),
+    ($75,$a4,$f6,$eb), ($7e,$aa,$ff,$e6), ($63,$b8,$e4,$f1), ($68,$b6,$ed,$fc), 
+    ($b1,$0c,$0a,$67), ($ba,$02,$03,$6a), ($a7,$10,$18,$7d), ($ac,$1e,$11,$70), 
+    ($9d,$34,$2e,$53), ($96,$3a,$27,$5e), ($8b,$28,$3c,$49), ($80,$26,$35,$44), 
+    ($e9,$7c,$42,$0f), ($e2,$72,$4b,$02), ($ff,$60,$50,$15), ($f4,$6e,$59,$18),
+    ($c5,$44,$66,$3b), ($ce,$4a,$6f,$36), ($d3,$58,$74,$21), ($d8,$56,$7d,$2c), 
+    ($7a,$37,$a1,$0c), ($71,$39,$a8,$01), ($6c,$2b,$b3,$16), ($67,$25,$ba,$1b), 
+    ($56,$0f,$85,$38), ($5d,$01,$8c,$35), ($40,$13,$97,$22), ($4b,$1d,$9e,$2f), 
+    ($22,$47,$e9,$64), ($29,$49,$e0,$69), ($34,$5b,$fb,$7e), ($3f,$55,$f2,$73),
+    ($0e,$7f,$cd,$50), ($05,$71,$c4,$5d), ($18,$63,$df,$4a), ($13,$6d,$d6,$47),
+    ($ca,$d7,$31,$dc), ($c1,$d9,$38,$d1), ($dc,$cb,$23,$c6), ($d7,$c5,$2a,$cb), 
+    ($e6,$ef,$15,$e8), ($ed,$e1,$1c,$e5), ($f0,$f3,$07,$f2), ($fb,$fd,$0e,$ff), 
+    ($92,$a7,$79,$b4), ($99,$a9,$70,$b9), ($84,$bb,$6b,$ae), ($8f,$b5,$62,$a3),
+    ($be,$9f,$5d,$80), ($b5,$91,$54,$8d), ($a8,$83,$4f,$9a), ($a3,$8d,$46,$97));
+  U3: array[0..255,0..3] of byte= (
+    ($00,$00,$00,$00), ($0d,$0b,$0e,$09), ($1a,$16,$1c,$12), ($17,$1d,$12,$1b),
+    ($34,$2c,$38,$24), ($39,$27,$36,$2d), ($2e,$3a,$24,$36), ($23,$31,$2a,$3f),
+    ($68,$58,$70,$48), ($65,$53,$7e,$41), ($72,$4e,$6c,$5a), ($7f,$45,$62,$53),
+    ($5c,$74,$48,$6c), ($51,$7f,$46,$65), ($46,$62,$54,$7e), ($4b,$69,$5a,$77),
+    ($d0,$b0,$e0,$90), ($dd,$bb,$ee,$99), ($ca,$a6,$fc,$82), ($c7,$ad,$f2,$8b), 
+    ($e4,$9c,$d8,$b4), ($e9,$97,$d6,$bd), ($fe,$8a,$c4,$a6), ($f3,$81,$ca,$af),
+    ($b8,$e8,$90,$d8), ($b5,$e3,$9e,$d1), ($a2,$fe,$8c,$ca), ($af,$f5,$82,$c3),
+    ($8c,$c4,$a8,$fc), ($81,$cf,$a6,$f5), ($96,$d2,$b4,$ee), ($9b,$d9,$ba,$e7), 
+    ($bb,$7b,$db,$3b), ($b6,$70,$d5,$32), ($a1,$6d,$c7,$29), ($ac,$66,$c9,$20), 
+    ($8f,$57,$e3,$1f), ($82,$5c,$ed,$16), ($95,$41,$ff,$0d), ($98,$4a,$f1,$04), 
+    ($d3,$23,$ab,$73), ($de,$28,$a5,$7a), ($c9,$35,$b7,$61), ($c4,$3e,$b9,$68),
+    ($e7,$0f,$93,$57), ($ea,$04,$9d,$5e), ($fd,$19,$8f,$45), ($f0,$12,$81,$4c), 
+    ($6b,$cb,$3b,$ab), ($66,$c0,$35,$a2), ($71,$dd,$27,$b9), ($7c,$d6,$29,$b0), 
+    ($5f,$e7,$03,$8f), ($52,$ec,$0d,$86), ($45,$f1,$1f,$9d), ($48,$fa,$11,$94), 
+    ($03,$93,$4b,$e3), ($0e,$98,$45,$ea), ($19,$85,$57,$f1), ($14,$8e,$59,$f8), 
+    ($37,$bf,$73,$c7), ($3a,$b4,$7d,$ce), ($2d,$a9,$6f,$d5), ($20,$a2,$61,$dc), 
+    ($6d,$f6,$ad,$76), ($60,$fd,$a3,$7f), ($77,$e0,$b1,$64), ($7a,$eb,$bf,$6d),
+    ($59,$da,$95,$52), ($54,$d1,$9b,$5b), ($43,$cc,$89,$40), ($4e,$c7,$87,$49),
+    ($05,$ae,$dd,$3e), ($08,$a5,$d3,$37), ($1f,$b8,$c1,$2c), ($12,$b3,$cf,$25),
+    ($31,$82,$e5,$1a), ($3c,$89,$eb,$13), ($2b,$94,$f9,$08), ($26,$9f,$f7,$01),
+    ($bd,$46,$4d,$e6), ($b0,$4d,$43,$ef), ($a7,$50,$51,$f4), ($aa,$5b,$5f,$fd), 
+    ($89,$6a,$75,$c2), ($84,$61,$7b,$cb), ($93,$7c,$69,$d0), ($9e,$77,$67,$d9), 
+    ($d5,$1e,$3d,$ae), ($d8,$15,$33,$a7), ($cf,$08,$21,$bc), ($c2,$03,$2f,$b5),
+    ($e1,$32,$05,$8a), ($ec,$39,$0b,$83), ($fb,$24,$19,$98), ($f6,$2f,$17,$91),
+    ($d6,$8d,$76,$4d), ($db,$86,$78,$44), ($cc,$9b,$6a,$5f), ($c1,$90,$64,$56),
+    ($e2,$a1,$4e,$69), ($ef,$aa,$40,$60), ($f8,$b7,$52,$7b), ($f5,$bc,$5c,$72),
+    ($be,$d5,$06,$05), ($b3,$de,$08,$0c), ($a4,$c3,$1a,$17), ($a9,$c8,$14,$1e),
+    ($8a,$f9,$3e,$21), ($87,$f2,$30,$28), ($90,$ef,$22,$33), ($9d,$e4,$2c,$3a), 
+    ($06,$3d,$96,$dd), ($0b,$36,$98,$d4), ($1c,$2b,$8a,$cf), ($11,$20,$84,$c6),
+    ($32,$11,$ae,$f9), ($3f,$1a,$a0,$f0), ($28,$07,$b2,$eb), ($25,$0c,$bc,$e2),
+    ($6e,$65,$e6,$95), ($63,$6e,$e8,$9c), ($74,$73,$fa,$87), ($79,$78,$f4,$8e), 
+    ($5a,$49,$de,$b1), ($57,$42,$d0,$b8), ($40,$5f,$c2,$a3), ($4d,$54,$cc,$aa),
+    ($da,$f7,$41,$ec), ($d7,$fc,$4f,$e5), ($c0,$e1,$5d,$fe), ($cd,$ea,$53,$f7), 
+    ($ee,$db,$79,$c8), ($e3,$d0,$77,$c1), ($f4,$cd,$65,$da), ($f9,$c6,$6b,$d3),
+    ($b2,$af,$31,$a4), ($bf,$a4,$3f,$ad), ($a8,$b9,$2d,$b6), ($a5,$b2,$23,$bf), 
+    ($86,$83,$09,$80), ($8b,$88,$07,$89), ($9c,$95,$15,$92), ($91,$9e,$1b,$9b), 
+    ($0a,$47,$a1,$7c), ($07,$4c,$af,$75), ($10,$51,$bd,$6e), ($1d,$5a,$b3,$67), 
+    ($3e,$6b,$99,$58), ($33,$60,$97,$51), ($24,$7d,$85,$4a), ($29,$76,$8b,$43), 
+    ($62,$1f,$d1,$34), ($6f,$14,$df,$3d), ($78,$09,$cd,$26), ($75,$02,$c3,$2f), 
+    ($56,$33,$e9,$10), ($5b,$38,$e7,$19), ($4c,$25,$f5,$02), ($41,$2e,$fb,$0b),
+    ($61,$8c,$9a,$d7), ($6c,$87,$94,$de), ($7b,$9a,$86,$c5), ($76,$91,$88,$cc),
+    ($55,$a0,$a2,$f3), ($58,$ab,$ac,$fa), ($4f,$b6,$be,$e1), ($42,$bd,$b0,$e8),
+    ($09,$d4,$ea,$9f), ($04,$df,$e4,$96), ($13,$c2,$f6,$8d), ($1e,$c9,$f8,$84),
+    ($3d,$f8,$d2,$bb), ($30,$f3,$dc,$b2), ($27,$ee,$ce,$a9), ($2a,$e5,$c0,$a0), 
+    ($b1,$3c,$7a,$47), ($bc,$37,$74,$4e), ($ab,$2a,$66,$55), ($a6,$21,$68,$5c), 
+    ($85,$10,$42,$63), ($88,$1b,$4c,$6a), ($9f,$06,$5e,$71), ($92,$0d,$50,$78),
+    ($d9,$64,$0a,$0f), ($d4,$6f,$04,$06), ($c3,$72,$16,$1d), ($ce,$79,$18,$14),
+    ($ed,$48,$32,$2b), ($e0,$43,$3c,$22), ($f7,$5e,$2e,$39), ($fa,$55,$20,$30),
+    ($b7,$01,$ec,$9a), ($ba,$0a,$e2,$93), ($ad,$17,$f0,$88), ($a0,$1c,$fe,$81),
+    ($83,$2d,$d4,$be), ($8e,$26,$da,$b7), ($99,$3b,$c8,$ac), ($94,$30,$c6,$a5),
+    ($df,$59,$9c,$d2), ($d2,$52,$92,$db), ($c5,$4f,$80,$c0), ($c8,$44,$8e,$c9),
+    ($eb,$75,$a4,$f6), ($e6,$7e,$aa,$ff), ($f1,$63,$b8,$e4), ($fc,$68,$b6,$ed),
+    ($67,$b1,$0c,$0a), ($6a,$ba,$02,$03), ($7d,$a7,$10,$18), ($70,$ac,$1e,$11),
+    ($53,$9d,$34,$2e), ($5e,$96,$3a,$27), ($49,$8b,$28,$3c), ($44,$80,$26,$35),
+    ($0f,$e9,$7c,$42), ($02,$e2,$72,$4b), ($15,$ff,$60,$50), ($18,$f4,$6e,$59),
+    ($3b,$c5,$44,$66), ($36,$ce,$4a,$6f), ($21,$d3,$58,$74), ($2c,$d8,$56,$7d),
+    ($0c,$7a,$37,$a1), ($01,$71,$39,$a8), ($16,$6c,$2b,$b3), ($1b,$67,$25,$ba),
+    ($38,$56,$0f,$85), ($35,$5d,$01,$8c), ($22,$40,$13,$97), ($2f,$4b,$1d,$9e),
+    ($64,$22,$47,$e9), ($69,$29,$49,$e0), ($7e,$34,$5b,$fb), ($73,$3f,$55,$f2),
+    ($50,$0e,$7f,$cd), ($5d,$05,$71,$c4), ($4a,$18,$63,$df), ($47,$13,$6d,$d6),
+    ($dc,$ca,$d7,$31), ($d1,$c1,$d9,$38), ($c6,$dc,$cb,$23), ($cb,$d7,$c5,$2a),
+    ($e8,$e6,$ef,$15), ($e5,$ed,$e1,$1c), ($f2,$f0,$f3,$07), ($ff,$fb,$fd,$0e),
+    ($b4,$92,$a7,$79), ($b9,$99,$a9,$70), ($ae,$84,$bb,$6b), ($a3,$8f,$b5,$62),
+    ($80,$be,$9f,$5d), ($8d,$b5,$91,$54), ($9a,$a8,$83,$4f), ($97,$a3,$8d,$46));
+  U4: array[0..255,0..3] of byte= (
+    ($00,$00,$00,$00), ($09,$0d,$0b,$0e), ($12,$1a,$16,$1c), ($1b,$17,$1d,$12),
+    ($24,$34,$2c,$38), ($2d,$39,$27,$36), ($36,$2e,$3a,$24), ($3f,$23,$31,$2a),
+    ($48,$68,$58,$70), ($41,$65,$53,$7e), ($5a,$72,$4e,$6c), ($53,$7f,$45,$62),
+    ($6c,$5c,$74,$48), ($65,$51,$7f,$46), ($7e,$46,$62,$54), ($77,$4b,$69,$5a),
+    ($90,$d0,$b0,$e0), ($99,$dd,$bb,$ee), ($82,$ca,$a6,$fc), ($8b,$c7,$ad,$f2),
+    ($b4,$e4,$9c,$d8), ($bd,$e9,$97,$d6), ($a6,$fe,$8a,$c4), ($af,$f3,$81,$ca),
+    ($d8,$b8,$e8,$90), ($d1,$b5,$e3,$9e), ($ca,$a2,$fe,$8c), ($c3,$af,$f5,$82),
+    ($fc,$8c,$c4,$a8), ($f5,$81,$cf,$a6), ($ee,$96,$d2,$b4), ($e7,$9b,$d9,$ba),
+    ($3b,$bb,$7b,$db), ($32,$b6,$70,$d5), ($29,$a1,$6d,$c7), ($20,$ac,$66,$c9),
+    ($1f,$8f,$57,$e3), ($16,$82,$5c,$ed), ($0d,$95,$41,$ff), ($04,$98,$4a,$f1), 
+    ($73,$d3,$23,$ab), ($7a,$de,$28,$a5), ($61,$c9,$35,$b7), ($68,$c4,$3e,$b9), 
+    ($57,$e7,$0f,$93), ($5e,$ea,$04,$9d), ($45,$fd,$19,$8f), ($4c,$f0,$12,$81),
+    ($ab,$6b,$cb,$3b), ($a2,$66,$c0,$35), ($b9,$71,$dd,$27), ($b0,$7c,$d6,$29),
+    ($8f,$5f,$e7,$03), ($86,$52,$ec,$0d), ($9d,$45,$f1,$1f), ($94,$48,$fa,$11), 
+    ($e3,$03,$93,$4b), ($ea,$0e,$98,$45), ($f1,$19,$85,$57), ($f8,$14,$8e,$59), 
+    ($c7,$37,$bf,$73), ($ce,$3a,$b4,$7d), ($d5,$2d,$a9,$6f), ($dc,$20,$a2,$61),
+    ($76,$6d,$f6,$ad), ($7f,$60,$fd,$a3), ($64,$77,$e0,$b1), ($6d,$7a,$eb,$bf), 
+    ($52,$59,$da,$95), ($5b,$54,$d1,$9b), ($40,$43,$cc,$89), ($49,$4e,$c7,$87),
+    ($3e,$05,$ae,$dd), ($37,$08,$a5,$d3), ($2c,$1f,$b8,$c1), ($25,$12,$b3,$cf),
+    ($1a,$31,$82,$e5), ($13,$3c,$89,$eb), ($08,$2b,$94,$f9), ($01,$26,$9f,$f7),
+    ($e6,$bd,$46,$4d), ($ef,$b0,$4d,$43), ($f4,$a7,$50,$51), ($fd,$aa,$5b,$5f),
+    ($c2,$89,$6a,$75), ($cb,$84,$61,$7b), ($d0,$93,$7c,$69), ($d9,$9e,$77,$67),
+    ($ae,$d5,$1e,$3d), ($a7,$d8,$15,$33), ($bc,$cf,$08,$21), ($b5,$c2,$03,$2f), 
+    ($8a,$e1,$32,$05), ($83,$ec,$39,$0b), ($98,$fb,$24,$19), ($91,$f6,$2f,$17),
+    ($4d,$d6,$8d,$76), ($44,$db,$86,$78), ($5f,$cc,$9b,$6a), ($56,$c1,$90,$64), 
+    ($69,$e2,$a1,$4e), ($60,$ef,$aa,$40), ($7b,$f8,$b7,$52), ($72,$f5,$bc,$5c), 
+    ($05,$be,$d5,$06), ($0c,$b3,$de,$08), ($17,$a4,$c3,$1a), ($1e,$a9,$c8,$14), 
+    ($21,$8a,$f9,$3e), ($28,$87,$f2,$30), ($33,$90,$ef,$22), ($3a,$9d,$e4,$2c), 
+    ($dd,$06,$3d,$96), ($d4,$0b,$36,$98), ($cf,$1c,$2b,$8a), ($c6,$11,$20,$84),
+    ($f9,$32,$11,$ae), ($f0,$3f,$1a,$a0), ($eb,$28,$07,$b2), ($e2,$25,$0c,$bc), 
+    ($95,$6e,$65,$e6), ($9c,$63,$6e,$e8), ($87,$74,$73,$fa), ($8e,$79,$78,$f4), 
+    ($b1,$5a,$49,$de), ($b8,$57,$42,$d0), ($a3,$40,$5f,$c2), ($aa,$4d,$54,$cc),
+    ($ec,$da,$f7,$41), ($e5,$d7,$fc,$4f), ($fe,$c0,$e1,$5d), ($f7,$cd,$ea,$53), 
+    ($c8,$ee,$db,$79), ($c1,$e3,$d0,$77), ($da,$f4,$cd,$65), ($d3,$f9,$c6,$6b), 
+    ($a4,$b2,$af,$31), ($ad,$bf,$a4,$3f), ($b6,$a8,$b9,$2d), ($bf,$a5,$b2,$23), 
+    ($80,$86,$83,$09), ($89,$8b,$88,$07), ($92,$9c,$95,$15), ($9b,$91,$9e,$1b),
+    ($7c,$0a,$47,$a1), ($75,$07,$4c,$af), ($6e,$10,$51,$bd), ($67,$1d,$5a,$b3), 
+    ($58,$3e,$6b,$99), ($51,$33,$60,$97), ($4a,$24,$7d,$85), ($43,$29,$76,$8b),
+    ($34,$62,$1f,$d1), ($3d,$6f,$14,$df), ($26,$78,$09,$cd), ($2f,$75,$02,$c3), 
+    ($10,$56,$33,$e9), ($19,$5b,$38,$e7), ($02,$4c,$25,$f5), ($0b,$41,$2e,$fb), 
+    ($d7,$61,$8c,$9a), ($de,$6c,$87,$94), ($c5,$7b,$9a,$86), ($cc,$76,$91,$88),
+    ($f3,$55,$a0,$a2), ($fa,$58,$ab,$ac), ($e1,$4f,$b6,$be), ($e8,$42,$bd,$b0),
+    ($9f,$09,$d4,$ea), ($96,$04,$df,$e4), ($8d,$13,$c2,$f6), ($84,$1e,$c9,$f8),
+    ($bb,$3d,$f8,$d2), ($b2,$30,$f3,$dc), ($a9,$27,$ee,$ce), ($a0,$2a,$e5,$c0),
+    ($47,$b1,$3c,$7a), ($4e,$bc,$37,$74), ($55,$ab,$2a,$66), ($5c,$a6,$21,$68),
+    ($63,$85,$10,$42), ($6a,$88,$1b,$4c), ($71,$9f,$06,$5e), ($78,$92,$0d,$50), 
+    ($0f,$d9,$64,$0a), ($06,$d4,$6f,$04), ($1d,$c3,$72,$16), ($14,$ce,$79,$18),
+    ($2b,$ed,$48,$32), ($22,$e0,$43,$3c), ($39,$f7,$5e,$2e), ($30,$fa,$55,$20),
+    ($9a,$b7,$01,$ec), ($93,$ba,$0a,$e2), ($88,$ad,$17,$f0), ($81,$a0,$1c,$fe),
+    ($be,$83,$2d,$d4), ($b7,$8e,$26,$da), ($ac,$99,$3b,$c8), ($a5,$94,$30,$c6),
+    ($d2,$df,$59,$9c), ($db,$d2,$52,$92), ($c0,$c5,$4f,$80), ($c9,$c8,$44,$8e),
+    ($f6,$eb,$75,$a4), ($ff,$e6,$7e,$aa), ($e4,$f1,$63,$b8), ($ed,$fc,$68,$b6),
+    ($0a,$67,$b1,$0c), ($03,$6a,$ba,$02), ($18,$7d,$a7,$10), ($11,$70,$ac,$1e),
+    ($2e,$53,$9d,$34), ($27,$5e,$96,$3a), ($3c,$49,$8b,$28), ($35,$44,$80,$26),
+    ($42,$0f,$e9,$7c), ($4b,$02,$e2,$72), ($50,$15,$ff,$60), ($59,$18,$f4,$6e),
+    ($66,$3b,$c5,$44), ($6f,$36,$ce,$4a), ($74,$21,$d3,$58), ($7d,$2c,$d8,$56),
+    ($a1,$0c,$7a,$37), ($a8,$01,$71,$39), ($b3,$16,$6c,$2b), ($ba,$1b,$67,$25),
+    ($85,$38,$56,$0f), ($8c,$35,$5d,$01), ($97,$22,$40,$13), ($9e,$2f,$4b,$1d),
+    ($e9,$64,$22,$47), ($e0,$69,$29,$49), ($fb,$7e,$34,$5b), ($f2,$73,$3f,$55),
+    ($cd,$50,$0e,$7f), ($c4,$5d,$05,$71), ($df,$4a,$18,$63), ($d6,$47,$13,$6d),
+    ($31,$dc,$ca,$d7), ($38,$d1,$c1,$d9), ($23,$c6,$dc,$cb), ($2a,$cb,$d7,$c5),
+    ($15,$e8,$e6,$ef), ($1c,$e5,$ed,$e1), ($07,$f2,$f0,$f3), ($0e,$ff,$fb,$fd),
+    ($79,$b4,$92,$a7), ($70,$b9,$99,$a9), ($6b,$ae,$84,$bb), ($62,$a3,$8f,$b5),
+    ($5d,$80,$be,$9f), ($54,$8d,$b5,$91), ($4f,$9a,$a8,$83), ($46,$97,$a3,$8d));
+
+  rcon: array[0..29] of cardinal= (
+    $01, $02, $04, $08, $10, $20, $40, $80, $1b, $36, $6c, $d8, $ab, $4d, $9a,
+    $2f, $5e, $bc, $63, $c6, $97, $35, $6a, $d4, $b3, $7d, $fa, $ef, $c5, $91);
+
+{==============================================================================}
+type
+  PDWord = ^LongWord;
+
+procedure hperm_op(var a, t: integer; n, m: integer);
+begin
+  t:= ((a shl (16 - n)) xor a) and m;
+  a:= a xor t xor (t shr (16 - n));
+end;
+
+procedure perm_op(var a, b, t: integer; n, m: integer);
+begin
+  t:= ((a shr n) xor b) and m;
+  b:= b xor t;
+  a:= a xor (t shl n);
+end;
+
+{==============================================================================}
+function TSynaBlockCipher.GetSize: byte;
+begin
+  Result := 8;
+end;
+
+procedure TSynaBlockCipher.IncCounter;
+var
+  i: integer;
+begin
+  Inc(CV[GetSize]);
+  i:= GetSize -1;
+  while (i> 0) and (CV[i + 1] = #0) do
+  begin
+    Inc(CV[i]);
+    Dec(i);
+  end;
+end;
+
+procedure TSynaBlockCipher.Reset;
+begin
+  CV := IV;
+end;
+
+procedure TSynaBlockCipher.InitKey(Key: AnsiString);
+begin
+end;
+
+procedure TSynaBlockCipher.SetIV(const Value: AnsiString);
+begin
+  IV := PadString(Value, GetSize, #0);
+  Reset;
+end;
+
+function TSynaBlockCipher.GetIV: AnsiString;
+begin
+  Result := CV;
+end;
+
+function TSynaBlockCipher.EncryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := InData;
+end;
+
+function TSynaBlockCipher.DecryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := InData;
+end;
+
+function TSynaBlockCipher.EncryptCBC(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  s: ansistring;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, CV);
+    s := EncryptECB(s);
+    CV := s;
+    Result := Result + s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.DecryptCBC(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  s, temp: ansistring;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    temp := s;
+    s := DecryptECB(s);
+    s := XorString(s, CV);
+    Result := Result + s;
+    CV := Temp;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.EncryptCFB8bit(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  Temp: AnsiString;
+  c: AnsiChar;
+begin
+  Result := '';
+  for i:= 1 to Length(Indata) do
+  begin
+    Temp := EncryptECB(CV);
+    c := AnsiChar(ord(InData[i]) xor ord(temp[1]));
+    Result := Result + c;
+    Delete(CV, 1, 1);
+    CV := CV + c;
+  end;
+end;
+
+function TSynaBlockCipher.DecryptCFB8bit(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  Temp: AnsiString;
+  c: AnsiChar;
+begin
+  Result := '';
+  for i:= 1 to length(Indata) do
+  begin
+    c:= Indata[i];
+    Temp := EncryptECB(CV);
+    Result := Result + AnsiChar(ord(InData[i]) xor ord(temp[1]));
+    Delete(CV, 1, 1);
+    CV := CV + c;
+  end;
+end;
+
+function TSynaBlockCipher.EncryptCFBblock(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+    CV := s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.DecryptCFBblock(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  S, Temp: AnsiString;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    Temp := s;
+    CV := EncryptECB(CV);
+    s := XorString(s, CV);
+    Result := result + s;
+    CV := temp;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.EncryptOFB(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.DecryptOFB(const Indata: AnsiString): AnsiString;
+var
+  i: integer;
+  s: AnsiString;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    Cv := EncryptECB(CV);
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    CV := EncryptECB(CV);
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, CV);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.EncryptCTR(const Indata: AnsiString): AnsiString;
+var
+  temp: AnsiString;
+  i: integer;
+  s: AnsiString;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    temp := EncryptECB(CV);
+    IncCounter;
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, temp);
+    Result := Result + s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    temp := EncryptECB(CV);
+    IncCounter;
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, temp);
+    Result := Result + s;
+  end;
+end;
+
+function TSynaBlockCipher.DecryptCTR(const Indata: AnsiString): AnsiString;
+var
+  temp: AnsiString;
+  s: AnsiString;
+  i: integer;
+  l: integer;
+  bs: byte;
+begin
+  Result := '';
+  l := Length(InData);
+  bs := GetSize;
+  for i:= 1 to (l div bs) do
+  begin
+    temp := EncryptECB(CV);
+    IncCounter;
+    s := copy(Indata, (i - 1) * bs + 1, bs);
+    s := XorString(s, temp);
+    Result := Result + s;
+  end;
+  if (l mod bs)<> 0 then
+  begin
+    temp := EncryptECB(CV);
+    IncCounter;
+    s := copy(Indata, (l div bs) * bs + 1, l mod bs);
+    s := XorString(s, temp);
+    Result := Result + s;
+  end;
+end;
+
+constructor TSynaBlockCipher.Create(Key: AnsiString);
+begin
+  inherited Create;
+  InitKey(Key);
+  IV := StringOfChar(#0, GetSize);
+  IV := EncryptECB(IV);
+  Reset;
+end;
+
+{==============================================================================}
+
+procedure TSynaCustomDes.DoInit(KeyB: AnsiString; var KeyData: TDesKeyData);
+var
+  c, d, t, s, t2, i: integer;
+begin
+  KeyB := PadString(KeyB, 8, #0);
+  c:= ord(KeyB[1]) or (ord(KeyB[2]) shl 8) or (ord(KeyB[3]) shl 16) or (ord(KeyB[4]) shl 24);
+  d:= ord(KeyB[5]) or (ord(KeyB[6]) shl 8) or (ord(KeyB[7]) shl 16) or (ord(KeyB[8]) shl 24);
+  perm_op(d,c,t,4,integer($0f0f0f0f));
+  hperm_op(c,t,integer(-2),integer($cccc0000));
+  hperm_op(d,t,integer(-2),integer($cccc0000));
+  perm_op(d,c,t,1,integer($55555555));
+  perm_op(c,d,t,8,integer($00ff00ff));
+  perm_op(d,c,t,1,integer($55555555));
+  d:= ((d and $ff) shl 16) or (d and $ff00) or ((d and $ff0000) shr 16) or
+        ((c and integer($f0000000)) shr 4);
+  c:= c and $fffffff;
+  for i:= 0 to 15 do
+  begin
+    if shifts2[i]<> 0 then
+    begin
+      c:= ((c shr 2) or (c shl 26));
+      d:= ((d shr 2) or (d shl 26));
+    end
+    else
+    begin
+      c:= ((c shr 1) or (c shl 27));
+      d:= ((d shr 1) or (d shl 27));
+    end;
+    c:= c and $fffffff;
+    d:= d and $fffffff;
+    s:= des_skb[0,c and $3f] or
+        des_skb[1,((c shr  6) and $03) or ((c shr  7) and $3c)] or
+        des_skb[2,((c shr 13) and $0f) or ((c shr 14) and $30)] or
+        des_skb[3,((c shr 20) and $01) or ((c shr 21) and $06) or ((c shr 22) and $38)];
+    t:= des_skb[4,d and $3f] or
+        des_skb[5,((d shr  7) and $03) or ((d shr  8) and $3c)] or
+        des_skb[6, (d shr 15) and $3f                         ] or
+        des_skb[7,((d shr 21) and $0f) or ((d shr 22) and $30)];
+    t2:= ((t shl 16) or (s and $ffff));
+    KeyData[(i shl 1)]:= ((t2 shl 2) or (t2 shr 30));
+    t2:= ((s shr 16) or (t and integer($ffff0000)));
+    KeyData[(i shl 1)+1]:= ((t2 shl 6) or (t2 shr 26));
+  end;
+end;
+
+function TSynaCustomDes.EncryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
+var
+  l, r, t, u: integer;
+  i: longint;
+begin
+  r := Swapbytes(DecodeLongint(Indata, 1));
+  l := swapbytes(DecodeLongint(Indata, 5));
+  t:= ((l shr 4) xor r) and $0f0f0f0f;
+  r:= r xor t;
+  l:= l xor (t shl 4);
+  t:= ((r shr 16) xor l) and $0000ffff;
+  l:= l xor t;
+  r:= r xor (t shl 16);
+  t:= ((l shr 2) xor r) and $33333333;
+  r:= r xor t;
+  l:= l xor (t shl 2);
+  t:= ((r shr 8) xor l) and $00ff00ff;
+  l:= l xor t;
+  r:= r xor (t shl 8);
+  t:= ((l shr 1) xor r) and $55555555;
+  r:= r xor t;
+  l:= l xor (t shl 1);
+  r:= (r shr 29) or (r shl 3);
+  l:= (l shr 29) or (l shl 3);
+  i:= 0;
+  while i< 32 do
+  begin
+    u:= r xor KeyData[i  ];
+    t:= r xor KeyData[i+1];
+    t:= (t shr 4) or (t shl 28);
+    l:= l xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= l xor KeyData[i+2];
+    t:= l xor KeyData[i+3];
+    t:= (t shr 4) or (t shl 28);
+    r:= r xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= r xor KeyData[i+4];
+    t:= r xor KeyData[i+5];
+    t:= (t shr 4) or (t shl 28);
+    l:= l xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= l xor KeyData[i+6];
+    t:= l xor KeyData[i+7];
+    t:= (t shr 4) or (t shl 28);
+    r:= r xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    Inc(i,8);
+  end;
+  r:= (r shr 3) or (r shl 29);
+  l:= (l shr 3) or (l shl 29);
+  t:= ((r shr 1) xor l) and $55555555;
+  l:= l xor t;
+  r:= r xor (t shl 1);
+  t:= ((l shr 8) xor r) and $00ff00ff;
+  r:= r xor t;
+  l:= l xor (t shl 8);
+  t:= ((r shr 2) xor l) and $33333333;
+  l:= l xor t;
+  r:= r xor (t shl 2);
+  t:= ((l shr 16) xor r) and $0000ffff;
+  r:= r xor t;
+  l:= l xor (t shl 16);
+  t:= ((r shr 4) xor l) and $0f0f0f0f;
+  l:= l xor t;
+  r:= r xor (t shl 4);
+  Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r));
+end;
+
+function TSynaCustomDes.DecryptBlock(const InData: AnsiString; var KeyData: TDesKeyData): AnsiString;
+var
+  l, r, t, u: integer;
+  i: longint;
+begin
+  r := Swapbytes(DecodeLongint(Indata, 1));
+  l := Swapbytes(DecodeLongint(Indata, 5));
+  t:= ((l shr 4) xor r) and $0f0f0f0f;
+  r:= r xor t;
+  l:= l xor (t shl 4);
+  t:= ((r shr 16) xor l) and $0000ffff;
+  l:= l xor t;
+  r:= r xor (t shl 16);
+  t:= ((l shr 2) xor r) and $33333333;
+  r:= r xor t;
+  l:= l xor (t shl 2);
+  t:= ((r shr 8) xor l) and $00ff00ff;
+  l:= l xor t;
+  r:= r xor (t shl 8);
+  t:= ((l shr 1) xor r) and $55555555;
+  r:= r xor t;
+  l:= l xor (t shl 1);
+  r:= (r shr 29) or (r shl 3);
+  l:= (l shr 29) or (l shl 3);
+  i:= 30;
+  while i> 0 do
+  begin
+    u:= r xor KeyData[i  ];
+    t:= r xor KeyData[i+1];
+    t:= (t shr 4) or (t shl 28);
+    l:= l xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= l xor KeyData[i-2];
+    t:= l xor KeyData[i-1];
+    t:= (t shr 4) or (t shl 28);
+    r:= r xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= r xor KeyData[i-4];
+    t:= r xor KeyData[i-3];
+    t:= (t shr 4) or (t shl 28);
+    l:= l xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    u:= l xor KeyData[i-6];
+    t:= l xor KeyData[i-5];
+    t:= (t shr 4) or (t shl 28);
+    r:= r xor des_SPtrans[0,(u shr  2) and $3f] xor
+              des_SPtrans[2,(u shr 10) and $3f] xor
+              des_SPtrans[4,(u shr 18) and $3f] xor
+              des_SPtrans[6,(u shr 26) and $3f] xor
+              des_SPtrans[1,(t shr  2) and $3f] xor
+              des_SPtrans[3,(t shr 10) and $3f] xor
+              des_SPtrans[5,(t shr 18) and $3f] xor
+              des_SPtrans[7,(t shr 26) and $3f];
+    Dec(i,8);
+  end;
+  r:= (r shr 3) or (r shl 29);
+  l:= (l shr 3) or (l shl 29);
+  t:= ((r shr 1) xor l) and $55555555;
+  l:= l xor t;
+  r:= r xor (t shl 1);
+  t:= ((l shr 8) xor r) and $00ff00ff;
+  r:= r xor t;
+  l:= l xor (t shl 8);
+  t:= ((r shr 2) xor l) and $33333333;
+  l:= l xor t;
+  r:= r xor (t shl 2);
+  t:= ((l shr 16) xor r) and $0000ffff;
+  r:= r xor t;
+  l:= l xor (t shl 16);
+  t:= ((r shr 4) xor l) and $0f0f0f0f;
+  l:= l xor t;
+  r:= r xor (t shl 4);
+  Result := CodeLongInt(Swapbytes(l)) + CodeLongInt(Swapbytes(r));
+end;
+
+{==============================================================================}
+
+procedure TSynaDes.InitKey(Key: AnsiString);
+begin
+  Key := PadString(Key, 8, #0);
+  DoInit(Key,KeyData);
+end;
+
+function TSynaDes.EncryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := EncryptBlock(InData,KeyData);
+end;
+
+function TSynaDes.DecryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := DecryptBlock(Indata,KeyData);
+end;
+
+{==============================================================================}
+
+procedure TSyna3Des.InitKey(Key: AnsiString);
+var
+  Size: integer;
+  n: integer;
+begin
+  Size := length(Key);
+  key := PadString(key, 3 * 8, #0);
+  DoInit(Copy(key, 1, 8),KeyData[0]);
+  DoInit(Copy(key, 9, 8),KeyData[1]);
+  if Size > 16 then
+    DoInit(Copy(key, 17, 8),KeyData[2])
+  else
+    for n := 0 to high(KeyData[0]) do
+      KeyData[2][n] := Keydata[0][n];
+end;
+
+function TSyna3Des.EncryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := EncryptBlock(Indata,KeyData[0]);
+  Result := DecryptBlock(Result,KeyData[1]);
+  Result := EncryptBlock(Result,KeyData[2]);
+end;
+
+function TSyna3Des.DecryptECB(const InData: AnsiString): AnsiString;
+begin
+  Result := DecryptBlock(InData,KeyData[2]);
+  Result := EncryptBlock(Result,KeyData[1]);
+  Result := DecryptBlock(Result,KeyData[0]);
+end;
+
+{==============================================================================}
+
+procedure InvMixColumn(a: PByteArray; BC: byte);
+var
+  j: longword;
+begin
+  for j:= 0 to (BC-1) do
+    PDWord(@(a^[j*4]))^:= PDWord(@U1[a^[j*4+0]])^
+      xor PDWord(@U2[a^[j*4+1]])^
+      xor PDWord(@U3[a^[j*4+2]])^
+      xor PDWord(@U4[a^[j*4+3]])^;
+end;
+
+{==============================================================================}
+
+function TSynaAes.GetSize: byte;
+begin
+  Result := 16;
+end;
+
+procedure TSynaAes.InitKey(Key: AnsiString);
+var
+  Size: integer;
+  KC, ROUNDS, j, r, t, rconpointer: longword;
+  tk: array[0..MAXKC-1,0..3] of byte;
+  //n: integer;
+begin
+  FillChar(tk,Sizeof(tk),0);
+  //key must have at least 128 bits and max 256 bits
+  if length(key) < 16 then
+    key := PadString(key, 16, #0);
+  if length(key) > 32 then
+    delete(key, 33, maxint);
+  Size := length(Key);
+  Move(PAnsiChar(Key)^, tk, Size);
+  if Size<= 16 then
+  begin
+    KC:= 4;
+    Rounds:= 10;
+  end
+  else if Size<= 24 then
+  begin
+    KC:= 6;
+    Rounds:= 12;
+  end
+  else
+  begin
+    KC:= 8;
+    Rounds:= 14;
+  end;
+  numrounds:= rounds;
+  r:= 0;
+  t:= 0;
+  j:= 0;
+  while (j< KC) and (r< (rounds+1)) do
+  begin
+    while (j< KC) and (t< BC) do
+    begin
+      rk[r,t]:= PDWord(@tk[j])^;
+      Inc(j);
+      Inc(t);
+    end;
+    if t= BC then
+    begin
+      t:= 0;
+      Inc(r);
+    end;
+  end;
+  rconpointer:= 0;
+  while (r< (rounds+1)) do
+  begin
+    tk[0,0]:= tk[0,0] xor S[tk[KC-1,1]];
+    tk[0,1]:= tk[0,1] xor S[tk[KC-1,2]];
+    tk[0,2]:= tk[0,2] xor S[tk[KC-1,3]];
+    tk[0,3]:= tk[0,3] xor S[tk[KC-1,0]];
+    tk[0,0]:= tk[0,0] xor rcon[rconpointer];
+    Inc(rconpointer);
+    if KC<> 8 then
+    begin
+      for j:= 1 to (KC-1) do
+        PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^;
+    end
+    else
+    begin
+      for j:= 1 to ((KC div 2)-1) do
+        PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^;
+      tk[KC div 2,0]:= tk[KC div 2,0] xor S[tk[KC div 2 - 1,0]];
+      tk[KC div 2,1]:= tk[KC div 2,1] xor S[tk[KC div 2 - 1,1]];
+      tk[KC div 2,2]:= tk[KC div 2,2] xor S[tk[KC div 2 - 1,2]];
+      tk[KC div 2,3]:= tk[KC div 2,3] xor S[tk[KC div 2 - 1,3]];
+      for j:= ((KC div 2) + 1) to (KC-1) do
+        PDWord(@tk[j])^:= PDWord(@tk[j])^ xor PDWord(@tk[j-1])^;
+    end;
+    j:= 0;
+    while (j< KC) and (r< (rounds+1)) do
+    begin
+      while (j< KC) and (t< BC) do
+      begin
+        rk[r,t]:= PDWord(@tk[j])^;
+        Inc(j);
+        Inc(t);
+      end;
+      if t= BC then
+      begin
+        Inc(r);
+        t:= 0;
+      end;
+    end;
+  end;
+  Move(rk,drk,Sizeof(rk));
+  for r:= 1 to (numrounds-1) do
+    InvMixColumn(@drk[r],BC);
+end;
+
+function TSynaAes.EncryptECB(const InData: AnsiString): AnsiString;
+var
+  r: longword;
+  tempb: array[0..MAXBC-1,0..3] of byte;
+  a: array[0..MAXBC,0..3] of byte;
+  p: pointer;
+begin
+  p := @a[0,0];
+  move(pointer(InData)^, p^, 16);
+  for r:= 0 to (numrounds-2) do
+  begin
+    PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[r,0];
+    PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[r,1];
+    PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[r,2];
+    PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[r,3];
+    PDWord(@a[0])^:= PDWord(@T1[tempb[0,0]])^ xor
+                     PDWord(@T2[tempb[1,1]])^ xor
+                     PDWord(@T3[tempb[2,2]])^ xor
+                     PDWord(@T4[tempb[3,3]])^;
+    PDWord(@a[1])^:= PDWord(@T1[tempb[1,0]])^ xor
+                     PDWord(@T2[tempb[2,1]])^ xor
+                     PDWord(@T3[tempb[3,2]])^ xor
+                     PDWord(@T4[tempb[0,3]])^;
+    PDWord(@a[2])^:= PDWord(@T1[tempb[2,0]])^ xor
+                     PDWord(@T2[tempb[3,1]])^ xor
+                     PDWord(@T3[tempb[0,2]])^ xor
+                     PDWord(@T4[tempb[1,3]])^;
+    PDWord(@a[3])^:= PDWord(@T1[tempb[3,0]])^ xor
+                     PDWord(@T2[tempb[0,1]])^ xor
+                     PDWord(@T3[tempb[1,2]])^ xor
+                     PDWord(@T4[tempb[2,3]])^;
+  end;
+  PDWord(@tempb[0])^:= PDWord(@a[0])^ xor rk[numrounds-1,0];
+  PDWord(@tempb[1])^:= PDWord(@a[1])^ xor rk[numrounds-1,1];
+  PDWord(@tempb[2])^:= PDWord(@a[2])^ xor rk[numrounds-1,2];
+  PDWord(@tempb[3])^:= PDWord(@a[3])^ xor rk[numrounds-1,3];
+  a[0,0]:= T1[tempb[0,0],1];
+  a[0,1]:= T1[tempb[1,1],1];
+  a[0,2]:= T1[tempb[2,2],1];
+  a[0,3]:= T1[tempb[3,3],1];
+  a[1,0]:= T1[tempb[1,0],1];
+  a[1,1]:= T1[tempb[2,1],1];
+  a[1,2]:= T1[tempb[3,2],1];
+  a[1,3]:= T1[tempb[0,3],1];
+  a[2,0]:= T1[tempb[2,0],1];
+  a[2,1]:= T1[tempb[3,1],1];
+  a[2,2]:= T1[tempb[0,2],1];
+  a[2,3]:= T1[tempb[1,3],1];
+  a[3,0]:= T1[tempb[3,0],1];
+  a[3,1]:= T1[tempb[0,1],1];
+  a[3,2]:= T1[tempb[1,2],1];
+  a[3,3]:= T1[tempb[2,3],1];
+  PDWord(@a[0])^:= PDWord(@a[0])^ xor rk[numrounds,0];
+  PDWord(@a[1])^:= PDWord(@a[1])^ xor rk[numrounds,1];
+  PDWord(@a[2])^:= PDWord(@a[2])^ xor rk[numrounds,2];
+  PDWord(@a[3])^:= PDWord(@a[3])^ xor rk[numrounds,3];
+
+  Result := StringOfChar(#0, 16);
+  move(p^, pointer(Result)^, 16);
+end;
+
+function TSynaAes.DecryptECB(const InData: AnsiString): AnsiString;
+var
+  r: longword;
+  tempb: array[0..MAXBC-1,0..3] of byte;
+  a: array[0..MAXBC,0..3] of byte;
+  p: pointer;
+begin
+  p := @a[0,0];
+  move(pointer(InData)^, p^, 16);
+  for r:= NumRounds downto 2 do
+  begin
+    PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[r,0];
+    PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[r,1];
+    PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[r,2];
+    PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[r,3];
+    PDWord(@a[0])^:= PDWord(@T5[tempb[0,0]])^ xor
+                     PDWord(@T6[tempb[3,1]])^ xor
+                     PDWord(@T7[tempb[2,2]])^ xor
+                     PDWord(@T8[tempb[1,3]])^;
+    PDWord(@a[1])^:= PDWord(@T5[tempb[1,0]])^ xor
+                     PDWord(@T6[tempb[0,1]])^ xor
+                     PDWord(@T7[tempb[3,2]])^ xor
+                     PDWord(@T8[tempb[2,3]])^;
+    PDWord(@a[2])^:= PDWord(@T5[tempb[2,0]])^ xor
+                     PDWord(@T6[tempb[1,1]])^ xor
+                     PDWord(@T7[tempb[0,2]])^ xor
+                     PDWord(@T8[tempb[3,3]])^;
+    PDWord(@a[3])^:= PDWord(@T5[tempb[3,0]])^ xor
+                     PDWord(@T6[tempb[2,1]])^ xor
+                     PDWord(@T7[tempb[1,2]])^ xor
+                     PDWord(@T8[tempb[0,3]])^;
+  end;
+  PDWord(@tempb[0])^:= PDWord(@a[0])^ xor drk[1,0];
+  PDWord(@tempb[1])^:= PDWord(@a[1])^ xor drk[1,1];
+  PDWord(@tempb[2])^:= PDWord(@a[2])^ xor drk[1,2];
+  PDWord(@tempb[3])^:= PDWord(@a[3])^ xor drk[1,3];
+  a[0,0]:= S5[tempb[0,0]];
+  a[0,1]:= S5[tempb[3,1]];
+  a[0,2]:= S5[tempb[2,2]];
+  a[0,3]:= S5[tempb[1,3]];
+  a[1,0]:= S5[tempb[1,0]];
+  a[1,1]:= S5[tempb[0,1]];
+  a[1,2]:= S5[tempb[3,2]];
+  a[1,3]:= S5[tempb[2,3]];
+  a[2,0]:= S5[tempb[2,0]];
+  a[2,1]:= S5[tempb[1,1]];
+  a[2,2]:= S5[tempb[0,2]];
+  a[2,3]:= S5[tempb[3,3]];
+  a[3,0]:= S5[tempb[3,0]];
+  a[3,1]:= S5[tempb[2,1]];
+  a[3,2]:= S5[tempb[1,2]];
+  a[3,3]:= S5[tempb[0,3]];
+  PDWord(@a[0])^:= PDWord(@a[0])^ xor drk[0,0];
+  PDWord(@a[1])^:= PDWord(@a[1])^ xor drk[0,1];
+  PDWord(@a[2])^:= PDWord(@a[2])^ xor drk[0,2];
+  PDWord(@a[3])^:= PDWord(@a[3])^ xor drk[0,3];
+  Result := StringOfChar(#0, 16);
+  move(p^, pointer(Result)^, 16);
+end;
+
+{==============================================================================}
+
+function TestDes: boolean;
+var
+  des: TSynaDes;
+  s, t: string;
+const
+  key = '01234567';
+  data1= '01234567';
+  data2= '0123456789abcdefghij';
+begin
+  //ECB
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptECB(data1);
+    t := strtohex(s);
+    result := t = 'c50ad028c6da9800';
+    s := des.DecryptECB(s);
+    result := result and (data1 = s);
+  finally
+    des.free;
+  end;
+  //CBC
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptCBC(data2);
+    t := strtohex(s);
+    result := result and (t = 'eec50f6353115ad6dee90a22ed1b6a88a0926e35');
+    des.Reset;
+    s := des.DecryptCBC(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CFB-8bit
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptCFB8bit(data2);
+    t := strtohex(s);
+    result := result and (t = 'eb6aa12c2f0ff634b4dfb6da6cb2af8f9c5c1452');
+    des.Reset;
+    s := des.DecryptCFB8bit(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CFB-block
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptCFBblock(data2);
+    t := strtohex(s);
+    result := result and (t = 'ebdbbaa7f9286cdec28605e07f9b7f3be1053257');
+    des.Reset;
+    s := des.DecryptCFBblock(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //OFB
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptOFB(data2);
+    t := strtohex(s);
+    result := result and (t = 'ebdbbaa7f9286cdee0b8b3798c4c34baac87dbdc');
+    des.Reset;
+    s := des.DecryptOFB(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CTR
+  des := TSynaDes.Create(key);
+  try
+    s := des.EncryptCTR(data2);
+    t := strtohex(s);
+    result := result and (t = 'ebdbbaa7f9286cde0dd20b45f3afd9aa1b91b87e');
+    des.Reset;
+    s := des.DecryptCTR(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+end;
+
+function Test3Des: boolean;
+var
+  des: TSyna3Des;
+  s, t: string;
+const
+  key = '0123456789abcdefghijklmn';
+  data1= '01234567';
+  data2= '0123456789abcdefghij';
+begin
+  //ECB
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptECB(data1);
+    t := strtohex(s);
+    result := t = 'e0dee91008dc460c';
+    s := des.DecryptECB(s);
+    result := result and (data1 = s);
+  finally
+    des.free;
+  end;
+  //CBC
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptCBC(data2);
+    t := strtohex(s);
+    result := result and (t = 'ee844a2a4f49c01b91a1599b8eba29128c1ad87a');
+    des.Reset;
+    s := des.DecryptCBC(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CFB-8bit
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptCFB8bit(data2);
+    t := strtohex(s);
+    result := result and (t = '935bbf5210c32cfa1faf61f91e8dc02dfa0ff1e8');
+    des.Reset;
+    s := des.DecryptCFB8bit(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CFB-block
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptCFBblock(data2);
+    t := strtohex(s);
+    result := result and (t = '93754e3d54828fbf4bd81f1739419e8d2cfe1671');
+    des.Reset;
+    s := des.DecryptCFBblock(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //OFB
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptOFB(data2);
+    t := strtohex(s);
+    result := result and (t = '93754e3d54828fbf04ef0a5efc926ebdf2d95f20');
+    des.Reset;
+    s := des.DecryptOFB(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+  //CTR
+  des := TSyna3Des.Create(key);
+  try
+    s := des.EncryptCTR(data2);
+    t := strtohex(s);
+    result := result and (t = '93754e3d54828fbf1c51a121d2c93f989e70b3ad');
+    des.Reset;
+    s := des.DecryptCTR(s);
+    result := result and (data2 = s);
+  finally
+    des.free;
+  end;
+end;
+
+function TestAes: boolean;
+var
+  aes: TSynaAes;
+  s, t: string;
+const
+  key1 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12;
+  data1= #$50#$68#$12#$A4#$5F#$08#$C8#$89#$B9#$7F#$59#$80#$03#$8B#$83#$59;
+  key2 = #$A0#$A1#$A2#$A3#$A5#$A6#$A7#$A8#$AA#$AB#$AC#$AD#$AF#$B0#$B1#$B2#$B4#$B5#$B6#$B7#$B9#$BA#$BB#$BC;
+  data2= #$4F#$1C#$76#$9D#$1E#$5B#$05#$52#$C7#$EC#$A8#$4D#$EA#$26#$A5#$49;
+  key3 = #$00#$01#$02#$03#$05#$06#$07#$08#$0A#$0B#$0C#$0D#$0F#$10#$11#$12#$14#$15#$16#$17#$19#$1A#$1B#$1C#$1E#$1F#$20#$21#$23#$24#$25#$26;
+  data3= #$5E#$25#$CA#$78#$F0#$DE#$55#$80#$25#$24#$D3#$8D#$A3#$FE#$44#$56;
+begin
+  //ECB
+  aes := TSynaAes.Create(key1);
+  try
+    t := aes.EncryptECB(data1);
+    result := t = #$D8#$F5#$32#$53#$82#$89#$EF#$7D#$06#$B5#$06#$A4#$FD#$5B#$E9#$C9;
+    s := aes.DecryptECB(t);
+    result := result and (data1 = s);
+  finally
+    aes.free;
+  end;
+  aes := TSynaAes.Create(key2);
+  try
+    t := aes.EncryptECB(data2);
+    result := result and (t = #$F3#$84#$72#$10#$D5#$39#$1E#$23#$60#$60#$8E#$5A#$CB#$56#$05#$81);
+    s := aes.DecryptECB(t);
+    result := result and (data2 = s);
+  finally
+    aes.free;
+  end;
+  aes := TSynaAes.Create(key3);
+  try
+    t := aes.EncryptECB(data3);
+    result := result and (t = #$E8#$B7#$2B#$4E#$8B#$E2#$43#$43#$8C#$9F#$FF#$1F#$0E#$20#$58#$72);
+    s := aes.DecryptECB(t);
+    result := result and (data3 = s);
+  finally
+    aes.free;
+  end;
+end;
+
+{==============================================================================}
+
+end.

synadbg.pas

@@ -0,0 +1,156 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.002 |
+|==============================================================================|
+| Content: Socket debug tools                                                  |
+|==============================================================================|
+| Copyright (c)2008-2011, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2008-2011.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Socket debug tools)
+
+Routines for help with debugging of events on the Sockets.
+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit synadbg;
+
+interface
+
+uses
+  blcksock, synsock, synautil, classes, sysutils, synafpc;
+
+type
+  TSynaDebug = class(TObject)
+    class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
+    class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
+  end;
+
+procedure AppendToLog(const value: Ansistring);
+
+var
+  LogFile: string;
+
+implementation
+
+procedure AppendToLog(const value: Ansistring);
+var
+  st: TFileStream;
+  s: string;
+  h, m, ss, ms: word;
+  dt: Tdatetime;
+begin
+  if fileexists(LogFile) then
+    st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
+  else
+    st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
+  try
+    st.Position := st.Size;
+    dt := now;
+    decodetime(dt, h, m, ss, ms);
+    s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
+    WriteStrToStream(st, s);
+  finally
+    st.free;
+  end;
+end;
+
+class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
+var
+  s: string;
+begin
+  case Reason of
+    HR_ResolvingBegin:
+      s := 'HR_ResolvingBegin';
+    HR_ResolvingEnd:
+      s := 'HR_ResolvingEnd';
+    HR_SocketCreate:
+      s := 'HR_SocketCreate';
+    HR_SocketClose:
+      s := 'HR_SocketClose';
+    HR_Bind:
+      s := 'HR_Bind';
+    HR_Connect:
+      s := 'HR_Connect';
+    HR_CanRead:
+      s := 'HR_CanRead';
+    HR_CanWrite:
+      s := 'HR_CanWrite';
+    HR_Listen:
+      s := 'HR_Listen';
+    HR_Accept:
+      s := 'HR_Accept';
+    HR_ReadCount:
+      s := 'HR_ReadCount';
+    HR_WriteCount:
+      s := 'HR_WriteCount';
+    HR_Wait:
+      s := 'HR_Wait';
+    HR_Error:
+      s := 'HR_Error';
+  else
+    s := '-unknown-';
+  end;
+  s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF;
+  AppendToLog(s);
+end;
+
+class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
+var
+  s, d: Ansistring;
+begin
+  setlength(s, len);
+  move(Buffer^, pointer(s)^, len);
+  if writing then
+    d := '-> '
+  else
+    d := '<- ';
+  s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF;
+  AppendToLog(s);
+end;
+
+initialization
+begin
+  Logfile := changefileext(paramstr(0), '.slog');
+end;
+
+end.

synafpc.pas

@@ -0,0 +1,152 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.001 |
+|==============================================================================|
+| Content: Utils for FreePascal compatibility                                  |
+|==============================================================================|
+| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2003-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Tomas Hajny (OS2 support)                                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+unit synafpc;
+
+interface
+
+uses
+{$IFDEF FPC}
+  {$IFNDEF ULTIBO}dynlibs,{$ENDIF} sysutils;
+{$ELSE}
+  {$IFDEF MSWINDOWS}
+  Windows;
+  {$ELSE}
+  SysUtils;
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF FPC}
+type
+  TLibHandle = {$IFNDEF ULTIBO}dynlibs.TLibHandle;{$ELSE}THandle;{$ENDIF}
+  
+function LoadLibrary(ModuleName: PChar): TLibHandle;
+function FreeLibrary(Module: TLibHandle): LongBool;
+function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
+function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
+{$ELSE} //not FPC
+type
+  {$IFDEF CIL}
+  TLibHandle = Integer;
+  PtrInt = Integer;
+  {$ELSE}
+  TLibHandle = HModule;
+    {$IFDEF WIN64}
+  PtrInt = NativeInt;
+    {$ELSE}
+  PtrInt = Integer;
+    {$ENDIF}
+  {$ENDIF}
+  {$IFDEF VER100}
+  LongWord = DWord;
+  {$ENDIF}
+{$ENDIF}
+
+procedure Sleep(milliseconds: Cardinal);
+
+
+implementation
+
+{==============================================================================}
+{$IFDEF FPC}
+function LoadLibrary(ModuleName: PChar): TLibHandle;
+begin
+  Result := {$IFNDEF ULTIBO}dynlibs.LoadLibrary(Modulename);{$ELSE}-1;{$ENDIF}
+end;
+
+function FreeLibrary(Module: TLibHandle): LongBool;
+begin
+  Result := {$IFNDEF ULTIBO}dynlibs.UnloadLibrary(Module);{$ELSE}False;{$ENDIF}
+end;
+
+function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
+begin
+{$IFNDEF ULTIBO}
+  {$IFDEF OS2GCC}
+    Result := dynlibs.GetProcedureAddress(Module, '_' + Proc);
+  {$ELSE OS2GCC}
+    Result := dynlibs.GetProcedureAddress(Module, Proc);
+  {$ENDIF OS2GCC}
+{$ELSE}
+  Result := nil;
+{$ENDIF}
+end;
+
+function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
+begin
+  Result := 0;
+end;
+
+{$ELSE}
+{$ENDIF}
+
+procedure Sleep(milliseconds: Cardinal);
+begin
+{$IFDEF MSWINDOWS}
+  {$IFDEF FPC}
+  sysutils.sleep(milliseconds);
+  {$ELSE}
+  windows.sleep(milliseconds);
+  {$ENDIF}
+{$ELSE}
+  sysutils.sleep(milliseconds);
+{$ENDIF}
+
+end;
+
+end.

synaicnv.pas

@@ -0,0 +1,368 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.001.002 |
+|==============================================================================|
+| Content: ICONV support for Win32, OS/2, Linux and .NET                       |
+|==============================================================================|
+| Copyright (c)2004-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2004-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Tomas Hajny (OS2 support)                                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{:@abstract(LibIconv support)
+
+This unit is Pascal interface to LibIconv library for charset translations.
+LibIconv is loaded dynamicly on-demand. If this library is not found in system,
+requested LibIconv function just return errorcode.
+}
+unit synaicnv;
+
+interface
+
+uses
+{$IFDEF CIL}
+  System.Runtime.InteropServices,
+  System.Text,
+{$ENDIF}
+  synafpc,
+{$IFNDEF MSWINDOWS}
+  {$IFNDEF FPC}
+  Libc,
+  {$ENDIF}
+  SysUtils;
+{$ELSE}
+  Windows;
+{$ENDIF}
+
+
+const
+  {$IFNDEF MSWINDOWS}
+   {$IFDEF OS2}
+  DLLIconvName = 'iconv.dll';
+   {$ELSE OS2}
+  DLLIconvName = 'libiconv.so';
+   {$ENDIF OS2}
+  {$ELSE}
+  DLLIconvName = 'iconv.dll';
+  {$ENDIF}
+
+type
+  size_t = Cardinal;
+{$IFDEF CIL}
+  iconv_t = IntPtr;
+{$ELSE}
+  iconv_t = Pointer;
+{$ENDIF}
+  argptr = iconv_t;
+
+var
+  iconvLibHandle: TLibHandle = 0;
+
+function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t;
+function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
+function SynaIconvClose(var cd: iconv_t): integer;
+function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
+
+function IsIconvloaded: Boolean;
+function InitIconvInterface: Boolean;
+function DestroyIconvInterface: Boolean;
+
+const
+  ICONV_TRIVIALP          = 0;  // int *argument
+  ICONV_GET_TRANSLITERATE = 1;  // int *argument
+  ICONV_SET_TRANSLITERATE = 2;  // const int *argument
+  ICONV_GET_DISCARD_ILSEQ = 3;  // int *argument
+  ICONV_SET_DISCARD_ILSEQ = 4;  // const int *argument
+
+
+implementation
+
+uses SyncObjs;
+
+{$IFDEF CIL}
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv_open')]
+    function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv')]
+    function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
+    var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconv_close')]
+    function _iconv_close(cd: iconv_t): integer; external;
+
+  [DllImport(DLLIconvName, CharSet = CharSet.Ansi,
+    SetLastError = False, CallingConvention= CallingConvention.cdecl,
+    EntryPoint = 'libiconvctl')]
+    function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
+
+{$ELSE}
+type
+  Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
+  Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
+    var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
+  Ticonv_close = function(cd: iconv_t): integer; cdecl;
+  Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
+var
+  _iconv_open: Ticonv_open = nil;
+  _iconv: Ticonv = nil;
+  _iconv_close: Ticonv_close = nil;
+  _iconvctl: Ticonvctl = nil;
+{$ENDIF}
+
+
+var
+  IconvCS: TCriticalSection;
+  Iconvloaded: boolean = false;
+
+function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
+begin
+{$IFDEF CIL}
+  try
+    Result := _iconv_open(tocode, fromcode);
+  except
+    on Exception do
+      Result := iconv_t(-1);
+  end;
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv_open) then
+    Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
+  else
+    Result := iconv_t(-1);
+{$ENDIF}
+end;
+
+function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
+begin
+  Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
+end;
+
+function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
+begin
+  Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
+end;
+
+function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
+var
+{$IFDEF CIL}
+  ib, ob: IntPtr;
+  ibsave, obsave: IntPtr;
+  l: integer;
+{$ELSE}
+  ib, ob: Pointer;
+{$ENDIF}
+  ix, ox: size_t;
+begin
+{$IFDEF CIL}
+  l := Length(inbuf) * 4;
+  ibsave := IntPtr.Zero;
+  obsave := IntPtr.Zero;
+  try
+    ibsave := Marshal.StringToHGlobalAnsi(inbuf);
+    obsave := Marshal.AllocHGlobal(l);
+    ib := ibsave;
+    ob := obsave;
+    ix := Length(inbuf);
+    ox := l;
+    _iconv(cd, ib, ix, ob, ox);
+    Outbuf := Marshal.PtrToStringAnsi(obsave, l);
+    setlength(Outbuf, l - ox);
+    Result := Length(inbuf) - ix;
+  finally
+    Marshal.FreeCoTaskMem(ibsave);
+    Marshal.FreeHGlobal(obsave);
+  end;
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv) then
+  begin
+    setlength(Outbuf, Length(inbuf) * 4);
+    ib := Pointer(inbuf);
+    ob := Pointer(Outbuf);
+    ix := Length(inbuf);
+    ox := Length(Outbuf);
+    _iconv(cd, ib, ix, ob, ox);
+    setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
+    Result := Cardinal(Length(inbuf)) - ix;
+  end
+  else
+  begin
+    Outbuf := '';
+    Result := 0;
+  end;
+{$ENDIF}
+end;
+
+function SynaIconvClose(var cd: iconv_t): integer;
+begin
+  if cd = iconv_t(-1) then
+  begin
+    Result := 0;
+    Exit;
+  end;
+{$IFDEF CIL}
+  try;
+    Result := _iconv_close(cd)
+  except
+    on Exception do
+      Result := -1;
+  end;
+  cd := iconv_t(-1);
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconv_close) then
+    Result := _iconv_close(cd)
+  else
+    Result := -1;
+  cd := iconv_t(-1);
+{$ENDIF}
+end;
+
+function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
+begin
+{$IFDEF CIL}
+  Result := _iconvctl(cd, request, argument)
+{$ELSE}
+  if InitIconvInterface and Assigned(_iconvctl) then
+    Result := _iconvctl(cd, request, argument)
+  else
+    Result := 0;
+{$ENDIF}
+end;
+
+function InitIconvInterface: Boolean;
+begin
+  IconvCS.Enter;
+  try
+    if not IsIconvloaded then
+    begin
+{$IFDEF CIL}
+      IconvLibHandle := 1;
+{$ELSE}
+      IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
+{$ENDIF}
+      if (IconvLibHandle <> 0) then
+      begin
+{$IFNDEF CIL}
+        _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
+        _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
+        _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
+        _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
+{$ENDIF}
+        Result := True;
+        Iconvloaded := True;
+      end
+      else
+      begin
+        //load failed!
+        if IconvLibHandle <> 0 then
+        begin
+{$IFNDEF CIL}
+          FreeLibrary(IconvLibHandle);
+{$ENDIF}
+          IconvLibHandle := 0;
+        end;
+        Result := False;
+      end;
+    end
+    else
+      //loaded before...
+      Result := true;
+  finally
+    IconvCS.Leave;
+  end;
+end;
+
+function DestroyIconvInterface: Boolean;
+begin
+  IconvCS.Enter;
+  try
+    Iconvloaded := false;
+    if IconvLibHandle <> 0 then
+    begin
+{$IFNDEF CIL}
+      FreeLibrary(IconvLibHandle);
+{$ENDIF}
+      IconvLibHandle := 0;
+    end;
+{$IFNDEF CIL}
+    _iconv_open := nil;
+    _iconv := nil;
+    _iconv_close := nil;
+    _iconvctl := nil;
+{$ENDIF}
+  finally
+    IconvCS.Leave;
+  end;
+  Result := True;
+end;
+
+function IsIconvloaded: Boolean;
+begin
+  Result := IconvLoaded;
+end;
+
+ initialization
+begin
+  IconvCS:= TCriticalSection.Create;
+end;
+
+finalization
+begin
+{$IFNDEF CIL}
+  DestroyIconvInterface;
+{$ENDIF}
+  IconvCS.Free;
+end;
+
+end.

synaip.pas

@@ -0,0 +1,422 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.002.001 |
+|==============================================================================|
+| Content: IP address support procedures and functions                         |
+|==============================================================================|
+| Copyright (c)2006-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 2006-2010.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(IP address support procedures and functions)}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$R-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+  {$WARN SUSPICIOUS_TYPECAST OFF}
+{$ENDIF}
+
+unit synaip;
+
+interface
+
+uses
+  SysUtils, SynaUtil;
+
+type
+{:binary form of IPv6 address (for string conversion routines)}
+  TIp6Bytes = array [0..15] of Byte;
+{:binary form of IPv6 address (for string conversion routines)}
+  TIp6Words = array [0..7] of Word;
+
+{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
+function IsIP(const Value: string): Boolean;
+
+{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
+function IsIP6(const Value: string): Boolean;
+
+{:Returns a string with the "Host" ip address converted to binary form.}
+function IPToID(Host: string): string;
+
+{:Convert IPv6 address from their string form to binary byte array.}
+function StrToIp6(value: string): TIp6Bytes;
+
+{:Convert IPv6 address from binary byte array to string form.}
+function Ip6ToStr(value: TIp6Bytes): string;
+
+{:Convert IPv4 address from their string form to binary.}
+function StrToIp(value: string): integer;
+
+{:Convert IPv4 address from binary to string form.}
+function IpToStr(value: integer): string;
+
+{:Convert IPv4 address to reverse form.}
+function ReverseIP(Value: String): String;
+
+{:Convert IPv6 address to reverse form.}
+function ReverseIP6(const Value: String): String;
+
+{:Expand short form of IPv6 address to long form.}
+function ExpandIP6(Value: String): String;
+
+
+implementation
+
+{==============================================================================}
+
+function IsIP(const Value: string): Boolean;
+var
+  TempIP: string;
+  function ByteIsOk(const Value: string): Boolean;
+  var
+    x, n: integer;
+  begin
+    x := StrToIntDef(Value, -1);
+    Result := (x >= 0) and (x < 256);
+    // X may be in correct range, but value still may not be correct value!
+    // i.e. "$80"
+    if Result then
+      for n := 1 to length(Value) do
+        if not (CharInSet(Value[n], ['0'..'9'])) then
+        begin
+          Result := False;
+          Break;
+        end;
+  end;
+begin
+  TempIP := Value;
+  Result := False;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if not ByteIsOk(Fetch(TempIP, '.')) then
+    Exit;
+  if ByteIsOk(TempIP) then
+    Result := True;
+end;
+
+{==============================================================================}
+
+function IsIP6(const Value: string): Boolean;
+var
+  TempIP: string;
+  s,t: string;
+  x: integer;
+  partcount: integer;
+  zerocount: integer;
+  First: Boolean;
+begin
+  TempIP := Value;
+  Result := False;
+  if Value = '::' then
+  begin
+    Result := True;
+    Exit;
+  end;
+  partcount := 0;
+  zerocount := 0;
+  First := True;
+  while tempIP <> '' do
+  begin
+    s := fetch(TempIP, ':');
+    if not(First) and (s = '') then
+      Inc(zerocount);
+    First := False;
+    if zerocount > 1 then
+      break;
+    Inc(partCount);
+    if s = '' then
+      Continue;
+    if partCount > 8 then
+      break;
+    if tempIP = '' then
+    begin
+      t := SeparateRight(s, '%');
+      s := SeparateLeft(s, '%');
+      x := StrToIntDef('$' + t, -1);
+      if (x < 0) or (x > $ffff) then
+        break;
+    end;
+    x := StrToIntDef('$' + s, -1);
+    if (x < 0) or (x > $ffff) then
+      break;
+    if tempIP = '' then
+      if not((PartCount = 1) and (ZeroCount = 0)) then
+        Result := True;
+  end;
+end;
+
+{==============================================================================}
+function IPToID(Host: string): String;
+var
+  s: string;
+  i, x: Integer;
+begin
+  Result := '';
+  for x := 0 to 3 do
+  begin
+    s := Fetch(Host, '.');
+    i := StrToIntDef(s, 0);
+    Result := Result + Char(i);
+  end;
+end;
+
+{==============================================================================}
+
+function StrToIp(value: string): integer;
+var
+  s: string;
+  i, x: Integer;
+begin
+  Result := 0;
+  for x := 0 to 3 do
+  begin
+    s := Fetch(value, '.');
+    i := StrToIntDef(s, 0);
+    Result := (256 * Result) + i;
+  end;
+end;
+
+{==============================================================================}
+
+function IpToStr(value: integer): string;
+var
+  x1, x2: word;
+  y1, y2: byte;
+begin
+  Result := '';
+  x1 := value shr 16;
+  x2 := value and $FFFF;
+  y1 := x1 div $100;
+  y2 := x1 mod $100;
+  Result := IntToStr(y1) + '.' + IntToStr(y2) + '.';
+  y1 := x2 div $100;
+  y2 := x2 mod $100;
+  Result := Result + IntToStr(y1) + '.' + IntToStr(y2);
+end;
+
+{==============================================================================}
+
+function ExpandIP6(Value: String): String;
+var
+ n: integer;
+ s: String;
+ x: integer;
+begin
+  Result := '';
+  if value = '' then
+    exit;
+  x := countofchar(value, ':');
+  if x > 7 then
+    exit;
+  if value[1] = ':' then
+    value := '0' + value;
+  if value[length(value)] = ':' then
+    value := value + '0';
+  x := 8 - x;
+  s := '';
+  for n := 1 to x do
+    s := s + ':0';
+  s := s + ':';
+  Result := replacestring(value, '::', s);
+end;
+{==============================================================================}
+
+function StrToIp6(Value: string): TIp6Bytes;
+var
+ IPv6: TIp6Words;
+ Index: Integer;
+ n: integer;
+ b1, b2: byte;
+ s: string;
+ x: integer;
+begin
+  for n := 0 to 15 do
+    Result[n] := 0;
+  for n := 0 to 7 do
+    Ipv6[n] := 0;
+  Index := 0;
+  Value := ExpandIP6(value);
+  if value = '' then
+    exit;
+  while Value <> '' do
+  begin
+    if Index > 7 then
+      Exit;
+    s := fetch(value, ':');
+    if s = '@' then
+      break;
+    if s = '' then
+    begin
+      IPv6[Index] := 0;
+    end
+    else
+    begin
+      x := StrToIntDef('$' + s, -1);
+      if (x > 65535) or (x < 0) then
+        Exit;
+      IPv6[Index] := x;
+    end;
+    Inc(Index);
+  end;
+  for n := 0 to 7 do
+  begin
+    b1 := ipv6[n] div 256;
+    b2 := ipv6[n] mod 256;
+    Result[n * 2] := b1;
+    Result[(n * 2) + 1] := b2;
+  end;
+end;
+
+{==============================================================================}
+//based on routine by the Free Pascal development team
+function Ip6ToStr(value: TIp6Bytes): string;
+var
+  i, x: byte;
+  zr1,zr2: set of byte;
+  zc1,zc2: byte;
+  have_skipped: boolean;
+  ip6w: TIp6words;
+begin
+  zr1 := [];
+  zr2 := [];
+  zc1 := 0;
+  zc2 := 0;
+  for i := 0 to 7 do
+  begin
+    x := i * 2;
+    ip6w[i] := value[x] * 256 + value[x + 1];
+    if ip6w[i] = 0 then
+    begin
+      include(zr2, i);
+      inc(zc2);
+    end
+    else
+    begin
+      if zc1 < zc2 then
+      begin
+        zc1 := zc2;
+        zr1 := zr2;
+        zc2 := 0;
+        zr2 := [];
+      end;
+    end;
+  end;
+  if zc1 < zc2 then
+  begin
+    zr1 := zr2;
+  end;
+  SetLength(Result, 8*5-1);
+  SetLength(Result, 0);
+  have_skipped := false;
+  for i := 0 to 7 do
+  begin
+    if not(i in zr1) then
+    begin
+      if have_skipped then
+      begin
+        if Result = '' then
+          Result := '::'
+        else
+          Result := Result + ':';
+        have_skipped := false;
+      end;
+      Result := Result + IntToHex(Ip6w[i], 1) + ':';
+    end
+    else
+    begin
+      have_skipped := true;
+    end;
+  end;
+  if have_skipped then
+    if Result = '' then
+      Result := '::0'
+    else
+      Result := Result + ':';
+
+  if Result = '' then
+    Result := '::0';
+  if not (7 in zr1) then
+    SetLength(Result, Length(Result)-1);
+  Result := LowerCase(result);
+end;
+
+{==============================================================================}
+function ReverseIP(Value: String): String;
+var
+  x: Integer;
+begin
+  Result := '';
+  repeat
+    x := LastDelimiter('.', Value);
+    Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
+    Delete(Value, x, Length(Value) - x + 1);
+  until x < 1;
+  if Length(Result) > 0 then
+    if Result[1] = '.' then
+      Delete(Result, 1, 1);
+end;
+
+{==============================================================================}
+function ReverseIP6(const Value: String): String;
+var
+  ip6: TIp6bytes;
+  n: integer;
+  x, y: integer;
+begin
+  ip6 := StrToIP6(Value);
+  x := ip6[15] div 16;
+  y := ip6[15] mod 16;
+  Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
+  for n := 14 downto 0 do
+  begin
+    x := ip6[n] div 16;
+    y := ip6[n] mod 16;
+    Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
+  end;
+end;
+
+{==============================================================================}
+end.

synamisc.pas

@@ -0,0 +1,482 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.001 |
+|==============================================================================|
+| Content: misc. procedures and functions                                      |
+|==============================================================================|
+| Copyright (c)1999-2014, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 2002-2010.               |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Miscellaneous network based utilities)}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$Q-}
+{$H+}
+
+//Kylix does not known UNIX define
+{$IFDEF LINUX}
+  {$IFNDEF UNIX}
+    {$DEFINE UNIX}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF POSIX}
+  {$IFNDEF UNIX}
+    {$DEFINE UNIX}
+  {$ENDIF}
+{$ENDIF}
+
+{$TYPEDADDRESS OFF}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit synamisc;
+
+interface
+
+{$IFDEF VER125}
+  {$DEFINE BCB}
+{$ENDIF}
+{$IFDEF BCB}
+  {$ObjExportAll On}
+  {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
+{$ENDIF}
+
+uses
+  synautil, blcksock, SysUtils, Classes
+{$IFDEF POSIX}
+  ,Types,Posix.Stdlib
+{$ELSE}
+  {$IFDEF UNIX}
+  {$IFNDEF FPC}
+  , Libc
+  {$ENDIF}
+{$ELSE}
+  {$IFDEF ULTIBO}
+    , GlobalConst, Iphlpapi
+  {$ELSE}
+    , Windows
+  {$ENDIF}
+{$ENDIF}
+;
+
+
+const
+  lIPV4 = 1;
+  lIPV6 = 2;
+
+Type
+  {:@abstract(This record contains information about proxy settings.)}
+  TProxySetting = record
+    Host: string;
+    Port: string;
+    Bypass: string;
+  end;
+
+{:With this function you can turn on a computer on the network, if this computer
+ supports Wake-on-LAN feature. You need the MAC address 
+ (network card identifier) of the computer. You can also assign a target IP 
+ addres. If you do not specify it, then broadcast is used to deliver magic 
+ wake-on-LAN packet. 
+ However broadcasts work only on your local network. When you need to wake-up a
+ computer on another network, you must specify any existing IP addres on same
+ network segment as targeting computer.}
+procedure WakeOnLan(MAC, IP: string);
+
+{:Autodetect current DNS servers used by the system. If more than one DNS server
+ is defined, then the result is comma-delimited.}
+function GetDNS: string;
+
+{:Autodetect InternetExplorer proxy setting for given protocol. This function
+works only on windows!}
+function GetIEProxy(protocol: string): TProxySetting;
+
+{:Return all known IP addresses on the local system. Addresses are divided by 
+comma/comma-delimited.}
+procedure GetLocalIPs(iplist: TStrings; ipfamily: Integer); overload;
+function GetLocalIPs: string; overload
+
+implementation
+
+{==============================================================================}
+procedure WakeOnLan(MAC, IP: string);
+var
+  sock: TUDPBlockSocket;
+  HexMac: string;
+  data: string;
+  n: integer;
+  b: Byte;
+begin
+  if MAC <> '' then
+  begin
+    MAC := ReplaceString(MAC, '-', '');
+    MAC := ReplaceString(MAC, ':', '');
+    if Length(MAC) < 12 then
+      Exit;
+    HexMac := '';
+    for n := 0 to 5 do
+    begin
+      b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
+      HexMac := HexMac + char(b);
+    end;
+    if IP = '' then
+      IP := cBroadcast;
+    sock := TUDPBlockSocket.Create;
+    try
+      sock.CreateSocket;
+      sock.EnableBroadcast(true);
+      sock.Connect(IP, '9');
+      data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
+      for n := 1 to 16 do
+        data := data + HexMac;
+      sock.SendString(data);
+    finally
+      sock.Free;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+{$IFNDEF UNIX}
+function GetDNSbyIpHlp: string;
+{$IFDEF ULTIBO}
+var
+  InfoSize: DWORD;
+  FixedInfo: TFixedInfo;
+  PDnsServer: PIP_ADDR_STRING;
+  ResultCode: DWORD;
+begin
+  Result:='';
+  
+  InfoSize:=SizeOf(TFixedInfo);
+  ResultCode:=GetNetworkParams(@FixedInfo,InfoSize);
+  if ResultCode <> ERROR_SUCCESS then Exit;
+  
+  Result:=FixedInfo.DnsServerList.IpAddress.S;
+  PDnsServer:=FixedInfo.DnsServerList.Next;
+  while PDnsServer <> nil do
+   begin
+    if Result <> '' then Result:=Result + ',';
+    Result:=Result + PDnsServer^.IPAddress.S;
+    PDnsServer:=PDnsServer.Next;
+   end;
+end;
+{$ELSE}
+type
+  PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
+  TIP_ADDRESS_STRING = array[0..15] of Ansichar;
+  PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
+  TIP_ADDR_STRING = packed record
+    Next: PTIP_ADDR_STRING;
+    IpAddress: TIP_ADDRESS_STRING;
+    IpMask: TIP_ADDRESS_STRING;
+    Context: DWORD;
+  end;
+  PTFixedInfo = ^TFixedInfo;
+  TFixedInfo = packed record
+    HostName: array[1..128 + 4] of Ansichar;
+    DomainName: array[1..128 + 4] of Ansichar;
+    CurrentDNSServer: PTIP_ADDR_STRING;
+    DNSServerList: TIP_ADDR_STRING;
+    NodeType: UINT;
+    ScopeID: array[1..256 + 4] of Ansichar;
+    EnableRouting: UINT;
+    EnableProxy: UINT;
+    EnableDNS: UINT;
+  end;
+const
+  IpHlpDLL = 'IPHLPAPI.DLL';
+var
+  IpHlpModule: THandle;
+  FixedInfo: PTFixedInfo;
+  InfoSize: Longint;
+  PDnsServer: PTIP_ADDR_STRING;
+  err: integer;
+  GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
+begin
+  InfoSize := 0;
+  Result := '...';
+  IpHlpModule := LoadLibrary(IpHlpDLL);
+  if IpHlpModule = 0 then
+    exit;
+  try
+    GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
+    if @GetNetworkParams = nil then
+      Exit;
+    err := GetNetworkParams(Nil, @InfoSize);
+    if err <> ERROR_BUFFER_OVERFLOW then
+      Exit;
+    Result := '';
+    GetMem (FixedInfo, InfoSize);
+    try
+      err := GetNetworkParams(FixedInfo, @InfoSize);
+      if err <> ERROR_SUCCESS then
+        exit;
+      with FixedInfo^ do
+      begin
+        Result := DnsServerList.IpAddress;
+        PDnsServer := DnsServerList.Next;
+        while PDnsServer <> Nil do
+        begin
+          if Result <> '' then
+            Result := Result + ',';
+          Result := Result + PDnsServer^.IPAddress;
+          PDnsServer := PDnsServer.Next;
+        end;
+    end;
+    finally
+      FreeMem(FixedInfo);
+    end;
+  finally
+    FreeLibrary(IpHlpModule);
+  end;
+end;
+
+function ReadReg(SubKey, Vn: PChar): string;
+var
+ OpenKey: HKEY;
+ DataType, DataSize: integer;
+ Temp: array [0..2048] of char;
+begin
+  Result := '';
+  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
+    KEY_READ, OpenKey) = ERROR_SUCCESS then
+  begin
+    DataType := REG_SZ;
+    DataSize := SizeOf(Temp);
+    if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
+      SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
+    RegCloseKey(OpenKey);
+   end;
+end ;
+{$ENDIF}
+{$ENDIF}
+
+function GetDNS: string;
+{$IFDEF ULTIBO}
+begin
+  Result := GetDNSbyIpHlp;
+end;
+{$ELSE}
+{$IFDEF UNIX}
+var
+  l: TStringList;
+  n: integer;
+begin
+  Result := '';
+  l := TStringList.Create;
+  try
+    l.LoadFromFile('/etc/resolv.conf');
+    for n := 0 to l.Count - 1 do
+      if Pos('NAMESERVER', uppercase(l[n])) = 1 then
+      begin
+        if Result <> '' then
+          Result := Result + ',';
+        Result := Result + SeparateRight(l[n], ' ');
+      end;
+  finally
+    l.Free;
+  end;
+end;
+{$ELSE}
+const
+  NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
+  NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
+  W9xfix = 'System\CurrentControlSet\Services\MSTCP';
+begin
+  Result := GetDNSbyIpHlp;
+  if Result = '...' then
+  begin
+    if Win32Platform = VER_PLATFORM_WIN32_NT then
+    begin
+      Result := ReadReg(NTdyn, 'NameServer');
+      if result = '' then
+        Result := ReadReg(NTfix, 'NameServer');
+      if result = '' then
+        Result := ReadReg(NTfix, 'DhcpNameServer');
+    end
+    else
+      Result := ReadReg(W9xfix, 'NameServer');
+    Result := ReplaceString(trim(Result), ' ', ',');
+  end;
+end;
+{$ENDIF}
+{$ENDIF}
+
+{==============================================================================}
+
+function GetIEProxy(protocol: string): TProxySetting;
+{$IFDEF ULTIBO}
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+end;
+{$ELSE}
+{$IFDEF UNIX}
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+end;
+{$ELSE}
+type
+  PInternetProxyInfo = ^TInternetProxyInfo;
+  TInternetProxyInfo = packed record
+    dwAccessType: DWORD;
+    lpszProxy: LPCSTR;
+    lpszProxyBypass: LPCSTR;
+  end;
+const
+  INTERNET_OPTION_PROXY = 38;
+  INTERNET_OPEN_TYPE_PROXY = 3;
+  WininetDLL = 'WININET.DLL';
+var
+  WininetModule: THandle;
+  ProxyInfo: PInternetProxyInfo;
+  Err: Boolean;
+  Len: DWORD;
+  Proxy: string;
+  DefProxy: string;
+  ProxyList: TStringList;
+  n: integer;
+  InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
+    lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
+begin
+  Result.Host := '';
+  Result.Port := '';
+  Result.Bypass := '';
+  WininetModule := LoadLibrary(WininetDLL);
+  if WininetModule = 0 then
+    exit;
+  try
+    InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
+    if @InternetQueryOption = nil then
+      Exit;
+
+    if protocol = '' then
+      protocol := 'http';
+    Len := 4096;
+    GetMem(ProxyInfo, Len);
+    ProxyList := TStringList.Create;
+    try
+      Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
+      if Err then
+        if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
+        begin
+          ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
+          Proxy := '';
+          DefProxy := '';
+          for n := 0 to ProxyList.Count -1 do
+          begin
+            if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
+            begin
+              Proxy := SeparateRight(ProxyList[n], '=');
+              break;
+            end;
+            if Pos('=', ProxyList[n]) < 1 then
+              DefProxy := ProxyList[n];
+          end;
+          if Proxy = '' then
+            Proxy := DefProxy;
+          if Proxy <> '' then
+          begin
+            Result.Host := Trim(SeparateLeft(Proxy, ':'));
+            Result.Port := Trim(SeparateRight(Proxy, ':'));
+          end;
+          Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
+        end;
+    finally
+      ProxyList.Free;
+      FreeMem(ProxyInfo);
+    end;
+  finally
+    FreeLibrary(WininetModule);
+  end;
+end;
+{$ENDIF}
+{$ENDIF}
+
+{==============================================================================}
+
+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;
+var
+  TcpSock: TTCPBlockSocket;
+  ipList: TStringList;
+begin
+  Result := '';
+  ipList := TStringList.Create;
+  try
+    TcpSock := TTCPBlockSocket.create;
+    TcpSock.family:=SF_IP4;
+    try
+      TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
+      Result := ipList.CommaText;
+    finally
+      TcpSock.Free;
+    end;
+  finally
+    ipList.Free;
+  end;
+end;
+
+{==============================================================================}
+
+end.

synaser.pas

@@ -0,0 +1,2788 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 007.006.001 |
+|==============================================================================|
+| Content: Serial port support                                                 |
+|==============================================================================|
+| Copyright (c)2001-2017, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2017.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|  (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes)   |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{: @abstract(Serial port communication library)
+This unit contains a class that implements serial port communication 
+ for Windows, Linux, Unix, MacOSx and Ultibo. This class provides numerous methods
+ with same name and functionality as methods of the Ararat Synapse TCP/IP library.
+
+The following is a small example how establish a connection by modem (in this
+case with my USB modem):
+@longcode(#
+  ser:=TBlockSerial.Create;
+  try
+    ser.Connect('COM3');
+    ser.config(460800,8,'N',0,false,true);
+    ser.ATCommand('AT');
+    if (ser.LastError <> 0) or (not ser.ATResult) then
+      Exit;
+    ser.ATConnect('ATDT+420971200111');
+    if (ser.LastError <> 0) or (not ser.ATResult) then
+      Exit;
+    // you are now connected to a modem at +420971200111
+    // you can transmit or receive data now
+  finally
+    ser.free;
+  end;
+#)
+}
+
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+//Kylix does not known UNIX define
+{$IFDEF LINUX}
+  {$IFNDEF UNIX}
+    {$DEFINE UNIX}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+  {$IFDEF MSWINDOWS}
+    {$ASMMODE intel}
+  {$ENDIF}
+  {define working mode w/o LIBC for fpc}
+  {$DEFINE NO_LIBC}
+{$ENDIF}
+{$Q-}
+{$H+}
+{$M+}
+
+unit synaser;
+
+interface
+
+uses
+{$IFNDEF MSWINDOWS}
+  {$IFDEF ULTIBO}
+    GlobalConst,
+    GlobalConfig,
+    Devices,
+    Serial,
+  {$ELSE}
+    {$IFNDEF NO_LIBC}
+    Libc,
+    KernelIoctl,
+    {$ELSE}
+    termio, baseunix, unix,
+    {$ENDIF}
+    {$IFNDEF FPC}
+    Types,
+    {$ENDIF}
+  {$ENDIF}
+{$ELSE}
+  Windows, registry,
+  {$IFDEF FPC}
+  winver,
+  {$ENDIF}
+{$ENDIF}
+  synafpc,
+  Classes, SysUtils, synautil;
+
+const
+  CR = #$0d;
+  LF = #$0a;
+  CRLF = CR + LF;
+  cSerialChunk = 8192;
+
+  LockfileDirectory = '/var/lock'; {HGJ}
+  PortIsClosed = -1;               {HGJ}
+  ErrAlreadyOwned = 9991;          {HGJ}
+  ErrAlreadyInUse = 9992;          {HGJ}
+  ErrWrongParameter = 9993;        {HGJ}
+  ErrPortNotOpen = 9994;           {HGJ}
+  ErrNoDeviceAnswer =  9995;       {HGJ}
+  ErrMaxBuffer = 9996;
+  ErrTimeout = 9997;
+  ErrNotRead = 9998;
+  ErrFrame = 9999;
+  ErrOverrun = 10000;
+  ErrRxOver = 10001;
+  ErrRxParity = 10002;
+  ErrTxFull = 10003;
+
+  dcb_Binary = $00000001;
+  dcb_ParityCheck = $00000002;
+  dcb_OutxCtsFlow = $00000004;
+  dcb_OutxDsrFlow = $00000008;
+  dcb_DtrControlMask = $00000030;
+  dcb_DtrControlDisable = $00000000;
+  dcb_DtrControlEnable = $00000010;
+  dcb_DtrControlHandshake = $00000020;
+  dcb_DsrSensivity = $00000040;
+  dcb_TXContinueOnXoff = $00000080;
+  dcb_OutX = $00000100;
+  dcb_InX = $00000200;
+  dcb_ErrorChar = $00000400;
+  dcb_NullStrip = $00000800;
+  dcb_RtsControlMask = $00003000;
+  dcb_RtsControlDisable = $00000000;
+  dcb_RtsControlEnable = $00001000;
+  dcb_RtsControlHandshake = $00002000;
+  dcb_RtsControlToggle = $00003000;
+  dcb_AbortOnError = $00004000;
+  dcb_Reserveds = $FFFF8000;
+
+  {:stopbit value for 1 stopbit}
+  SB1 = 0;
+  {:stopbit value for 1.5 stopbit}
+  SB1andHalf = 1;
+  {:stopbit value for 2 stopbits}
+  SB2 = 2;
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}  
+const
+  INVALID_HANDLE_VALUE = THandle(-1);
+  CS7fix = $0000020;
+{$ENDIF}
+
+type
+  TDCB = record
+    DCBlength: DWORD;
+    BaudRate: DWORD;
+    Flags: Longint;
+    wReserved: Word;
+    XonLim: Word;
+    XoffLim: Word;
+    ByteSize: Byte;
+    Parity: Byte;
+    StopBits: Byte;
+    XonChar: CHAR;
+    XoffChar: CHAR;
+    ErrorChar: CHAR;
+    EofChar: CHAR;
+    EvtChar: CHAR;
+    wReserved1: Word;
+  end;
+  PDCB = ^TDCB;
+
+{$IFNDEF ULTIBO}  
+const
+{$IFDEF UNIX}
+  {$IFDEF BSD}
+  MaxRates = 18;  //MAC
+  {$ELSE}
+   MaxRates = 30; //UNIX
+  {$ENDIF}
+{$ELSE}
+  MaxRates = 19;  //WIN
+{$ENDIF}
+  Rates: array[0..MaxRates, 0..1] of cardinal =
+  (
+    (0, B0),
+    (50, B50),
+    (75, B75),
+    (110, B110),
+    (134, B134),
+    (150, B150),
+    (200, B200),
+    (300, B300),
+    (600, B600),
+    (1200, B1200),
+    (1800, B1800),
+    (2400, B2400),
+    (4800, B4800),
+    (9600, B9600),
+    (19200, B19200),
+    (38400, B38400),
+    (57600, B57600),
+    (115200, B115200),
+    (230400, B230400)
+{$IFNDEF BSD}
+    ,(460800, B460800)
+  {$IFDEF UNIX}
+    ,(500000, B500000),
+    (576000, B576000),
+    (921600, B921600),
+    (1000000, B1000000),
+    (1152000, B1152000),
+    (1500000, B1500000),
+    (2000000, B2000000),
+    (2500000, B2500000),
+    (3000000, B3000000),
+    (3500000, B3500000),
+    (4000000, B4000000)
+  {$ENDIF}
+{$ENDIF}
+    );
+{$ENDIF}
+{$ENDIF}
+
+{$IFDEF BSD}
+const // From fcntl.h
+  O_SYNC = $0080;  { synchronous writes }
+{$ENDIF}
+
+const
+  sOK = 0;
+  sErr = integer(-1);
+
+type
+
+  {:Possible status event types for @link(THookSerialStatus)}
+  THookSerialReason = (
+    HR_SerialClose,
+    HR_Connect,
+    HR_CanRead,
+    HR_CanWrite,
+    HR_ReadCount,
+    HR_WriteCount,
+    HR_Wait
+    );
+
+  {:procedural prototype for status event hooking}
+  THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
+    const Value: string) of object;
+
+  {:@abstract(Exception type for SynaSer errors)}
+  ESynaSerError = class(Exception)
+  public
+    ErrorCode: integer;
+    ErrorMessage: string;
+  end;
+
+  {:@abstract(Main class implementing all communication routines)}
+  TBlockSerial = class(TObject)
+  protected
+    FOnStatus: THookSerialStatus;
+    Fhandle: THandle;
+    FTag: integer;
+    FDevice: string;
+    FLastError: integer;
+    FLastErrorDesc: string;
+    FBuffer: AnsiString;
+    FRaiseExcept: boolean;
+    FRecvBuffer: integer;
+    FSendBuffer: integer;
+    FModemWord: integer;
+    FRTSToggle: Boolean;
+    FDeadlockTimeout: integer;
+    FInstanceActive: boolean;      {HGJ}
+    FTestDSR: Boolean;
+    FTestCTS: Boolean;
+    FLastCR: Boolean;
+    FLastLF: Boolean;
+    FMaxLineLength: Integer;
+    FLinuxLock: Boolean;
+    FMaxSendBandwidth: Integer;
+    FNextSend: LongWord;
+    FMaxRecvBandwidth: Integer;
+    FNextRecv: LongWord;
+    FConvertLineEnd: Boolean;
+    FATResult: Boolean;
+    FAtTimeout: integer;
+    FInterPacketTimeout: Boolean;
+    FComNr: integer;
+{$IFDEF MSWINDOWS}
+    FPortAddr: Word;
+    function CanEvent(Event: dword; Timeout: integer): boolean;
+    procedure DecodeCommError(Error: DWord); virtual;
+ {$IFDEF WIN32}
+    function GetPortAddr: Word;  virtual;
+    function ReadTxEmpty(PortAddr: Word): Boolean; virtual;
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF ULTIBO}
+    FSerialDevice: PSerialDevice;
+    procedure SetSizeSendBuffer(size: integer); virtual;
+{$ENDIF}
+    procedure SetSizeRecvBuffer(size: integer); virtual;
+    function GetDSR: Boolean; virtual;
+    procedure SetDTRF(Value: Boolean); virtual;
+    function GetCTS: Boolean; virtual;
+    procedure SetRTSF(Value: Boolean); virtual;
+    function GetCarrier: Boolean; virtual;
+    function GetRing: Boolean; virtual;
+    procedure DoStatus(Reason: THookSerialReason; const Value: string); virtual;
+    procedure GetComNr(Value: string); virtual;
+    function PreTestFailing: boolean; virtual;{HGJ}
+    function TestCtrlLine: Boolean; virtual;
+{$IFDEF UNIX}    
+    procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
+    procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
+    function ReadLockfile: integer; virtual;
+    function LockfileName: String; virtual;
+    procedure CreateLockfile(PidNr: integer); virtual;
+{$ENDIF}
+    procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); virtual;
+    procedure SetBandwidth(Value: Integer); virtual;
+  public
+    {: data Control Block with communication parameters. Usable only when you
+     need to call API directly.}
+    DCB: Tdcb;
+{$IFDEF UNIX}
+    TermiosStruc: termios;
+{$ENDIF}
+    {:Object constructor.}
+    constructor Create;
+    {:Object destructor.}
+    destructor Destroy; override;
+
+    {:Returns a string containing the version number of the library.}
+    class function GetVersion: string; virtual;
+
+    {:Destroy handle in use. It close connection to serial port.}
+    procedure CloseSocket; virtual;
+
+    {:Reconfigure communication parameters on the fly. You must be connected to
+     port before!
+     @param(baud Define connection speed. Baud rate can be from 50 to 4000000
+      bits per second. (it depends on your hardware!))
+     @param(bits Number of bits in communication.)
+     @param(parity Define communication parity (N - None, O - Odd, E - Even, M - Mark or S - Space).)
+     @param(stop Define number of stopbits. Use constants @link(SB1),
+      @link(SB1andHalf) and @link(SB2).)
+     @param(softflow Enable XON/XOFF handshake.)
+     @param(hardflow Enable CTS/RTS handshake.)}
+    procedure Config(baud, bits: integer; parity: char; stop: integer;
+      softflow, hardflow: boolean); virtual;
+
+    {:Connects to the port indicated by comport. Comport can be used in Windows
+     style (COM2), or in Linux style (/dev/ttyS1). When you use windows style
+     in Linux, then it will be converted to Linux name. And vice versa! However
+     you can specify any device name! (other device names then standart is not
+     converted!). In Ultibo you must use a serial device name (eg Serial0).
+
+     After successfull connection the DTR signal is set (if you not set hardware
+     handshake, then the RTS signal is set, too!)
+
+     Connection parameters is predefined by your system configuration. If you
+     need use another parameters, then you can use Config method after.
+     Notes:
+
+      - Remember, the commonly used serial Laplink cable does not support
+       hardware handshake.
+
+      - Before setting any handshake you must be sure that it is supported by
+       your hardware.
+
+      - Some serial devices are slow. In some cases you must wait up to a few
+       seconds after connection for the device to respond.
+
+      - when you connect to a modem device, then is best to test it by an empty
+       AT command. (call ATCommand('AT'))}
+    procedure Connect(comport: string); virtual;
+
+    {:Set communication parameters from the DCB structure (the DCB structure is
+     simulated under Linux and Ultibo).}
+    procedure SetCommState; virtual;
+
+    {:Read communication parameters into the DCB structure (DCB structure is
+     simulated under Linux and Ultibo).}
+    procedure GetCommState; virtual;
+
+    {:Sends Length bytes of data from Buffer through the connected port.}
+    function SendBuffer(buffer: pointer; length: integer): integer; virtual;
+
+    {:One data BYTE is sent.}
+    procedure SendByte(data: byte); virtual;
+
+    {:Send the string in the data parameter. No terminator is appended by this
+     method. If you need to send a string with CR/LF terminator, you must append
+     the CR/LF characters to the data string!
+
+     Since no terminator is appended, you can use this function for sending
+     binary data too.}
+    procedure SendString(data: AnsiString); virtual;
+
+    {:send four bytes as integer.}
+    procedure SendInteger(Data: integer); virtual;
+
+    {:send data as one block. Each block begins with integer value with Length
+     of block.}
+    procedure SendBlock(const Data: AnsiString); virtual;
+
+    {:send content of stream from current position}
+    procedure SendStreamRaw(const Stream: TStream); virtual;
+
+    {:send content of stream as block. see @link(SendBlock)}
+    procedure SendStream(const Stream: TStream); virtual;
+
+    {:send content of stream as block, but this is compatioble with Indy library.
+     (it have swapped lenght of block). See @link(SendStream)}
+    procedure SendStreamIndy(const Stream: TStream); virtual;
+
+    {:Waits until the allocated buffer is filled by received data. Returns number
+     of data bytes received, which equals to the Length value under normal
+     operation. If it is not equal, the communication channel is possibly broken.
+
+     This method not using any internal buffering, like all others receiving
+     methods. You cannot freely combine this method with all others receiving
+     methods!}
+    function RecvBuffer(buffer: pointer; length: integer): integer; virtual;
+
+    {:Method waits until data is received. If no data is received within
+     the Timeout (in milliseconds) period, @link(LastError) is set to
+     @link(ErrTimeout). This method is used to read any amount of data
+     (e. g. 1MB), and may be freely combined with all receviving methods what
+     have Timeout parameter, like the @link(RecvString), @link(RecvByte) or
+     @link(RecvTerminated) methods.}
+    function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer; virtual;
+
+    {:It is like recvBufferEx, but data is readed to dynamicly allocated binary
+     string.}
+    function RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; virtual;
+
+    {:Read all available data and return it in the function result string. This
+     function may be combined with @link(RecvString), @link(RecvByte) or related
+     methods.}
+    function RecvPacket(Timeout: Integer): AnsiString; virtual;
+
+    {:Waits until one data byte is received which is returned as the function
+     result. If no data is received within the Timeout (in milliseconds) period,
+     @link(LastError) is set to @link(ErrTimeout).}
+    function RecvByte(timeout: integer): byte; virtual;
+
+    {:This method waits until a terminated data string is received. This string
+     is terminated by the Terminator string. The resulting string is returned
+     without this termination string! If no data is received within the Timeout
+     (in milliseconds) period, @link(LastError) is set to @link(ErrTimeout).}
+    function RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString; virtual;
+
+    {:This method waits until a terminated data string is received. The string
+     is terminated by a CR/LF sequence. The resulting string is returned without
+     the terminator (CR/LF)! If no data is received within the Timeout (in
+     milliseconds) period, @link(LastError) is set to @link(ErrTimeout).
+
+     If @link(ConvertLineEnd) is used, then the CR/LF sequence may not be exactly
+     CR/LF. See the description of @link(ConvertLineEnd).
+
+     This method serves for line protocol implementation and uses its own
+     buffers to maximize performance. Therefore do NOT use this method with the
+     @link(RecvBuffer) method to receive data as it may cause data loss.}
+    function RecvString(timeout: integer): AnsiString; virtual;
+
+    {:Waits until four data bytes are received which is returned as the function
+     integer result. If no data is received within the Timeout (in milliseconds) period,
+     @link(LastError) is set to @link(ErrTimeout).}
+    function RecvInteger(Timeout: Integer): Integer; virtual;
+
+    {:Waits until one data block is received. See @link(sendblock). If no data
+     is received within the Timeout (in milliseconds) period, @link(LastError)
+     is set to @link(ErrTimeout).}
+    function RecvBlock(Timeout: Integer): AnsiString; virtual;
+
+    {:Receive all data to stream, until some error occured. (for example timeout)}
+    procedure RecvStreamRaw(const Stream: TStream; Timeout: Integer); virtual;
+
+    {:receive requested count of bytes to stream}
+    procedure RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer); virtual;
+
+    {:receive block of data to stream. (Data can be sended by @link(sendstream)}
+    procedure RecvStream(const Stream: TStream; Timeout: Integer); virtual;
+
+    {:receive block of data to stream. (Data can be sended by @link(sendstreamIndy)}
+    procedure RecvStreamIndy(const Stream: TStream; Timeout: Integer); virtual;
+
+    {:Returns the number of received bytes waiting for reading. 0 is returned
+     when there is no data waiting.}
+    function WaitingData: integer; virtual;
+
+    {:Same as @link(WaitingData), but in respect to data in the internal
+     @link(LineBuffer).}
+    function WaitingDataEx: integer; virtual;
+
+    {:Returns the number of bytes waiting to be sent in the output buffer.
+     0 is returned when the output buffer is empty.}
+    function SendingData: integer; virtual;
+
+    {:Enable or disable RTS driven communication (half-duplex). It can be used
+     to communicate with RS485 converters, or other special equipment. If you
+     enable this feature, the system automatically controls the RTS signal.
+
+     Notes:
+
+     - On Windows NT (or higher) ir RTS signal driven by system driver.
+
+     - On Win9x family is used special code for waiting until last byte is
+      sended from your UART.
+
+     - On Linux you must have kernel 2.1 or higher!}
+    procedure EnableRTSToggle(value: boolean); virtual;
+
+    {:Waits until all data to is sent and buffers are emptied.
+     Warning: On Windows systems is this method returns when all buffers are
+     flushed to the serial port controller, before the last byte is sent!}
+    procedure Flush; virtual;
+
+    {:Unconditionally empty all buffers. It is good when you need to interrupt
+     communication and for cleanups.}
+    procedure Purge; virtual;
+
+    {:Returns @True, if you can from read any data from the port. Status is
+     tested for a period of time given by the Timeout parameter (in milliseconds).
+     If the value of the Timeout parameter is 0, the status is tested only once
+     and the function returns immediately. If the value of the Timeout parameter
+     is set to -1, the function returns only after it detects data on the port
+     (this may cause the process to hang).}
+    function CanRead(Timeout: integer): boolean; virtual;
+
+    {:Returns @True, if you can write any data to the port (this function is not
+     sending the contents of the buffer). Status is tested for a period of time
+     given by the Timeout parameter (in milliseconds). If the value of
+     the Timeout parameter is 0, the status is tested only once and the function
+     returns immediately. If the value of the  Timeout parameter is set to -1,
+     the function returns only after it detects that it can write data to
+     the port (this may cause the process to hang).}
+    function CanWrite(Timeout: integer): boolean; virtual;
+
+    {:Same as @link(CanRead), but the test is against data in the internal
+    @link(LineBuffer) too.}
+    function CanReadEx(Timeout: integer): boolean; virtual;
+
+    {:Returns the status word of the modem. Decoding the status word could yield
+     the status of carrier detect signaland other signals. This method is used
+     internally by the modem status reading properties. You usually do not need
+     to call this method directly.}
+    function ModemStatus: integer; virtual;
+
+    {:Send a break signal to the communication device for Duration milliseconds.}
+    procedure SetBreak(Duration: integer); virtual;
+
+    {:This function is designed to send AT commands to the modem. The AT command
+     is sent in the Value parameter and the response is returned in the function
+     return value (may contain multiple lines!).
+     If the AT command is processed successfully (modem returns OK), then the
+     @link(ATResult) property is set to True.
+
+     This function is designed only for AT commands that return OK or ERROR
+     response! To call connection commands the @link(ATConnect) method.
+     Remember, when you connect to a modem device, it is in AT command mode.
+     Now you can send AT commands to the modem. If you need to transfer data to
+     the modem on the other side of the line, you must first switch to data mode
+     using the @link(ATConnect) method.}
+    function ATCommand(value: AnsiString): AnsiString; virtual;
+
+    {:This function is used to send connect type AT commands to the modem. It is
+     for commands to switch to connected state. (ATD, ATA, ATO,...)
+     It sends the AT command in the Value parameter and returns the modem's
+     response (may be multiple lines - usually with connection parameters info).
+     If the AT command is processed successfully (the modem returns CONNECT),
+     then the ATResult property is set to @True.
+
+     This function is designed only for AT commands which respond by CONNECT,
+     BUSY, NO DIALTONE NO CARRIER or ERROR. For other AT commands use the
+     @link(ATCommand) method.
+
+     The connect timeout is 90*@link(ATTimeout). If this command is successful
+     (@link(ATresult) is @true), then the modem is in data state. When you now
+     send or receive some data, it is not to or from your modem, but from the
+     modem on other side of the line. Now you can transfer your data.
+     If the connection attempt failed (@link(ATResult) is @False), then the
+     modem is still in AT command mode.}
+    function ATConnect(value: AnsiString): AnsiString; virtual;
+
+    {:If you "manually" call API functions, forward their return code in
+     the SerialResult parameter to this function, which evaluates it and sets
+     @link(LastError) and @link(LastErrorDesc).}
+    function SerialCheck(SerialResult: integer): integer; virtual;
+
+    {:If @link(Lasterror) is not 0 and exceptions are enabled, then this procedure
+     raises an exception. This method is used internally. You may need it only
+     in special cases.}
+    procedure ExceptCheck; virtual;
+
+    {:Set Synaser to error state with ErrNumber code. Usually used by internal
+     routines.}
+    procedure SetSynaError(ErrNumber: integer); virtual;
+
+    {:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
+    procedure RaiseSynaError(ErrNumber: integer); virtual;
+{$IFDEF UNIX}
+    function  cpomComportAccessible: boolean; virtual;{HGJ}
+    procedure cpomReleaseComport; virtual; {HGJ}
+{$ENDIF}
+    {:True device name of currently used port}
+    property Device: string read FDevice;
+
+    {:Error code of last operation. Value is defined by the host operating
+     system, but value 0 is always OK.}
+    property LastError: integer read FLastError;
+
+    {:Human readable description of LastError code.}
+    property LastErrorDesc: string read FLastErrorDesc;
+
+    {:Indicates if the last @link(ATCommand) or @link(ATConnect) method was successful}
+    property ATResult: Boolean read FATResult;
+
+    {:Read the value of the RTS signal.}
+    property RTS: Boolean write SetRTSF;
+
+    {:Indicates the presence of the CTS signal}
+    property CTS: boolean read GetCTS;
+
+    {:Use this property to set the value of the DTR signal.}
+    property DTR: Boolean write SetDTRF;
+
+    {:Exposes the status of the DSR signal.}
+    property DSR: boolean read GetDSR;
+
+    {:Indicates the presence of the Carrier signal}
+    property Carrier: boolean read GetCarrier;
+
+    {:Reflects the status of the Ring signal.}
+    property Ring: boolean read GetRing;
+
+    {:indicates if this instance of SynaSer is active. (Connected to some port)}
+    property InstanceActive: boolean read FInstanceActive; {HGJ}
+
+    {:Defines maximum bandwidth for all sending operations in bytes per second.
+     If this value is set to 0 (default), bandwidth limitation is not used.}
+    property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
+
+    {:Defines maximum bandwidth for all receiving operations in bytes per second.
+     If this value is set to 0 (default), bandwidth limitation is not used.}
+    property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
+
+    {:Defines maximum bandwidth for all sending and receiving operations
+     in bytes per second. If this value is set to 0 (default), bandwidth
+     limitation is not used.}
+    property MaxBandwidth: Integer Write SetBandwidth;
+
+    {:Size of the Windows and Ultibo internal receive buffer. Default value is
+      usually 4096 or 2048 bytes respectively. Note: Valid only in Windows and
+      Ultibo versions!}
+    property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer;
+    
+{$IFDEF ULTIBO}
+    {:Size of the Ultibo internal transmit buffer. Default value is usually
+      2048 bytes. Note: Valid only in Ultibo version!}
+    property SizeSendBuffer: integer read FSendBuffer write SetSizeSendBuffer;
+{$ENDIF}    
+  published
+    {:Returns the descriptive text associated with ErrorCode. You need this
+     method only in special cases. Description of LastError is now accessible
+     through the LastErrorDesc property.}
+    class function GetErrorDesc(ErrorCode: integer): string;
+
+    {:Freely usable property}
+    property Tag: integer read FTag write FTag;
+
+    {:Contains the handle of the open communication port.
+    You may need this value to directly call communication functions outside
+    SynaSer.}
+    property Handle: THandle read Fhandle write FHandle;
+
+    {:Internally used read buffer.}
+    property LineBuffer: AnsiString read FBuffer write FBuffer;
+
+    {:If @true, communication errors raise exceptions. If @false (default), only
+     the @link(LastError) value is set.}
+    property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept;
+
+    {:This event is triggered when the communication status changes. It can be
+     used to monitor communication status.}
+    property OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
+
+    {:If you set this property to @true, then the value of the DSR signal
+     is tested before every data transfer. It can be used to detect the presence
+     of a communications device.}
+    property TestDSR: boolean read FTestDSR write FTestDSR;
+
+    {:If you set this property to @true, then the value of the CTS signal
+     is tested before every data transfer. It can be used to detect the presence
+     of a communications device. Warning: This property cannot be used if you
+     need hardware handshake!}
+    property TestCTS: boolean read FTestCTS write FTestCTS;
+
+    {:Use this property you to limit the maximum size of LineBuffer
+     (as a protection against unlimited memory allocation for LineBuffer).
+     Default value is 0 - no limit.}
+    property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
+
+    {:This timeout value is used as deadlock protection when trying to send data
+     to (or receive data from) a device that stopped communicating during data
+     transmission (e.g. by physically disconnecting the device).
+     The timeout value is in milliseconds. The default value is 30,000 (30 seconds).}
+    property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
+
+    {:If set to @true (default value), port locking is enabled (under Linux only).
+     WARNING: To use this feature, the application must run by a user with full
+     permission to the /var/lock directory!}
+    property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
+
+    {:Indicates if non-standard line terminators should be converted to a CR/LF pair
+     (standard DOS line terminator). If @TRUE, line terminators CR, single LF
+     or LF/CR are converted to CR/LF. Defaults to @FALSE.
+     This property has effect only on the behavior of the RecvString method.}
+    property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
+
+    {:Timeout for AT modem based operations}
+    property AtTimeout: integer read FAtTimeout Write FAtTimeout;
+
+    {:If @true (default), then all timeouts is timeout between two characters.
+     If @False, then timeout is overall for whoole reading operation.}
+    property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout;
+  end;
+
+{:Returns list of existing computer serial ports. Working properly only in Windows and Ultibo!}
+function GetSerialPortNames: string;
+
+implementation
+
+constructor TBlockSerial.Create;
+begin
+  inherited create;
+  FRaiseExcept := false;
+  FHandle := INVALID_HANDLE_VALUE;
+  FDevice := '';
+  FComNr:= PortIsClosed;               {HGJ}
+  FInstanceActive:= false;             {HGJ}
+  Fbuffer := '';
+  FRTSToggle := False;
+  FMaxLineLength := 0;
+  FTestDSR := False;
+  FTestCTS := False;
+  FDeadlockTimeout := 30000;
+  FLinuxLock := True;
+  FMaxSendBandwidth := 0;
+  FNextSend := 0;
+  FMaxRecvBandwidth := 0;
+  FNextRecv := 0;
+  FConvertLineEnd := False;
+  SetSynaError(sOK);
+  {$IFDEF ULTIBO}
+  FRecvBuffer := SERIAL_RECEIVE_DEPTH_DEFAULT;
+  FSendBuffer := SERIAL_TRANSMIT_DEPTH_DEFAULT;
+  {$ELSE}
+  FRecvBuffer := 4096;
+  {$ENDIF}
+  FLastCR := False;
+  FLastLF := False;
+  FAtTimeout := 1000;
+  FInterPacketTimeout := True;
+end;
+
+destructor TBlockSerial.Destroy;
+begin
+  CloseSocket;
+  inherited destroy;
+end;
+
+class function TBlockSerial.GetVersion: string;
+begin
+	Result := 'SynaSer 7.6.0';
+end;
+
+procedure TBlockSerial.CloseSocket;
+begin
+  if Fhandle <> INVALID_HANDLE_VALUE then
+  begin
+    Purge;
+    RTS := False;
+    DTR := False;
+    {$IFDEF ULTIBO}
+    SerialDeviceClose(FSerialDevice);
+    FSerialDevice := nil;
+    {$ELSE}
+    FileClose(FHandle);
+    {$ENDIF}
+  end;
+  if InstanceActive then
+  begin
+    {$IFDEF UNIX}
+    if FLinuxLock then
+      cpomReleaseComport;
+    {$ENDIF}
+    FInstanceActive:= false
+  end;
+  Fhandle := INVALID_HANDLE_VALUE;
+  FComNr:= PortIsClosed;
+  SetSynaError(sOK);
+  DoStatus(HR_SerialClose, FDevice);
+end;
+
+{$IFDEF WIN32}
+function TBlockSerial.GetPortAddr: Word;
+begin
+  Result := 0;
+  if Win32Platform <> VER_PLATFORM_WIN32_NT then
+  begin
+    EscapeCommFunction(FHandle, 10);
+    asm
+      MOV @Result, DX;
+    end;
+  end;
+end;
+
+function TBlockSerial.ReadTxEmpty(PortAddr: Word): Boolean;
+begin
+  Result := True;
+  if Win32Platform <> VER_PLATFORM_WIN32_NT then
+  begin
+    asm
+      MOV DX, PortAddr;
+      ADD DX, 5;
+      IN AL, DX;
+      AND AL, $40;
+      JZ @K;
+      MOV AL,1;
+    @K: MOV @Result, AL;
+    end;
+  end;
+end;
+{$ENDIF}
+
+procedure TBlockSerial.GetComNr(Value: string);
+begin
+  FComNr := PortIsClosed;
+  if pos('COM', uppercase(Value)) = 1 then
+    FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
+  {$IFNDEF ULTIBO}
+  if pos('/DEV/TTYS', uppercase(Value)) = 1 then
+    FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1);
+  {$ELSE} 
+  if pos(uppercase(SERIAL_NAME_PREFIX), uppercase(Value)) = 1 then
+    FComNr := StrToIntdef(copy(Value, Length(SERIAL_NAME_PREFIX) + 1, Length(Value) - Length(SERIAL_NAME_PREFIX)), PortIsClosed);
+  {$ENDIF}
+end;
+
+procedure TBlockSerial.SetBandwidth(Value: Integer);
+begin
+  MaxSendBandwidth := Value;
+  MaxRecvBandwidth := Value;
+end;
+
+procedure TBlockSerial.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord);
+var
+  x: LongWord;
+  y: LongWord;
+begin
+  if MaxB > 0 then
+  begin
+    y := GetTick;
+    if Next > y then
+    begin
+      x := Next - y;
+      if x > 0 then
+      begin
+        DoStatus(HR_Wait, IntToStr(x));
+        sleep(x);
+      end;
+    end;
+    Next := GetTick + Trunc((Length / MaxB) * 1000);
+  end;
+end;
+
+procedure TBlockSerial.Config(baud, bits: integer; parity: char; stop: integer;
+  softflow, hardflow: boolean);
+begin
+  FillChar(dcb, SizeOf(dcb), 0);
+  GetCommState;
+  dcb.DCBlength := SizeOf(dcb);
+  dcb.BaudRate := baud;
+  dcb.ByteSize := bits;
+  case parity of
+    'N', 'n': dcb.parity := 0;
+    'O', 'o': dcb.parity := 1;
+    'E', 'e': dcb.parity := 2;
+    'M', 'm': dcb.parity := 3;
+    'S', 's': dcb.parity := 4;
+  end;
+  dcb.StopBits := stop;
+  dcb.XonChar := #17;
+  dcb.XoffChar := #19;
+  dcb.XonLim := FRecvBuffer div 4;
+  dcb.XoffLim := FRecvBuffer div 4;
+  dcb.Flags := dcb_Binary;
+  if softflow then
+    dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
+  if hardflow then
+    dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
+  else
+    dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
+  dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
+  if dcb.Parity > 0 then
+    dcb.Flags := dcb.Flags or dcb_ParityCheck;
+  SetCommState;
+end;
+
+procedure TBlockSerial.Connect(comport: string);
+{$IFDEF MSWINDOWS}
+var
+  CommTimeouts: TCommTimeouts;
+{$ENDIF}
+{$IFDEF ULTIBO}
+var
+  ResultCode: LongWord;
+{$ENDIF}
+begin
+  // Is this TBlockSerial Instance already busy?
+  if InstanceActive then           {HGJ}
+  begin                            {HGJ}
+    RaiseSynaError(ErrAlreadyInUse);
+    Exit;                          {HGJ}
+  end;                             {HGJ}
+  FBuffer := '';
+  FDevice := comport;
+  GetComNr(comport);
+{$IFDEF MSWINDOWS}
+  SetLastError (sOK);
+{$ELSE}
+  {$IFDEF ULTIBO}
+  SetLastError (sOK);
+  {$ELSE}
+    {$IFNDEF FPC}
+    SetLastError (sOK);
+    {$ELSE}
+    fpSetErrno(sOK);
+  {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  if FComNr <> PortIsClosed then
+    FDevice := '/dev/ttyS' + IntToStr(FComNr);
+  // Comport already owned by another process?          {HGJ}
+  if FLinuxLock then
+    if not cpomComportAccessible then
+    begin
+      RaiseSynaError(ErrAlreadyOwned);
+      Exit;
+    end;
+  {$IFNDEF FPC}
+  FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
+  {$ELSE}
+  FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
+  {$ENDIF}
+  if FHandle = INVALID_HANDLE_VALUE then  //because THandle is not integer on all platforms!
+    SerialCheck(-1)
+  else
+    SerialCheck(0);
+  {$IFDEF UNIX}
+  if FLastError <> sOK then
+    if FLinuxLock then
+      cpomReleaseComport;
+  {$ENDIF}
+  ExceptCheck;
+  if FLastError <> sOK then
+    Exit;
+{$ELSE}
+  if FComNr <> PortIsClosed then
+    FDevice := SERIAL_NAME_PREFIX + IntToStr(FComNr);
+    
+  // Find device  
+  FSerialDevice := SerialDeviceFindByName(FDevice);
+  if FSerialDevice = nil then
+    SetSynaError(ErrWrongParameter)
+  else
+    SetSynaError(sOK);
+  ExceptCheck;
+  if FLastError <> sOK then
+    Exit;
+    
+  // Open device  
+  ResultCode := SerialDeviceOpen(FSerialDevice, SERIAL_BAUD_RATE_DEFAULT, SERIAL_DATA_8BIT, SERIAL_STOP_1BIT, SERIAL_PARITY_NONE, SERIAL_FLOW_NONE, FRecvBuffer, FSendBuffer);
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+    SerialCheck(-1)
+  else
+    SerialCheck(0);
+  ExceptCheck;
+  if FLastError <> sOK then
+    Exit;
+    
+  FHandle := THandle(FSerialDevice);
+{$ENDIF}    
+{$ELSE}
+  if FComNr <> PortIsClosed then
+    FDevice := '\\.\COM' + IntToStr(FComNr + 1);
+  FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
+    0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
+  if FHandle = INVALID_HANDLE_VALUE then  //because THandle is not integer on all platforms!
+    SerialCheck(-1)
+  else
+    SerialCheck(0);
+  ExceptCheck;
+  if FLastError <> sOK then
+    Exit;
+  SetCommMask(FHandle, 0);
+  SetupComm(Fhandle, FRecvBuffer, 0);
+  CommTimeOuts.ReadIntervalTimeout := MAXWORD;
+  CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
+  CommTimeOuts.ReadTotalTimeoutConstant := 0;
+  CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
+  CommTimeOuts.WriteTotalTimeoutConstant := 0;
+  SetCommTimeOuts(FHandle, CommTimeOuts);
+  {$IFDEF WIN32}
+  FPortAddr := GetPortAddr;
+  {$ENDIF}
+{$ENDIF}
+  SetSynaError(sOK);
+  if not TestCtrlLine then  {HGJ}
+  begin
+    SetSynaError(ErrNoDeviceAnswer);
+    {$IFDEF ULTIBO}
+    SerialDeviceClose(FSerialDevice);
+    FSerialDevice := nil;
+    {$ELSE}
+    FileClose(FHandle);         {HGJ}
+    {$ENDIF}
+    {$IFDEF UNIX}
+    if FLinuxLock then
+      cpomReleaseComport;                {HGJ}
+    {$ENDIF}                             {HGJ}
+    Fhandle := INVALID_HANDLE_VALUE;     {HGJ}
+    FComNr:= PortIsClosed;               {HGJ}
+  end
+  else
+  begin
+    FInstanceActive:= True;
+    RTS := True;
+    DTR := True;
+    Purge;
+  end;
+  ExceptCheck;
+  DoStatus(HR_Connect, FDevice);
+end;
+
+function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
+{$IFDEF MSWINDOWS}
+var
+  Overlapped: TOverlapped;
+  x, y, Err: DWord;
+{$ENDIF}
+{$IFDEF ULTIBO}
+var
+  ResultCode: LongWord;
+{$ENDIF}  
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
+  if FRTSToggle then
+  begin
+    Flush;
+    RTS := True;
+  end;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  result := FileWrite(Fhandle, Buffer^, Length);
+  serialcheck(result);
+{$ELSE}
+  ResultCode := SerialDeviceWrite(FSerialDevice, buffer, length, SERIAL_WRITE_NONE, LongWord(Result));
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+    SerialCheck(sErr)
+  else
+    SetSynaError(sOK);
+{$ENDIF}    
+{$ELSE}
+  FillChar(Overlapped, Sizeof(Overlapped), 0);
+  SetSynaError(sOK);
+  y := 0;
+  if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then
+    y := GetLastError;
+  if y = ERROR_IO_PENDING then
+  begin
+    x := WaitForSingleObject(FHandle, FDeadlockTimeout);
+    if x = WAIT_TIMEOUT then
+    begin
+      PurgeComm(FHandle, PURGE_TXABORT);
+      SetSynaError(ErrTimeout);
+    end;
+    GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
+  end
+  else
+    SetSynaError(y);
+  err := 0;
+  ClearCommError(FHandle, err, nil);
+  if err <> 0 then
+    DecodeCommError(err);
+{$ENDIF}
+  if FRTSToggle then
+  begin
+    Flush;
+    CanWrite(255);
+    RTS := False;
+  end;
+  ExceptCheck;
+  DoStatus(HR_WriteCount, IntToStr(Result));
+end;
+
+procedure TBlockSerial.SendByte(data: byte);
+begin
+  SendBuffer(@Data, 1);
+end;
+
+procedure TBlockSerial.SendString(data: AnsiString);
+begin
+  SendBuffer(Pointer(Data), Length(Data));
+end;
+
+procedure TBlockSerial.SendInteger(Data: integer);
+begin
+  SendBuffer(@data, SizeOf(Data));
+end;
+
+procedure TBlockSerial.SendBlock(const Data: AnsiString);
+begin
+  SendInteger(Length(data));
+  SendString(Data);
+end;
+
+procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
+var
+  si: integer;
+  x, y, yr: integer;
+  s: AnsiString;
+begin
+  si := Stream.Size - Stream.Position;
+  x := 0;
+  while x < si do
+  begin
+    y := si - x;
+    if y > cSerialChunk then
+      y := cSerialChunk;
+    Setlength(s, y);
+    yr := Stream.read(PAnsiChar(s)^, y);
+    if yr > 0 then
+    begin
+      SetLength(s, yr);
+      SendString(s);
+      Inc(x, yr);
+    end
+    else
+      break;
+  end;
+end;
+
+procedure TBlockSerial.SendStreamIndy(const Stream: TStream);
+var
+  si: integer;
+begin
+  si := Stream.Size - Stream.Position;
+  si := Swapbytes(si);
+  SendInteger(si);
+  SendStreamRaw(Stream);
+end;
+
+procedure TBlockSerial.SendStream(const Stream: TStream);
+var
+  si: integer;
+begin
+  si := Stream.Size - Stream.Position;
+  SendInteger(si);
+  SendStreamRaw(Stream);
+end;
+
+function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
+  result := FileRead(FHandle, Buffer^, length);
+  serialcheck(result);
+{$ELSE}
+var
+  ResultCode: LongWord;
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
+  ResultCode := SerialDeviceRead(FSerialDevice, buffer, length, SERIAL_READ_NONE, LongWord(Result));
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+    SerialCheck(sErr)
+  else
+    SetSynaError(sOK);
+{$ENDIF}    
+{$ELSE}
+var
+  Overlapped: TOverlapped;
+  x, y, Err: DWord;
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
+  FillChar(Overlapped, Sizeof(Overlapped), 0);
+  SetSynaError(sOK);
+  y := 0;
+  if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then
+    y := GetLastError;
+  if y = ERROR_IO_PENDING then
+  begin
+    x := WaitForSingleObject(FHandle, FDeadlockTimeout);
+    if x = WAIT_TIMEOUT then
+    begin
+      PurgeComm(FHandle, PURGE_RXABORT);
+      SetSynaError(ErrTimeout);
+    end;
+    GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
+  end
+  else
+    SetSynaError(y);
+  err := 0;
+  ClearCommError(FHandle, err, nil);
+  if err <> 0 then
+    DecodeCommError(err);
+{$ENDIF}
+  ExceptCheck;
+  DoStatus(HR_ReadCount, IntToStr(Result));
+end;
+
+function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
+var
+  s: AnsiString;
+  rl, l: integer;
+  ti: LongWord;
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  SetSynaError(sOK);
+  rl := 0;
+  repeat
+    ti := GetTick;
+    s := RecvPacket(Timeout);
+    l := System.Length(s);
+    if (rl + l) > Length then
+      l := Length - rl;
+    Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
+    rl := rl + l;
+    if FLastError <> sOK then
+      Break;
+    if rl >= Length then
+      Break;
+    if not FInterPacketTimeout then
+    begin
+      Timeout := Timeout - integer(TickDelta(ti, GetTick));
+      if Timeout <= 0 then
+      begin
+        SetSynaError(ErrTimeout);
+        Break;
+      end;
+    end;
+  until False;
+  delete(s, 1, l);
+  FBuffer := s;
+  Result := rl;
+end;
+
+function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString;
+var
+  x: integer;
+begin
+  Result := '';
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  SetSynaError(sOK);
+  if Length > 0 then
+  begin
+    Setlength(Result, Length);
+    x := RecvBufferEx(PAnsiChar(Result), Length , Timeout);
+    if FLastError = sOK then
+      SetLength(Result, x)
+    else
+      Result := '';
+  end;
+end;
+
+function TBlockSerial.RecvPacket(Timeout: Integer): AnsiString;
+var
+  x: integer;
+begin
+  Result := '';
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  SetSynaError(sOK);
+  if FBuffer <> '' then
+  begin
+    Result := FBuffer;
+    FBuffer := '';
+  end
+  else
+  begin
+    //not drain CPU on large downloads...
+    Sleep(0);
+    x := WaitingData;
+    if x > 0 then
+    begin
+      SetLength(Result, x);
+      x := RecvBuffer(Pointer(Result), x);
+      if x >= 0 then
+        SetLength(Result, x);
+    end
+    else
+    begin
+      if CanRead(Timeout) then
+      begin
+        x := WaitingData;
+        if x = 0 then
+          SetSynaError(ErrTimeout);
+        if x > 0 then
+        begin
+          SetLength(Result, x);
+          x := RecvBuffer(Pointer(Result), x);
+          if x >= 0 then
+            SetLength(Result, x);
+        end;
+      end
+      else
+        SetSynaError(ErrTimeout);
+    end;
+  end;
+  ExceptCheck;
+end;
+
+
+function TBlockSerial.RecvByte(timeout: integer): byte;
+begin
+  Result := 0;
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  SetSynaError(sOK);
+  if FBuffer = '' then
+    FBuffer := RecvPacket(Timeout);
+  if (FLastError = sOK) and (FBuffer <> '') then
+  begin
+    Result := Ord(FBuffer[1]);
+    System.Delete(FBuffer, 1, 1);
+  end;
+  ExceptCheck;
+end;
+
+function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: AnsiString): AnsiString;
+var
+  x: Integer;
+  s: AnsiString;
+  l: Integer;
+  CorCRLF: Boolean;
+  t: ansistring;
+  tl: integer;
+  ti: LongWord;
+begin
+  Result := '';
+  if PreTestFailing then   {HGJ}
+    Exit;                  {HGJ}
+  SetSynaError(sOK);
+  l := system.Length(Terminator);
+  if l = 0 then
+    Exit;
+  tl := l;
+  CorCRLF := FConvertLineEnd and (Terminator = CRLF);
+  s := '';
+  x := 0;
+  repeat
+    ti := GetTick;
+    //get rest of FBuffer or incomming new data...
+    s := s + RecvPacket(Timeout);
+    if FLastError <> sOK then
+      Break;
+    x := 0;
+    if Length(s) > 0 then
+      if CorCRLF then
+      begin
+        if FLastCR and (s[1] = LF) then
+          Delete(s, 1, 1);
+        if FLastLF and (s[1] = CR) then
+          Delete(s, 1, 1);
+        FLastCR := False;
+        FLastLF := False;
+        t := '';
+        x := PosCRLF(s, t);
+        tl := system.Length(t);
+        if t = CR then
+          FLastCR := True;
+        if t = LF then
+          FLastLF := True;
+      end
+      else
+      begin
+        x := pos(Terminator, s);
+        tl := l;
+      end;
+    if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
+    begin
+      SetSynaError(ErrMaxBuffer);
+      Break;
+    end;
+    if x > 0 then
+      Break;
+    if not FInterPacketTimeout then
+    begin
+      Timeout := Timeout - integer(TickDelta(ti, GetTick));
+      if Timeout <= 0 then
+      begin
+        SetSynaError(ErrTimeout);
+        Break;
+      end;
+    end;
+  until False;
+  if x > 0 then
+  begin
+    Result := Copy(s, 1, x - 1);
+    System.Delete(s, 1, x + tl - 1);
+  end;
+  FBuffer := s;
+  ExceptCheck;
+end;
+
+
+function TBlockSerial.RecvString(Timeout: Integer): AnsiString;
+var
+  s: AnsiString;
+begin
+  Result := '';
+  s := RecvTerminated(Timeout, #13 + #10);
+  if FLastError = sOK then
+    Result := s;
+end;
+
+function TBlockSerial.RecvInteger(Timeout: Integer): Integer;
+var
+  s: AnsiString;
+begin
+  Result := 0;
+  s := RecvBufferStr(4, Timeout);
+  if FLastError = 0 then
+    Result := (ord(s[1]) + ord(s[2]) * 256) + (ord(s[3]) + ord(s[4]) * 256) * 65536;
+end;
+
+function TBlockSerial.RecvBlock(Timeout: Integer): AnsiString;
+var
+  x: integer;
+begin
+  Result := '';
+  x := RecvInteger(Timeout);
+  if FLastError = 0 then
+    Result := RecvBufferStr(x, Timeout);
+end;
+
+procedure TBlockSerial.RecvStreamRaw(const Stream: TStream; Timeout: Integer);
+var
+  s: AnsiString;
+begin
+  repeat
+    s := RecvPacket(Timeout);
+    if FLastError = 0 then
+      WriteStrToStream(Stream, s);
+  until FLastError <> 0;
+end;
+
+procedure TBlockSerial.RecvStreamSize(const Stream: TStream; Timeout: Integer; Size: Integer);
+var
+  s: AnsiString;
+  n: integer;
+begin
+  for n := 1 to (Size div cSerialChunk) do
+  begin
+    s := RecvBufferStr(cSerialChunk, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    Stream.Write(PAnsichar(s)^, cSerialChunk);
+  end;
+  n := Size mod cSerialChunk;
+  if n > 0 then
+  begin
+    s := RecvBufferStr(n, Timeout);
+    if FLastError <> 0 then
+      Exit;
+    Stream.Write(PAnsichar(s)^, n);
+  end;
+end;
+
+procedure TBlockSerial.RecvStreamIndy(const Stream: TStream; Timeout: Integer);
+var
+  x: integer;
+begin
+  x := RecvInteger(Timeout);
+  x := SwapBytes(x);
+  if FLastError = 0 then
+    RecvStreamSize(Stream, Timeout, x);
+end;
+
+procedure TBlockSerial.RecvStream(const Stream: TStream; Timeout: Integer);
+var
+  x: integer;
+begin
+  x := RecvInteger(Timeout);
+  if FLastError = 0 then
+    RecvStreamSize(Stream, Timeout, x);
+end;
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+function TBlockSerial.WaitingData: integer;
+begin
+  {$IFNDEF FPC}
+  serialcheck(ioctl(FHandle, FIONREAD, @result));
+  {$ELSE}
+  serialcheck(fpIoctl(FHandle, FIONREAD, @result));
+  {$ENDIF}
+  if FLastError <> 0 then
+    Result := 0;
+  ExceptCheck;
+end;
+{$ELSE}
+function TBlockSerial.WaitingData: integer;
+var
+  ResultCode: LongWord;
+begin
+  ResultCode := SerialDeviceRead(FSerialDevice, @ResultCode, SizeOf(ResultCode), SERIAL_READ_PEEK_BUFFER, LongWord(Result));
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+  begin
+    SerialCheck(sErr);
+    Result := 0;
+  end  
+  else
+    SetSynaError(sOK);
+  ExceptCheck;
+end;
+{$ENDIF}    
+{$ELSE}
+function TBlockSerial.WaitingData: integer;
+var
+  stat: TComStat;
+  err: DWORD;
+begin
+  err := 0;
+  if ClearCommError(FHandle, err, @stat) then
+  begin
+    SetSynaError(sOK);
+    Result := stat.cbInQue;
+  end
+  else
+  begin
+    SerialCheck(sErr);
+    Result := 0;
+  end;
+  ExceptCheck;
+end;
+{$ENDIF}
+
+function TBlockSerial.WaitingDataEx: integer;
+begin
+	if FBuffer <> '' then
+  	Result := Length(FBuffer)
+  else
+  	Result := Waitingdata;
+end;
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+function TBlockSerial.SendingData: integer;
+begin
+  SetSynaError(sOK);
+  Result := 0;
+end;
+{$ELSE}
+function TBlockSerial.SendingData: integer;
+var
+  ResultCode: LongWord;
+begin
+  ResultCode := SerialDeviceWrite(FSerialDevice, @ResultCode, SizeOf(ResultCode), SERIAL_WRITE_PEEK_BUFFER, LongWord(Result));
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+  begin
+    SerialCheck(sErr);
+    Result := 0;
+  end  
+  else
+  begin
+    SetSynaError(sOK);
+    Result := FSendBuffer - Result;
+  end;  
+  ExceptCheck;
+end;
+{$ENDIF}    
+{$ELSE}
+function TBlockSerial.SendingData: integer;
+var
+  stat: TComStat;
+  err: DWORD;
+begin
+  SetSynaError(sOK);
+  err := 0;
+  if not ClearCommError(FHandle, err, @stat) then
+    serialcheck(sErr);
+  ExceptCheck;
+  result := stat.cbOutQue;
+end;
+{$ENDIF}
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
+var
+  n: integer;
+  x: cardinal;
+begin
+  //others
+  cfmakeraw(term);
+  term.c_cflag := term.c_cflag or CREAD;
+  term.c_cflag := term.c_cflag or CLOCAL;
+  term.c_cflag := term.c_cflag or HUPCL;
+  //hardware handshake
+  if (dcb.flags and dcb_RtsControlHandshake) > 0 then
+    term.c_cflag := term.c_cflag or CRTSCTS
+  else
+    term.c_cflag := term.c_cflag and (not CRTSCTS);
+  //software handshake
+  if (dcb.flags and dcb_OutX) > 0 then
+    term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY
+  else
+    term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY));
+  //size of byte
+  term.c_cflag := term.c_cflag and (not CSIZE);
+  case dcb.bytesize of
+    5:
+      term.c_cflag := term.c_cflag or CS5;
+    6:
+      term.c_cflag := term.c_cflag or CS6;
+    7:
+  {$IFDEF FPC}
+      term.c_cflag := term.c_cflag or CS7;
+  {$ELSE}
+      term.c_cflag := term.c_cflag or CS7fix;
+  {$ENDIF}
+    8:
+      term.c_cflag := term.c_cflag or CS8;
+  end;
+  //parity
+  if (dcb.flags and dcb_ParityCheck) > 0 then
+    term.c_cflag := term.c_cflag or PARENB
+  else
+    term.c_cflag := term.c_cflag and (not PARENB);
+  case dcb.parity of
+    1: //'O'
+      term.c_cflag := term.c_cflag or PARODD;
+    2: //'E'
+      term.c_cflag := term.c_cflag and (not PARODD);
+  end;
+  //stop bits
+  if dcb.stopbits > 0 then
+    term.c_cflag := term.c_cflag or CSTOPB
+  else
+    term.c_cflag := term.c_cflag and (not CSTOPB);
+  //set baudrate;
+  x := 0;
+  for n := 0 to Maxrates do
+    if rates[n, 0] = dcb.BaudRate then
+    begin
+      x := rates[n, 1];
+      break;
+    end;
+  cfsetospeed(term, x);
+  cfsetispeed(term, x);
+end;
+
+procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB);
+var
+  n: integer;
+  x: cardinal;
+begin
+  //set baudrate;
+  dcb.baudrate := 0;
+ {$IFDEF FPC}
+  //why FPC not have cfgetospeed???
+  x := term.c_oflag and $0F;
+ {$ELSE}
+  x := cfgetospeed(term);
+ {$ENDIF}
+  for n := 0 to Maxrates do
+    if rates[n, 1] = x then
+    begin
+      dcb.baudrate := rates[n, 0];
+      break;
+    end;
+  //hardware handshake
+  if (term.c_cflag and CRTSCTS) > 0 then
+    dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
+  else
+    dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow));
+  //software handshake
+  if (term.c_cflag and IXOFF) > 0 then
+    dcb.flags := dcb.flags or dcb_OutX or dcb_InX
+  else
+    dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX));
+  //size of byte
+  case term.c_cflag and CSIZE of
+    CS5:
+      dcb.bytesize := 5;
+    CS6:
+      dcb.bytesize := 6;
+    CS7fix:
+      dcb.bytesize := 7;
+    CS8:
+      dcb.bytesize := 8;
+  end;
+  //parity
+  if (term.c_cflag and PARENB) > 0 then
+    dcb.flags := dcb.flags or dcb_ParityCheck
+  else
+    dcb.flags := dcb.flags and (not dcb_ParityCheck);
+  dcb.parity := 0;
+  if (term.c_cflag and PARODD) > 0 then
+    dcb.parity := 1
+  else
+    dcb.parity := 2;
+  //stop bits
+  if (term.c_cflag and CSTOPB) > 0 then
+    dcb.stopbits := 2
+  else
+    dcb.stopbits := 0;
+end;
+{$ENDIF}    
+{$ENDIF}
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+procedure TBlockSerial.SetCommState;
+begin
+  DcbToTermios(dcb, termiosstruc);
+  SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
+  ExceptCheck;
+end;
+{$ELSE}
+procedure TBlockSerial.SetCommState;
+var
+  ResultCode: LongWord;
+  Properties: TSerialProperties;
+begin
+  FillChar(Properties, SizeOf(TSerialProperties), 0);
+  
+  // Baud Rate
+  Properties.BaudRate := DCB.BaudRate;
+  
+  // Data bits
+  Properties.DataBits := SERIAL_DATA_8BIT;
+  case DCB.ByteSize of
+    7: Properties.DataBits := SERIAL_DATA_7BIT;
+    6: Properties.DataBits := SERIAL_DATA_6BIT;
+    5: Properties.DataBits := SERIAL_DATA_5BIT;
+  end;
+
+  // Stop Bits
+  Properties.StopBits := SERIAL_STOP_1BIT;
+  case DCB.StopBits of
+    2: Properties.StopBits := SERIAL_STOP_2BIT;
+    1: Properties.StopBits := SERIAL_STOP_1BIT5;
+  end;
+  
+  // Parity
+  Properties.Parity := SERIAL_PARITY_NONE;
+  case DCB.Parity of
+    1: Properties.Parity := SERIAL_PARITY_ODD;
+    2: Properties.Parity := SERIAL_PARITY_EVEN;
+    3: Properties.Parity := SERIAL_PARITY_MARK;
+    4: Properties.Parity := SERIAL_PARITY_SPACE;
+  end;
+  
+  // Flow Control
+  Properties.FlowControl := SERIAL_FLOW_NONE;
+  if (DCB.Flags and dcb_RtsControlHandshake) <> 0 then
+    Properties.FlowControl := SERIAL_FLOW_RTS_CTS
+  else if (DCB.Flags and dcb_DtrControlHandshake) <> 0 then 
+    Properties.FlowControl := SERIAL_FLOW_DSR_DTR;
+  
+  // Receive and Send Buffer
+  Properties.ReceiveDepth := FRecvBuffer;
+  Properties.TransmitDepth := FSendBuffer;
+  
+  // Set device properties
+  ResultCode := SerialDeviceSetProperties(FSerialDevice, @Properties);
+  
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+    SerialCheck(sErr)
+  else
+    SetSynaError(sOK);
+  ExceptCheck;
+end;
+{$ENDIF}    
+{$ELSE}
+procedure TBlockSerial.SetCommState;
+begin
+  SetSynaError(sOK);
+  if not windows.SetCommState(Fhandle, dcb) then
+    SerialCheck(sErr);
+  ExceptCheck;
+end;
+{$ENDIF}
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+procedure TBlockSerial.GetCommState;
+begin
+  SerialCheck(tcgetattr(FHandle, termiosstruc));
+  ExceptCheck;
+  TermiostoDCB(termiosstruc, dcb);
+end;
+{$ELSE}
+procedure TBlockSerial.GetCommState;
+var
+  ResultCode: LongWord;
+  Properties: TSerialProperties;
+begin
+  ResultCode := SerialDeviceGetProperties(FSerialDevice, @Properties);
+  SetLastError(ResultCode);
+  if ResultCode <> ERROR_SUCCESS then
+    SerialCheck(sErr)
+  else
+  begin
+    SetSynaError(sOK);
+   
+    // Get DCB 
+    DCB.DCBlength := SizeOf(Tdcb);
+    
+    // Baud Rate
+    DCB.BaudRate :=  Properties.BaudRate;
+    
+    // Flags
+    DCB.Flags := 0;
+    if Properties.Parity <> SERIAL_PARITY_NONE then
+      DCB.Flags := DCB.Flags or dcb_ParityCheck;
+    if Properties.FlowControl = SERIAL_FLOW_RTS_CTS then
+      DCB.Flags := DCB.Flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
+    else if Properties.FlowControl = SERIAL_FLOW_DSR_DTR then
+      DCB.Flags := DCB.Flags or dcb_DtrControlHandshake or dcb_OutxDsrFlow;
+    
+    // Data Bits
+    case Properties.DataBits of
+      SERIAL_DATA_8BIT: DCB.ByteSize := 8;
+      SERIAL_DATA_7BIT: DCB.ByteSize := 7;
+      SERIAL_DATA_6BIT: DCB.ByteSize := 6;
+      SERIAL_DATA_5BIT: DCB.ByteSize := 5;
+    end;
+    
+    // Parity
+    case Properties.Parity of
+      SERIAL_PARITY_NONE: DCB.Parity := 0;
+      SERIAL_PARITY_ODD: DCB.Parity := 1;
+      SERIAL_PARITY_EVEN: DCB.Parity := 2;
+      SERIAL_PARITY_MARK: DCB.Parity := 3;
+      SERIAL_PARITY_SPACE: DCB.Parity := 4;
+    end;
+    
+    // Stop Bits
+    case Properties.StopBits of
+      SERIAL_STOP_1BIT: DCB.StopBits := 0;
+      SERIAL_STOP_2BIT: DCB.StopBits := 2;
+      SERIAL_STOP_1BIT5: DCB.StopBits := 1;
+    end;
+  end;  
+  ExceptCheck;
+end;
+{$ENDIF}    
+{$ELSE}
+procedure TBlockSerial.GetCommState;
+begin
+  SetSynaError(sOK);
+  if not windows.GetCommState(Fhandle, dcb) then
+    SerialCheck(sErr);
+  ExceptCheck;
+end;
+{$ENDIF}
+
+procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
+begin
+{$IFDEF MSWINDOWS}
+  SetupComm(Fhandle, size, 0);
+  GetCommState;
+  dcb.XonLim := size div 4;
+  dcb.XoffLim := size div 4;
+  SetCommState;
+{$ENDIF}
+  FRecvBuffer := size;
+end;
+
+{$IFDEF ULTIBO}
+procedure TBlockSerial.SetSizeSendBuffer(size: integer);
+begin
+  FSendBuffer := size;
+end;
+{$ENDIF}
+
+function TBlockSerial.GetDSR: Boolean;
+begin
+  ModemStatus;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  Result := (FModemWord and TIOCM_DSR) > 0;
+{$ELSE}
+  Result := (FModemWord and SERIAL_STATUS_DSR) <> 0;
+{$ENDIF}    
+{$ELSE}
+  Result := (FModemWord and MS_DSR_ON) > 0;
+{$ENDIF}
+end;
+
+procedure TBlockSerial.SetDTRF(Value: Boolean);
+begin
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  ModemStatus;
+  if Value then
+    FModemWord := FModemWord or TIOCM_DTR
+  else
+    FModemWord := FModemWord and not TIOCM_DTR;
+  {$IFNDEF FPC}
+  ioctl(FHandle, TIOCMSET, @FModemWord);
+  {$ELSE}
+  fpioctl(FHandle, TIOCMSET, @FModemWord);
+  {$ENDIF}
+{$ELSE}
+  if Value then
+    SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) or SERIAL_STATUS_DTR)
+  else
+    SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) and not(SERIAL_STATUS_DTR));
+{$ENDIF}    
+{$ELSE}
+  if Value then
+    EscapeCommFunction(FHandle, SETDTR)
+  else
+    EscapeCommFunction(FHandle, CLRDTR);
+{$ENDIF}
+end;
+
+function TBlockSerial.GetCTS: Boolean;
+begin
+  ModemStatus;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  Result := (FModemWord and TIOCM_CTS) > 0;
+{$ELSE}
+  Result := (FModemWord and SERIAL_STATUS_CTS) <> 0;
+{$ENDIF}    
+{$ELSE}
+  Result := (FModemWord and MS_CTS_ON) > 0;
+{$ENDIF}
+end;
+
+procedure TBlockSerial.SetRTSF(Value: Boolean);
+begin
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  ModemStatus;
+  if Value then
+    FModemWord := FModemWord or TIOCM_RTS
+  else
+    FModemWord := FModemWord and not TIOCM_RTS;
+  {$IFNDEF FPC}
+  ioctl(FHandle, TIOCMSET, @FModemWord);
+  {$ELSE}
+  fpioctl(FHandle, TIOCMSET, @FModemWord);
+  {$ENDIF}
+{$ELSE}
+  if Value then
+    SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) or SERIAL_STATUS_RTS)
+  else
+    SerialDeviceSetStatus(FSerialDevice, SerialDeviceGetStatus(FSerialDevice) and not(SERIAL_STATUS_RTS));
+{$ENDIF}    
+{$ELSE}
+  if Value then
+    EscapeCommFunction(FHandle, SETRTS)
+  else
+    EscapeCommFunction(FHandle, CLRRTS);
+{$ENDIF}
+end;
+
+function TBlockSerial.GetCarrier: Boolean;
+begin
+  ModemStatus;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  Result := (FModemWord and TIOCM_CAR) > 0;
+{$ELSE}
+  Result := (FModemWord and SERIAL_STATUS_DCD) <> 0;
+{$ENDIF}    
+{$ELSE}
+  Result := (FModemWord and MS_RLSD_ON) > 0;
+{$ENDIF}
+end;
+
+function TBlockSerial.GetRing: Boolean;
+begin
+  ModemStatus;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  Result := (FModemWord and TIOCM_RNG) > 0;
+{$ELSE}
+  Result := (FModemWord and SERIAL_STATUS_RI) <> 0;
+{$ENDIF}    
+{$ELSE}
+  Result := (FModemWord and MS_RING_ON) > 0;
+{$ENDIF}
+end;
+
+{$IFDEF MSWINDOWS}
+function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
+var
+  ex: DWord;
+  y: Integer;
+  Overlapped: TOverlapped;
+begin
+  FillChar(Overlapped, Sizeof(Overlapped), 0);
+  Overlapped.hEvent := CreateEvent(nil, True, False, nil);
+  try
+    SetCommMask(FHandle, Event);
+    SetSynaError(sOK);
+    if (Event = EV_RXCHAR) and (Waitingdata > 0) then
+      Result := True
+    else
+    begin
+      y := 0;
+      ex := 0;
+      if not WaitCommEvent(FHandle, ex, @Overlapped) then
+        y := GetLastError;
+      if y = ERROR_IO_PENDING then
+      begin
+        //timedout
+        WaitForSingleObject(Overlapped.hEvent, Timeout);
+        SetCommMask(FHandle, 0);
+        GetOverlappedResult(FHandle, Overlapped, DWord(y), True);
+      end;
+      Result := (ex and Event) = Event;
+    end;
+  finally
+    SetCommMask(FHandle, 0);
+    CloseHandle(Overlapped.hEvent);
+  end;
+end;
+{$ENDIF}
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+function TBlockSerial.CanRead(Timeout: integer): boolean;
+var
+  FDSet: TFDSet;
+  TimeVal: PTimeVal;
+  TimeV: TTimeVal;
+  x: Integer;
+begin
+  TimeV.tv_usec := (Timeout mod 1000) * 1000;
+  TimeV.tv_sec := Timeout div 1000;
+  TimeVal := @TimeV;
+  if Timeout = -1 then
+    TimeVal := nil;
+  {$IFNDEF FPC}
+  FD_ZERO(FDSet);
+  FD_SET(FHandle, FDSet);
+  x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
+  {$ELSE}
+  fpFD_ZERO(FDSet);
+  fpFD_SET(FHandle, FDSet);
+  x := fpSelect(FHandle + 1, @FDSet, nil, nil, TimeVal);
+  {$ENDIF}
+  SerialCheck(x);
+  if FLastError <> sOK then
+    x := 0;
+  Result := x > 0;
+  ExceptCheck;
+  if Result then
+    DoStatus(HR_CanRead, '');
+end;
+{$ELSE}
+function TBlockSerial.CanRead(Timeout: integer): boolean;
+var
+  Count: LongWord;
+begin
+  Result := WaitingData > 0;
+  if not Result then
+  begin
+    if Timeout <> 0 then
+    begin
+      if Timeout = -1 then
+        Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_RECEIVE, INFINITE, Count) = ERROR_SUCCESS
+      else
+        Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_RECEIVE, Timeout, Count) = ERROR_SUCCESS;
+    end;  
+  end;  
+  if Result then
+    DoStatus(HR_CanRead, '');
+end;
+{$ENDIF}    
+{$ELSE}
+function TBlockSerial.CanRead(Timeout: integer): boolean;
+begin
+  Result := WaitingData > 0;
+  if not Result then
+    Result := CanEvent(EV_RXCHAR, Timeout) or (WaitingData > 0);
+    //check WaitingData again due some broken virtual ports
+  if Result then
+    DoStatus(HR_CanRead, '');
+end;
+{$ENDIF}
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+function TBlockSerial.CanWrite(Timeout: integer): boolean;
+var
+  FDSet: TFDSet;
+  TimeVal: PTimeVal;
+  TimeV: TTimeVal;
+  x: Integer;
+begin
+  TimeV.tv_usec := (Timeout mod 1000) * 1000;
+  TimeV.tv_sec := Timeout div 1000;
+  TimeVal := @TimeV;
+  if Timeout = -1 then
+    TimeVal := nil;
+  {$IFNDEF FPC}
+  FD_ZERO(FDSet);
+  FD_SET(FHandle, FDSet);
+  x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
+  {$ELSE}
+  fpFD_ZERO(FDSet);
+  fpFD_SET(FHandle, FDSet);
+  x := fpSelect(FHandle + 1, nil, @FDSet, nil, TimeVal);
+  {$ENDIF}
+  SerialCheck(x);
+  if FLastError <> sOK then
+    x := 0;
+  Result := x > 0;
+  ExceptCheck;
+  if Result then
+    DoStatus(HR_CanWrite, '');
+end;
+{$ELSE}
+function TBlockSerial.CanWrite(Timeout: integer): boolean;
+var
+  Count: LongWord;
+begin
+  Result := SendingData < FSendBuffer;
+  if not Result then
+  begin
+    if Timeout <> 0 then
+    begin
+      if Timeout = -1 then
+        Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_TRANSMIT, INFINITE, Count) = ERROR_SUCCESS
+      else
+        Result := SerialDeviceWait(FSerialDevice, SERIAL_WAIT_TRANSMIT, Timeout, Count) = ERROR_SUCCESS;
+    end;  
+  end;  
+  if Result then
+    DoStatus(HR_CanWrite, '');
+end;
+{$ENDIF}    
+{$ELSE}
+function TBlockSerial.CanWrite(Timeout: integer): boolean;
+var
+  t: LongWord;
+begin
+  Result := SendingData = 0;
+  if not Result then
+	  Result := CanEvent(EV_TXEMPTY, Timeout);
+  {$IFDEF WIN32}
+  if Result and (Win32Platform <> VER_PLATFORM_WIN32_NT) then
+  begin
+    t := GetTick;
+    while not ReadTxEmpty(FPortAddr) do
+    begin
+      if TickDelta(t, GetTick) > 255 then
+        Break;
+      Sleep(0);
+    end;
+  end;
+  {$ENDIF}
+  if Result then
+    DoStatus(HR_CanWrite, '');
+end;
+{$ENDIF}
+
+function TBlockSerial.CanReadEx(Timeout: integer): boolean;
+begin
+	if Fbuffer <> '' then
+  	Result := True
+  else
+  	Result := CanRead(Timeout);
+end;
+
+procedure TBlockSerial.EnableRTSToggle(Value: boolean);
+begin
+  SetSynaError(sOK);
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  FRTSToggle := Value;
+  if Value then
+    RTS:=False;
+{$ELSE}
+  FRTSToggle := Value;
+  if Value then
+    RTS:=False;
+{$ENDIF}    
+{$ELSE}
+  if Win32Platform = VER_PLATFORM_WIN32_NT then
+  begin
+    GetCommState;
+    if value then
+      dcb.Flags := dcb.Flags or dcb_RtsControlToggle
+    else
+      dcb.flags := dcb.flags and (not dcb_RtsControlToggle);
+    SetCommState;
+  end
+  else
+  begin
+    FRTSToggle := Value;
+    if Value then
+      RTS:=False;
+  end;
+{$ENDIF}
+end;
+
+procedure TBlockSerial.Flush;
+begin
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  SerialCheck(tcdrain(FHandle));
+{$ELSE}
+  SetSynaError(sOK);
+  while SendingData > 0 do
+  begin
+   Sleep(0);
+  end;
+{$ENDIF}    
+{$ELSE}
+  SetSynaError(sOK);
+  if not Flushfilebuffers(FHandle) then
+    SerialCheck(sErr);
+{$ENDIF}
+  ExceptCheck;
+end;
+
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+procedure TBlockSerial.Purge;
+begin
+  {$IFNDEF FPC}
+  SerialCheck(ioctl(FHandle, TCFLSH, TCIOFLUSH));
+  {$ELSE}
+    {$IFDEF DARWIN}
+    SerialCheck(fpioctl(FHandle, TCIOflush, Pointer(PtrInt(TCIOFLUSH))));
+    {$ELSE}
+    SerialCheck(fpioctl(FHandle, {$IFDEF FreeBSD}TCIOFLUSH{$ELSE}TCFLSH{$ENDIF}, Pointer(PtrInt(TCIOFLUSH))));
+    {$ENDIF}
+  {$ENDIF}
+  FBuffer := '';
+  ExceptCheck;
+end;
+{$ELSE}
+procedure TBlockSerial.Purge;
+begin
+  SetSynaError(sOK);
+  if SerialDeviceFlush(FSerialDevice, SERIAL_FLUSH_RECEIVE or SERIAL_FLUSH_TRANSMIT) <> ERROR_SUCCESS then
+  begin
+    SerialCheck(sErr);
+  end;  
+  FBuffer := '';
+  ExceptCheck;
+end;
+{$ENDIF}    
+{$ELSE}
+procedure TBlockSerial.Purge;
+var
+  x: integer;
+begin
+  SetSynaError(sOK);
+  x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR;
+  if not PurgeComm(FHandle, x) then
+    SerialCheck(sErr);
+  FBuffer := '';
+  ExceptCheck;
+end;
+{$ENDIF}
+
+function TBlockSerial.ModemStatus: integer;
+begin
+  Result := 0;
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  {$IFNDEF FPC}
+  SerialCheck(ioctl(FHandle, TIOCMGET, @Result));
+  {$ELSE}
+  SerialCheck(fpioctl(FHandle, TIOCMGET, @Result));
+  {$ENDIF}
+{$ELSE}
+  SetSynaError(sOK);
+  Result:=SerialDeviceStatus(FSerialDevice);
+{$ENDIF}    
+{$ELSE}
+  SetSynaError(sOK);
+  if not GetCommModemStatus(FHandle, dword(Result)) then
+    SerialCheck(sErr);
+{$ENDIF}
+  ExceptCheck;
+  FModemWord := Result;
+end;
+
+procedure TBlockSerial.SetBreak(Duration: integer);
+begin
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+  SerialCheck(tcsendbreak(FHandle, Duration));
+{$ELSE}
+  //To Do //Ultibo //SerialDeviceSetBreak/ClearBreak to be implemented
+{$ENDIF}    
+{$ELSE}
+  SetCommBreak(FHandle);
+  Sleep(Duration);
+  SetSynaError(sOK);
+  if not ClearCommBreak(FHandle) then
+    SerialCheck(sErr);
+{$ENDIF}
+end;
+
+{$IFDEF MSWINDOWS}
+procedure TBlockSerial.DecodeCommError(Error: DWord);
+begin
+  if (Error and DWord(CE_FRAME)) > 1 then
+    FLastError := ErrFrame;
+  if (Error and DWord(CE_OVERRUN)) > 1 then
+    FLastError := ErrOverrun;
+  if (Error and DWord(CE_RXOVER)) > 1 then
+    FLastError := ErrRxOver;
+  if (Error and DWord(CE_RXPARITY)) > 1 then
+    FLastError := ErrRxParity;
+  if (Error and DWord(CE_TXFULL)) > 1 then
+    FLastError := ErrTxFull;
+end;
+{$ENDIF}
+
+//HGJ
+function TBlockSerial.PreTestFailing: Boolean;
+begin
+  if not FInstanceActive then
+  begin
+    RaiseSynaError(ErrPortNotOpen);
+    result:= true;
+    Exit;
+  end;
+  Result := not TestCtrlLine;
+  if result then
+    RaiseSynaError(ErrNoDeviceAnswer)
+end;
+
+function TBlockSerial.TestCtrlLine: Boolean;
+begin
+  result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
+end;
+
+function TBlockSerial.ATCommand(value: AnsiString): AnsiString;
+var
+  s: AnsiString;
+  ConvSave: Boolean;
+begin
+  result := '';
+  FAtResult := False;
+  ConvSave := FConvertLineEnd;
+  try
+    FConvertLineEnd := True;
+    SendString(value + #$0D);
+    repeat
+      s := RecvString(FAtTimeout);
+      if s <> Value then
+        result := result + s + CRLF;
+      if s = 'OK' then
+      begin
+        FAtResult := True;
+        break;
+      end;
+      if s = 'ERROR' then
+        break;
+    until FLastError <> sOK;
+  finally
+    FConvertLineEnd := Convsave;
+  end;
+end;
+
+
+function TBlockSerial.ATConnect(value: AnsiString): AnsiString;
+var
+  s: AnsiString;
+  ConvSave: Boolean;
+begin
+  result := '';
+  FAtResult := False;
+  ConvSave := FConvertLineEnd;
+  try
+    FConvertLineEnd := True;
+    SendString(value + #$0D);
+    repeat
+      s := RecvString(90 * FAtTimeout);
+      if s <> Value then
+        result := result + s + CRLF;
+      if s = 'NO CARRIER' then
+        break;
+      if s = 'ERROR' then
+        break;
+      if s = 'BUSY' then
+        break;
+      if s = 'NO DIALTONE' then
+        break;
+      if Pos('CONNECT', s) = 1 then
+      begin
+        FAtResult := True;
+        break;
+      end;
+    until FLastError <> sOK;
+  finally
+    FConvertLineEnd := Convsave;
+  end;
+end;
+
+function TBlockSerial.SerialCheck(SerialResult: integer): integer;
+begin
+  if SerialResult = integer(INVALID_HANDLE_VALUE) then
+{$IFDEF MSWINDOWS}
+    result := GetLastError
+{$ELSE}
+  {$IFDEF ULTIBO}
+    result := GetLastError
+  {$ELSE}
+    {$IFNDEF FPC}
+      result := GetLastError
+    {$ELSE}
+      result := fpGetErrno
+    {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+  else
+    result := sOK;
+  FLastError := result;
+  FLastErrorDesc := GetErrorDesc(FLastError);
+end;
+
+procedure TBlockSerial.ExceptCheck;
+var
+  e: ESynaSerError;
+  s: string;
+begin
+  if FRaiseExcept and (FLastError <> sOK) then
+  begin
+    s := GetErrorDesc(FLastError);
+    e := ESynaSerError.CreateFmt('Communication error %d: %s', [FLastError, s]);
+    e.ErrorCode := FLastError;
+    e.ErrorMessage := s;
+    raise e;
+  end;
+end;
+
+procedure TBlockSerial.SetSynaError(ErrNumber: integer);
+begin
+  FLastError := ErrNumber;
+  FLastErrorDesc := GetErrorDesc(FLastError);
+end;
+
+procedure TBlockSerial.RaiseSynaError(ErrNumber: integer);
+begin
+  SetSynaError(ErrNumber);
+  ExceptCheck;
+end;
+
+procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string);
+begin
+  if assigned(OnStatus) then
+    OnStatus(Self, Reason, Value);
+end;
+
+{======================================================================}
+
+class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
+begin
+  Result:= '';
+  case ErrorCode of
+    sOK:               Result := 'OK';
+    ErrAlreadyOwned:   Result := 'Port owned by other process';{HGJ}
+    ErrAlreadyInUse:   Result := 'Instance already in use';    {HGJ}
+    ErrWrongParameter: Result := 'Wrong parameter at call';     {HGJ}
+    ErrPortNotOpen:    Result := 'Instance not yet connected'; {HGJ}
+    ErrNoDeviceAnswer: Result := 'No device answer detected';  {HGJ}
+    ErrMaxBuffer:      Result := 'Maximal buffer length exceeded';
+    ErrTimeout:        Result := 'Timeout during operation';
+    ErrNotRead:        Result := 'Reading of data failed';
+    ErrFrame:          Result := 'Receive framing error';
+    ErrOverrun:        Result := 'Receive Overrun Error';
+    ErrRxOver:         Result := 'Receive Queue overflow';
+    ErrRxParity:       Result := 'Receive Parity Error';
+    ErrTxFull:         Result := 'Tranceive Queue is full';
+  end;
+  if Result = '' then
+  begin
+    Result := SysErrorMessage(ErrorCode);
+  end;
+end;
+
+
+{---------- cpom Comport Ownership Manager Routines -------------
+ by Hans-Georg Joepgen of Stuttgart, Germany.
+ Copyright (c) 2002, by Hans-Georg Joepgen
+
+  Stefan Krauss of Stuttgart, Germany, contributed literature and Internet
+  research results, invaluable advice and excellent answers to the Comport
+  Ownership Manager.
+}
+
+{$IFDEF UNIX}
+
+function TBlockSerial.LockfileName: String;
+var
+  s: string;
+begin
+  s := SeparateRight(FDevice, '/dev/');
+  result := LockfileDirectory + '/LCK..' + s;
+end;
+
+procedure TBlockSerial.CreateLockfile(PidNr: integer);
+var
+  f: TextFile;
+  s: string;
+begin
+  // Create content for file
+  s := IntToStr(PidNr);
+  while length(s) < 10 do
+    s := ' ' + s;
+  // Create file
+  try
+    AssignFile(f, LockfileName);
+    try
+      Rewrite(f);
+      writeln(f, s);
+    finally
+      CloseFile(f);
+    end;
+    // Allow all users to enjoy the benefits of cpom
+    s := 'chmod a+rw ' + LockfileName;
+  {$IFNDEF FPC}
+    FileSetReadOnly( LockfileName, False ) ;
+    // Libc.system(pchar(s));
+  {$ELSE}
+    fpSystem(s);
+  {$ENDIF}
+  except
+    // not raise exception, if you not have write permission for lock.
+    on Exception do
+      ;
+  end;
+end;
+
+function TBlockSerial.ReadLockfile: integer;
+{Returns PID from Lockfile. Lockfile must exist.}
+var
+  f: TextFile;
+  s: string;
+begin
+  AssignFile(f, LockfileName);
+  Reset(f);
+  try
+    readln(f, s);
+  finally
+    CloseFile(f);
+  end;
+  Result := StrToIntDef(s, -1)
+end;
+
+function TBlockSerial.cpomComportAccessible: boolean;
+var
+  MyPid: integer;
+  Filename: string;
+begin
+  Filename := LockfileName;
+  {$IFNDEF FPC}
+  MyPid := Libc.getpid;
+  {$ELSE}
+  MyPid := fpGetPid;
+  {$ENDIF}
+  // Make sure, the Lock Files Directory exists. We need it.
+  if not DirectoryExists(LockfileDirectory) then
+    CreateDir(LockfileDirectory);
+  // Check the Lockfile
+  if not FileExists (Filename) then
+  begin // comport is not locked. Lock it for us.
+    CreateLockfile(MyPid);
+    result := true;
+    exit;  // done.
+  end;
+  // Is port owned by orphan? Then it's time for error recovery.
+  //FPC forgot to add getsid.. :-(
+  {$IFNDEF FPC}
+  if Libc.getsid(ReadLockfile) = -1 then
+  begin //  Lockfile was left from former desaster
+    DeleteFile(Filename); // error recovery
+    CreateLockfile(MyPid);
+    result := true;
+    exit;
+  end;
+  {$ENDIF}
+  result := false // Sorry, port is owned by living PID and locked
+end;
+
+procedure TBlockSerial.cpomReleaseComport;
+begin
+  DeleteFile(LockfileName);
+end;
+
+{$ENDIF}
+{----------------------------------------------------------------}
+
+{$IFDEF MSWINDOWS}
+function GetSerialPortNames: string;
+var
+  reg: TRegistry;
+  l, v: TStringList;
+  n: integer;
+begin
+  l := TStringList.Create;
+  v := TStringList.Create;
+  reg := TRegistry.Create;
+  try
+{$IFNDEF VER100}
+{$IFNDEF VER120}
+    reg.Access := KEY_READ;
+{$ENDIF}
+{$ENDIF}
+    reg.RootKey := HKEY_LOCAL_MACHINE;
+    reg.OpenKey('\HARDWARE\DEVICEMAP\SERIALCOMM', false);
+    reg.GetValueNames(l);
+    for n := 0 to l.Count - 1 do
+      v.Add(PChar(reg.ReadString(l[n])));
+    Result := v.CommaText;
+  finally
+    reg.Free;
+    l.Free;
+    v.Free;
+  end;
+end;
+{$ENDIF}
+{$IFNDEF MSWINDOWS}
+{$IFNDEF ULTIBO}
+function GetSerialPortNames: string;
+var
+  sr : TSearchRec;
+begin
+  Result := '';
+  if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then
+    repeat
+      if (sr.Attr and $FFFFFFFF) = Sr.Attr then
+      begin
+        if Result <> '' then
+          Result := Result + ',';
+        Result := Result + '/dev/' + sr.Name;
+      end;
+    until FindNext(sr) <> 0;
+  FindClose(sr);
+  if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin
+    repeat
+      if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
+        if Result <> '' then Result := Result + ',';
+        Result := Result + '/dev/' + sr.Name;
+      end;
+    until FindNext(sr) <> 0;
+  end;
+  FindClose(sr);
+  if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin
+    repeat
+      if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin
+        if Result <> '' then Result := Result + ',';
+        Result := Result + '/dev/' + sr.Name;
+      end;
+    until FindNext(sr) <> 0;
+  end;
+  FindClose(sr);
+end;
+{$ELSE}
+type
+  PSerialCallbackData = ^TSerialCallbackData;
+  TSerialCallbackData = record
+    Count: Integer;
+    Devices: String;
+  end;
+  
+function SerialDeviceCallback(Serial:PSerialDevice;Data:Pointer):LongWord;
+var 
+  SerialCallbackData: PSerialCallbackData;
+begin
+  Result := ERROR_INVALID_PARAMETER;
+  
+  if Serial = nil then Exit;
+  if Data = nil then Exit;
+ 
+  //Get data
+  SerialCallbackData := PSerialCallbackData(Data);
+ 
+  //Increment count
+  Inc(SerialCallbackData.Count);
+  
+  //Add comma
+  if SerialCallbackData.Devices <> '' then
+    SerialCallbackData.Devices := SerialCallbackData.Devices + ',';
+    
+  //Add device name
+  SerialCallbackData.Devices := SerialCallbackData.Devices + DeviceGetName(@Serial.Device);
+  
+  Result:=ERROR_SUCCESS;
+end;
+
+function GetSerialPortNames: string;
+var
+  SerialCallbackData: TSerialCallbackData;
+begin
+  //Setup callback
+  SerialCallbackData.Count := 0;
+  SerialCallbackData.Devices := '';
+  
+  //Perform callback
+  SerialDeviceEnumerate(SerialDeviceCallback, @SerialCallbackData);
+  
+  //Return names
+  Result := SerialCallbackData.Devices;
+end;
+{$ENDIF}
+{$ENDIF}
+
+end.

synautil.pas

@@ -0,0 +1,2161 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 004.015.007 |
+|==============================================================================|
+| Content: support procedures and functions                                    |
+|==============================================================================|
+| Copyright (c)1999-2017, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c) 1999-2017.               |
+| Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
+| Portions created by Petr Fejfar are Copyright (c)2011-2012.                  |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Hernan Sanchez ([email protected])                                  |
+|   Tomas Hajny (OS2 support)                                                  |
+|   Radek Cervinka (POSIX support)                                             |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Support procedures and functions)}
+
+{$I jedi.inc} // load common compiler defines
+
+{$Q-}
+{$R-}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+  {$WARN SUSPICIOUS_TYPECAST OFF}
+{$ENDIF}
+
+unit synautil;
+
+interface
+
+uses
+{$IFDEF MSWINDOWS}
+  Windows,
+{$ELSE MSWINDOWS}
+  {$IFDEF ULTIBO}
+    Ultibo,
+  {$ELSE} 
+    {$IFDEF FPC}
+      {$IFDEF OS2}
+      Dos, TZUtil,
+      {$ELSE OS2}
+      UnixUtil, Unix, BaseUnix,
+      {$ENDIF OS2}
+    {$ELSE FPC}
+      {$IFDEF POSIX}
+        Posix.Base, Posix.Time, Posix.SysTypes, Posix.SysTime, Posix.Stdio,
+        Posix.Unistd,
+      {$ELSE}
+        Libc,
+      {$ENDIF}
+    {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+{$IFDEF CIL}
+  System.IO,
+{$ENDIF}
+  SysUtils, Classes, SynaFpc, synabyte;
+
+{$IFDEF VER100}
+type
+  int64 = integer;
+{$ENDIF}
+{$IFDEF POSIX}
+type
+  TTimeVal = Posix.SysTime.timeval;
+  Ttimezone = record
+               tz_minuteswest: Integer ;     // minutes west of Greenwich
+               tz_dsttime: integer ;         // type of DST correction
+           end;
+
+  PTimeZone = ^Ttimezone;
+{$ENDIF}
+
+
+{:Return your timezone bias from UTC time in minutes.}
+function TimeZoneBias: integer;
+
+{:Return your timezone bias from UTC time in string representation like "+0200".}
+function TimeZone: string;
+
+{:Returns current time in format defined in RFC-822. Useful for SMTP messages,
+ but other protocols use this time format as well. Results contains the timezone
+ specification. Four digit year is used to break any Y2K concerns. (Example
+ 'Fri, 15 Oct 1999 21:14:56 +0200')}
+function Rfc822DateTime(t: TDateTime): string;
+
+{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
+function CDateTime(t: TDateTime): string;
+
+{:Returns date and time in format defined in format 'yymmdd hhnnss'}
+function SimpleDateTime(t: TDateTime): string;
+
+{:Returns date and time in format defined in ANSI C compilers in format
+ "ddd mmm d hh:nn:ss yyyy" }
+function AnsiCDateTime(t: TDateTime): string;
+
+{:Decode three-letter string with name of month to their month number. If string
+ not match any month name, then is returned 0. For parsing are used predefined
+ names for English, French and German and names from system locale too.}
+function GetMonthNumber(Value: String): integer;
+
+{:Return decoded time from given string. Time must be witch separator ':'. You
+ can use "hh:mm" or "hh:mm:ss".}
+function GetTimeFromStr(Value: string): TDateTime;
+
+{:Decode string representation of TimeZone (CEST, GMT, +0200, -0800, etc.)
+ to timezone offset.} 
+function DecodeTimeZone(const Value: string; var Zone: integer): Boolean;
+
+{:Decode string in format "m-d-y" to TDateTime type.}
+function GetDateMDYFromStr(Value: string): TDateTime;
+
+{:Decode various string representations of date and time to Tdatetime type.
+ This function do all timezone corrections too! This function can decode lot of
+  formats like:
+ @longcode(#
+ ddd, d mmm yyyy hh:mm:ss
+ ddd, d mmm yy hh:mm:ss
+ ddd, mmm d yyyy hh:mm:ss
+ ddd mmm dd hh:mm:ss yyyy #)
+
+and more with lot of modifications, include:
+@longcode(#
+Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
+Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
+Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format
+#)
+Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
+or numeric representation (like +0200). By convention defined in RFC timezone
+ +0000 is GMT and -0000 is current your system timezone.}
+function DecodeRfcDateTime(Value: string): TDateTime;
+
+{:Return current system date and time in UTC timezone.}
+function GetUTTime: TDateTime;
+
+{:Set Newdt as current system date and time in UTC timezone. This function work
+ only if you have administrator rights!}
+function SetUTTime(Newdt: TDateTime): Boolean;
+
+{:Return current value of system timer with precizion 1 millisecond. Good for
+ measure time difference.}
+function GetTick: LongWord;
+
+{:Return difference between two timestamps. It working fine only for differences
+ smaller then maxint. (difference must be smaller then 24 days.)}
+function TickDelta(TickOld, TickNew: LongWord): LongWord;
+
+{:Return two characters, which ordinal values represents the value in byte
+ format. (High-endian)}
+function CodeInt(Value: Word): string;
+
+{:Decodes two characters located at "Index" offset position of the "Value"
+ string to Word values.}
+function DecodeInt(const Value: string; Index: integer): Word;
+
+{:Return four characters, which ordinal values represents the value in byte
+ format. (High-endian)}
+function CodeLongInt(Value: LongInt): string;
+
+{:Decodes four characters located at "Index" offset position of the "Value"
+ string to LongInt values.}
+function DecodeLongInt(const Value: string; Index: integer): LongInt;
+
+{:Dump binary buffer stored in a string to a result string.}
+function DumpStr(const Buffer: string): string;
+
+{:Dump binary buffer stored in a string to a result string. All bytes with code
+ of character is written as character, not as hexadecimal value.}
+function DumpExStr(const Buffer: string): string;
+
+{:Dump binary buffer stored in a string to a file with DumpFile filename.}
+procedure Dump(const Buffer: string; const DumpFile: string);
+
+{:Dump binary buffer stored in a string to a file with DumpFile filename. All
+ bytes with code of character is written as character, not as hexadecimal value.}
+procedure DumpEx(const Buffer: string; const DumpFile: string);
+
+{:Like TrimLeft, but remove only spaces, not control characters!}
+function TrimSPLeft(const S: string): string;
+
+{:Like TrimRight, but remove only spaces, not control characters!}
+function TrimSPRight(const S: string): string;
+
+{:Like Trim, but remove only spaces, not control characters!}
+function TrimSP(const S: string): string;
+
+{:Returns a portion of the "Value" string located to the left of the "Delimiter"
+ string. If a delimiter is not found, results is original string.}
+function SeparateLeft(const Value, Delimiter: string): string;
+
+{:Returns the portion of the "Value" string located to the right of the
+ "Delimiter" string. If a delimiter is not found, results is original string.}
+function SeparateRight(const Value, Delimiter: string): string;
+
+{:Returns parameter value from string in format:
+ parameter1="value1"; parameter2=value2}
+function GetParameter(const Value, Parameter: string): string;
+
+{:parse value string with elements differed by Delimiter into stringlist.}
+procedure ParseParametersEx(Value: string; const Delimiter: string; const Parameters: TStrings);
+
+{:parse value string with elements differed by ';' into stringlist.}
+procedure ParseParameters(const Value: string; const Parameters: TStrings);
+
+{:Index of string in stringlist with same beginning as Value is returned.}
+function IndexByBegin(Value: string; const List: TStrings): integer;
+
+{:Returns only the e-mail portion of an address from the full address format.
+ i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'}
+function GetEmailAddr(const Value: string): string;
+
+{:Returns only the description part from a full address format. i.e. returns
+ 'someone' from '"someone" <nobody@@somewhere.com>'}
+function GetEmailDesc(Value: string): string;
+
+{:Returns a string with hexadecimal digits representing the corresponding values
+ of the bytes found in "Value" string.}
+function StrToHex(const Value: string): string;
+
+{:Returns a string of binary "Digits" representing "Value".}
+function IntToBin(Value: Integer; Digits: Byte): string;
+
+{:Returns an integer equivalent of the binary string in "Value".
+ (i.e. ('10001010') returns 138)}
+function BinToInt(const Value: string): Integer;
+
+{:Parses a URL to its various components.}
+function ParseURL(const URL: string; var Prot, User, Pass, Host, Port, Path,
+  Para: string): string;
+
+{:Replaces all "Search" string values found within "Value" string, with the
+ "Replace" string value.}
+function ReplaceString(Value: string; const Search, Replace: string): string;
+
+{:It is like RPos, but search is from specified possition.}
+function RPosEx(const Sub, Value: string; From: integer): Integer;
+
+{:It is like POS function, but from right side of Value string.}
+function RPos(const Sub, Value: String): Integer;
+
+{:Like @link(fetch), but working with binary strings, not with text.}
+function FetchBin(var Value: string; const Delimiter: string): string;
+
+{:Fetch string from left of Value string.}
+function Fetch(var Value: string; const Delimiter: string): string;
+
+{:Fetch string from left of Value string. This function ignore delimitesr inside
+ quotations.}
+function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
+
+{:If string is binary string (contains non-printable characters), then is
+ returned true.}
+function IsBinaryString(const Value: string): Boolean;
+
+{:return position of string terminator in string. If terminator found, then is
+ returned in terminator parameter.
+ Possible line terminators are: CRLF, LFCR, CR, LF}
+function PosCRLF(const Value: string; var Terminator: string): integer;
+
+{:Delete empty strings from end of stringlist.}
+Procedure StringsTrim(const value: TStrings);
+
+{:Like Pos function, buf from given string possition.}
+function PosFrom(const SubStr, Value: String; From: integer): integer;
+
+{$IFNDEF CIL}
+{:Increase pointer by value.}
+function IncPoint(const p: pbyte; Value: integer): pointer;
+{$ENDIF}
+
+{:Get string between PairBegin and PairEnd. This function respect nesting.
+ For example:
+ @longcode(#
+ Value is: 'Hi! (hello(yes!))'
+ pairbegin is: '('
+ pairend is: ')'
+ In this case result is: 'hello(yes!)'#)}
+function GetBetween(const PairBegin, PairEnd, Value: string): string;
+
+{:Return count of Chr in Value string.}
+function CountOfChar(const Value: string; Chr: char): integer;
+
+{:Remove quotation from Value string. If Value is not quoted, then return same
+ string without any modification. }
+function UnquoteStr(const Value: string; Quote: Char): string;
+
+{:Quote Value string. If Value contains some Quote chars, then it is doubled.}
+function QuoteStr(const Value: string; Quote: Char): string;
+
+{:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
+procedure HeadersToList(const Value: TStrings);
+
+{:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
+procedure ListToHeaders(const Value: TStrings);
+
+{:swap bytes in integer.}
+function SwapBytes(Value: integer): integer;
+
+{:read string with requested length form stream.}
+function ReadStrFromStream(const Stream: TStream; len: integer): string;
+
+{:write string to stream.}
+procedure WriteStrToStream(const Stream: TStream; const Value: string); {$IFDEF UNICODE} overload;{$ENDIF}
+
+{$IFDEF UNICODE}
+procedure WriteStrToStream(const Stream: TStream; const Value: TSynaBytes); overload;
+{$ENDIF}
+
+{:Return filename of new temporary file in Dir (if empty, then default temporary
+ directory is used) and with optional filename prefix.}
+function GetTempFile(const Dir, prefix: TFileName): TFileName;
+
+{:Return padded string. If length is greater, string is truncated. If length is
+ smaller, string is padded by Pad character.}
+function PadString(const Value: string; len: integer; Pad: char): string;
+
+{:XOR each byte in the strings}
+function XorString(const Indata1: string; Indata2: string): string;
+
+{:Read header from "Value" stringlist beginning at "Index" position. If header
+ is Splitted into multiple lines, then this procedure de-split it into one line.}
+function NormalizeHeader(Value: TStrings; var Index: Integer): string;
+
+{pf}
+{:Search for one of line terminators CR, LF or NUL. Return position of the
+ line beginning and length of text.}
+procedure SearchForLineBreak(var APtr: PChar; AEtx: PChar; out ABol: PChar; out ALength: integer);
+{:Skip both line terminators CR LF (if any). Move APtr position forward.}
+procedure SkipLineBreak(var APtr: PChar; AEtx: PChar);
+{:Skip all blank lines in a buffer starting at APtr and move APtr position forward.}
+procedure SkipNullLines(var APtr: PChar; AEtx: PChar);
+{:Copy all lines from a buffer starting at APtr to ALines until empty line
+ or end of the buffer is reached. Move APtr position forward).}
+procedure CopyLinesFromStreamUntilNullLine(var APtr: PChar; AEtx: PChar;  ALines: TStrings);
+{:Copy all lines from a buffer starting at APtr to ALines until ABoundary
+ or end of the buffer is reached. Move APtr position forward).}
+procedure CopyLinesFromStreamUntilBoundary(var APtr: PChar; AEtx: PChar;  ALines: TStrings; const ABoundary: string);
+{:Search ABoundary in a buffer starting at APtr.
+ Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).}
+function SearchForBoundary(var APtr: PChar; AEtx: PChar;  const ABoundary: string): PChar;
+{:Compare a text at position ABOL with ABoundary and return position behind the
+ match (including a trailing CRLF if any).}
+function MatchBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar;
+{:Compare a text at position ABOL with ABoundary + the last boundary suffix
+ and return position behind the match (including a trailing CRLF if any).}
+function MatchLastBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar;
+{:Copy data from a buffer starting at position APtr and delimited by AEtx
+ position into string. }
+function BuildStringFromBuffer(AStx, AEtx: PChar): string;
+{/pf}
+
+function CompareString(const Str1, Str2: String;  const CaseSensitive: Boolean = false): Boolean;
+
+var
+  {:can be used for your own months strings for @link(getmonthnumber)}
+  CustomMonthNames: array[1..12] of string;
+
+implementation
+
+{==============================================================================}
+
+const
+  MyDayNames: array[1..7] of string =
+    ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
+var
+  MyMonthNames: array[0..6, 1..12] of String =
+    (
+    ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',  //rewrited by system locales
+     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
+    ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',  //English
+     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
+    ('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French
+     'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'),
+    ('jan', 'fev', 'mar', 'avr', 'mai', 'jun',  //French#2
+     'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
+    ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun',  //German
+     'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
+    ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun',  //German#2
+     'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
+    ('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen',  //Czech
+     'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro')
+     );
+
+
+{==============================================================================}
+
+function TimeZoneBias: integer;
+{$IF NOT(DEFINED(MSWINDOWS)) and NOT(DEFINED(ULTIBO))}
+{$IFNDEF FPC}
+var
+{$IFDEF POSIX}
+  t: Posix.SysTypes.time_t;
+  UT: Posix.time.tm;
+{$ELSE}
+  t: TTime_T;
+  UT: TUnixTime;
+{$ENDIF}
+begin
+  {$IFDEF POSIX}
+    __time(T);
+    localtime_r(T, UT);
+    Result := UT.tm_gmtoff div 60;
+  {$ELSE}
+    __time(@T);
+    localtime_r(@T, UT);
+    Result := ut.__tm_gmtoff div 60;
+  {$ENDIF}
+{$ELSE}
+begin
+  Result := TZSeconds div 60;
+{$ENDIF}
+{$ELSE}
+var
+  zoneinfo: TTimeZoneInformation;
+  bias: Integer;
+begin
+  case GetTimeZoneInformation(Zoneinfo) of
+    2:
+      bias := zoneinfo.Bias + zoneinfo.DaylightBias;
+    1:
+      bias := zoneinfo.Bias + zoneinfo.StandardBias;
+  else
+    bias := zoneinfo.Bias;
+  end;
+  Result := bias * (-1);
+{$ENDIF}
+end;
+
+{==============================================================================}
+
+function TimeZone: string;
+var
+  bias: Integer;
+  h, m: Integer;
+begin
+  bias := TimeZoneBias;
+  if bias >= 0 then
+    Result := '+'
+  else
+    Result := '-';
+  bias := Abs(bias);
+  h := bias div 60;
+  m := bias mod 60;
+  Result := Result + Format('%.2d%.2d', [h, m]);
+end;
+
+{==============================================================================}
+
+function Rfc822DateTime(t: TDateTime): string;
+var
+  wYear, wMonth, wDay: word;
+begin
+  DecodeDate(t, wYear, wMonth, wDay);
+  Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
+    MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]);
+end;
+
+{==============================================================================}
+
+function CDateTime(t: TDateTime): string;
+var
+  wYear, wMonth, wDay: word;
+begin
+  DecodeDate(t, wYear, wMonth, wDay);
+  Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
+    FormatDateTime('hh":"nn":"ss', t)]);
+end;
+
+{==============================================================================}
+
+function SimpleDateTime(t: TDateTime): string;
+begin
+  Result := FormatDateTime('yymmdd hhnnss', t);
+end;
+
+{==============================================================================}
+
+function AnsiCDateTime(t: TDateTime): string;
+var
+  wYear, wMonth, wDay: word;
+begin
+  DecodeDate(t, wYear, wMonth, wDay);
+  Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
+    wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]);
+end;
+
+{==============================================================================}
+
+function DecodeTimeZone(const Value: string; var Zone: integer): Boolean;
+var
+  x: integer;
+  zh, zm: integer;
+  s: string;
+begin
+  Result := false;
+  s := Value;
+  if (Pos('+', s) = 1) or (Pos('-',s) = 1) then
+  begin
+    if s = '-0000' then
+      Zone := TimeZoneBias
+    else
+      if Length(s) > 4 then
+      begin
+        zh := StrToIntDef(s[2] + s[3], 0);
+        zm := StrToIntDef(s[4] + s[5], 0);
+        zone := zh * 60 + zm;
+        if s[1] = '-' then
+          zone := zone * (-1);
+      end;
+    Result := True;
+  end
+  else
+  begin
+    x := 32767;
+    if s = 'NZDT' then x := 13;
+    if s = 'IDLE' then x := 12;
+    if s = 'NZST' then x := 12;
+    if s = 'NZT' then x := 12;
+    if s = 'EADT' then x := 11;
+    if s = 'GST' then x := 10;
+    if s = 'JST' then x := 9;
+    if s = 'CCT' then x := 8;
+    if s = 'WADT' then x := 8;
+    if s = 'WAST' then x := 7;
+    if s = 'ZP6' then x := 6;
+    if s = 'ZP5' then x := 5;
+    if s = 'ZP4' then x := 4;
+    if s = 'BT' then x := 3;
+    if s = 'EET' then x := 2;
+    if s = 'MEST' then x := 2;
+    if s = 'MESZ' then x := 2;
+    if s = 'SST' then x := 2;
+    if s = 'FST' then x := 2;
+    if s = 'CEST' then x := 2;
+    if s = 'CET' then x := 1;
+    if s = 'FWT' then x := 1;
+    if s = 'MET' then x := 1;
+    if s = 'MEWT' then x := 1;
+    if s = 'SWT' then x := 1;
+    if s = 'UT' then x := 0;
+    if s = 'UTC' then x := 0;
+    if s = 'GMT' then x := 0;
+    if s = 'WET' then x := 0;
+    if s = 'WAT' then x := -1;
+    if s = 'BST' then x := -1;
+    if s = 'AT' then x := -2;
+    if s = 'ADT' then x := -3;
+    if s = 'AST' then x := -4;
+    if s = 'EDT' then x := -4;
+    if s = 'EST' then x := -5;
+    if s = 'CDT' then x := -5;
+    if s = 'CST' then x := -6;
+    if s = 'MDT' then x := -6;
+    if s = 'MST' then x := -7;
+    if s = 'PDT' then x := -7;
+    if s = 'PST' then x := -8;
+    if s = 'YDT' then x := -8;
+    if s = 'YST' then x := -9;
+    if s = 'HDT' then x := -9;
+    if s = 'AHST' then x := -10;
+    if s = 'CAT' then x := -10;
+    if s = 'HST' then x := -10;
+    if s = 'EAST' then x := -10;
+    if s = 'NT' then x := -11;
+    if s = 'IDLW' then x := -12;
+    if x <> 32767 then
+    begin
+      zone := x * 60;
+      Result := True;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function GetMonthNumber(Value: String): integer;
+var
+  n: integer;
+  function TestMonth(const Value: String; Index: Integer): Boolean;
+  var
+    n: integer;
+  begin
+    Result := False;
+    for n := 0 to 6 do
+      if Value = AnsiUppercase(MyMonthNames[n, Index]) then
+      begin
+        Result := True;
+        Break;
+      end;
+  end;
+begin
+  Result := 0;
+  Value := AnsiUppercase(Value);
+  for n := 1 to 12 do
+    if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
+    begin
+      Result := n;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+function GetTimeFromStr(Value: string): TDateTime;
+var
+  x: integer;
+begin
+  x := rpos(':', Value);
+  if (x > 0) and ((Length(Value) - x) > 2) then
+    Value := Copy(Value, 1, x + 2);
+  Value := ReplaceString(Value, ':', {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}TimeSeparator);
+  Result := -1;
+  try
+    Result := StrToTime(Value);
+  except
+    on Exception do ;
+  end;
+end;
+
+{==============================================================================}
+
+function GetDateMDYFromStr(Value: string): TDateTime;
+var
+  wYear, wMonth, wDay: word;
+  s: string;
+begin
+  Result := 0;
+  s := Fetch(Value, '-');
+  wMonth := StrToIntDef(s, 12);
+  s := Fetch(Value, '-');
+  wDay := StrToIntDef(s, 30);
+  wYear := StrToIntDef(Value, 1899);
+  if wYear < 1000 then
+    if (wYear > 99) then
+      wYear := wYear + 1900
+    else
+      if wYear > 50 then
+        wYear := wYear + 1900
+      else
+        wYear := wYear + 2000;
+  try
+    Result := EncodeDate(wYear, wMonth, wDay);
+  except
+    on Exception do ;
+  end;
+end;
+
+{==============================================================================}
+
+function DecodeRfcDateTime(Value: string): TDateTime;
+var
+  day, month, year: Word;
+  zone: integer;
+  x, y: integer;
+  s: string;
+  t: TDateTime;
+begin
+// ddd, d mmm yyyy hh:mm:ss
+// ddd, d mmm yy hh:mm:ss
+// ddd, mmm d yyyy hh:mm:ss
+// ddd mmm dd hh:mm:ss yyyy
+// Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
+// Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
+// Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format
+
+  Result := 0;
+  if Value = '' then
+    Exit;
+  day := 0;
+  month := 0;
+  year := 0;
+  zone := 0;
+  Value := ReplaceString(Value, ' -', ' #');
+  Value := ReplaceString(Value, '-', ' ');
+  Value := ReplaceString(Value, ' #', ' -');
+  while Value <> '' do
+  begin
+    s := Fetch(Value, ' ');
+    s := uppercase(s);
+    // timezone
+    if DecodetimeZone(s, x) then
+    begin
+      zone := x;
+      continue;
+    end;
+    x := StrToIntDef(s, 0);
+    // day or year
+    if x > 0 then
+      if (x < 32) and (day = 0) then
+      begin
+        day := x;
+        continue;
+      end
+      else
+      begin
+        if (year = 0) and ((month > 0) or (x > 12)) then
+        begin
+          year := x;
+          if year < 32 then
+            year := year + 2000;
+          if year < 1000 then
+           year := year + 1900;
+          continue;
+        end;
+      end;
+    // time
+    if rpos(':', s) > Pos(':', s) then
+    begin
+      t := GetTimeFromStr(s);
+      if t <> -1 then
+        Result := t;
+      continue;
+    end;
+    //timezone daylight saving time
+    if s = 'DST' then
+    begin
+      zone := zone + 60;
+      continue;
+    end;
+    // month
+    y := GetMonthNumber(s);
+    if (y > 0) and (month = 0) then
+      month := y;
+  end;
+  if year = 0 then
+    year := 1980;
+  if month < 1 then
+    month := 1;
+  if month > 12 then
+    month := 12;
+  if day < 1 then
+    day := 1;
+  x := MonthDays[IsLeapYear(year), month];
+  if day > x then
+    day := x;
+  Result := Result + Encodedate(year, month, day);
+  zone := zone - TimeZoneBias;
+  x := zone div 1440;
+  Result := Result - x;
+  zone := zone mod 1440;
+  t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
+  if zone < 0 then
+    t := 0 - t;
+  Result := Result - t;
+end;
+
+{==============================================================================}
+
+function GetUTTime: TDateTime;
+{$IF DEFINED(MSWINDOWS) or DEFINED(ULTIBO)}
+{$IFNDEF FPC}
+var
+  st: TSystemTime;
+begin
+  GetSystemTime(st);
+  result := SystemTimeToDateTime(st);
+{$ELSE}
+var
+  st: SysUtils.TSystemTime;
+  stw: {$IFNDEF ULTIBO}Windows.TSystemTime{$ELSE}Ultibo.SYSTEMTIME{$ENDIF};
+begin
+  GetSystemTime(stw);
+  st.Year := stw.wYear;
+  st.Month := stw.wMonth;
+  st.Day := stw.wDay;
+  st.Hour := stw.wHour;
+  st.Minute := stw.wMinute;
+  st.Second := stw.wSecond;
+  st.Millisecond := stw.wMilliseconds;
+  result := SystemTimeToDateTime(st);
+{$ENDIF}
+{$ELSE MSWINDOWS}
+{$IFNDEF FPC}
+var
+  TV: TTimeVal;
+begin
+  gettimeofday(TV, nil);
+  Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
+{$ELSE FPC}
+ {$IFDEF UNIX}
+var
+  TV: TimeVal;
+begin
+  fpgettimeofday(@TV, nil);
+  Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
+ {$ELSE UNIX}
+  {$IFDEF OS2}
+var
+  ST: TSystemTime;
+begin
+  GetLocalTime (ST);
+  Result := SystemTimeToDateTime (ST);
+  {$ENDIF OS2}
+ {$ENDIF UNIX}
+{$ENDIF FPC}
+{$ENDIF MSWINDOWS}
+end;
+
+{==============================================================================}
+
+function SetUTTime(Newdt: TDateTime): Boolean;
+{$IF DEFINED(MSWINDOWS) or DEFINED(ULTIBO)}
+{$IFNDEF FPC}
+var
+  st: TSystemTime;
+begin
+  DateTimeToSystemTime(newdt,st);
+  Result := SetSystemTime(st);
+{$ELSE}
+var
+  st: SysUtils.TSystemTime;
+  stw: {$IFNDEF ULTIBO}Windows.TSystemTime{$ELSE}Ultibo.SYSTEMTIME{$ENDIF};
+begin
+  DateTimeToSystemTime(newdt,st);
+  stw.wYear := st.Year;
+  stw.wMonth := st.Month;
+  stw.wDay := st.Day;
+  stw.wHour := st.Hour;
+  stw.wMinute := st.Minute;
+  stw.wSecond := st.Second;
+  stw.wMilliseconds := st.Millisecond;
+  Result := SetSystemTime(stw);
+{$ENDIF}
+{$ELSE MSWINDOWS}
+{$IFNDEF FPC}
+var
+  TV: TTimeVal;
+  d: double;
+  TZ: Ttimezone;
+  PZ: PTimeZone;
+begin
+  TZ.tz_minuteswest := 0;
+  TZ.tz_dsttime := 0;
+  PZ := @TZ;
+  gettimeofday(TV, PZ);
+  d := (newdt - UnixDateDelta) * 86400;
+  TV.tv_sec := trunc(d);
+  TV.tv_usec := trunc(frac(d) * 1000000);
+  {$IFNDEF POSIX}
+  Result := settimeofday(TV, TZ) <> -1;
+  {$ELSE}
+  Result := False; // in POSIX settimeofday is not defined? http://www.kernel.org/doc/man-pages/online/pages/man2/gettimeofday.2.html
+  {$ENDIF}
+{$ELSE FPC}
+ {$IFDEF UNIX}
+var
+  TV: TimeVal;
+  d: double;
+begin
+  d := (newdt - UnixDateDelta) * 86400;
+  TV.tv_sec := trunc(d);
+  TV.tv_usec := trunc(frac(d) * 1000000);
+  Result := fpsettimeofday(@TV, nil) <> -1;
+ {$ELSE UNIX}
+  {$IFDEF OS2}
+var
+  ST: TSystemTime;
+begin
+  DateTimeToSystemTime (NewDT, ST);
+  SetTime (ST.Hour, ST.Minute, ST.Second, ST.Millisecond div 10);
+  Result := true;
+  {$ENDIF OS2}
+ {$ENDIF UNIX}
+{$ENDIF FPC}
+{$ENDIF MSWINDOWS}
+end;
+
+{==============================================================================}
+
+{$IFNDEF MSWINDOWS}
+function GetTick: LongWord;
+var
+  Stamp: TTimeStamp;
+begin
+  Stamp := DateTimeToTimeStamp(Now);
+  Result := Stamp.Time;
+end;
+{$ELSE}
+function GetTick: LongWord;
+var
+  tick, freq: TLargeInteger;
+{$IFDEF VER100}
+  x: TLargeInteger;
+{$ENDIF}
+begin
+  if Windows.QueryPerformanceFrequency(freq) then
+  begin
+    Windows.QueryPerformanceCounter(tick);
+{$IFDEF VER100}
+    x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000;
+    Result := x.LowPart;
+{$ELSE}
+    Result := Trunc((tick / freq) * 1000) and High(LongWord)
+{$ENDIF}
+  end
+  else
+    Result := Windows.GetTickCount;
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+function TickDelta(TickOld, TickNew: LongWord): LongWord;
+begin
+//if DWord is signed type (older Deplhi),
+// then it not work properly on differencies larger then maxint!
+  Result := 0;
+  if TickOld <> TickNew then
+  begin
+    if TickNew < TickOld then
+    begin
+      TickNew := TickNew + LongWord(MaxInt) + 1;
+      TickOld := TickOld + LongWord(MaxInt) + 1;
+    end;
+    Result := TickNew - TickOld;
+    if TickNew < TickOld then
+      if Result > 0 then
+        Result := 0 - Result;
+  end;
+end;
+
+{==============================================================================}
+
+function CodeInt(Value: Word): string;
+begin
+  setlength(result, 2);
+  Result[1] := char(Value div 256);
+  Result[2] := char(Value mod 256);
+// Result := Char(Value div 256) + Char(Value mod 256)
+end;
+
+{==============================================================================}
+
+function DecodeInt(const Value: string; Index: integer): Word;
+var
+  x, y: Byte;
+begin
+  if Length(Value) > Index then
+    x := Ord(Value[Index])
+  else
+    x := 0;
+  if Length(Value) >= (Index + 1) then
+    y := Ord(Value[Index + 1])
+  else
+    y := 0;
+  Result := x * 256 + y;
+end;
+
+{==============================================================================}
+
+function CodeLongInt(Value: LongInt): string;
+var
+  x, y: word;
+begin
+  // this is fix for negative numbers on systems where longint = integer
+  x := (Value shr 16) and integer($ffff);
+  y := Value and integer($ffff);
+  setlength(result, 4);
+  Result[1] := char(x div 256);
+  Result[2] := char(x mod 256);
+  Result[3] := char(y div 256);
+  Result[4] := char(y mod 256);
+end;
+
+{==============================================================================}
+
+function DecodeLongInt(const Value: string; Index: integer): LongInt;
+var
+  x, y: Byte;
+  xl, yl: Byte;
+begin
+  if Length(Value) > Index then
+    x := Ord(Value[Index])
+  else
+    x := 0;
+  if Length(Value) >= (Index + 1) then
+    y := Ord(Value[Index + 1])
+  else
+    y := 0;
+  if Length(Value) >= (Index + 2) then
+    xl := Ord(Value[Index + 2])
+  else
+    xl := 0;
+  if Length(Value) >= (Index + 3) then
+    yl := Ord(Value[Index + 3])
+  else
+    yl := 0;
+  Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
+end;
+
+{==============================================================================}
+
+function DumpStr(const Buffer: string): string;
+var
+  n: Integer;
+begin
+  Result := '';
+  for n := 1 to Length(Buffer) do
+    Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
+end;
+
+{==============================================================================}
+
+function DumpExStr(const Buffer: string): string;
+var
+  n: Integer;
+  x: Byte;
+begin
+  Result := '';
+  for n := 1 to Length(Buffer) do
+  begin
+    x := Ord(Buffer[n]);
+    if x in [65..90, 97..122] then
+      Result := Result + ' +''' + char(x) + ''''
+    else
+      Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
+  end;
+end;
+
+{==============================================================================}
+
+procedure Dump(const Buffer: string; const DumpFile: string);
+var
+  f: Text;
+begin
+  AssignFile(f, DumpFile);
+  if FileExists(DumpFile) then
+    DeleteFile(DumpFile);
+  Rewrite(f);
+  try
+    Writeln(f, DumpStr(Buffer));
+  finally
+    CloseFile(f);
+  end;
+end;
+
+{==============================================================================}
+
+procedure DumpEx(const Buffer: string; const DumpFile: string);
+var
+  f: Text;
+begin
+  AssignFile(f, DumpFile);
+  if FileExists(DumpFile) then
+    DeleteFile(DumpFile);
+  Rewrite(f);
+  try
+    Writeln(f, DumpExStr(Buffer));
+  finally
+    CloseFile(f);
+  end;
+end;
+
+{==============================================================================}
+
+function TrimSPLeft(const S: string): string;
+var
+  I, L: Integer;
+begin
+  Result := '';
+  if S = '' then
+    Exit;
+  L := Length(S);
+  I := 1;
+  while (I <= L) and (S[I] = ' ') do
+    Inc(I);
+  Result := Copy(S, I, MaxInt);
+end;
+
+{==============================================================================}
+
+function TrimSPRight(const S: string): string;
+var
+  I: Integer;
+begin
+  Result := '';
+  if S = '' then
+    Exit;
+  I := Length(S);
+  while (I > 0) and (S[I] = ' ') do
+    Dec(I);
+  Result := Copy(S, 1, I);
+end;
+
+{==============================================================================}
+
+function TrimSP(const S: string): string;
+begin
+  Result := TrimSPLeft(s);
+  Result := TrimSPRight(Result);
+end;
+
+{==============================================================================}
+
+function SeparateLeft(const Value, Delimiter: string): string;
+var
+  x: Integer;
+begin
+  x := Pos(Delimiter, Value);
+  if x < 1 then
+    Result := Value
+  else
+    Result := Copy(Value, 1, x - 1);
+end;
+
+{==============================================================================}
+
+function SeparateRight(const Value, Delimiter: string): string;
+var
+  x: Integer;
+begin
+  x := Pos(Delimiter, Value);
+  if x > 0 then
+    x := x + Length(Delimiter) - 1;
+  Result := Copy(Value, x + 1, Length(Value) - x);
+end;
+
+{==============================================================================}
+
+function GetParameter(const Value, Parameter: string): string;
+var
+  s: string;
+  v: string;
+begin
+  Result := '';
+  v := Value;
+  while v <> '' do
+  begin
+    s := Trim(FetchEx(v, ';', '"'));
+    if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
+    begin                       
+      Delete(s, 1, Length(Parameter));
+      s := Trim(s);
+      if s = '' then
+        Break;
+      if s[1] = '=' then
+      begin
+        Result := Trim(SeparateRight(s, '='));
+        Result := UnquoteStr(Result, '"');
+        break;
+      end;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+procedure ParseParametersEx(Value: string; const Delimiter: string; const
+    Parameters: TStrings);
+var
+  s: string;
+begin
+  Parameters.Clear;
+  while Value <> '' do
+  begin
+    s := Trim(FetchEx(Value, Delimiter, '"'));
+    Parameters.Add(s);
+  end;
+end;
+
+{==============================================================================}
+
+procedure ParseParameters(const Value: string; const Parameters: TStrings);
+begin
+  ParseParametersEx(Value, ';', Parameters);
+end;
+
+{==============================================================================}
+
+function IndexByBegin(Value: string; const List: TStrings): integer;
+var
+  n: integer;
+  s: string;
+begin
+  Result := -1;
+  Value := uppercase(Value);
+  for n := 0 to List.Count -1 do
+  begin
+    s := UpperCase(List[n]);
+    if Pos(Value, s) = 1 then
+    begin
+      Result := n;
+      Break;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function GetEmailAddr(const Value: string): string;
+var
+  s: string;
+begin
+  s := SeparateRight(Value, '<');
+  s := SeparateLeft(s, '>');
+  Result := Trim(s);
+end;
+
+{==============================================================================}
+
+function GetEmailDesc(Value: string): string;
+var
+  s: string;
+begin
+  Value := Trim(Value);
+  s := SeparateRight(Value, '"');
+  if s <> Value then
+    s := SeparateLeft(s, '"')
+  else
+  begin
+    s := SeparateLeft(Value, '<');
+    if s = Value then
+    begin
+      s := SeparateRight(Value, '(');
+      if s <> Value then
+        s := SeparateLeft(s, ')')
+      else
+        s := '';
+    end;
+  end;
+  Result := Trim(s);
+end;
+
+{==============================================================================}
+
+function StrToHex(const Value: string): string;
+var
+  n: Integer;
+begin
+  Result := '';
+  for n := 1 to Length(Value) do
+    Result := Result + IntToHex(Byte(Value[n]), 2);
+  Result := LowerCase(Result);
+end;
+
+{==============================================================================}
+
+function IntToBin(Value: Integer; Digits: Byte): string;
+var
+  x, y, n: Integer;
+begin
+  Result := '';
+  x := Value;
+  repeat
+    y := x mod 2;
+    x := x div 2;
+    if y > 0 then
+      Result := '1' + Result
+    else
+      Result := '0' + Result;
+  until x = 0;
+  x := Length(Result);
+  for n := x to Digits - 1 do
+    Result := '0' + Result;
+end;
+
+{==============================================================================}
+
+function BinToInt(const Value: string): Integer;
+var
+  n: Integer;
+begin
+  Result := 0;
+  for n := 1 to Length(Value) do
+  begin
+    if Value[n] = '0' then
+      Result := Result * 2
+    else
+      if Value[n] = '1' then
+        Result := Result * 2 + 1
+      else
+        Break;
+  end;
+end;
+
+{==============================================================================}
+
+function ParseURL(const URL: string; var Prot, User, Pass, Host, Port, Path,
+  Para: string): string;
+var
+  x, y: Integer;
+  sURL: string;
+  s: string;
+  s1, s2: string;
+begin
+  Prot := 'http';
+  User := '';
+  Pass := '';
+  Host := '';
+  Port := '';
+  Path := '';
+  Para := '';
+
+  x := Pos('://', URL);
+  if x > 0 then
+  begin
+    Prot := SeparateLeft(URL, '://');
+    sURL := SeparateRight(URL, '://');
+  end
+  else
+    sURL := URL;
+  s := UpperCase(Prot);
+  if s = 'HTTP' then
+    Port := '80'
+  else
+  if s = 'HTTPS' then
+    Port := '443'
+  else
+  if s = 'WS' then
+    Port := '80'
+  else
+  if s = 'WSS' then
+    Port := '443'
+  else
+  if s = 'FTP' then
+    Port := '21';
+  x := Pos('@', sURL);
+  y := Pos('/', sURL);
+  if (x > 0) and ((x < y) or (y < 1))then
+  begin
+    s := SeparateLeft(sURL, '@');
+    sURL := SeparateRight(sURL, '@');
+    x := Pos(':', s);
+    if x > 0 then
+    begin
+      User := SeparateLeft(s, ':');
+      Pass := SeparateRight(s, ':');
+    end
+    else
+      User := s;
+  end;
+  x := Pos('/', sURL);
+  if x > 0 then
+  begin
+    s1 := SeparateLeft(sURL, '/');
+    s2 := SeparateRight(sURL, '/');
+  end
+  else
+  begin
+    s1 := sURL;
+    s2 := '';
+  end;
+  if Pos('[', s1) = 1 then
+  begin
+    Host := Separateleft(s1, ']');
+    Delete(Host, 1, 1);
+    s1 := SeparateRight(s1, ']');
+    if Pos(':', s1) = 1 then
+      Port := SeparateRight(s1, ':');
+  end
+  else
+  begin
+    x := Pos(':', s1);
+    if x > 0 then
+    begin
+      Host := SeparateLeft(s1, ':');
+      Port := SeparateRight(s1, ':');
+    end
+    else
+      Host := s1;
+  end;
+  Result := '/' + s2;
+  x := Pos('?', s2);
+  if x > 0 then
+  begin
+    Path := '/' + SeparateLeft(s2, '?');
+    Para := SeparateRight(s2, '?');
+  end
+  else
+    Path := '/' + s2;
+  if Host = '' then
+    Host := 'localhost';
+end;
+
+{==============================================================================}
+
+function ReplaceString(Value: string; const Search, Replace: string): string;
+var
+  x, l, ls, lr: Integer;
+begin
+  if (Value = '') or (Search = '') then
+  begin
+    Result := Value;
+    Exit;
+  end;
+  ls := Length(Search);
+  lr := Length(Replace);
+  Result := '';
+  x := Pos(Search, Value);
+  while x > 0 do
+  begin
+    {$IFNDEF CIL}
+    l := Length(Result);
+    SetLength(Result, l + x - 1);
+    Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
+    {$ELSE}
+    Result:=Result+Copy(Value,1,x-1);
+    {$ENDIF}
+    {$IFNDEF CIL}
+    l := Length(Result);
+    SetLength(Result, l + lr);
+    Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
+    {$ELSE}
+    Result:=Result+Replace;
+    {$ENDIF}
+    Delete(Value, 1, x - 1 + ls);
+    x := Pos(Search, Value);
+  end;
+  Result := Result + Value;
+end;
+
+{==============================================================================}
+
+function RPosEx(const Sub, Value: string; From: integer): Integer;
+var
+  n: Integer;
+  l: Integer;
+begin
+  result := 0;
+  l := Length(Sub);
+  for n := From - l + 1 downto 1 do
+  begin
+    if Copy(Value, n, l) = Sub then
+    begin
+      result := n;
+      break;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function RPos(const Sub, Value: String): Integer;
+begin
+  Result := RPosEx(Sub, Value, Length(Value));
+end;
+
+{==============================================================================}
+
+function FetchBin(var Value: string; const Delimiter: string): string;
+var
+  s: string;
+begin
+  Result := SeparateLeft(Value, Delimiter);
+  s := SeparateRight(Value, Delimiter);
+  if s = Value then
+    Value := ''
+  else
+    Value := s;
+end;
+
+{==============================================================================}
+
+function Fetch(var Value: string; const Delimiter: string): string;
+begin
+  Result := FetchBin(Value, Delimiter);
+  Result := TrimSP(Result);
+  Value := TrimSP(Value);
+end;
+
+{==============================================================================}
+
+function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
+var
+  b: Boolean;
+begin
+  Result := '';
+  b := False;
+  while Length(Value) > 0 do
+  begin
+    if b then
+    begin
+      if Pos(Quotation, Value) = 1 then
+        b := False;
+      Result := Result + Value[1];
+      Delete(Value, 1, 1);
+    end
+    else
+    begin
+      if Pos(Delimiter, Value) = 1 then
+      begin
+        Delete(Value, 1, Length(delimiter));
+        break;
+      end;
+      b := Pos(Quotation, Value) = 1;
+      Result := Result + Value[1];
+      Delete(Value, 1, 1);
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function IsBinaryString(const Value: string): Boolean;
+var
+  n: integer;
+begin
+  Result := False;
+  for n := 1 to Length(Value) do
+    if CharInSet(Value[n], [#0 .. #8, #10 .. #31]) then
+      // ignore null-terminated strings
+      if not((n = Length(Value)) and (Value[n] = char(#0))) then
+      begin
+        Result := True;
+        Break;
+      end;
+end;
+
+{==============================================================================}
+
+function PosCRLF(const Value: string; var Terminator: string): integer;
+var
+  n, l: integer;
+begin
+  Result := -1;
+  Terminator := '';
+  l := length(value);
+  for n := 1 to L do
+    if CharInSet(Value[n], [#$0d, #$0a]) then
+    begin
+      Result := n;
+      Terminator := Value[n];
+      if n <> l then
+        case value[n] of
+          #$0d:
+            if value[n + 1] = #$0a then
+              Terminator := #$0d + #$0a;
+          #$0a:
+            if value[n + 1] = #$0d then
+              Terminator := #$0a + #$0d;
+        end;
+      Break;
+    end;
+end;
+
+{==============================================================================}
+
+Procedure StringsTrim(const Value: TStrings);
+var
+  n: integer;
+begin
+  for n := Value.Count - 1 downto 0 do
+    if Value[n] = '' then
+      Value.Delete(n)
+    else
+      Break;
+end;
+
+{==============================================================================}
+
+function PosFrom(const SubStr, Value: String; From: integer): integer;
+var
+  ls,lv: integer;
+begin
+  Result := 0;
+  ls := Length(SubStr);
+  lv := Length(Value);
+  if (ls = 0) or (lv = 0) then
+    Exit;
+  if From < 1 then
+    From := 1;
+  while (ls + from - 1) <= (lv) do
+  begin
+    {$IFNDEF CIL}
+    if CompareMem(@SubStr[1],@Value[from],ls) then
+    {$ELSE}
+    if SubStr = copy(Value, from, ls) then
+    {$ENDIF}
+    begin
+      result := from;
+      break;
+    end
+    else
+      inc(from);
+  end;
+end;
+
+{==============================================================================}
+
+{$IFNDEF CIL}
+function IncPoint(const p: pbyte; Value: integer): pointer;
+begin
+  Result := p;
+  Inc(pbyte(Result), Value);
+end;
+{$ENDIF}
+
+{==============================================================================}
+//improved by 'DoggyDawg'
+function GetBetween(const PairBegin, PairEnd, Value: string): string;
+var
+  n: integer;
+  x: integer;
+  s: string;
+  lenBegin: integer;
+  lenEnd: integer;
+  str: string;
+  max: integer;
+begin
+  lenBegin := Length(PairBegin);
+  lenEnd := Length(PairEnd);
+  n := Length(Value);
+  if (Value = PairBegin + PairEnd) then
+  begin
+    Result := '';//nothing between
+    exit;
+  end;
+  if (n < lenBegin + lenEnd) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  s := SeparateRight(Value, PairBegin);
+  if (s = Value) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  n := Pos(PairEnd, s);
+  if (n = 0) then
+  begin
+    Result := Value;
+    exit;
+  end;
+  Result := '';
+  x := 1;
+  max := Length(s) - lenEnd + 1;
+  for n := 1 to max do
+  begin
+    str := copy(s, n, lenEnd);
+    if (str = PairEnd) then
+    begin
+      Dec(x);
+      if (x <= 0) then
+        Break;
+    end;
+    str := copy(s, n, lenBegin);
+    if (str = PairBegin) then
+      Inc(x);
+    Result := Result + s[n];
+  end;
+end;
+
+{==============================================================================}
+
+function CountOfChar(const Value: string; Chr: char): integer;
+var
+  n: integer;
+begin
+  Result := 0;
+  for n := 1 to Length(Value) do
+    if Value[n] = chr then
+      Inc(Result);
+end;
+
+{==============================================================================}
+// ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application!
+function UnquoteStr(const Value: string; Quote: Char): string;
+var
+  n: integer;
+  inq, dq: Boolean;
+  c, cn: char;
+begin
+  Result := '';
+  if Value = '' then
+    Exit;
+  if Value = Quote + Quote then
+    Exit;
+  inq := False;
+  dq := False;
+  for n := 1 to Length(Value) do
+  begin
+    c := Value[n];
+    if n <> Length(Value) then
+      cn := Value[n + 1]
+    else
+      cn := #0;
+    if c = quote then
+      if dq then
+        dq := False
+      else
+        if not inq then
+          inq := True
+        else
+          if cn = quote then
+          begin
+            Result := Result + Quote;
+            dq := True;
+          end
+          else
+            inq := False
+    else
+      Result := Result + c;
+  end;
+end;
+
+{==============================================================================}
+
+function QuoteStr(const Value: string; Quote: Char): string;
+var
+  n: integer;
+begin
+  Result := '';
+  for n := 1 to length(value) do
+  begin
+    Result := result + Value[n];
+    if value[n] = Quote then
+      Result := Result + Quote;
+  end;
+  Result :=  Quote + Result + Quote;
+end;
+
+{==============================================================================}
+
+procedure HeadersToList(const Value: TStrings);
+var
+  n, x, y: integer;
+  s: string;
+begin
+  for n := 0 to Value.Count -1 do
+  begin
+    s := Value[n];
+    x := Pos(':', s);
+    if x > 0 then
+    begin
+      y:= Pos('=',s); 
+      if not ((y > 0) and (y < x)) then
+      begin
+        s[x] := '=';
+        Value[n] := s;
+      end;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+procedure ListToHeaders(const Value: TStrings);
+var
+  n, x: integer;
+  s: string;
+begin
+  for n := 0 to Value.Count -1 do
+  begin
+    s := Value[n];
+    x := Pos('=', s);
+    if x > 0 then
+    begin
+      s[x] := ':';
+      Value[n] := s;
+    end;
+  end;
+end;
+
+{==============================================================================}
+
+function SwapBytes(Value: integer): integer;
+var
+  S: string;
+  x, y, xl, yl: Byte;
+begin
+  s := CodeLongInt(Value);
+  x := Ord(s[4]);
+  y := Ord(s[3]);
+  xl := Ord(s[2]);
+  yl := Ord(s[1]);
+  Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
+end;
+
+{==============================================================================}
+
+function ReadStrFromStream(const Stream: TStream; len: integer): string;
+var
+  x: integer;
+  Buf: TBytes;
+begin
+  Setlength(Buf, Len);
+  x := Stream.Read(Buf, Len);
+  Setlength(Buf, x);
+  Result := StringOf(Buf);
+end;
+
+{==============================================================================}
+
+procedure WriteStrToStream(const Stream: TStream; const Value: string);
+{$IFDEF CIL}
+var
+  buf: Array of Byte;
+{$ENDIF}
+begin
+{$IFDEF CIL}
+  buf := BytesOf(Value);
+  Stream.Write(buf,length(Value));
+{$ELSE}
+  {$IFDEF UNICODE}
+    Stream.Write(MarshaledAString(TMarshal.AsAnsi(Value))^, Length(Value));
+  {$ELSE}
+    Stream.Write(PAnsiChar(Value)^, Length(Value));
+  {$ENDIF}
+{$ENDIF}
+end;
+
+{$IFDEF UNICODE}
+procedure WriteStrToStream(const Stream: TStream; const Value: TSynaBytes);
+begin
+  stream.WriteData(Value.Bytes, Value.Length);
+end;
+{$ENDIF}
+
+{==============================================================================}
+
+{$IFDEF POSIX}
+function tempnam(const Path: PChar; const prefix: PChar): PChar; cdecl;
+  external libc name _PU + 'tempnam';
+{$ENDIF}
+
+function GetTempFile(const Dir, prefix: TFileName): TFileName;
+{$IFNDEF FPC}
+{$IFDEF MSWINDOWS}
+var
+  Path: TFileName;
+  x: integer;
+{$ENDIF}
+{$ENDIF}
+begin
+{$IFDEF FPC}
+  Result := GetTempFileName(Dir, Prefix);
+{$ELSE}
+  {$IFNDEF MSWINDOWS}
+    Result := tempnam(Pointer(Dir), Pointer(prefix));
+  {$ELSE}
+    {$IFDEF CIL}
+  Result := System.IO.Path.GetTempFileName;
+    {$ELSE}
+  if Dir = '' then
+  begin
+    Path := StringOfChar(#0, MAX_PATH);
+	  GetTempPath(Length(Path), PChar(Path));
+    Path := PChar(Path);
+  end
+  else
+    Path := Dir;
+  x := Length(Path);
+  if Path[x] <> '\' then
+    Path := Path + '\';
+  Result := StringOfChar(#0, MAX_PATH);
+  GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result));
+  Result := PChar(Result);
+  SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY);
+    {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+end;
+
+{==============================================================================}
+
+function PadString(const Value: string; len: integer; Pad: char): string;
+begin
+  if length(value) >= len then
+    Result := Copy(value, 1, len)
+  else
+    Result := Value + StringOfChar(Pad, len - length(value));
+end;
+
+{==============================================================================}
+
+function XorString(const Indata1: string; Indata2: string): string;
+var
+  i: integer;
+begin
+  Indata2 := PadString(Indata2, length(Indata1), #0);
+  Result := '';
+  for i := 1 to length(Indata1) do
+    Result := Result + char(ord(Indata1[i]) xor ord(Indata2[i]));
+end;
+
+{==============================================================================}
+
+function NormalizeHeader(Value: TStrings; var Index: Integer): string;
+var
+  s, t: string;
+  n: Integer;
+begin
+  s := Value[Index];
+  Inc(Index);
+  if s <> '' then
+    while (Value.Count - 1) > Index do
+    begin
+      t := Value[Index];
+      if t = '' then
+        Break;
+      for n := 1 to Length(t) do
+        if t[n] = #9 then
+          t[n] := ' ';
+      if not(CharInSet(char(t[1]), [' ', '"', ':', '='])) then
+        Break
+      else
+      begin
+        s := s + ' ' + Trim(t);
+        Inc(Index);
+      end;
+    end;
+  Result := TrimRight(s);
+end;
+
+{==============================================================================}
+
+{pf}
+procedure SearchForLineBreak(var APtr: PChar; AEtx: PChar; out ABol: PChar;
+  out ALength: integer);
+begin
+  ABol := APtr;
+  while (APtr < AEtx) and not(CharInSet(APtr^, [#0, #10, #13])) do
+    Inc(APtr);
+  ALength := APtr - ABol;
+end;
+{/pf}
+
+{pf}
+procedure SkipLineBreak(var APtr: PChar; AEtx: PChar);
+begin
+  if (APtr < AEtx) and (APtr^ = #13) then
+    inc(APtr);
+  if (APtr < AEtx) and (APtr^ = #10) then
+    inc(APtr);
+end;
+{/pf}
+
+{pf}
+procedure SkipNullLines(var APtr: PChar; AEtx: PChar);
+var
+  bol: PChar;
+  lng: integer;
+begin
+  while (APtr < AEtx) do
+    begin
+      SearchForLineBreak(APtr,AEtx,bol,lng);
+      SkipLineBreak(APtr,AEtx);
+      if lng>0 then
+        begin
+          APtr := bol;
+          Break;
+        end;
+    end;
+end;
+{/pf}
+
+{pf}
+procedure CopyLinesFromStreamUntilNullLine(var APtr: PChar; AEtx: PChar; ALines: TStrings);
+var
+  bol: PChar;
+  lng: integer;
+  s: string;
+begin
+  // Copying until body separator will be reached
+  while (APtr<AEtx) and (APtr^<>#0) do
+    begin
+      SearchForLineBreak(APtr,AEtx,bol,lng);
+      SkipLineBreak(APtr,AEtx);
+      if lng=0 then
+        Break;
+      SetString(s,bol,lng);
+      ALines.Add(s);
+    end;
+end;
+{/pf}
+
+{pf}
+procedure CopyLinesFromStreamUntilBoundary(var APtr: PChar; AEtx: PChar;  ALines: TStrings; const ABoundary: string);
+var
+  bol: PChar;
+  lng:      integer;
+  s: string;
+  //BackStop: string;
+  eob1: PChar;
+  eob2: PChar;
+begin
+  //BackStop := '--'+ABoundary;
+  eob2     := nil;
+  // Copying until Boundary will be reached
+  while (APtr<AEtx) do
+    begin
+      SearchForLineBreak(APtr,AEtx,bol,lng);
+      SkipLineBreak(APtr,AEtx);
+      eob1 := MatchBoundary(bol,APtr,ABoundary);
+      if Assigned(eob1) then
+        eob2 := MatchLastBoundary(bol,AEtx,ABoundary);
+      if Assigned(eob2) then
+        begin
+          APtr := eob2;
+          Break;
+        end
+      else if Assigned(eob1) then
+        begin
+          APtr := eob1;
+          Break;
+        end
+      else
+        begin
+          SetString(s,bol,lng);
+          ALines.Add(s);
+        end;
+    end;
+end;
+{/pf}
+
+{pf}
+function SearchForBoundary(var APtr: PChar; AEtx: PChar;  const ABoundary: string): PChar;
+var
+  eob: PChar;
+  Step: integer;
+begin
+  Result := nil;
+  // Moving Aptr position forward until boundary will be reached
+  while (APtr<AEtx) do
+    begin
+      if strlcomp(APtr,#13#10'--',4)=0 then
+        begin
+          eob  := MatchBoundary(APtr,AEtx,ABoundary);
+          Step := 4;
+        end
+      else if strlcomp(APtr,'--',2)=0 then
+        begin
+          eob  := MatchBoundary(APtr,AEtx,ABoundary);
+          Step := 2;
+        end
+      else
+        begin
+          eob  := nil;
+          Step := 1;
+        end;
+      if Assigned(eob) then
+        begin
+          Result := APtr;  // boundary beginning
+          APtr   := eob;   // boundary end
+          exit;
+        end
+      else
+        inc(APtr,Step);
+    end;
+end;
+{/pf}
+
+{pf}
+function MatchBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar;
+var
+  MatchPos: PChar;
+  Lng:        integer;
+begin
+  Result   := nil;
+  MatchPos := ABol;
+  Lng := length(ABoundary);
+  if (MatchPos + 2 + lng) > AEtx then
+    exit;
+  if strlcomp(MatchPos, #13#10, 2) = 0 then
+    inc(MatchPos,2);
+  if (MatchPos + 2 + lng) > AEtx then
+    exit;
+  if strlcomp(MatchPos,'--',2)<>0 then
+    exit;
+  inc(MatchPos,2);
+  if strlcomp(MatchPos, PChar(ABoundary), lng) <> 0 then
+    exit;
+  inc(MatchPos,Lng);
+  if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
+    inc(MatchPos,2);
+  Result := MatchPos;
+end;
+{/pf}
+
+{pf}
+function MatchLastBoundary(ABol, AEtx: PChar; const ABoundary: string): PChar;
+var
+  MatchPos: PChar;
+begin
+  Result   := nil;
+  MatchPos := MatchBoundary(ABol, AEtx, ABoundary);
+  if not Assigned(MatchPos) then
+    exit;
+  if strlcomp(MatchPos,'--',2)<>0 then
+    exit;
+  inc(MatchPos,2);
+  if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
+    inc(MatchPos,2);
+  Result := MatchPos;
+end;
+{/pf}
+
+{pf}
+function BuildStringFromBuffer(AStx, AEtx: PChar): string;
+var
+  lng: integer;
+begin
+  Lng := 0;
+  if Assigned(AStx) and Assigned(AEtx) then
+    begin
+      Lng := AEtx-AStx;
+      if Lng<0 then
+        Lng := 0;
+    end;
+  SetString(Result,AStx,lng);
+end;
+{/pf}
+
+
+function CompareString(const Str1, Str2: String;
+  const CaseSensitive: Boolean = false): Boolean;
+begin
+  if not CaseSensitive then
+    Result := Pos(LowerCase(Str1), LowerCase(Str2)) > 0
+  else
+    Result := Pos(Str1, Str2) > 0;
+end;
+
+{==============================================================================}
+var
+  n: integer;
+begin
+  for n :=  1 to 12 do
+  begin
+    CustomMonthNames[n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n];
+    MyMonthNames[0, n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n];
+  end;
+end.

synsock.pas

@@ -0,0 +1,93 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 005.002.003 |
+|==============================================================================|
+| Content: Socket Independent Platform Layer                                   |
+|==============================================================================|
+| Copyright (c)1999-2013, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2001-2013.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|   Tomas Hajny (OS2 support)                                                  |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@exclude}
+
+unit synsock;
+
+{$MINENUMSIZE 4}
+
+//old Delphi does not have MSWINDOWS define.
+{$IFDEF WIN32}
+  {$IFNDEF MSWINDOWS}
+    {$DEFINE MSWINDOWS}
+  {$ENDIF}
+{$ENDIF}
+
+{$IFDEF CIL}
+  {$I ssdotnet.inc}
+{$ELSE}
+  {$IFDEF MSWINDOWS}
+    {$I sswin32.inc}
+  {$ELSE}
+    {$IFDEF ULTIBO}
+      {$I ssultibo.inc}
+    {$ELSE}
+      {$IFDEF WINCE}
+        {$I sswin32.inc}  //not complete yet!
+      {$ELSE}
+        {$IFDEF FPC}
+          {$IFDEF OS2}
+            {$I ssos2ws1.inc}
+          {$ELSE OS2}
+            {$I ssfpc.inc}
+          {$ENDIF OS2}
+        {$ELSE}
+          {$IFDEF POSIX}
+            {$I ssposix.inc} //experimental!
+          {$ELSE}
+            {$I sslinux.inc}
+          {$ENDIF}
+        {$ENDIF}
+      {$ENDIF}
+    {$ENDIF}
+  {$ENDIF}
+{$ENDIF}
+{$IFDEF POSIX}
+   {$I ssposix.inc} //experimental!
+{$ENDIF}
+
+end.
+

tlntsend.pas

@@ -0,0 +1,364 @@
+{==============================================================================|
+| Project : Ararat Synapse                                       | 001.003.001 |
+|==============================================================================|
+| Content: TELNET and SSH2 client                                              |
+|==============================================================================|
+| Copyright (c)1999-2010, Lukas Gebauer                                        |
+| All rights reserved.                                                         |
+|                                                                              |
+| Redistribution and use in source and binary forms, with or without           |
+| modification, are permitted provided that the following conditions are met:  |
+|                                                                              |
+| Redistributions of source code must retain the above copyright notice, this  |
+| list of conditions and the following disclaimer.                             |
+|                                                                              |
+| Redistributions in binary form must reproduce the above copyright notice,    |
+| this list of conditions and the following disclaimer in the documentation    |
+| and/or other materials provided with the distribution.                       |
+|                                                                              |
+| Neither the name of Lukas Gebauer nor the names of its contributors may      |
+| be used to endorse or promote products derived from this software without    |
+| specific prior written permission.                                           |
+|                                                                              |
+| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
+| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
+| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
+| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
+| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
+| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
+| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
+| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
+| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
+| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
+| DAMAGE.                                                                      |
+|==============================================================================|
+| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
+| Portions created by Lukas Gebauer are Copyright (c)2002-2010.                |
+| All Rights Reserved.                                                         |
+|==============================================================================|
+| Contributor(s):                                                              |
+|==============================================================================|
+| History: see HISTORY.HTM from distribution package                           |
+|          (Found at URL: http://www.ararat.cz/synapse/)                       |
+|==============================================================================}
+
+{:@abstract(Telnet script client)
+
+Used RFC: RFC-854
+}
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+{$H+}
+
+{$IFDEF UNICODE}
+  {$WARN IMPLICIT_STRING_CAST OFF}
+  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
+{$ENDIF}
+
+unit tlntsend;
+
+interface
+
+uses
+  SysUtils, Classes,
+  blcksock, synautil;
+
+const
+  cTelnetProtocol = '23';
+  cSSHProtocol = '22';
+
+  TLNT_EOR                = #239;
+  TLNT_SE                 = #240;
+  TLNT_NOP                = #241;
+  TLNT_DATA_MARK          = #242;
+  TLNT_BREAK              = #243;
+  TLNT_IP                 = #244;
+  TLNT_AO                 = #245;
+  TLNT_AYT                = #246;
+  TLNT_EC                 = #247;
+  TLNT_EL                 = #248;
+  TLNT_GA                 = #249;
+  TLNT_SB                 = #250;
+  TLNT_WILL               = #251;
+  TLNT_WONT               = #252;
+  TLNT_DO                 = #253;
+  TLNT_DONT               = #254;
+  TLNT_IAC                = #255;
+
+type
+  {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
+  TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
+     tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
+
+  {:@abstract(Class with implementation of Telnet/SSH script client.)
+
+   Note: Are you missing properties for specify server address and port? Look to
+   parent @link(TSynaClient) too!}
+  TTelnetSend = class(TSynaClient)
+  private
+    FSock: TTCPBlockSocket;
+    FBuffer: Ansistring;
+    FState: TTelnetState;
+    FSessionLog: Ansistring;
+    FSubNeg: Ansistring;
+    FSubType: Ansichar;
+    FTermType: Ansistring;
+    function Connect: Boolean;
+    function Negotiate(const Buf: Ansistring): Ansistring;
+    procedure FilterHook(Sender: TObject; var Value: AnsiString);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    {:Connects to Telnet server.}
+    function Login: Boolean;
+
+    {:Connects to SSH2 server and login by Username and Password properties.
+
+     You must use some of SSL plugins with SSH support. For exammple CryptLib.}
+    function SSHLogin: Boolean;
+
+    {:Logout from telnet server.}
+    procedure Logout;
+
+    {:Send this data to telnet server.}
+    procedure Send(const Value: string);
+
+    {:Reading data from telnet server until Value is readed. If it is not readed
+     until timeout, result is @false. Otherwise result is @true.}
+    function WaitFor(const Value: string): Boolean;
+
+    {:Read data terminated by terminator from telnet server.}
+    function RecvTerminated(const Terminator: string): string;
+
+    {:Read string from telnet server.}
+    function RecvString: string;
+  published
+    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
+    property Sock: TTCPBlockSocket read FSock;
+
+    {:all readed datas in this session (from connect) is stored in this large
+     string.}
+    property SessionLog: Ansistring read FSessionLog write FSessionLog;
+
+    {:Terminal type indentification. By default is 'SYNAPSE'.}
+    property TermType: Ansistring read FTermType write FTermType;
+  end;
+
+implementation
+
+constructor TTelnetSend.Create;
+begin
+  inherited Create;
+  FSock := TTCPBlockSocket.Create;
+  FSock.Owner := self;
+  FSock.OnReadFilter := FilterHook;
+  FTimeout := 60000;
+  FTargetPort := cTelnetProtocol;
+  FSubNeg := '';
+  FSubType := #0;
+  FTermType := 'SYNAPSE';
+end;
+
+destructor TTelnetSend.Destroy;
+begin
+  FSock.Free;
+  inherited Destroy;
+end;
+
+function TTelnetSend.Connect: Boolean;
+begin
+  // Do not call this function! It is calling by LOGIN method!
+  FBuffer := '';
+  FSessionLog := '';
+  FState := tsDATA;
+  FSock.CloseSocket;
+  FSock.LineBuffer := '';
+  FSock.Bind(FIPInterface, cAnyPort);
+  FSock.Connect(FTargetHost, FTargetPort);
+  Result := FSock.LastError = 0;
+end;
+
+function TTelnetSend.RecvTerminated(const Terminator: string): string;
+begin
+  Result := FSock.RecvTerminated(FTimeout, Terminator);
+end;
+
+function TTelnetSend.RecvString: string;
+begin
+  Result := FSock.RecvTerminated(FTimeout, CRLF);
+end;
+
+function TTelnetSend.WaitFor(const Value: string): Boolean;
+begin
+  Result := FSock.RecvTerminated(FTimeout, Value) <> '';
+end;
+
+procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
+begin
+  Value := Negotiate(Value);
+  FSessionLog := FSessionLog + Value;
+end;
+
+function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
+var
+  n: integer;
+  c: Ansichar;
+  Reply: Ansistring;
+  SubReply: Ansistring;
+begin
+  Result := '';
+  for n := 1 to Length(Buf) do
+  begin
+    c := Buf[n];
+    Reply := '';
+    case FState of
+      tsData:
+        if c = TLNT_IAC then
+          FState := tsIAC
+        else
+          Result := Result + c;
+
+      tsIAC:
+        case c of
+          TLNT_IAC:
+            begin
+              FState := tsData;
+              Result := Result + TLNT_IAC;
+            end;
+          TLNT_WILL:
+            FState := tsIAC_WILL;
+          TLNT_WONT:
+            FState := tsIAC_WONT;
+          TLNT_DONT:
+            FState := tsIAC_DONT;
+          TLNT_DO:
+            FState := tsIAC_DO;
+          TLNT_EOR:
+            FState := tsDATA;
+          TLNT_SB:
+            begin
+              FState := tsIAC_SB;
+              FSubType := #0;
+              FSubNeg := '';
+            end;
+        else
+          FState := tsData;
+        end;
+
+      tsIAC_WILL:
+        begin
+        case c of
+          #3:  //suppress GA
+            Reply := TLNT_DO;
+        else
+          Reply := TLNT_DONT;
+        end;
+          FState := tsData;
+        end;
+
+      tsIAC_WONT:
+        begin
+          Reply := TLNT_DONT;
+          FState := tsData;
+        end;
+
+      tsIAC_DO:
+      begin
+        case c of
+          #24:  //termtype
+            Reply := TLNT_WILL;
+        else
+          Reply := TLNT_WONT;
+        end;
+        FState := tsData;
+      end;
+
+      tsIAC_DONT:
+      begin
+        Reply := TLNT_WONT;
+        FState := tsData;
+      end;
+
+      tsIAC_SB:
+        begin
+          FSubType := c;
+          FState := tsIAC_SBDATA;
+        end;
+
+      tsIAC_SBDATA:
+        begin
+          if c = TLNT_IAC then
+            FState := tsSBDATA_IAC
+          else
+            FSubNeg := FSubNeg + c;
+        end;
+
+      tsSBDATA_IAC:
+        case c of
+          TLNT_IAC:
+            begin
+              FState := tsIAC_SBDATA;
+              FSubNeg := FSubNeg + c;
+            end;
+          TLNT_SE:
+            begin
+              SubReply := '';
+              case FSubType of
+                #24:  //termtype
+                  begin
+                    if (FSubNeg <> '') and (FSubNeg[1] = #1) then
+                      SubReply := #0 + FTermType;
+                  end;
+              end;
+              Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
+              FState := tsDATA;
+            end;
+         else
+           FState := tsDATA;
+         end;
+
+      else
+        FState := tsData;
+    end;
+    if Reply <> '' then
+      Sock.SendString(TLNT_IAC + Reply + c);
+  end;
+
+end;
+
+procedure TTelnetSend.Send(const Value: string);
+begin
+  Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
+end;
+
+function TTelnetSend.Login: Boolean;
+begin
+  Result := False;
+  if not Connect then
+    Exit;
+  Result := True;
+end;
+
+function TTelnetSend.SSHLogin: Boolean;
+begin
+  Result := False;
+  if Connect then
+  begin
+    FSock.SSL.SSLType := LT_SSHv2;
+    FSock.SSL.Username := FUsername;
+    FSock.SSL.Password := FPassword;
+    FSock.SSLDoConnect;
+    Result := FSock.LastError = 0;
+  end;
+end;
+
+procedure TTelnetSend.Logout;
+begin
+  FSock.CloseSocket;
+end;
+
+
+end.

tzutil.pas

@@ -0,0 +1,702 @@
+//Unit with timezone support for some Freepascal platforms.
+//Tomas Hajny
+
+unit tzutil;
+
+
+interface
+
+type
+ DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX);
+
+(* Initialized to default values *)
+const
+  TZName: string = '';
+  TZDSTName: string = '';
+  TZOffset: longint = 0;
+  DSTOffset: longint = 0;
+  DSTStartMonth: byte = 4;
+  DSTStartWeek: shortint = 1;
+  DSTStartDay: word = 0;
+  DSTStartSec: cardinal = 7200;
+  DSTEndMonth: byte = 10;
+  DSTEndWeek: shortint = -1;
+  DSTEndDay: word = 0;
+  DSTEndSec: cardinal = 10800;
+  DSTStartSpecType: DSTSpecType = DSTMonthWeekDay;
+  DSTEndSpecType: DSTSpecType = DSTMonthWeekDay;
+
+function TZSeconds: longint;
+(* Return current offset from UTC in seconds while respecting DST *)
+
+implementation
+
+uses
+  Dos;
+
+function TZSeconds: longint;
+const
+  MonthDays: array [1..12] of byte =
+                              (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
+  MonthEnds: array [1..12] of word =
+                     (31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365);
+var
+  Y, Mo, D, WD, H, Mi, S, S100: word;
+  MS, DS, ME, DE: byte;
+  L: longint;
+  Second: cardinal;
+  AfterDSTStart, BeforeDSTEnd: boolean;
+
+function LeapDay: byte;
+begin
+ if (Y mod 400 = 0) or (Y mod 100 <> 0) and (Y mod 4 = 0) then
+  LeapDay := 1
+ else
+  LeapDay := 0;
+end;
+
+function FirstDay (MM: byte): byte;
+(* What day of week (0-6) is the first day of month MM? *)
+var
+ DD: longint;
+begin
+ if MM < Mo then
+  begin
+   DD := D + MonthEnds [Pred (Mo)];
+   if MM > 1 then
+    Dec (DD, MonthEnds [Pred (MM)]);
+   if (MM <= 2) and (Mo > 2) then
+    Inc (DD, LeapDay);
+  end
+ else
+  if MM > Mo then
+   begin
+    DD := - MonthDays [Mo] + D - MonthEnds [Pred (MM)] + MonthEnds [Mo];
+    if (Mo <= 2) and (MM > 2) then
+     Dec (DD, LeapDay);
+   end
+  else
+(* M = MM *)
+   DD := D;
+ DD := WD - DD mod 7 + 1;
+ if DD < 0 then
+  FirstDay := DD + 7
+ else
+  FirstDay := DD mod 7;
+end;
+
+begin
+ TZSeconds := TZOffset;
+ if DSTOffset <> TZOffset then
+  begin
+   GetDate (Y, Mo, D, WD);
+   GetTime (H, Mi, S, S100);
+   Second := cardinal (H) * 3600 + Mi * 60 + S;
+
+   if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay)
+                                                                           then
+    begin
+     MS := DSTStartMonth;
+     if DSTStartSpecType = DSTMonthDay then
+      DS := DSTStartDay
+     else
+      begin
+       DS := FirstDay (DSTStartMonth);
+       if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then
+        if DSTStartDay < DS then
+         DS := DSTStartWeek * 7 + DSTStartDay - DS + 1
+        else
+         DS := Pred (DSTStartWeek) * 7 + DSTStartDay - DS + 1
+       else
+(* Last week in month *)
+        begin
+         DS := DS + MonthDays [MS] - 1;
+         if MS = 2 then
+          Inc (DS, LeapDay);
+         DS := DS mod 7;
+         if DS < DSTStartDay then
+          DS := DS + 7 - DSTStartDay
+         else
+          DS := DS - DSTStartDay;
+         DS := MonthDays [MS] - DS;
+        end;
+      end;
+    end
+   else
+    begin
+(* Julian day *)
+     L := DSTStartDay;
+     if (DSTStartSpecType = DSTJulian) then
+(* 0-based *)
+      if (L + LeapDay <= 59) then
+       Inc (L)
+      else
+       L := L + 1 - LeapDay;
+     if L <= 31 then
+      begin
+       MS := 1;
+       DS := L;
+      end
+     else
+      if (L <= 59) or
+                    (DSTStartSpecType = DSTJulian) and (L - LeapDay <= 59) then
+       begin
+        MS := 2;
+        DS := DSTStartDay - 31;
+       end
+      else
+       begin
+        MS := 3;
+        while (MS < 12) and (MonthEnds [MS] > L) do
+         Inc (MS);
+        DS := L - MonthEnds [Pred (MS)];
+       end;
+    end;
+
+   if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then
+    begin
+     ME := DSTEndMonth;
+     if DSTEndSpecType = DSTMonthDay then
+      DE := DSTEndDay
+     else
+      begin
+       DE := FirstDay (DSTEndMonth);
+       if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then
+        if DSTEndDay < DE then
+         DE := DSTEndWeek * 7 + DSTEndDay - DE + 1
+        else
+         DE := Pred (DSTEndWeek) * 7 + DSTEndDay - DE + 1
+       else
+(* Last week in month *)
+        begin
+         DE := DE + MonthDays [ME] - 1;
+         if ME = 2 then
+          Inc (DE, LeapDay);
+         DE := DE mod 7;
+         if DE < DSTEndDay then
+          DE := DE + 7 - DSTEndDay
+         else
+          DE := DE - DSTEndDay;
+         DE := MonthDays [ME] - DE;
+        end;
+      end;
+    end
+   else
+    begin
+(* Julian day *)
+     L := DSTEndDay;
+     if (DSTEndSpecType = DSTJulian) then
+(* 0-based *)
+      if (L + LeapDay <= 59) then
+       Inc (L)
+      else
+       L := L + 1 - LeapDay;
+     if L <= 31 then
+      begin
+       ME := 1;
+       DE := L;
+      end
+     else
+      if (L <= 59) or
+                      (DSTEndSpecType = DSTJulian) and (L - LeapDay <= 59) then
+       begin
+        ME := 2;
+        DE := DSTEndDay - 31;
+       end
+      else
+       begin
+        ME := 3;
+        while (ME < 12) and (MonthEnds [ME] > L) do
+         Inc (ME);
+        DE := L - MonthEnds [Pred (ME)];
+       end;
+    end;
+
+   if Mo < MS then
+    AfterDSTStart := false
+   else
+    if Mo > MS then
+     AfterDSTStart := true
+    else
+     if D < DS then
+      AfterDSTStart := false
+     else
+      if D > DS then
+       AfterDSTStart := true
+      else
+       AfterDSTStart := Second > DSTStartSec;
+   if Mo > ME then
+    BeforeDSTEnd := false
+   else
+    if Mo < ME then
+     BeforeDSTEnd := true
+    else
+     if D > DE then
+      BeforeDSTEnd := false
+     else
+      if D < DE then
+       BeforeDSTEnd := true
+      else
+       BeforeDSTEnd := Second < DSTEndSec;
+   if AfterDSTStart and BeforeDSTEnd then
+    TZSeconds := DSTOffset;
+  end;
+end;
+
+procedure InitTZ;
+const
+  TZEnvName = 'TZ';
+  EMXTZEnvName = 'EMXTZ';
+var
+  TZ, S: string;
+  I, J: byte;
+  Err: longint;
+  GnuFmt: boolean;
+  ADSTStartMonth: byte;
+  ADSTStartWeek: shortint;
+  ADSTStartDay: word;
+  ADSTStartSec: cardinal;
+  ADSTEndMonth: byte;
+  ADSTEndWeek: shortint;
+  ADSTEndDay: word;
+  ADSTEndSec: cardinal;
+  ADSTStartSpecType: DSTSpecType;
+  ADSTEndSpecType: DSTSpecType;
+  ADSTChangeSec: cardinal;
+
+  function ParseOffset (OffStr: string): longint;
+  (* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *)
+  var
+    TZShiftHH, TZShiftDir: shortint;
+    TZShiftMI, TZShiftSS: byte;
+    N1, N2: byte;
+  begin
+    TZShiftHH := 0;
+    TZShiftMI := 0;
+    TZShiftSS := 0;
+    TZShiftDir := 1;
+    N1 := 1;
+    while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do
+     Inc (N1);
+    Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err);
+    if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then
+     begin
+(* Normalize the hour offset to -12..11 if necessary *)
+      if TZShiftHH > 11 then
+       Dec (TZShiftHH, 24) else
+      if TZShiftHH < -12 then
+       Inc (TZShiftHH, 24);
+      if TZShiftHH < 0 then
+       TZShiftDir := -1;
+      if (N1 <= Length (OffStr)) then
+       begin
+        N2 := Succ (N1);
+        while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do
+         Inc (N2);
+        Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err);
+         if (Err = 0) and (TZShiftMI <= 59) then
+          begin
+           if (N2 <= Length (OffStr)) then
+            begin
+             Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err);
+             if (Err <> 0) or (TZShiftSS > 59) then
+              TZShiftSS := 0;
+            end
+          end
+         else
+          TZShiftMI := 0;
+       end;
+     end
+    else
+     TZShiftHH := 0;
+    ParseOffset := longint (TZShiftHH) * 3600 +
+                           TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS);
+  end;
+
+begin
+  TZ := GetEnv (TZEnvName);
+  if TZ = '' then
+   TZ := GetEnv (EMXTZEnvName);
+  if TZ <> '' then
+   begin
+    TZ := Upcase (TZ);
+(* Timezone name *)
+    I := 1;
+    while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do
+     Inc (I);
+    TZName := Copy (TZ, 1, Pred (I));
+    if I <= Length (TZ) then
+     begin
+(* Timezone shift *)
+      J := Succ (I);
+      while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do
+       Inc (J);
+      TZOffset := ParseOffset (Copy (TZ, I, J - I));
+(* DST timezone name *)
+      I := J;
+      while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do
+       Inc (J);
+      if J > I then
+       begin
+        TZDSTName := Copy (TZ, I, J - I);
+(* DST timezone name provided; if equal to the standard timezone  *)
+(* name then DSTOffset is set to be equal to TZOffset by default, *)
+(* otherwise it is set to TZOffset - 3600 seconds.                *)
+        if TZDSTName <> TZName then
+         DSTOffset := -3600 + TZOffset
+        else
+         DSTOffset := TZOffset;
+       end
+      else
+       begin
+        TZDSTName := TZName;
+(* No DST timezone name provided => DSTOffset is equal to TZOffset *)
+        DSTOffset := TZOffset;
+       end;
+      if J <= Length (TZ) then
+       begin
+(* Check if DST offset is specified here;   *)
+(* if not, default value set above is used. *)
+        if TZ [J] <> ',' then
+         begin
+          I := J;
+          Inc (J);
+          while (J <= Length (TZ)) and (TZ [J] <> ',') do
+           Inc (J);
+          DSTOffset := ParseOffset (Copy (TZ, I, J - I));
+         end;
+        if J < Length (TZ) then
+         begin
+          Inc (J);
+(* DST switching details *)
+          case TZ [J] of
+           'M':
+            begin
+(* Mmonth.week.dayofweek[/StartHour] *)
+             ADSTStartSpecType := DSTMonthWeekDay;
+             if J >= Length (TZ) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+              Inc (J);
+             if (J >= Length (TZ)) or (TZ [J] <> '.') then
+              Exit;
+             Val (Copy (TZ, I, J - I), ADSTStartMonth, Err);
+             if (Err > 0) or (ADSTStartMonth > 12) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+              Inc (J);
+             if (J >= Length (TZ)) or (TZ [J] <> '.') then
+              Exit;
+             Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
+             if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
+              Inc (J);
+             Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+             if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6)
+                                                     or (J >= Length (TZ)) then
+              Exit;
+             if TZ [J] = '/' then
+              begin
+               Inc (J);
+               I := J;
+               while (J <= Length (TZ)) and (TZ [J] <> ',') do
+                Inc (J);
+               Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+               if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ))
+                                                                           then
+                Exit
+               else
+                ADSTStartSec := ADSTStartSec * 3600;
+              end
+             else
+              (* Use the preset default *)
+              ADSTStartSec := DSTStartSec;
+             Inc (J);
+            end;
+           'J':
+            begin
+(* Jjulianday[/StartHour] *)
+             ADSTStartSpecType := DSTJulianX;
+             if J >= Length (TZ) then
+              Exit;
+             Inc (J);
+             I := J;
+             while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
+              Inc (J);
+             Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+             if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365)
+                                                     or (J >= Length (TZ)) then
+              Exit;
+             if TZ [J] = '/' then
+              begin
+               Inc (J);
+               I := J;
+               while (J <= Length (TZ)) and (TZ [J] <> ',') do
+                Inc (J);
+               Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+               if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ))
+                                                                           then
+                Exit
+               else
+                ADSTStartSec := ADSTStartSec * 3600;
+              end
+             else
+              (* Use the preset default *)
+              ADSTStartSec := DSTStartSec;
+             Inc (J);
+            end
+          else
+           begin
+(* Check the used format first - GNU libc / GCC / EMX expect                 *)
+(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]";           *)
+(* if more than one comma (',') is found, the following format is assumed:   *)
+(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond,  *)
+(*                         EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *)
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> ',') do
+             Inc (J);
+            S := Copy (TZ, I, J - I);
+            if J < Length (TZ) then
+             begin
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              GnuFmt := J > Length (TZ);
+             end
+            else
+             Exit;
+            if GnuFmt then
+             begin
+              ADSTStartSpecType := DSTJulian;
+              J := Pos ('/', S);
+              if J = 0 then
+               begin
+                Val (S, ADSTStartDay, Err);
+                if (Err > 0) or (ADSTStartDay > 365) then
+                 Exit;
+                (* Use the preset default *)
+                ADSTStartSec := DSTStartSec;
+               end
+              else
+               begin
+                if J = Length (S) then
+                 Exit;
+                Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err);
+                if (Err > 0) or (ADSTStartDay > 365) then
+                 Exit;
+                Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err);
+                if (Err > 0) or (ADSTStartSec > 86399) then
+                 Exit
+                else
+                 ADSTStartSec := ADSTStartSec * 3600;
+               end;
+              J := I;
+             end
+            else
+             begin
+              Val (S, ADSTStartMonth, Err);
+              if (Err > 0) or (ADSTStartMonth > 12) then
+               Exit;
+              Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
+              if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or
+                                                        (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
+              if (DSTStartWeek = 0) then
+               begin
+                if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31)
+                  or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11])
+                           or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then
+                 Exit;
+                ADSTStartSpecType := DSTMonthDay;
+               end
+              else
+               begin
+                if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) then
+                 Exit;
+                ADSTStartSpecType := DSTMonthWeekDay;
+               end;
+              if J >= Length (TZ) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
+              if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
+              if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
+              if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5)
+                                                     or (J >= Length (TZ)) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+              if (DSTEndWeek = 0) then
+               begin
+                if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31)
+                   or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11])
+                               or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then
+                 Exit;
+                ADSTEndSpecType := DSTMonthDay;
+               end
+              else
+               begin
+                if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then
+                 Exit;
+                ADSTEndSpecType := DSTMonthWeekDay;
+               end;
+              if J >= Length (TZ) then
+               Exit;
+              Inc (J);
+              I := J;
+              while (J <= Length (TZ)) and (TZ [J] <> ',') do
+               Inc (J);
+              Val (Copy (TZ, I, J - I), ADSTEndSec, Err);
+              if (Err > 0) or (ADSTEndSec > 86399) or (J >= Length (TZ)) then
+               Exit;
+              Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err);
+              if (Err = 0) and (ADSTChangeSec < 86400) then
+               begin
+(* Format complete, all checks successful => accept the parsed values. *)
+                DSTStartMonth := ADSTStartMonth;
+                DSTStartWeek := ADSTStartWeek;
+                DSTStartDay := ADSTStartDay;
+                DSTStartSec := ADSTStartSec;
+                DSTEndMonth := ADSTEndMonth;
+                DSTEndWeek := ADSTEndWeek;
+                DSTEndDay := ADSTEndDay;
+                DSTEndSec := ADSTEndSec;
+                DSTStartSpecType := ADSTStartSpecType;
+                DSTEndSpecType := ADSTEndSpecType;
+                DSTOffset := TZOffset - ADSTChangeSec;
+               end;
+(* Parsing finished *)
+              Exit;
+             end;
+           end;
+          end;
+(* GnuFmt - DST end specification *)
+          if TZ [J] = 'M' then
+           begin
+(* Mmonth.week.dayofweek *)
+            ADSTEndSpecType := DSTMonthWeekDay;
+            if J >= Length (TZ) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+             Inc (J);
+            if (J >= Length (TZ)) or (TZ [J] <> '.') then
+             Exit;
+            Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
+            if (Err > 0) or (ADSTEndMonth > 12) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
+             Inc (J);
+            if (J >= Length (TZ)) or (TZ [J] <> '.') then
+             Exit;
+            Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
+            if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> '/') do
+             Inc (J);
+            Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+            if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then
+             Exit;
+           end
+          else
+           begin
+            if TZ [J] = 'J' then
+             begin
+(* Jjulianday *)
+              if J = Length (TZ) then
+               Exit;
+              Inc (J);
+              ADSTEndSpecType := DSTJulianX
+             end
+            else
+             ADSTEndSpecType := DSTJulian;
+            if J >= Length (TZ) then
+             Exit;
+            Inc (J);
+            I := J;
+            while (J <= Length (TZ)) and (TZ [J] <> '/') do
+             Inc (J);
+            Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
+            if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX)
+                                                     or (ADSTEndDay > 365) then
+             Exit;
+           end;
+          if (J <= Length (TZ)) and (TZ [J] = '/') then
+           begin
+            if J = Length (TZ) then
+             Exit;
+            Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err);
+            if (Err > 0) or (ADSTEndSec > 86399) then
+             Exit
+            else
+             ADSTEndSec := ADSTEndSec * 3600;
+           end
+          else
+           (* Use the preset default *)
+           ADSTEndSec := DSTEndSec;
+
+(* Format complete, all checks successful => accept the parsed values. *)
+         if ADSTStartSpecType = DSTMonthWeekDay then
+          begin
+           DSTStartMonth := ADSTStartMonth;
+           DSTStartWeek := ADSTStartWeek;
+          end;
+         DSTStartDay := ADSTStartDay;
+         DSTStartSec := ADSTStartSec;
+         if ADSTStartSpecType = DSTMonthWeekDay then
+          begin
+           DSTEndMonth := ADSTEndMonth;
+           DSTEndWeek := ADSTEndWeek;
+          end;
+          DSTEndDay := ADSTEndDay;
+          DSTEndSec := ADSTEndSec;
+          DSTStartSpecType := ADSTStartSpecType;
+          DSTEndSpecType := ADSTEndSpecType;
+         end;
+       end
+      else
+       DSTOffset := -3600 + TZOffset;
+     end;
+   end;
+end;
+
+
+begin
+  InitTZ;
+end.