diff --git a/EvilLibrary.groupproj b/EvilLibrary.groupproj new file mode 100644 index 0000000..a0f4b8e --- /dev/null +++ b/EvilLibrary.groupproj @@ -0,0 +1,48 @@ + + + {554334B1-9FC2-45F5-8997-809AA011BA4C} + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/EvilLibrary.groupproj.local b/EvilLibrary.groupproj.local new file mode 100644 index 0000000..cd6bd32 --- /dev/null +++ b/EvilLibrary.groupproj.local @@ -0,0 +1,7 @@ + + + + + + + diff --git a/EvilLibraryD.dpk b/EvilLibraryD.dpk new file mode 100644 index 0000000..c3fbe61 --- /dev/null +++ b/EvilLibraryD.dpk @@ -0,0 +1,41 @@ +package EvilLibraryD; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'EvilWorks.EvilLibrary.Designtime'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + rtl, + designide, + EvilLibraryR; + +contains + EvilWorks.Vcl.Reg in 'EvilWorks.Vcl.Reg.pas', + EvilWorks.Design.HTTPHeadersEditor in 'EvilWorks.Design.HTTPHeadersEditor.pas' {HTTPHeadersPropertyEditorForm}; + +end. diff --git a/EvilLibraryD.dproj b/EvilLibraryD.dproj new file mode 100644 index 0000000..36cb684 --- /dev/null +++ b/EvilLibraryD.dproj @@ -0,0 +1,158 @@ + + + {665D088D-3B13-48F3-AE60-C5A293B8222A} + EvilLibraryD.dpk + 13.4 + VCL + True + Debug + Win32 + 1 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + rtl;$(DCC_UsePackage) + true + 1050 + EvilWorks.EvilLibrary.Designtime + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + ..\Bin\$(platform)\$(config) + System.Win;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + 00400000 + + + vcl;$(DCC_UsePackage) + + + vcl;EvilLibraryR;$(DCC_UsePackage) + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + $(BDS)\bin\delphi_PROJECTICON.ico + $(BDS)\bin\default_app.manifest + true + true + true + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + false + + + $(BDS)\bin\default_app.manifest + $(BDS)\bin\delphi_PROJECTICON.ico + false + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + + + + + +
HTTPHeadersPropertyEditorForm
+ dfm + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + EvilLibraryD.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1050 + 1250 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + False + True + + + 12 + + + + diff --git a/EvilLibraryD.dproj.local b/EvilLibraryD.dproj.local new file mode 100644 index 0000000..5924f80 --- /dev/null +++ b/EvilLibraryD.dproj.local @@ -0,0 +1,16 @@ + + + + 1899.12.30 00:00:00.000.315,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.561,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.376,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Design.HTTPHeadersEditor.pas + 1899.12.30 00:00:00.000.988,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.dfm=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Design.HTTPHeadersEditor.dfm + 1899.12.30 00:00:00.000.988,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Design.HTTPHeadersEditor.pas + 1899.12.30 00:00:00.000.677,C:\Dev\Delphi\Projects\Package1.dproj=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilLibraryD.dproj + 1899.12.30 00:00:00.000.965,=rtl.dcp + 1899.12.30 00:00:00.000.952,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Design.HTTPHeadersEditor.pas= + 1899.12.30 00:00:00.000.639,=vcl.dcp + 1899.12.30 00:00:00.000.142,=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.Reg.pas + + + diff --git a/EvilLibraryD.identcache b/EvilLibraryD.identcache new file mode 100644 index 0000000..980df72 Binary files /dev/null and b/EvilLibraryD.identcache differ diff --git a/EvilLibraryD.res b/EvilLibraryD.res new file mode 100644 index 0000000..c287ee9 Binary files /dev/null and b/EvilLibraryD.res differ diff --git a/EvilLibraryR.dpk b/EvilLibraryR.dpk new file mode 100644 index 0000000..536a221 --- /dev/null +++ b/EvilLibraryR.dpk @@ -0,0 +1,58 @@ +package EvilLibraryR; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'EvilWorks.EvilLibrary.Runtime'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + vclimg; + +contains + EvilWorks.Vcl.BrowseDialog in 'EvilWorks.Vcl.BrowseDialog.pas', + EvilWorks.Vcl.ConnectionMonitor in 'EvilWorks.Vcl.ConnectionMonitor.pas', + EvilWorks.Vcl.ConsoleIO in 'EvilWorks.Vcl.ConsoleIO.pas', + EvilWorks.Vcl.FindFiles in 'EvilWorks.Vcl.FindFiles.pas', + EvilWorks.Vcl.FormSettings in 'EvilWorks.Vcl.FormSettings.pas', + EvilWorks.Vcl.GenericControl in 'EvilWorks.Vcl.GenericControl.pas', + EvilWorks.Vcl.SplitPanel in 'EvilWorks.Vcl.SplitPanel.pas', + EvilWorks.Vcl.Timers in 'EvilWorks.Vcl.Timers.pas', + EvilWorks.Web.AsyncSockets in 'EvilWorks.Web.AsyncSockets.pas', + EvilWorks.Web.HTTP in 'EvilWorks.Web.HTTP.pas', + EvilWorks.Web.IRC in 'EvilWorks.Web.IRC.pas', + EvilWorks.Web.Twitter in 'EvilWorks.Web.Twitter.pas', + EvilWorks.Vcl.VirtualListbox in 'EvilWorks.Vcl.VirtualListbox.pas', + EvilWorks.Vcl.TweetsControl in 'EvilWorks.Vcl.TweetsControl.pas', + EvilWorks.Vcl.MarkupLabel in 'EvilWorks.Vcl.MarkupLabel.pas', + EvilWorks.Vcl.MarkupControl in 'EvilWorks.Vcl.MarkupControl.pas', + EvilWorks.Web.TwitterTypes in 'EvilWorks.Web.TwitterTypes.pas', + EvilWorks.Vcl.Fullscreen in 'EvilWorks.Vcl.Fullscreen.pas'; + +end. + diff --git a/EvilLibraryR.dproj b/EvilLibraryR.dproj new file mode 100644 index 0000000..275ac02 --- /dev/null +++ b/EvilLibraryR.dproj @@ -0,0 +1,166 @@ + + + {6D3FEB20-736A-4C6D-92A2-3DEAC986BCE9} + EvilLibraryR.dpk + True + Debug + 1 + Package + VCL + 13.4 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + rtl;$(DCC_UsePackage) + 1050 + false + 00400000 + false + true + false + false + EvilWorks.EvilLibrary.Runtime + false + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + true + + + vcl;vclimg;$(DCC_UsePackage) + + + vcl;vclimg;$(DCC_UsePackage) + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + false + + + true + true + DEBUG;$(DCC_Define) + false + + + true + 1033 + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + EvilLibraryR.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1050 + 1250 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + False + True + + + 12 + + + + diff --git a/EvilLibraryR.dproj.local b/EvilLibraryR.dproj.local new file mode 100644 index 0000000..7e2e6b1 --- /dev/null +++ b/EvilLibraryR.dproj.local @@ -0,0 +1,41 @@ + + + + 1899.12.30 00:00:00.000.867,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.VirtualListbox.pas + 1899.12.30 00:00:00.000.011,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.516,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.736,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.514,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.039,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.760,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.Reg.pas= + 1899.12.30 00:00:00.000.626,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.123,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.142,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.MarkupControl.pas + 1899.12.30 00:00:00.000.531,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.ProxyConnector.pas + 1899.12.30 00:00:00.000.643,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilLibraryR.dproj=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilLibrary.dproj + 1899.12.30 00:00:00.000.180,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.Connectors.pas + 1899.12.30 00:00:00.000.082,C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.TweetsControl.pas + 1899.12.30 00:00:00.000.278,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.174,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.691,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.658,=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.908,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.TextDisplay.pas= + 1899.12.30 00:00:00.000.676,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.TextDisplay.pas= + 1899.12.30 00:00:00.000.656,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.ProxyConnector.pas= + 1899.12.30 00:00:00.000.545,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.Fullscreen.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.303,=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.TextDisplay.pas + 1899.12.30 00:00:00.000.076,=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Vcl.MarkupLabel.pas + 1899.12.30 00:00:00.000.712,=C:\Dev\Delphi\Components\EvilLibrary\Source\JSONInspector.pas + 1899.12.30 00:00:00.000.670,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.TwitterTypes.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.193,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.OAuth.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.140,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.VCL.AsyncSockets.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.161,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.AsyncSockets.pas=C:\Temp\EvilWorks.Web.AsyncSockets.pas + 1899.12.30 00:00:00.000.853,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.IRC.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\Unit1.pas + 1899.12.30 00:00:00.000.443,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.VCL.AsyncSockets.pas= + 1899.12.30 00:00:00.000.856,C:\Temp\EvilWorks.Web.AsyncSockets.pas=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.AsyncSockets.pas + 1899.12.30 00:00:00.000.096,=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.Twitter.pas + 1899.12.30 00:00:00.000.151,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.Clients.pas= + 1899.12.30 00:00:00.000.919,C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.Web.Connectors.pas= + 1899.12.30 00:00:00.000.876,=C:\Dev\Delphi\Components\EvilLibrary\Source\EvilWorks.VirtualTrees.LogTreeView.pas + + diff --git a/EvilLibraryR.identcache b/EvilLibraryR.identcache new file mode 100644 index 0000000..8905e53 Binary files /dev/null and b/EvilLibraryR.identcache differ diff --git a/EvilLibraryR.res b/EvilLibraryR.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/EvilLibraryR.res differ diff --git a/EvilLibraryR_project.tvsconfig b/EvilLibraryR_project.tvsconfig new file mode 100644 index 0000000..d430780 --- /dev/null +++ b/EvilLibraryR_project.tvsconfig @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/EvilWorks.APi.WInsock2.pas b/EvilWorks.APi.WInsock2.pas new file mode 100644 index 0000000..8a2c462 --- /dev/null +++ b/EvilWorks.APi.WInsock2.pas @@ -0,0 +1,2625 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.Api.Winsock2 +// Description: Winsock2 header file, because embarcadero's is, naturally, incomplete. +// Also some extra utilities, all self contained and lightweight. +// File last change date: September 14th. 2012 +// File version: Dev 0.0.0 +// Licence: Free. +// + +unit EvilWorks.Api.Winsock2; + +interface + +uses + WinApi.Windows; + +{$ALIGN OFF} + + +// Define the current Winsock version. To build an earlier Winsock version +// application redefine this value prior to including Winsock2.h +const + WINSOCK_VERSION = $0202; + WINSOCK2_DLL = 'ws2_32.dll'; + +type + u_char = Byte; + u_short = Word; + u_int = DWORD; + u_long = DWORD; + + // The new type to be used in all instances which refer to sockets. + TSocket = u_int; + socklen_t = integer; + + WSAEVENT = THandle; + PWSAEVENT = ^WSAEVENT; + LPWSAEVENT = PWSAEVENT; + +{$IFDEF UNICODE} + PMBChar = PWideChar; +{$ELSE} + PMBChar = PAnsiChar; +{$ENDIF} + + +const + FD_SETSIZE = 64; + +type + PFDSet = ^TFDSet; + + TFDSet = packed record + fd_count: u_int; + fd_array: array [0 .. FD_SETSIZE - 1] of TSocket; + end; + + PTimeVal = ^TTimeVal; + + TTimeVal = packed record + tv_sec: Longint; + tv_usec: Longint; + end; + + timeval = TTimeVal; + +const + IOCPARM_MASK = $7F; + IOC_VOID = $20000000; + IOC_OUT = $40000000; + IOC_IN = $80000000; + IOC_INOUT = (IOC_IN or IOC_OUT); + + // get # bytes to read + FIONREAD = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 127; + // set/clear non-blocking i/o + FIONBIO = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 126; + // set/clear async i/o + FIOASYNC = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('f') shl 8) or 125; + + // Socket I/O Controls + + // set high watermark + SIOCSHIWAT = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('s') shl 8); + // get high watermark + SIOCGHIWAT = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 1; + // set low watermark + SIOCSLOWAT = IOC_IN or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 2; + // get low watermark + SIOCGLOWAT = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 3; + // at oob mark? + SIOCATMARK = IOC_OUT or (SizeOf(Longint) shl 16) or (Ord('s') shl 8) or 7; + + // Structures returned by network data base library, taken from the + // BSD file netdb.h. All addresses are supplied in host order, and + // returned in network order (suitable for use in system calls). +type + PHostEnt = ^THostEnt; + + THostEnt = packed record + h_name: PAnsiChar; // official name of host + h_aliases: ^PAnsiChar; // alias list + h_addrtype: Smallint; // host address type + h_length: Smallint; // length of address + case Byte of + 0: + (h_addr_list: ^PAnsiChar); // list of addresses + 1: + (h_addr: ^PAnsiChar); // address, for backward compat + end; + + // It is assumed here that a network number + // fits in 32 bits. + PNetEnt = ^TNetEnt; + + TNetEnt = packed record + n_name: PAnsiChar; // official name of net + n_aliases: ^PAnsiChar; // alias list + n_addrtype: Smallint; // net address type + n_net: u_long; // network # + end; + + PServEnt = ^TServEnt; + + TServEnt = packed record + s_name: PAnsiChar; // official service name + s_aliases: ^PAnsiChar; // alias list + s_port: Smallint; // protocol to use + s_proto: PAnsiChar; // port # + end; + + PProtoEnt = ^TProtoEnt; + + TProtoEnt = packed record + p_name: PAnsiChar; // official protocol name + p_aliases: ^PAnsiChar; // alias list + p_proto: Smallint; // protocol # + end; + + // Constants and structures defined by the internet system, + // Per RFC 790, September 1981, taken from the BSD file netinet/in.h. +const + + // Protocols + IPPROTO_IP = 0; // dummy for IP + IPPROTO_ICMP = 1; // control message protocol + IPPROTO_IGMP = 2; // group management protocol + IPPROTO_GGP = 3; // gateway^2 (deprecated) + IPPROTO_TCP = 6; // TCP + IPPROTO_PUP = 12; // pup + IPPROTO_UDP = 17; // UDP - user datagram protocol + IPPROTO_IDP = 22; // xns idp + IPPROTO_ND = 77; // UNOFFICIAL net disk proto + + IPPROTO_RAW = 255; // raw IP packet + IPPROTO_MAX = 256; + + // Port/socket numbers: network standard functions + IPPORT_ECHO = 7; + IPPORT_DISCARD = 9; + IPPORT_SYSTAT = 11; + IPPORT_DAYTIME = 13; + IPPORT_NETSTAT = 15; + IPPORT_FTP = 21; + IPPORT_TELNET = 23; + IPPORT_SMTP = 25; + IPPORT_TIMESERVER = 37; + IPPORT_NAMESERVER = 42; + IPPORT_WHOIS = 43; + IPPORT_MTP = 57; + + // Port/socket numbers: host specific functions + IPPORT_TFTP = 69; + IPPORT_RJE = 77; + IPPORT_FINGER = 79; + IPPORT_TTYLINK = 87; + IPPORT_SUPDUP = 95; + + // UNIX TCP sockets + IPPORT_EXECSERVER = 512; + IPPORT_LOGINSERVER = 513; + IPPORT_CMDSERVER = 514; + IPPORT_EFSSERVER = 520; + + // UNIX UDP sockets + IPPORT_BIFFUDP = 512; + IPPORT_WHOSERVER = 513; + IPPORT_ROUTESERVER = 520; + + // Ports < IPPORT_RESERVED are reserved for privileged processes (e.g. root). + IPPORT_RESERVED = 1024; + + // Link numbers + IMPLINK_IP = 155; + IMPLINK_LOWEXPER = 156; + IMPLINK_HIGHEXPER = 158; + + TF_DISCONNECT = $01; + TF_REUSE_SOCKET = $02; + TF_WRITE_BEHIND = $04; + + // This is used instead of -1, since the TSocket type is unsigned. + INVALID_SOCKET = TSocket(not (0)); + SOCKET_ERROR = - 1; + + // The following may be used in place of the address family, socket type, or + // protocol in a call to WSASocket to indicate that the corresponding value + // should be taken from the supplied WSAPROTOCOL_INFO structure instead of the + // parameter itself. + FROM_PROTOCOL_INFO = - 1; + + // Types + 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 } + + // 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 = not SO_LINGER; + SO_EXCLUSIVEADDRUSE = not SO_REUSEADDR; // disallow local address reuse + + // 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 + + // Options for connect and disconnect data and options. + // Used only by non-TCP/IP transports such as DECNet, OSI TP4, etc. + SO_CONNDATA = $7000; + SO_CONNOPT = $7001; + SO_DISCDATA = $7002; + SO_DISCOPT = $7003; + SO_CONNDATALEN = $7004; + SO_CONNOPTLEN = $7005; + SO_DISCDATALEN = $7006; + SO_DISCOPTLEN = $7007; + + // 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_UPDATE_CONNECT_CONTEXT = $7010; + SO_CONNECT_TIME = $700C; + + // TCP options. + TCP_NODELAY = $0001; + TCP_BSDURGENT = $7000; + + // 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 +{$IFDEF UNICODE} + SO_Protocol_Info = SO_Protocol_InfoW; +{$ELSE} + SO_Protocol_Info = SO_Protocol_InfoA; +{$ENDIF} + PVD_CONFIG = $3001; // configuration info for service provider + SO_CONDITIONAL_ACCEPT = $3002; // enable true conditional accept: + // connection is not ack-ed to the + // other side until conditional + // function returns CF_ACCEPT + +// Address families. + AF_UNSPEC = 0; // unspecified + AF_UNIX = 1; // local to host (pipes, portals) + AF_INET = 2; // Internet protocol Version 4: UDP, TCP, etc. + AF_IMPLINK = 3; // arpanet imp addresses + AF_PUP = 4; // pup protocols: e.g. BSP + AF_CHAOS = 5; // mit CHAOS protocols + AF_IPX = 6; // IPX and SPX + AF_NS = AF_IPX; // XEROX NS protocols + AF_ISO = 7; // ISO protocols + AF_OSI = AF_ISO; // OSI is ISO + AF_ECMA = 8; // european computer manufacturers + AF_DATAKIT = 9; // datakit protocols + AF_CCITT = 10; // CCITT protocols, X.25 etc + AF_SNA = 11; // IBM SNA + AF_DECnet = 12; // DECnet + AF_DLI = 13; // Direct data link interface + AF_LAT = 14; // LAT + AF_HYLINK = 15; // NSC Hyperchannel + AF_APPLETALK = 16; // AppleTalk + AF_NETBIOS = 17; // NetBios-style addresses + AF_VOICEVIEW = 18; // VoiceView + AF_FIREFOX = 19; // FireFox + AF_UNKNOWN1 = 20; // Somebody is using this! + AF_BAN = 21; // Banyan + AF_ATM = 22; // Native ATM Services + AF_INET6 = 23; // Internet protocol Version 6 + AF_CLUSTER = 24; // Microsoft Wolfpack + AF_12844 = 25; // IEEE 1284.4 WG AF + AF_IRDA = 26; // IrDA + AF_NETDES = 28; // Network Designers OSI & gateway enabled protocols + + AF_MAX = 29; + + + // Protocol families, same as address families for now. + + PF_UNSPEC = AF_UNSPEC; + PF_UNIX = AF_UNIX; + PF_INET = AF_INET; + PF_IMPLINK = AF_IMPLINK; + PF_PUP = AF_PUP; + PF_CHAOS = AF_CHAOS; + PF_NS = AF_NS; + PF_IPX = AF_IPX; + PF_ISO = AF_ISO; + PF_OSI = AF_OSI; + PF_ECMA = AF_ECMA; + PF_DATAKIT = AF_DATAKIT; + PF_CCITT = AF_CCITT; + PF_SNA = AF_SNA; + PF_DECnet = AF_DECnet; + PF_DLI = AF_DLI; + PF_LAT = AF_LAT; + PF_HYLINK = AF_HYLINK; + PF_APPLETALK = AF_APPLETALK; + PF_VOICEVIEW = AF_VOICEVIEW; + PF_FIREFOX = AF_FIREFOX; + PF_UNKNOWN1 = AF_UNKNOWN1; + PF_BAN = AF_BAN; + PF_ATM = AF_ATM; + PF_INET6 = AF_INET6; + + PF_MAX = AF_MAX; + + WSAID_CONNECTEX: TGUID = (D1: $25A207B9; D2: $DDF3; D3: $4660; D4: ($8E, $E9, $76, $E5, $8C, $74, $06, $3E)); + + WSAID_TRANSMITFILE: TGUID = (D1: $B5367DF0; D2: $CBAC; D3: $11CF; D4: ($95, $CA, $00, $80, $5F, $48, $A1, $92)); + + // + // Flags used in "hints" argument to getaddrinfo() + // - AI_ADDRCONFIG is supported starting with Vista + // - default is AI_ADDRCONFIG ON whether the flag is set or not + // because the performance penalty in not having ADDRCONFIG in + // the multi-protocol stack environment is severe; + // this defaulting may be disabled by specifying the AI_ALL flag, + // in that case AI_ADDRCONFIG must be EXPLICITLY specified to + // enable ADDRCONFIG behavior + // + + AI_PASSIVE = $00000001; // Socket address will be used in bind() call + AI_CANONNAME = $00000002; // Return canonical name in first ai_canonname + AI_NUMERICHOST = $00000004; // Nodename must be a numeric address string + AI_NUMERICSERV = $00000008; // Servicename must be a numeric port number + + AI_ALL = $00000100; // Query both IP6 and IP4 with AI_V4MAPPED + AI_ADDRCONFIG = $00000400; // Resolution only if global address configured + AI_V4MAPPED = $00000800; // On v6 failure, query v4 and convert to V4MAPPED format + + AI_NON_AUTHORITATIVE = $00004000; // LUP_NON_AUTHORITATIVE + AI_SECURE = $00008000; // LUP_SECURE + AI_RETURN_PREFERRED_NAMES = $00010000; // LUP_RETURN_PREFERRED_NAMES + + AI_FQDN = $00020000; // Return the FQDN in ai_canonname + AI_FILESERVER = $00040000; // Resolving fileserver name resolution + +type + // IPv4 Address + SunB = packed record + s_b1, s_b2, s_b3, s_b4: u_char; + end; + + SunW = packed record + s_w1, s_w2: u_short; + end; + + in_addr = packed record + case integer of + 0: + (S_un_b: SunB); + 1: + (S_un_w: SunW); + 2: + (S_addr: u_long); + end; + + TInAddr = in_addr; + PInAddr = ^TInAddr; + + // IPv6 address + + in6_addr = packed record + case integer of + 0: + (Bytes: array [0 .. 15] of Byte); + 1: + (Words: array [0 .. 7] of Word); + end; + + TIn6Addr = in6_addr; + PIn6Addr = ^TIn6Addr; + + in_addr6 = in6_addr; + + // Structure used by kernel to store most addresses. + + 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; + + PSockAddrIn = ^TSockAddrIn; + TSockAddr = TSockAddrIn; + PSockAddr = ^TSockAddr; + SOCKADDR = TSockAddr; + SOCKADDR_IN = TSockAddrIn; + + TSockAddrIn6 = packed record + sin6_family: short; + sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: in6_addr; + sin6_scope_id: u_long; + end; + + PSockAddrIn6 = ^TSockAddrIn6; + SOCKADDR_IN6 = TSockAddrIn6; + + // 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; + + // Structure used for manipulating linger option. + PLinger = ^TLinger; + + TLinger = packed record + l_onoff: u_short; + l_linger: u_short; + end; + + PADDRINFOA = ^ADDRINFOA; + PPADDRINFOA = ^PADDRINFOA; + + ADDRINFOA = record + ai_flags: integer; + ai_family: integer; + ai_socktype: integer; + ai_protocol: integer; + ai_addrlen: cardinal; // size_t + AI_CANONNAME: PAnsiChar; + ai_addr: PSockAddr; + ai_next: PADDRINFOA; + end; + + TAddrInfoA = ADDRINFOA; + + PADDRINFOW = ^ADDRINFOW; + PPADDRINFOW = ^PADDRINFOW; + + ADDRINFOW = record + ai_flags: integer; + ai_family: integer; + ai_socktype: integer; + ai_protocol: integer; + ai_addrlen: cardinal; // size_t + AI_CANONNAME: PWideChar; + ai_addr: PSockAddr; + ai_next: PADDRINFOW; + end; + + TAddrInfoW = ADDRINFOW; + +{$IFDEF UNICODE} + addrinfo = ADDRINFOW; + TAddrInfo = TAddrInfoW; + PAddrInfo = PADDRINFOW; + PPAddrInfo = PPADDRINFOW; +{$ELSE} + addrinfo = ADDRINFOA; + TAddrInfo = TAddrInfoA; + PAddrInfo = PADDRINFOA; + PPAddrInfo = PPADDRINFOA; +{$ENDIF} + + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + + ADDR_ANY = INADDR_ANY; + + SOL_SOCKET = $FFFF; // options for socket level + + MSG_OOB = $1; // process out-of-band data + MSG_PEEK = $2; // peek at incoming message + MSG_DONTROUTE = $4; // send without using routing tables + MSG_WAITALL = $8; // do not complete until packet is completely filled + + MSG_PARTIAL = $8000; // partial send or recv for message xport + + // WinSock 2 extension -- new flags for WSASend(), WSASendTo(), WSARecv() and WSARecvFrom() + MSG_INTERRUPT = $10; // send/recv in the interrupt context + MSG_MAXIOVLEN = 16; + + + // Define constant based on rfc883, used by gethostbyxxxx() calls. + + MAXGETHOSTSTRUCT = 1024; + + // Maximum queue length specifiable by listen. + SOMAXCONN = $7FFFFFFF; + + // WinSock 2 extension -- bit values and indices for FD_XXX network events + FD_READ_BIT = 0; + FD_WRITE_BIT = 1; + FD_OOB_BIT = 2; + FD_ACCEPT_BIT = 3; + FD_CONNECT_BIT = 4; + FD_CLOSE_BIT = 5; + FD_QOS_BIT = 6; + FD_GROUP_QOS_BIT = 7; + + FD_MAX_EVENTS = 8; + + FD_READ = (1 shl FD_READ_BIT); + FD_WRITE = (1 shl FD_WRITE_BIT); + FD_OOB = (1 shl FD_OOB_BIT); + FD_ACCEPT = (1 shl FD_ACCEPT_BIT); + FD_CONNECT = (1 shl FD_CONNECT_BIT); + FD_CLOSE = (1 shl FD_CLOSE_BIT); + FD_QOS = (1 shl FD_QOS_BIT); + FD_GROUP_QOS = (1 shl FD_GROUP_QOS_BIT); + + FD_ALL_EVENTS = (1 shl FD_MAX_EVENTS) - 1; + + // 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; + WSAEINVALIDPROCTABLE = 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; + + // Define QOS related error return codes + + WSA_QOS_RECEIVERS = WSABASEERR + 1005; // at least one Reserve has arrived + WSA_QOS_SENDERS = WSABASEERR + 1006; // at least one Path has arrived + WSA_QOS_NO_SENDERS = WSABASEERR + 1007; // there are no senders + WSA_QOS_NO_RECEIVERS = WSABASEERR + 1008; // there are no receivers + WSA_QOS_REQUEST_CONFIRMED = WSABASEERR + 1009; // Reserve has been confirmed + WSA_QOS_ADMISSION_FAILURE = WSABASEERR + 1010; // error due to lack of resources + WSA_QOS_POLICY_FAILURE = WSABASEERR + 1011; // rejected for administrative reasons - bad credentials + WSA_QOS_BAD_STYLE = WSABASEERR + 1012; // unknown or conflicting style + WSA_QOS_BAD_OBJECT = WSABASEERR + 1013; + // problem with some part of the filterspec or providerspecific buffer in general + WSA_QOS_TRAFFIC_CTRL_ERROR = WSABASEERR + 1014; // problem with some part of the flowspec + WSA_QOS_GENERIC_ERROR = WSABASEERR + 1015; // general error + WSA_QOS_ESERVICETYPE = WSABASEERR + 1016; // invalid service type in flowspec + WSA_QOS_EFLOWSPEC = WSABASEERR + 1017; // invalid flowspec + WSA_QOS_EPROVSPECBUF = WSABASEERR + 1018; // invalid provider specific buffer + WSA_QOS_EFILTERSTYLE = WSABASEERR + 1019; // invalid filter style + WSA_QOS_EFILTERTYPE = WSABASEERR + 1020; // invalid filter type + WSA_QOS_EFILTERCOUNT = WSABASEERR + 1021; // incorrect number of filters + WSA_QOS_EOBJLENGTH = WSABASEERR + 1022; // invalid object length + WSA_QOS_EFLOWCOUNT = WSABASEERR + 1023; // incorrect number of flows + WSA_QOS_EUNKOWNPSOBJ = WSABASEERR + 1024; // unknown object in provider specific buffer + WSA_QOS_EPOLICYOBJ = WSABASEERR + 1025; // invalid policy object in provider specific buffer + WSA_QOS_EFLOWDESC = WSABASEERR + 1026; // invalid flow descriptor in the list + WSA_QOS_EPSFLOWSPEC = WSABASEERR + 1027; // inconsistent flow spec in provider specific buffer + WSA_QOS_EPSFILTERSPEC = WSABASEERR + 1028; // invalid filter spec in provider specific buffer + WSA_QOS_ESDMODEOBJ = WSABASEERR + 1029; // invalid shape discard mode object in provider specific buffer + WSA_QOS_ESHAPERATEOBJ = WSABASEERR + 1030; // invalid shaping rate object in provider specific buffer + WSA_QOS_RESERVED_PETYPE = WSABASEERR + 1031; // reserved policy element in provider specific buffer + + { WinSock 2 extension -- new error codes and type definition } + WSA_IO_PENDING = ERROR_IO_PENDING; + WSA_IO_INCOMPLETE = ERROR_IO_INCOMPLETE; + WSA_INVALID_HANDLE = ERROR_INVALID_HANDLE; + WSA_INVALID_PARAMETER = ERROR_INVALID_PARAMETER; + WSA_NOT_ENOUGH_MEMORY = ERROR_NOT_ENOUGH_MEMORY; + WSA_OPERATION_ABORTED = ERROR_OPERATION_ABORTED; + WSA_INVALID_EVENT = WSAEVENT(nil); + WSA_MAXIMUM_WAIT_EVENTS = MAXIMUM_WAIT_OBJECTS; + WSA_WAIT_FAILED = $FFFFFFFF; + WSA_WAIT_EVENT_0 = WAIT_OBJECT_0; + WSA_WAIT_IO_COMPLETION = WAIT_IO_COMPLETION; + WSA_WAIT_TIMEOUT = WAIT_TIMEOUT; + WSA_INFINITE = INFINITE; + + { Windows Sockets errors redefined as regular Berkeley error constants. + These are commented out in Windows NT to avoid conflicts with errno.h. + Use the WSA constants instead. } + + 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; + + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; + +type + PWSAData = ^TWSAData; + + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array [0 .. WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus: array [0 .. WSASYS_STATUS_LEN] of AnsiChar; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PAnsiChar; + end; + + { WSAOVERLAPPED = Record + Internal: LongInt; + InternalHigh: LongInt; + Offset: LongInt; + OffsetHigh: LongInt; + hEvent: WSAEVENT; + end; } + WSAOVERLAPPED = TOverlapped; + TWSAOverlapped = WSAOVERLAPPED; + PWSAOverlapped = ^WSAOVERLAPPED; + LPWSAOVERLAPPED = PWSAOverlapped; + + { WinSock 2 extension -- WSABUF and QOS struct, include qos.h } + { to pull in FLOWSPEC and related definitions } + + WSABUF = packed record + len: u_long; { the length of the buffer } + buf: pointer; { the pointer to the buffer } + end { WSABUF }; + + PWSABUF = ^WSABUF; + LPWSABUF = PWSABUF; + + TServiceType = Longint; + + TFlowSpec = packed record + TokenRate, // In Bytes/sec + TokenBucketSize, // In Bytes + PeakBandwidth, // In Bytes/sec + Latency, // In microseconds + DelayVariation: Longint; // In microseconds + ServiceType: TServiceType; + MaxSduSize, MinimumPolicedSize: Longint; // In Bytes + end; + + PFlowSpec = ^TFlowSpec; + + QOS = packed record + SendingFlowspec: TFlowSpec; { the flow spec for data sending } + ReceivingFlowspec: TFlowSpec; { the flow spec for data receiving } + ProviderSpecific: WSABUF; { additional provider specific stuff } + end; + + TQualityOfService = QOS; + PQOS = ^QOS; + LPQOS = PQOS; + +const + SERVICETYPE_NOTRAFFIC = $00000000; // No data in this direction + SERVICETYPE_BESTEFFORT = $00000001; // Best Effort + SERVICETYPE_CONTROLLEDLOAD = $00000002; // Controlled Load + SERVICETYPE_GUARANTEED = $00000003; // Guaranteed + SERVICETYPE_NETWORK_UNAVAILABLE = $00000004; // Used to notify change to user + SERVICETYPE_GENERAL_INFORMATION = $00000005; // corresponds to "General Parameters" defined by IntServ + SERVICETYPE_NOCHANGE = $00000006; + // used to indicate that the flow spec contains no change from any previous one + // to turn on immediate traffic control, OR this flag with the ServiceType field in teh FLOWSPEC + SERVICE_IMMEDIATE_TRAFFIC_CONTROL = $80000000; + + // WinSock 2 extension -- manifest constants for return values of the condition function + CF_ACCEPT = $0000; + CF_REJECT = $0001; + CF_DEFER = $0002; + + // WinSock 2 extension -- manifest constants for shutdown() + SD_RECEIVE = $00; + SD_SEND = $01; + SD_BOTH = $02; + + // WinSock 2 extension -- data type and manifest constants for socket groups + SG_UNCONSTRAINED_GROUP = $01; + SG_CONSTRAINED_GROUP = $02; + +type + GROUP = DWORD; + + // WinSock 2 extension -- data type for WSAEnumNetworkEvents() + TWSANetworkEvents = record + lNetworkEvents: Longint; + iErrorCode: array [0 .. FD_MAX_EVENTS - 1] of integer; + end; + + PWSANetworkEvents = ^TWSANetworkEvents; + LPWSANetworkEvents = PWSANetworkEvents; + + // WinSock 2 extension -- WSAPROTOCOL_INFO structure + +{$IFNDEF ver130} + + TGUID = packed record + D1: Longint; + D2: Word; + D3: Word; + D4: array [0 .. 7] of Byte; + end; + + PGUID = ^TGUID; +{$ENDIF} + LPGUID = PGUID; + + // WinSock 2 extension -- WSAPROTOCOL_INFO manifest constants +const + MAX_PROTOCOL_CHAIN = 7; + BASE_PROTOCOL = 1; + LAYERED_PROTOCOL = 0; + WSAPROTOCOL_LEN = 255; + +type + TWSAProtocolChain = record + ChainLen: integer; // the length of the chain, + // length = 0 means layered protocol, + // length = 1 means base protocol, + // length > 1 means protocol chain + ChainEntries: array [0 .. MAX_PROTOCOL_CHAIN - 1] of Longint; // a list of dwCatalogEntryIds + end; + +type + TWSAProtocol_InfoA = record + dwServiceFlags1: Longint; + dwServiceFlags2: Longint; + dwServiceFlags3: Longint; + dwServiceFlags4: Longint; + dwProviderFlags: Longint; + ProviderId: TGUID; + dwCatalogEntryId: Longint; + ProtocolChain: TWSAProtocolChain; + iVersion: integer; + iAddressFamily: integer; + iMaxSockAddr: integer; + iMinSockAddr: integer; + iSocketType: integer; + iProtocol: integer; + iProtocolMaxOffset: integer; + iNetworkByteOrder: integer; + iSecurityScheme: integer; + dwMessageSize: Longint; + dwProviderReserved: Longint; + szProtocol: array [0 .. WSAPROTOCOL_LEN + 1 - 1] of Char; + end { TWSAProtocol_InfoA }; + + PWSAProtocol_InfoA = ^TWSAProtocol_InfoA; + LPWSAProtocol_InfoA = PWSAProtocol_InfoA; + + TWSAProtocol_InfoW = record + dwServiceFlags1: Longint; + dwServiceFlags2: Longint; + dwServiceFlags3: Longint; + dwServiceFlags4: Longint; + dwProviderFlags: Longint; + ProviderId: TGUID; + dwCatalogEntryId: Longint; + ProtocolChain: TWSAProtocolChain; + iVersion: integer; + iAddressFamily: integer; + iMaxSockAddr: integer; + iMinSockAddr: integer; + iSocketType: integer; + iProtocol: integer; + iProtocolMaxOffset: integer; + iNetworkByteOrder: integer; + iSecurityScheme: integer; + dwMessageSize: Longint; + dwProviderReserved: Longint; + szProtocol: array [0 .. WSAPROTOCOL_LEN + 1 - 1] of WideChar; + end { TWSAProtocol_InfoW }; + + PWSAProtocol_InfoW = ^TWSAProtocol_InfoW; + LPWSAProtocol_InfoW = PWSAProtocol_InfoW; + +{$IFDEF UNICODE} + WSAProtocol_Info = TWSAProtocol_InfoW; + TWSAProtocol_Info = TWSAProtocol_InfoW; + PWSAProtocol_Info = PWSAProtocol_InfoW; + LPWSAProtocol_Info = PWSAProtocol_InfoW; +{$ELSE} + WSAProtocol_Info = TWSAProtocol_InfoA; + TWSAProtocol_Info = TWSAProtocol_InfoA; + PWSAProtocol_Info = PWSAProtocol_InfoA; + LPWSAProtocol_Info = PWSAProtocol_InfoA; +{$ENDIF} + + +const + // Flag bit definitions for dwProviderFlags + PFL_MULTIPLE_PROTO_ENTRIES = $00000001; + PFL_RECOMMENDED_PROTO_ENTRY = $00000002; + PFL_HIDDEN = $00000004; + PFL_MATCHES_PROTOCOL_ZERO = $00000008; + + // Flag bit definitions for dwServiceFlags1 + XP1_CONNECTIONLESS = $00000001; + XP1_GUARANTEED_DELIVERY = $00000002; + XP1_GUARANTEED_ORDER = $00000004; + XP1_MESSAGE_ORIENTED = $00000008; + XP1_PSEUDO_STREAM = $00000010; + XP1_GRACEFUL_CLOSE = $00000020; + XP1_EXPEDITED_DATA = $00000040; + XP1_CONNECT_DATA = $00000080; + XP1_DISCONNECT_DATA = $00000100; + XP1_SUPPORT_BROADCAST = $00000200; + XP1_SUPPORT_MULTIPOINT = $00000400; + XP1_MULTIPOINT_CONTROL_PLANE = $00000800; + XP1_MULTIPOINT_DATA_PLANE = $00001000; + XP1_QOS_SUPPORTED = $00002000; + XP1_INTERRUPT = $00004000; + XP1_UNI_SEND = $00008000; + XP1_UNI_RECV = $00010000; + XP1_IFS_HANDLES = $00020000; + XP1_PARTIAL_MESSAGE = $00040000; + + BIGENDIAN = $0000; + LITTLEENDIAN = $0001; + + SECURITY_PROTOCOL_NONE = $0000; + + // WinSock 2 extension -- manifest constants for WSAJoinLeaf() + JL_SENDER_ONLY = $01; + JL_RECEIVER_ONLY = $02; + JL_BOTH = $04; + + // WinSock 2 extension -- manifest constants for WSASocket() + WSA_FLAG_OVERLAPPED = $01; + WSA_FLAG_MULTIPOINT_C_ROOT = $02; + WSA_FLAG_MULTIPOINT_C_LEAF = $04; + WSA_FLAG_MULTIPOINT_D_ROOT = $08; + WSA_FLAG_MULTIPOINT_D_LEAF = $10; + + // WinSock 2 extension -- manifest constants for WSAIoctl() + IOC_UNIX = $00000000; + IOC_WS2 = $08000000; + IOC_PROTOCOL = $10000000; + IOC_VENDOR = $18000000; + + SIO_ASSOCIATE_HANDLE = 1 or IOC_WS2 or IOC_IN; + SIO_ENABLE_CIRCULAR_QUEUEING = 2 or IOC_WS2; + SIO_FIND_ROUTE = 3 or IOC_WS2 or IOC_OUT; + SIO_FLUSH = 4 or IOC_WS2; + SIO_GET_BROADCAST_ADDRESS = 5 or IOC_WS2 or IOC_OUT; + SIO_GET_EXTENSION_FUNCTION_POINTER = 6 or IOC_WS2 or IOC_INOUT; + SIO_GET_QOS = 7 or IOC_WS2 or IOC_INOUT; + SIO_GET_GROUP_QOS = 8 or IOC_WS2 or IOC_INOUT; + SIO_MULTIPOINT_LOOPBACK = 9 or IOC_WS2 or IOC_IN; + SIO_MULTICAST_SCOPE = 10 or IOC_WS2 or IOC_IN; + SIO_SET_QOS = 11 or IOC_WS2 or IOC_IN; + SIO_SET_GROUP_QOS = 12 or IOC_WS2 or IOC_IN; + SIO_TRANSLATE_HANDLE = 13 or IOC_WS2 or IOC_INOUT; + SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT; + SIO_ROUTING_INTERFACE_CHANGE = 21 or IOC_WS2 or IOC_IN; + SIO_ADDRESS_LIST_QUERY = 22 or IOC_WS2 or IOC_OUT; // see below SOCKET_ADDRESS_LIST + SIO_ADDRESS_LIST_CHANGE = 23 or IOC_WS2; + SIO_QUERY_TARGET_PNP_HANDLE = 24 or IOC_WS2 or IOC_OUT; + + // WinSock 2 extension -- manifest constants for SIO_TRANSLATE_HANDLE ioctl + TH_NETDEV = $00000001; + TH_TAPI = $00000002; + +type + + // Manifest constants and type definitions related to name resolution and + // registration (RNR) API + TBLOB = packed record + cbSize: u_long; + pBlobData: PBYTE; + end; + + PBLOB = ^TBLOB; + + // Service Install Flags + +const + SERVICE_MULTIPLE = $00000001; + + // & Name Spaces + NS_ALL = 0; + + NS_SAP = 1; + NS_NDS = 2; + NS_PEER_BROWSE = 3; + + NS_TCPIP_LOCAL = 10; + NS_TCPIP_HOSTS = 11; + NS_DNS = 12; + NS_NETBT = 13; + NS_WINS = 14; + + NS_NBP = 20; + + NS_MS = 30; + NS_STDA = 31; + NS_NTDS = 32; + + NS_X500 = 40; + NS_NIS = 41; + NS_NISPLUS = 42; + + NS_WRQ = 50; + + NS_NETDES = 60; + + { Resolution flags for WSAGetAddressByName(). + Note these are also used by the 1.1 API GetAddressByName, so leave them around. } + RES_UNUSED_1 = $00000001; + RES_FLUSH_CACHE = $00000002; + RES_SERVICE = $00000004; + + { Well known value names for Service Types } + SERVICE_TYPE_VALUE_IPXPORTA = 'IpxSocket'; + SERVICE_TYPE_VALUE_IPXPORTW: PWideChar = 'IpxSocket'; + +{$IFDEF UNICODE} + SERVICE_TYPE_VALUE_SAPID: PWideChar = 'SapId'; + SERVICE_TYPE_VALUE_TCPPORT: PWideChar = 'TcpPort'; + SERVICE_TYPE_VALUE_UDPPORT: PWideChar = 'UdpPort'; + SERVICE_TYPE_VALUE_OBJECTID: PWideChar = 'ObjectId'; +{$ELSE} + SERVICE_TYPE_VALUE_SAPID: PAnsiChar = 'SapId'; + SERVICE_TYPE_VALUE_TCPPORT: PAnsiChar = 'TcpPort'; + SERVICE_TYPE_VALUE_UDPPORT: PAnsiChar = 'UdpPort'; + SERVICE_TYPE_VALUE_OBJECTID: PAnsiChar = 'ObjectId'; +{$ENDIF} + + // SockAddr Information +type + SOCKET_ADDRESS = packed record + lpSockaddr: PSockAddr; + iSockaddrLength: integer; + end; + + PSOCKET_ADDRESS = ^SOCKET_ADDRESS; + + // CSAddr Information + CSADDR_INFO = packed record + LocalAddr, RemoteAddr: SOCKET_ADDRESS; + iSocketType, iProtocol: Longint; + end; + + PCSADDR_INFO = ^CSADDR_INFO; + LPCSADDR_INFO = ^CSADDR_INFO; + + + // + // Portable socket structure (RFC 2553). + // + + // + // Desired design of maximum size and alignment. + // These are implementation specific. + // + +const + _SS_MAXSIZE = 128; // Maximum size. +{$EXTERNALSYM _SS_MAXSIZE} + _SS_ALIGNSIZE = SizeOf(Int64); // Desired alignment. +{$EXTERNALSYM _SS_ALIGNSIZE} + + // + // Definitions used for sockaddr_storage structure paddings design. + // + + _SS_PAD1SIZE = _SS_ALIGNSIZE - SizeOf(short); +{$EXTERNALSYM _SS_PAD1SIZE} + _SS_PAD2SIZE = _SS_MAXSIZE - (SizeOf(short) + _SS_PAD1SIZE + _SS_ALIGNSIZE); +{$EXTERNALSYM _SS_PAD2SIZE} + + +type + sockaddr_storage = record + ss_family: short; // Address family. + __ss_pad1: array [0 .. _SS_PAD1SIZE - 1] of AnsiChar; // 6 byte pad, this is to make + // implementation specific pad up to + // alignment field that follows explicit + // in the data structure. + __ss_align: Int64; // Field to force desired structure. + __ss_pad2: array [0 .. _SS_PAD2SIZE - 1] of AnsiChar; // 112 byte pad to achieve desired size; + // _SS_MAXSIZE value minus size of + // ss_family, __ss_pad1, and + // __ss_align fields is 112. + end; +{$EXTERNALSYM sockaddr_storage} + + TSockAddrStorage = sockaddr_storage; + PSockAddrStorage = ^sockaddr_storage; + + // Address list returned via WSAIoctl( SIO_ADDRESS_LIST_QUERY ) + SOCKET_ADDRESS_LIST = packed record + iAddressCount: integer; + Address: array [0 .. 0] of SOCKET_ADDRESS; + end; + + LPSOCKET_ADDRESS_LIST = ^SOCKET_ADDRESS_LIST; + + // Address Family/Protocol Tuples + AFProtocols = record + iAddressFamily: integer; + iProtocol: integer; + end; + + TAFProtocols = AFProtocols; + PAFProtocols = ^TAFProtocols; + + + // Client Query API Typedefs + + // The comparators + TWSAEComparator = (COMP_EQUAL { = 0 } , COMP_NOTLESS); + + TWSAVersion = record + dwVersion: DWORD; + ecHow: TWSAEComparator; + end; + + PWSAVersion = ^TWSAVersion; + + TWSAQuerySetA = packed record + dwSize: DWORD; + lpszServiceInstanceName: PAnsiChar; + lpServiceClassId: PGUID; + lpVersion: PWSAVersion; + lpszComment: PAnsiChar; + dwNameSpace: DWORD; + lpNSProviderId: PGUID; + lpszContext: PAnsiChar; + dwNumberOfProtocols: DWORD; + lpafpProtocols: PAFProtocols; + lpszQueryString: PAnsiChar; + dwNumberOfCsAddrs: DWORD; + lpcsaBuffer: PCSADDR_INFO; + dwOutputFlags: DWORD; + lpBlob: PBLOB; + end; + + PWSAQuerySetA = ^TWSAQuerySetA; + LPWSAQuerySetA = PWSAQuerySetA; + + TWSAQuerySetW = packed record + dwSize: DWORD; + lpszServiceInstanceName: PWideChar; + lpServiceClassId: PGUID; + lpVersion: PWSAVersion; + lpszComment: PWideChar; + dwNameSpace: DWORD; + lpNSProviderId: PGUID; + lpszContext: PWideChar; + dwNumberOfProtocols: DWORD; + lpafpProtocols: PAFProtocols; + lpszQueryString: PWideChar; + dwNumberOfCsAddrs: DWORD; + lpcsaBuffer: PCSADDR_INFO; + dwOutputFlags: DWORD; + lpBlob: PBLOB; + end; + + PWSAQuerySetW = ^TWSAQuerySetW; + LPWSAQuerySetW = PWSAQuerySetW; + +{$IFDEF UNICODE} + TWSAQuerySet = TWSAQuerySetA; + PWSAQuerySet = PWSAQuerySetW; + LPWSAQuerySet = PWSAQuerySetW; +{$ELSE} + TWSAQuerySet = TWSAQuerySetA; + PWSAQuerySet = PWSAQuerySetA; + LPWSAQuerySet = PWSAQuerySetA; +{$ENDIF} + + +const + LUP_DEEP = $0001; + LUP_CONTAINERS = $0002; + LUP_NOCONTAINERS = $0004; + LUP_NEAREST = $0008; + LUP_RETURN_NAME = $0010; + LUP_RETURN_TYPE = $0020; + LUP_RETURN_VERSION = $0040; + LUP_RETURN_COMMENT = $0080; + LUP_RETURN_ADDR = $0100; + LUP_RETURN_BLOB = $0200; + LUP_RETURN_ALIASES = $0400; + LUP_RETURN_QUERY_STRING = $0800; + LUP_RETURN_ALL = $0FF0; + LUP_RES_SERVICE = $8000; + + LUP_FLUSHCACHE = $1000; + LUP_FLUSHPREVIOUS = $2000; + + // Return flags + RESULT_IS_ALIAS = $0001; + +type + // Service Address Registration and Deregistration Data Types. + TWSAeSetServiceOp = (RNRSERVICE_REGISTER { =0 } , RNRSERVICE_DEREGISTER, RNRSERVICE_DELETE); + + { Service Installation/Removal Data Types. } + TWSANSClassInfoA = packed record + lpszName: PAnsiChar; + dwNameSpace: DWORD; + dwValueType: DWORD; + dwValueSize: DWORD; + lpValue: pointer; + end; + + PWSANSClassInfoA = ^TWSANSClassInfoA; + + TWSANSClassInfoW = packed record + lpszName: PWideChar; + dwNameSpace: DWORD; + dwValueType: DWORD; + dwValueSize: DWORD; + lpValue: pointer; + end { TWSANSClassInfoW }; + + PWSANSClassInfoW = ^TWSANSClassInfoW; + +{$IFDEF UNICODE} + WSANSClassInfo = TWSANSClassInfoW; + TWSANSClassInfo = TWSANSClassInfoW; + PWSANSClassInfo = PWSANSClassInfoW; + LPWSANSClassInfo = PWSANSClassInfoW; +{$ELSE} + WSANSClassInfo = TWSANSClassInfoA; + TWSANSClassInfo = TWSANSClassInfoA; + PWSANSClassInfo = PWSANSClassInfoA; + LPWSANSClassInfo = PWSANSClassInfoA; +{$ENDIF // UNICODE} + + TWSAServiceClassInfoA = packed record + lpServiceClassId: PGUID; + lpszServiceClassName: PAnsiChar; + dwCount: DWORD; + lpClassInfos: PWSANSClassInfoA; + end; + + PWSAServiceClassInfoA = ^TWSAServiceClassInfoA; + LPWSAServiceClassInfoA = PWSAServiceClassInfoA; + + TWSAServiceClassInfoW = packed record + lpServiceClassId: PGUID; + lpszServiceClassName: PWideChar; + dwCount: DWORD; + lpClassInfos: PWSANSClassInfoW; + end; + + PWSAServiceClassInfoW = ^TWSAServiceClassInfoW; + LPWSAServiceClassInfoW = PWSAServiceClassInfoW; + +{$IFDEF UNICODE} + WSAServiceClassInfo = TWSAServiceClassInfoW; + TWSAServiceClassInfo = TWSAServiceClassInfoW; + PWSAServiceClassInfo = PWSAServiceClassInfoW; + LPWSAServiceClassInfo = PWSAServiceClassInfoW; +{$ELSE} + WSAServiceClassInfo = TWSAServiceClassInfoA; + TWSAServiceClassInfo = TWSAServiceClassInfoA; + PWSAServiceClassInfo = PWSAServiceClassInfoA; + LPWSAServiceClassInfo = PWSAServiceClassInfoA; +{$ENDIF} + + TWSANameSpace_InfoA = packed record + NSProviderId: TGUID; + dwNameSpace: DWORD; + fActive: DWORD { Bool }; + dwVersion: DWORD; + lpszIdentifier: PAnsiChar; + end; + + PWSANameSpace_InfoA = ^TWSANameSpace_InfoA; + LPWSANameSpace_InfoA = PWSANameSpace_InfoA; + + TWSANameSpace_InfoW = packed record + NSProviderId: TGUID; + dwNameSpace: DWORD; + fActive: DWORD { Bool }; + dwVersion: DWORD; + lpszIdentifier: PWideChar; + end { TWSANameSpace_InfoW }; + + PWSANameSpace_InfoW = ^TWSANameSpace_InfoW; + LPWSANameSpace_InfoW = PWSANameSpace_InfoW; + +{$IFDEF UNICODE} + WSANameSpace_Info = TWSANameSpace_InfoW; + TWSANameSpace_Info = TWSANameSpace_InfoW; + PWSANameSpace_Info = PWSANameSpace_InfoW; + LPWSANameSpace_Info = PWSANameSpace_InfoW; +{$ELSE} + WSANameSpace_Info = TWSANameSpace_InfoA; + TWSANameSpace_Info = TWSANameSpace_InfoA; + PWSANameSpace_Info = PWSANameSpace_InfoA; + LPWSANameSpace_Info = PWSANameSpace_InfoA; +{$ENDIF} + + +{ WinSock 2 extensions -- data types for the condition function in } +{ WSAAccept() and overlapped I/O completion routine. } +type + LPCONDITIONPROC = function(lpCallerId: LPWSABUF; lpCallerData: LPWSABUF; lpSQOS, lpGQOS: LPQOS; lpCalleeId, lpCalleeData: LPWSABUF; g: GROUP; + dwCallbackData: DWORD): integer; stdcall; + + LPWSAOVERLAPPED_COMPLETION_ROUTINE = procedure(const dwError, cbTransferred: DWORD; const lpOverlapped: LPWSAOVERLAPPED; const dwFlags: DWORD); stdcall; + + LPFN_CONNECTEX = function(s: TSocket; const SOCKADDR: PSockAddr; namelen: integer; lpSendBuffer: pointer; dwSendDataLength: DWORD; lpdwBytesSent: PDWORD; + lpOverlapped: POverlapped): BOOL; stdcall; + + LPFN_ACCEPTEX = function(sListenSocket, sAcceptSocket: TSocket; lpOutputBuffer: LPVOID; + dwReceiveDataLength, dwLocalAddressLength, dwRemoteAddressLength: DWORD; var lpdwBytesReceived: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; + + LPFN_TRANSMITFILE = function(hSocket: TSocket; hFile: THandle; nNumberOfBytesToWrite: DWORD; nNumberOfBytesPerSend: DWORD; lpOverlapped: POverlapped; + lpTransmitBuffers: pointer; dwFlags: DWORD): BOOL; stdcall; + + LPFN_GETACCEPTEXSOCKADDRS = procedure(lpOutputBuffer: LPVOID; dwReceiveDataLength, dwLocalAddressLength, dwRemoteAddressLength: DWORD; + var LocalSockaddr: PSockAddr; var LocalSockaddrLength: integer; var RemoteSockaddr: PSockAddr; var RemoteSockaddrLength: integer); stdcall; + +const + + // Flags for getnameinfo() + + NI_NOFQDN = $01; // Only return nodename portion for local hosts + NI_NUMERICHOST = $02; // Return numeric form of the host's address + NI_NAMEREQD = $04; // Error if the host's name not in DNS + NI_NUMERICSERV = $08; // Return numeric form of the service (port #) + NI_DGRAM = $10; // Service is a datagram service + + NI_MAXHOST = 1025; // Max size of a fully-qualified domain name + NI_MAXSERV = 32; // Max size of a service name + +function accept(const s: TSocket; var addr: TSockAddr; var addrlen: integer): TSocket; stdcall; +function bind(const s: TSocket; const addr: PSockAddr; const namelen: integer): integer; stdcall; +function closesocket(const s: TSocket): integer; stdcall; +function connect(const s: TSocket; const name: PSockAddr; namelen: integer): integer; stdcall; +function ioctlsocket(const s: TSocket; const cmd: DWORD; var arg: u_long): integer; stdcall; +function getpeername(const s: TSocket; var name: TSockAddr; var namelen: integer): integer; stdcall; +function getsockname(const s: TSocket; var name: TSockAddr; var namelen: integer): integer; stdcall; +function getsockopt(const s: TSocket; const level, optname: integer; optval: PAnsiChar; var optlen: integer): integer; stdcall; +function htonl(hostlong: u_long): u_long; stdcall; +function htons(hostshort: u_short): u_short; stdcall; +function inet_addr(cp: PAnsiChar): u_long; stdcall; +function inet_ntoa(inaddr: TInAddr): PAnsiChar; stdcall; +function listen(s: TSocket; backlog: integer): integer; stdcall; +function ntohl(netlong: u_long): u_long; stdcall; +function ntohs(netshort: u_short): u_short; stdcall; +function recv(s: TSocket; out buf; len, flags: integer): integer; stdcall; +function recvfrom(s: TSocket; var buf; len, flags: integer; var from: TSockAddr; var fromlen: integer): integer; stdcall; +function select(nfds: integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): integer; stdcall; +function send(s: TSocket; const buf; len, flags: integer): integer; stdcall; +function sendto(s: TSocket; var buf; len, flags: integer; var addrto: TSockAddr; tolen: integer): integer; stdcall; +function setsockopt(s: TSocket; level, optname: integer; optval: PAnsiChar; optlen: integer): integer; stdcall; +function shutdown(s: TSocket; how: integer): integer; stdcall; +function socket(const af, struct, protocol: integer): TSocket; stdcall; +function gethostbyaddr(addr: pointer; len, struct: integer): PHostEnt; stdcall; +function gethostbyname(name: PAnsiChar): PHostEnt; stdcall; +function gethostname(name: PAnsiChar; len: integer): integer; stdcall; +function getservbyport(port: integer; proto: PAnsiChar): PServEnt; stdcall; +function getservbyname(const name, proto: PAnsiChar): PServEnt; stdcall; +function getprotobynumber(const proto: integer): PProtoEnt; stdcall; +function getprotobyname(const name: PAnsiChar): PProtoEnt; stdcall; +function GetAddrInfo(const nodename, servname: PChar; const hints: PAddrInfo; res: PPAddrInfo): integer; stdcall; +procedure FreeAddrInfo(ai: PAddrInfo); stdcall; +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): integer; stdcall; +function WSACleanup: integer; stdcall; +procedure WSASetLastError(iError: integer); stdcall; +function WSAGetLastError: integer; stdcall; +function WSAIsBlocking: BOOL; stdcall; +function WSAUnhookBlockingHook: integer; stdcall; +function WSASetBlockingHook(lpBlockFunc: TFarProc): TFarProc; stdcall; +function WSACancelBlockingCall: integer; stdcall; +function WSAAsyncGetServByName(HWindow: HWND; wMsg: u_int; name, proto, buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSAAsyncGetServByPort(HWindow: HWND; wMsg, port: u_int; proto, buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSAAsyncGetProtoByName(HWindow: HWND; wMsg: u_int; name, buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSAAsyncGetProtoByNumber(HWindow: HWND; wMsg: u_int; number: integer; buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int; name, buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSAAsyncGetHostByAddr(HWindow: HWND; wMsg: u_int; addr: PAnsiChar; len, struct: integer; buf: PAnsiChar; buflen: integer): THandle; stdcall; +function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): integer; stdcall; +function WSAAsyncSelect(s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): integer; stdcall; +function __WSAFDIsSet(s: TSocket; var FDSet: TFDSet): BOOL; stdcall; + +{ WinSock 2 API new function prototypes } +function WSAAccept(s: TSocket; addr: TSockAddr; addrlen: PInteger; lpfnCondition: LPCONDITIONPROC; dwCallbackData: DWORD): TSocket; stdcall; +function WSACloseEvent(hEvent: WSAEVENT): WordBool; stdcall; +function WSAConnect(s: TSocket; const name: PSockAddr; namelen: integer; lpCallerData, lpCalleeData: LPWSABUF; lpSQOS, lpGQOS: LPQOS): integer; stdcall; +function WSACreateEvent: WSAEVENT; stdcall; + +function WSADuplicateSocketA(s: TSocket; dwProcessId: DWORD; lpProtocolInfo: LPWSAProtocol_InfoA): integer; stdcall; +function WSADuplicateSocketW(s: TSocket; dwProcessId: DWORD; lpProtocolInfo: LPWSAProtocol_InfoW): integer; stdcall; +function WSADuplicateSocket(s: TSocket; dwProcessId: DWORD; lpProtocolInfo: LPWSAProtocol_Info): integer; stdcall; + +function WSAEnumNetworkEvents(const s: TSocket; const hEventObject: WSAEVENT; lpNetworkEvents: LPWSANetworkEvents): integer; stdcall; +function WSAEnumProtocolsA(lpiProtocols: PInteger; lpProtocolBuffer: LPWSAProtocol_InfoA; var lpdwBufferLength: DWORD): integer; stdcall; +function WSAEnumProtocolsW(lpiProtocols: PInteger; lpProtocolBuffer: LPWSAProtocol_InfoW; var lpdwBufferLength: DWORD): integer; stdcall; +function WSAEnumProtocols(lpiProtocols: PInteger; lpProtocolBuffer: LPWSAProtocol_Info; var lpdwBufferLength: DWORD): integer; stdcall; + +function WSAEventSelect(s: TSocket; hEventObject: WSAEVENT; lNetworkEvents: Longint): integer; stdcall; + +function WSAGetOverlappedResult(s: TSocket; lpOverlapped: LPWSAOVERLAPPED; lpcbTransfer: LPDWORD; fWait: BOOL; var lpdwFlags: DWORD): WordBool; stdcall; + +function WSAGetQosByName(s: TSocket; lpQOSName: LPWSABUF; LPQOS: LPQOS): WordBool; stdcall; + +function WSAhtonl(s: TSocket; hostlong: u_long; var lpnetlong: DWORD): integer; stdcall; +function WSAhtons(s: TSocket; hostshort: u_short; var lpnetshort: Word): integer; stdcall; + +function WSAIoctl(s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: pointer; cbInBuffer: DWORD; lpvOutBuffer: pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: LPDWORD; lpOverlapped: LPWSAOVERLAPPED; lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): integer; stdcall; + +function WSAJoinLeaf(s: TSocket; name: PSockAddr; namelen: integer; lpCallerData, lpCalleeData: LPWSABUF; lpSQOS, lpGQOS: LPQOS; dwFlags: DWORD) + : TSocket; stdcall; + +function WSANtohl(s: TSocket; netlong: u_long; var lphostlong: DWORD): integer; stdcall; +function WSANtohs(s: TSocket; netshort: u_short; var lphostshort: Word): integer; stdcall; + +function WSARecv(s: TSocket; lpBuffers: LPWSABUF; dwBufferCount: DWORD; var lpNumberOfBytesRecvd: DWORD; var lpFlags: DWORD; lpOverlapped: LPWSAOVERLAPPED; + lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): integer; stdcall; +function WSARecvDisconnect(s: TSocket; lpInboundDisconnectData: LPWSABUF): integer; stdcall; +function WSARecvFrom(s: TSocket; lpBuffers: LPWSABUF; dwBufferCount: DWORD; var lpNumberOfBytesRecvd: DWORD; var lpFlags: DWORD; lpFrom: PSockAddr; + lpFromlen: PInteger; lpOverlapped: LPWSAOVERLAPPED; lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): integer; stdcall; + +function WSAResetEvent(hEvent: WSAEVENT): WordBool; stdcall; + +function WSASend(s: TSocket; lpBuffers: LPWSABUF; dwBufferCount: DWORD; var lpNumberOfBytesSent: DWORD; dwFlags: DWORD; lpOverlapped: LPWSAOVERLAPPED; + lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): integer; stdcall; +function WSASendDisconnect(s: TSocket; lpOutboundDisconnectData: LPWSABUF): integer; stdcall; +function WSASendTo(s: TSocket; lpBuffers: LPWSABUF; dwBufferCount: DWORD; var lpNumberOfBytesSent: DWORD; dwFlags: DWORD; lpTo: PSockAddr; iTolen: integer; + lpOverlapped: LPWSAOVERLAPPED; lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE): integer; stdcall; + +function WSASetEvent(hEvent: WSAEVENT): WordBool; stdcall; + +function WSASocketA(af, iType, protocol: integer; lpProtocolInfo: LPWSAProtocol_InfoA; g: GROUP; dwFlags: DWORD): TSocket; stdcall; +function WSASocketW(af, iType, protocol: integer; lpProtocolInfo: LPWSAProtocol_InfoW; g: GROUP; dwFlags: DWORD): TSocket; stdcall; +function WSASocket(af, iType, protocol: integer; lpProtocolInfo: LPWSAProtocol_Info; g: GROUP; dwFlags: DWORD): TSocket; stdcall; + +function WSAWaitForMultipleEvents(cEvents: DWORD; lphEvents: PWSAEVENT; fWaitAll: LongBool; dwTimeout: DWORD; fAlertable: LongBool): DWORD; stdcall; + +function WSAAddressToStringA(lpsaAddress: PSockAddr; const dwAddressLength: DWORD; const lpProtocolInfo: LPWSAProtocol_InfoA; const lpszAddressString: PAnsiChar; + var lpdwAddressStringLength: DWORD): integer; stdcall; +function WSAAddressToStringW(lpsaAddress: PSockAddr; const dwAddressLength: DWORD; const lpProtocolInfo: LPWSAProtocol_InfoW; + const lpszAddressString: PWideChar; var lpdwAddressStringLength: DWORD): integer; stdcall; +function WSAAddressToString(lpsaAddress: PSockAddr; const dwAddressLength: DWORD; const lpProtocolInfo: LPWSAProtocol_Info; const lpszAddressString: PMBChar; + var lpdwAddressStringLength: DWORD): integer; stdcall; + +function WSAStringToAddressA(const AddressString: PAnsiChar; const AddressFamily: integer; const lpProtocolInfo: LPWSAProtocol_InfoA; var lpAddress: TSockAddr; + var lpAddressLength: integer): integer; stdcall; +function WSAStringToAddressW(const AddressString: PWideChar; const AddressFamily: integer; const lpProtocolInfo: LPWSAProtocol_InfoA; var lpAddress: TSockAddr; + var lpAddressLength: integer): integer; stdcall; +function WSAStringToAddress(const AddressString: PMBChar; const AddressFamily: integer; const lpProtocolInfo: LPWSAProtocol_Info; var lpAddress: TSockAddr; + var lpAddressLength: integer): integer; stdcall; + +{ Registration and Name Resolution API functions } +function WSALookupServiceBeginA(var qsRestrictions: TWSAQuerySetA; const dwControlFlags: DWORD; var hLookup: THandle): integer; stdcall; +function WSALookupServiceBeginW(var qsRestrictions: TWSAQuerySetW; const dwControlFlags: DWORD; var hLookup: THandle): integer; stdcall; +function WSALookupServiceBegin(var qsRestrictions: TWSAQuerySet; const dwControlFlags: DWORD; var hLookup: THandle): integer; stdcall; + +function WSALookupServiceNextA(const hLookup: THandle; const dwControlFlags: DWORD; var dwBufferLength: DWORD; lpqsResults: PWSAQuerySetA): integer; stdcall; +function WSALookupServiceNextW(const hLookup: THandle; const dwControlFlags: DWORD; var dwBufferLength: DWORD; lpqsResults: PWSAQuerySetW): integer; stdcall; +function WSALookupServiceNext(const hLookup: THandle; const dwControlFlags: DWORD; var dwBufferLength: DWORD; lpqsResults: PWSAQuerySet): integer; stdcall; + +function WSALookupServiceEnd(const hLookup: THandle): integer; stdcall; + +function WSAInstallServiceClassA(const lpServiceClassInfo: LPWSAServiceClassInfoA): integer; stdcall; +function WSAInstallServiceClassW(const lpServiceClassInfo: LPWSAServiceClassInfoW): integer; stdcall; +function WSAInstallServiceClass(const lpServiceClassInfo: LPWSAServiceClassInfo): integer; stdcall; + +function WSARemoveServiceClass(const lpServiceClassId: PGUID): integer; stdcall; + +function WSAGetServiceClassInfoA(const lpProviderId: PGUID; const lpServiceClassId: PGUID; var lpdwBufSize: DWORD; lpServiceClassInfo: LPWSAServiceClassInfoA) + : integer; stdcall; +function WSAGetServiceClassInfoW(const lpProviderId: PGUID; const lpServiceClassId: PGUID; var lpdwBufSize: DWORD; lpServiceClassInfo: LPWSAServiceClassInfoW) + : integer; stdcall; +function WSAGetServiceClassInfo(const lpProviderId: PGUID; const lpServiceClassId: PGUID; var lpdwBufSize: DWORD; lpServiceClassInfo: LPWSAServiceClassInfo) + : integer; stdcall; + +function WSAEnumNameSpaceProvidersA(var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoA): integer; stdcall; +function WSAEnumNameSpaceProvidersW(var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_InfoW): integer; stdcall; +function WSAEnumNameSpaceProviders(var lpdwBufferLength: DWORD; const lpnspBuffer: LPWSANameSpace_Info): integer; stdcall; + +function WSAGetServiceClassNameByClassIdA(const lpServiceClassId: PGUID; lpszServiceClassName: PAnsiChar; var lpdwBufferLength: DWORD): integer; stdcall; +function WSAGetServiceClassNameByClassIdW(const lpServiceClassId: PGUID; lpszServiceClassName: PWideChar; var lpdwBufferLength: DWORD): integer; stdcall; +function WSAGetServiceClassNameByClassId(const lpServiceClassId: PGUID; lpszServiceClassName: PMBChar; var lpdwBufferLength: DWORD): integer; stdcall; + +function WSASetServiceA(const lpqsRegInfo: LPWSAQuerySetA; const essoperation: TWSAeSetServiceOp; const dwControlFlags: DWORD): integer; stdcall; +function WSASetServiceW(const lpqsRegInfo: LPWSAQuerySetW; const essoperation: TWSAeSetServiceOp; const dwControlFlags: DWORD): integer; stdcall; +function WSASetService(const lpqsRegInfo: LPWSAQuerySet; const essoperation: TWSAeSetServiceOp; const dwControlFlags: DWORD): integer; stdcall; + +function WSAProviderConfigChange(var lpNotificationHandle: THandle; lpOverlapped: LPWSAOVERLAPPED; lpCompletionRoutine: LPWSAOVERLAPPED_COMPLETION_ROUTINE) + : integer; stdcall; + +function getnameinfo(const pAddr: pointer; addrlen: socklen_t; host: PAnsiChar; hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; stdcall; +function GetNameInfoW(const pAddr: pointer; addrlen: socklen_t; host: PWideChar; hostlen: DWORD; serv: PWideChar; servlen: DWORD; flags: integer): integer; stdcall; + +{ Macros } +function WSAMakeSyncReply(buflen, Error: Word): Longint; +function WSAMakeSelectReply(Event, Error: Word): Longint; +function WSAGetAsyncBuflen(aParam: Longint): Word; +function WSAGetAsyncError(aParam: Longint): Word; +function WSAGetSelectEvent(aParam: Longint): Word; +function WSAGetSelectError(aParam: Longint): Word; + +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); + +{ Extension functions } + +var + ConnectEx: LPFN_CONNECTEX; + +function LoadConnectEx(const aSocket: TSocket): integer; + +{ ============================================================ } +{ ======================= Custom Types ======================= } +{ ============================================================ } + +const + { Socks version } + SOCKSVER4 = $04; + SOCKSVER5 = $05; + + { Socks commands } + SOCKSCMD_TCPCONNECT = $01; // RFC 1928 + SOCKSCMD_TCPBIND = $02; // RFC 1928 + SOCKSCMD_UDPASSOC = $03; // RFC 1928 + SOCKSCMD_RESOLVE = $F0; // Tor extension + SOCKSCMD_RESOLVEPTR = $F1; // Tor extension + + { Socks5 authentication methods } + SOCKS5AUTH_NOAUTH = 0; + SOCKS5AUTH_GSSAPI = 1; + SOCKS5AUTH_USERPASS = 2; + + { Socks address types } + SOCKSADDRTYP_IPV4 = $01; + SOCKSADDRTYP_DOMAINNAME = $03; + SOCKSADDRTYP_IPV6 = $04; + +type + { TIPProtocol } + { IP protocol in an enum form. } + TIPProtocol = ( + ptIP = IPPROTO_IP, + ptICMP = IPPROTO_ICMP, + ptIGMP = IPPROTO_IGMP, + ptGGP = IPPROTO_GGP, + ptTCP = IPPROTO_TCP, + ptPUP = IPPROTO_PUP, + ptUDP = IPPROTO_UDP, + ptIDP = IPPROTO_IDP, + ptND = IPPROTO_ND, + ptRAW = IPPROTO_RAW + ); + + { TSocketType } + { Socket type in an enum form. } + TSocketType = ( + stStream = SOCK_STREAM, + stDGram = SOCK_DGRAM, + stRaw = SOCK_RAW, + stRDM = SOCK_RDM, + stSeqpacket = SOCK_SEQPACKET + ); + + { TAddressFamily } + { IP address family in an enum form. } + TAddressFamily = (afUnspec = AF_UNSPEC, afIPv4 = AF_INET, afIPv6 = AF_INET6); + TAddressFamilies = set of TAddressFamily; + + { TProxyType } + { Proxy protocol type/version. } + TProxyType = (ptNone, ptHTTP, ptSocks4, ptSocks5); + TProxyTypes = set of TProxyType; + + { TTCPState } + { Indicates the state of a TCP connection. } + TTCPState = ( + tsClosed, tsListening, tsSynSent, tsSynReceived, tsEstablished, tsFinWait1, tsFinWait2, tsCloseWait, + tsClosing, tsLastAck, tsTimeWait, tsDeleteTCB + ); + +{ ============================================================ } +{ ==================== Helper functions ====================== } +{ ============================================================ } + +function InitWinsock: Boolean; +procedure FinWinsock; + +{ Error functions } +function GetWinsockErrorText(const aError: integer): string; +function GetLastWinsockErrorText: string; + +{ Quick utils for testing, mostly. } +function CreateTcpSock(const aAf: TAddressFamily = afIPv4): TSocket; +function CreateUdpSock(const aAf: TAddressFamily = afIPv4): TSocket; +function CreateRawSock(const aAf: TAddressFamily = afIPv4): TSocket; + +function ConnectTCPSock(const aSock: TSocket; const aAddrPool: PAddrInfo): Boolean; +function ConnectTCPSockNonBlocking(const aSock: TSocket; const aAddrPool: PAddrInfo): Boolean; + +function MakeTcpConnection(const aHost, aPort: string; const aAf: TAddressFamily = afIPv4): TSocket; +function MakeTcpConnectionSocks5(const aHost, aPort, aProxyHost, aProxyPort, aProxyUser, aProxyPass: string; const aAf: TAddressFamily = afIPv4): TSocket; + +function SendStrTcp(const aSock: TSocket; const aString: string): integer; +function RecvStrTcp(const aSock: TSocket; var aString: string): integer; +function RecvStrTcpNonBlocking(const aSock: TSocket; var aString: string): integer; + +procedure DeleteSock(var aSock: TSocket); + +{ Resolving utils } +function GetAddrPool( + const aHost, aPort: string; + var aAddrInfo: PAddrInfo; + const aAf: TAddressFamily = afIPv4; + const aSockType: TSocketType = stStream; + const aProtocol: TIPProtocol = ptTCP; + const aFlags: integer = 0 + ): integer; +procedure FreeAddrPool(var aAddrInfo: PAddrInfo); + +{ Proxy handshakes } +function GetSocks4ErrorText(const aErr: integer): string; +function GetSocks5ErrorText(const aErr: integer): string; + +function NegotiateProxy(const aSocket: TSocket; const aHost, aPort, aUser: string): integer; +function NegotiateSocks4(const aSocket: TSocket; const aHost, aPort, aUser, aPass: string): integer; +function NegotiateSocks5(const aSocket: TSocket; const aHost, aPort, aUser, aPass: string): integer; + +{ Address conversion } +function SockAddrToStr(const aSockAddr: PSockAddr; const aAddrLen: integer; var aOutString: string): Boolean; overload; +function SockAddrToStr(const aSockAddr: PSockAddr; const aAddrLen: integer): string; overload; +function ServToPortNum(const aServName: string; var aPort: Word): Boolean; + +function InAddr4ToStr(const aAddr: in_addr): string; +function InAddr6ToStr(const aAddr: in6_addr; const aAbbreviate: boolean = True): string; +function InAddr4RevLookup(const aAddr: in_addr; const aDGram: boolean = False): string; +function InAddr6RevLookup(const aAddr: in6_addr; const aDGram: boolean = False): string; + +{ String conversion } +function ProxyTypeToString(const aProxyType: TProxyType): string; +function ProxyTypeToScheme(const aProxyType: TProxyType): string; + +{ ============================================================ } +{ ====================== Helper types ======================== } +{ ============================================================ } + +type + + { GetAddrPoolAsync } + { Resolves an address asynchronously by using GetAddrInfo in a thread. } + { If you use more of these be sure to set IsMultiThreaded RTL var to true. } + + { TGetAddrPoolAsyncData events. } + TOnResolved = reference to procedure(const aAddrPool: PAddrInfo; const aError: integer); + + { GetAddrPoolAsync data } + TGetAddrPoolAsyncData = record + private + ThreadHandle: THandle; + class function GetAddrPoolAsyncThread(aParam: pointer): DWORD; stdcall; static; + public + host : string; + port : string; + AddressFamily: TAddressFamily; + SocketType : TSocketType; + Flags : integer; + OnResolved : TOnResolved; + procedure Initialize; + procedure Abort; + function Running: boolean; + end; + + PGetAddrPoolAsyncData = ^TGetAddrPoolAsyncData; + +procedure GetAddrPoolAsync(var aData: TGetAddrPoolAsyncData); + +implementation + +uses + EvilWorks.System.StrUtils; + +function LoadConnectEx(const aSocket: TSocket): integer; +var + guidConnectEx: System.TGUID; + Bytes : DWORD; +begin + guidConnectEx := WSAID_CONNECTEX; + Result := WSAIoctl(aSocket, SIO_GET_EXTENSION_FUNCTION_POINTER, @guidConnectEx, SizeOf(guidConnectEx), + @@ConnectEx, SizeOf(@ConnectEx), @Bytes, nil, nil + ); +end; + +function accept; external WINSOCK2_DLL name 'accept'; +function bind; external WINSOCK2_DLL name 'bind'; +function closesocket; external WINSOCK2_DLL name 'closesocket'; +function connect; external WINSOCK2_DLL name 'connect'; +function ioctlsocket; external WINSOCK2_DLL name 'ioctlsocket'; +function getpeername; external WINSOCK2_DLL name 'getpeername'; +function getsockname; external WINSOCK2_DLL name 'getsockname'; +function getsockopt; external WINSOCK2_DLL name 'getsockopt'; +function htonl; external WINSOCK2_DLL name 'htonl'; +function htons; external WINSOCK2_DLL name 'htons'; +function inet_addr; external WINSOCK2_DLL name 'inet_addr'; +function inet_ntoa; external WINSOCK2_DLL name 'inet_ntoa'; +function listen; external WINSOCK2_DLL name 'listen'; +function ntohl; external WINSOCK2_DLL name 'ntohl'; +function ntohs; external WINSOCK2_DLL name 'ntohs'; +function recv; external WINSOCK2_DLL name 'recv'; +function recvfrom; external WINSOCK2_DLL name 'recvfrom'; +function select; external WINSOCK2_DLL name 'select'; +function send; external WINSOCK2_DLL name 'send'; +function sendto; external WINSOCK2_DLL name 'sendto'; +function setsockopt; external WINSOCK2_DLL name 'setsockopt'; +function shutdown; external WINSOCK2_DLL name 'shutdown'; +function socket; external WINSOCK2_DLL name 'socket'; +function gethostbyaddr; external WINSOCK2_DLL name 'gethostbyaddr'; +function gethostbyname; external WINSOCK2_DLL name 'gethostbyname'; +function gethostname; external WINSOCK2_DLL name 'gethostname'; +function getservbyport; external WINSOCK2_DLL name 'getservbyport'; +function getservbyname; external WINSOCK2_DLL name 'getservbyname'; +function getprotobynumber; external WINSOCK2_DLL name 'getprotobynumber'; +function getprotobyname; external WINSOCK2_DLL name 'getprotobyname'; +function WSAStartup; external WINSOCK2_DLL name 'WSAStartup'; +function WSACleanup; external WINSOCK2_DLL name 'WSACleanup'; +procedure WSASetLastError; external WINSOCK2_DLL name 'WSASetLastError'; +function WSAGetLastError; external WINSOCK2_DLL name 'WSAGetLastError'; +function WSAIsBlocking; external WINSOCK2_DLL name 'WSAIsBlocking'; +function WSAUnhookBlockingHook; external WINSOCK2_DLL name 'WSAUnhookBlockingHook'; +function WSASetBlockingHook; external WINSOCK2_DLL name 'WSASetBlockingHook'; +function WSACancelBlockingCall; external WINSOCK2_DLL name 'WSACancelBlockingCall'; +function WSAAsyncGetServByName; external WINSOCK2_DLL name 'WSAAsyncGetServByName'; +function WSAAsyncGetServByPort; external WINSOCK2_DLL name 'WSAAsyncGetServByPort'; +function WSAAsyncGetProtoByName; external WINSOCK2_DLL name 'WSAAsyncGetProtoByName'; +function WSAAsyncGetProtoByNumber; external WINSOCK2_DLL name 'WSAAsyncGetProtoByNumber'; +function WSAAsyncGetHostByName; external WINSOCK2_DLL name 'WSAAsyncGetHostByName'; +function WSAAsyncGetHostByAddr; external WINSOCK2_DLL name 'WSAAsyncGetHostByAddr'; +function WSACancelAsyncRequest; external WINSOCK2_DLL name 'WSACancelAsyncRequest'; +function WSAAsyncSelect; external WINSOCK2_DLL name 'WSAAsyncSelect'; +function __WSAFDIsSet; external WINSOCK2_DLL name '__WSAFDIsSet'; + +{ WinSock 2 API new function prototypes } +function WSAAccept; external WINSOCK2_DLL name 'WSAAccept'; +function WSACloseEvent; external WINSOCK2_DLL name 'WSACloseEvent'; +function WSAConnect; external WINSOCK2_DLL name 'WSAConnect'; +function WSACreateEvent; external WINSOCK2_DLL name 'WSACreateEvent'; +function WSADuplicateSocketA; external WINSOCK2_DLL name 'WSADuplicateSocketA'; +function WSADuplicateSocketW; external WINSOCK2_DLL name 'WSADuplicateSocketW'; +function WSAEnumNetworkEvents; external WINSOCK2_DLL name 'WSAEnumNetworkEvents'; +function WSAEnumProtocolsA; external WINSOCK2_DLL name 'WSAEnumProtocolsA'; +function WSAEnumProtocolsW; external WINSOCK2_DLL name 'WSAEnumProtocolsW'; +function WSAEventSelect; external WINSOCK2_DLL name 'WSAEventSelect'; +function WSAGetOverlappedResult; external WINSOCK2_DLL name 'WSAGetOverlappedResult'; +function WSAGetQosByName; external WINSOCK2_DLL name 'WSAGetQosByName'; +function WSAhtonl; external WINSOCK2_DLL name 'WSAhtonl'; +function WSAhtons; external WINSOCK2_DLL name 'WSAhtons'; +function WSAIoctl; external WINSOCK2_DLL name 'WSAIoctl'; +function WSAJoinLeaf; external WINSOCK2_DLL name 'WSAJoinLeaf'; +function WSANtohl; external WINSOCK2_DLL name 'WSANtohl'; +function WSANtohs; external WINSOCK2_DLL name 'WSANtohs'; +function WSARecv; external WINSOCK2_DLL name 'WSARecv'; +function WSARecvDisconnect; external WINSOCK2_DLL name 'WSARecvDisconnect'; +function WSARecvFrom; external WINSOCK2_DLL name 'WSARecvFrom'; +function WSAResetEvent; external WINSOCK2_DLL name 'WSAResetEvent'; +function WSASend; external WINSOCK2_DLL name 'WSASend'; +function WSASendDisconnect; external WINSOCK2_DLL name 'WSASendDisconnect'; +function WSASendTo; external WINSOCK2_DLL name 'WSASendTo'; +function WSASetEvent; external WINSOCK2_DLL name 'WSASetEvent'; +function WSASocketA; external WINSOCK2_DLL name 'WSASocketA'; +function WSASocketW; external WINSOCK2_DLL name 'WSASocketW'; +function WSAWaitForMultipleEvents; external WINSOCK2_DLL name 'WSAWaitForMultipleEvents'; +function WSAAddressToStringA; external WINSOCK2_DLL name 'WSAAddressToStringA'; +function WSAAddressToStringW; external WINSOCK2_DLL name 'WSAAddressToStringW'; +function WSAStringToAddressA; external WINSOCK2_DLL name 'WSAStringToAddressA'; +function WSAStringToAddressW; external WINSOCK2_DLL name 'WSAStringToAddressW'; + +{ Registration and Name Resolution API functions } +function WSALookupServiceBeginA; external WINSOCK2_DLL name 'WSALookupServiceBeginA'; +function WSALookupServiceBeginW; external WINSOCK2_DLL name 'WSALookupServiceBeginW'; +function WSALookupServiceNextA; external WINSOCK2_DLL name 'WSALookupServiceNextA'; +function WSALookupServiceNextW; external WINSOCK2_DLL name 'WSALookupServiceNextW'; +function WSALookupServiceEnd; external WINSOCK2_DLL name 'WSALookupServiceEnd'; +function WSAInstallServiceClassA; external WINSOCK2_DLL name 'WSAInstallServiceClassA'; +function WSAInstallServiceClassW; external WINSOCK2_DLL name 'WSAInstallServiceClassW'; +function WSARemoveServiceClass; external WINSOCK2_DLL name 'WSARemoveServiceClass'; +function WSAGetServiceClassInfoA; external WINSOCK2_DLL name 'WSAGetServiceClassInfoA'; +function WSAGetServiceClassInfoW; external WINSOCK2_DLL name 'WSAGetServiceClassInfoW'; +function WSAEnumNameSpaceProvidersA; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersA'; +function WSAEnumNameSpaceProvidersW; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersW'; +function WSAGetServiceClassNameByClassIdA; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdA'; +function WSAGetServiceClassNameByClassIdW; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdW'; +function WSASetServiceA; external WINSOCK2_DLL name 'WSASetServiceA'; +function WSASetServiceW; external WINSOCK2_DLL name 'WSASetServiceW'; +function WSAProviderConfigChange; external WINSOCK2_DLL name 'WSAProviderConfigChange'; +function getnameinfo; external WINSOCK2_DLL name 'getnameinfo'; +function GetNameInfoW; external WINSOCK2_DLL name 'GetNameInfoW'; + +{$IFDEF UNICODE} +function WSADuplicateSocket; external WINSOCK2_DLL name 'WSADuplicateSocketW'; +function WSAEnumProtocols; external WINSOCK2_DLL name 'WSAEnumProtocolsW'; +function WSASocket; external WINSOCK2_DLL name 'WSASocketW'; +function WSAAddressToString; external WINSOCK2_DLL name 'WSAAddressToStringW'; +function WSAStringToAddress; external WINSOCK2_DLL name 'WSAStringToAddressW'; +function WSALookupServiceBegin; external WINSOCK2_DLL name 'WSALookupServiceBeginW'; +function WSALookupServiceNext; external WINSOCK2_DLL name 'WSALookupServiceNextW'; +function WSAInstallServiceClass; external WINSOCK2_DLL name 'WSAInstallServiceClassW'; +function WSAGetServiceClassInfo; external WINSOCK2_DLL name 'WSAGetServiceClassInfoW'; +function WSAEnumNameSpaceProviders; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersW'; +function WSAGetServiceClassNameByClassId; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdW'; +function WSASetService; external WINSOCK2_DLL name 'WSASetServiceW'; +function GetAddrInfo; external WINSOCK2_DLL name 'GetAddrInfoW'; +procedure FreeAddrInfo; external WINSOCK2_DLL name 'FreeAddrInfoW'; +{$ELSE} +function WSADuplicateSocket; external WINSOCK2_DLL name 'WSADuplicateSocketA'; +function WSAEnumProtocols; external WINSOCK2_DLL name 'WSAEnumProtocolsA'; +function WSASocket; external WINSOCK2_DLL name 'WSASocketA'; +function WSAAddressToString; external WINSOCK2_DLL name 'WSAAddressToStringA'; +function WSAStringToAddress; external WINSOCK2_DLL name 'WSAStringToAddressA'; +function WSALookupServiceBegin; external WINSOCK2_DLL name 'WSALookupServiceBeginA'; +function WSALookupServiceNext; external WINSOCK2_DLL name 'WSALookupServiceNextA'; +function WSAInstallServiceClass; external WINSOCK2_DLL name 'WSAInstallServiceClassA'; +function WSAGetServiceClassInfo; external WINSOCK2_DLL name 'WSAGetServiceClassInfoA'; +function WSAEnumNameSpaceProviders; external WINSOCK2_DLL name 'WSAEnumNameSpaceProvidersA'; +function WSAGetServiceClassNameByClassId; external WINSOCK2_DLL name 'WSAGetServiceClassNameByClassIdA'; +function WSASetService; external WINSOCK2_DLL name 'WSASetServiceA'; +function GetAddrInfo; external WINSOCK2_DLL name 'GetAddrInfoA'; +procedure FreeAddrInfo; external WINSOCK2_DLL name 'FreeAddrInfoA'; +{$ENDIF} + + +function WSAMakeSyncReply; +begin + WSAMakeSyncReply := MakeLong(buflen, Error); +end; + +function WSAMakeSelectReply; +begin + WSAMakeSelectReply := MakeLong(Event, Error); +end; + +function WSAGetAsyncBuflen(aParam: Longint): Word; +begin + WSAGetAsyncBuflen := Word(aParam); +end; + +function WSAGetAsyncError(aParam: Longint): Word; +begin + WSAGetAsyncError := HIWORD(aParam); +end; + +function WSAGetSelectEvent(aParam: Longint): Word; +begin + Result := Word(aParam); +end; + +function WSAGetSelectError(aParam: Longint): Word; +begin + WSAGetSelectError := HIWORD(aParam); +end; + +procedure FD_CLR(socket: TSocket; var FDSet: TFDSet); +var + i: DWORD; +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; + +{ Initializes Winsock to version 2.2 } +function InitWinsock: Boolean; +var + ret: integer; + wsd: TWSAData; +begin + ZeroMemory(@wsd, SizeOf(wsd)); + ret := WSAStartup($0202, wsd); + if (ret = 0) then + Result := True + else + Result := False; +end; + +{ Finalizes Winsock. } +procedure FinWinsock; +begin + WSACleanup; +end; + +{ Returns text description of a winsock error. } +function GetWinsockErrorText(const aError: integer): string; +var + buffer: array [0 .. 255] of Char; + flags : DWORD; +begin + FillChar(buffer, 256, #0); + flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; + FormatMessage(flags, nil, aError, 0, buffer, SizeOf(buffer), nil); + Result := buffer; +end; + +{ Returns last winsock error description. } +function GetLastWinsockErrorText: string; +begin + Result := GetWinsockErrorText(WSAGetLastError); +end; + +{ Creates a TCP socket. } +function CreateTcpSock(const aAf: TAddressFamily): TSocket; +begin + Result := socket(integer(aAf), SOCK_STREAM, IPPROTO_TCP); +end; + +{ Creates a UDP socket. } +function CreateUdpSock(const aAf: TAddressFamily): TSocket; +begin + Result := socket(integer(aAf), SOCK_DGRAM, IPPROTO_UDP); +end; + +{ Creates a RAW socket. } +function CreateRawSock(const aAf: TAddressFamily = afIPv4): TSocket; +begin + Result := socket(integer(aAf), SOCK_RAW, IPPROTO_RAW); +end; + +{ Tries to connect a TCP socket to an address in aAddrPool. True on success, False if not. } +function ConnectTCPSock(const aSock: TSocket; const aAddrPool: PAddrInfo): Boolean; +var + curr: PAddrInfo; +begin + Result := True; + + curr := aAddrPool; + while (curr <> nil) do + begin + if (connect(aSock, curr^.ai_addr, curr^.ai_addrlen) <> 0) then + curr := curr^.ai_next + else + Break; + + if (curr = nil) then + Exit(False); + end; +end; + +{ Same as ConnectTCPSock but it treats WSAEWOULDBLOCK error as success. Use it for non-blocking sockets. } +function ConnectTCPSockNonBlocking(const aSock: TSocket; const aAddrPool: PAddrInfo): Boolean; +var + curr: PAddrInfo; +begin + Result := True; + + curr := aAddrPool; + while (curr <> nil) do + begin + if (connect(aSock, curr^.ai_addr, curr^.ai_addrlen) <> 0) then + begin + if (WSAGetLastError = WSAEWOULDBLOCK) then + Break; + curr := curr^.ai_next; + end + else + Break; + + if (curr = nil) then + Exit(False); + end; +end; + +{ Returns a socket connected to aHost:aPort, SOCKET_ERROR if something failed. Call WSAGetLastError if so. } +function MakeTcpConnection(const aHost, aPort: string; const aAf: TAddressFamily): TSocket; +label Error; +var + addr: PAddrInfo; +begin + Result := CreateTcpSock(aAf); + if (Result = INVALID_SOCKET) then + Exit; + + if (GetAddrPool(aHost, aPort, addr, aAf) <> 0) then + goto Error; + + if (ConnectTCPSock(Result, addr) = False) then + goto Error; + + Exit; + +Error: + FreeAddrPool(addr); + closesocket(Result); +end; + +{ Same as MakeTcpConnection but over Socks5 proxy. } +function MakeTcpConnectionSocks5(const aHost, aPort, aProxyHost, aProxyPort, aProxyUser, aProxyPass: string; const aAf: TAddressFamily): TSocket; +begin + Result := MakeTcpConnection(aProxyHost, aProxyPort, aAf); + if (Result = INVALID_SOCKET) then + Exit; + + if (NegotiateSocks5(Result, aHost, aPort, aProxyUser, aProxyPass) = SOCKET_ERROR) then + begin + DeleteSock(Result); + Result := INVALID_SOCKET; + end; +end; + +{ Sends a string over a TCP socket. } +function SendStrTcp(const aSock: TSocket; const aString: string): integer; +var + buffer: rawbytestring; +begin + buffer := UTF8Encode(aString); + Result := send(aSock, buffer[1], Length(buffer), 0); +end; + +{ Receives a string over a TCP socket. Result -2 on rtl error, -1 on winsock, 0 on close, >0 = bytes received. } +function RecvStrTcp(const aSock: TSocket; var aString: string): integer; +var + buf : pointer; + bufsize: u_long; + optlen : integer; +begin + aString := ''; + + if (ioctlsocket(aSock, FIONREAD, bufsize) <> 0) then + Exit(SOCKET_ERROR); + + if (bufsize = 0) then + begin + optlen := SizeOf(bufsize); + if (getsockopt(aSock, SOL_SOCKET, SO_RCVBUF, @integer(bufsize), optlen) <> 0) then + Exit(SOCKET_ERROR); + end; + + buf := AllocMem(bufsize); + if (buf = nil) then + Exit( - 2); + + Result := recv(aSock, buf^, bufsize, 0); + if (Result > 0) then + aString := string(PAnsiChar(buf)); + + FreeMemory(buf); +end; + +{ Same as RecvStrTcp, but will immediately return empty aString and 0 if no data available. } +function RecvStrTcpNonBlocking(const aSock: TSocket; var aString: string): integer; +var + buf : pointer; + bufsize: u_long; +begin + aString := ''; + + if (ioctlsocket(aSock, FIONREAD, bufsize) <> 0) then + Exit(SOCKET_ERROR); + + if (bufsize = 0) then + Exit(SOCKET_ERROR); + + buf := AllocMem(bufsize); + if (buf = nil) then + Exit( - 2); + + Result := recv(aSock, buf^, bufsize, 0); + if (Result > 0) then + aString := string(PAnsiChar(buf)); + + FreeMemory(buf); +end; + +{ closes and deletes a socket if its value is not INVALID_SOCKET. } +procedure DeleteSock(var aSock: TSocket); +begin + if (aSock = INVALID_SOCKET) then + Exit; + closesocket(aSock); + aSock := INVALID_SOCKET; +end; + +{ Resolves aHost:aPort to an address pool in aAddrInfo. Returns 0 on success, Winsock Error otherwise. } +function GetAddrPool( + const aHost, aPort: string; var aAddrInfo: PAddrInfo; const aAf: TAddressFamily; + const aSockType: TSocketType; const aProtocol: TIPProtocol; const aFlags: integer + ): integer; +var + hints: TAddrInfo; +begin + ZeroMemory(@hints, SizeOf(hints)); + hints.ai_family := integer(aAf); + hints.ai_socktype := integer(aSockType); + hints.ai_protocol := integer(aProtocol); + hints.ai_flags := aFlags; + + Result := GetAddrInfo(PChar(aHost), PChar(aPort), @hints, @aAddrInfo); +end; + +{ Frees PAddrInfo. } +procedure FreeAddrPool(var aAddrInfo: PAddrInfo); +begin + if (aAddrInfo = nil) then + Exit; + FreeAddrInfo(aAddrInfo); + aAddrInfo := nil; +end; + +{ Returns a text description of a Socks4 handshake error. } +function GetSocks4ErrorText(const aErr: integer): string; +begin + case aErr of + $5A: + Result := 'Request granted.'; + $5B: + Result := 'Request rejected or failed.'; + $5C: + Result := 'Request failed because client is not running identd (or unreachable).'; + $5D: + Result := 'Request failed because client ident could not confirm user ID in request.'; + else + Result := 'Unknown error.'; + end; +end; + +{ Returns a text description of a Socks5 handshake error. } +function GetSocks5ErrorText(const aErr: integer): string; +begin + case aErr of + 0: + Result := 'Connected OK.'; + 1: + Result := 'General failure.'; + 2: + Result := 'Connection not allowed by ruleset.'; + 3: + Result := 'Network unreachable.'; + 4: + Result := 'Host unreachable.'; + 5: + Result := 'Connection refused by destination host.'; + 6: + Result := 'TTL expired.'; + 7: + Result := 'Command not supported / protocol error.'; + 8: + Result := 'Address type not supported.'; + else + Result := 'Unknown error.'; + end; +end; + +{ Negotiates a client connection with a HTTP proxy ON A BLOCKING SOCKET! } +{ aUser is optional, if HTTP proxy requests is for auth. } +{ Returns 0 on success, SOCKET_ERROR on winsock error, or a >0 value for Proxy error. } +{ Supports NoAuth and User Auth. } +function NegotiateProxy(const aSocket: TSocket; const aHost, aPort, aUser: string): integer; +begin + Result := 0; +end; + +{ Negotiates a client connection with a socks4 proxy ON A BLOCKING SOCKET! } +{ aUser, apass are optional, if Socks4 server requests them for an User/Pass auth. } +{ Returns 0 on success, SOCKET_ERROR on winsock error, or a >0 value for Socks4 error. } +{ Supports NoAuth and User/Pass. } +function NegotiateSocks4(const aSocket: TSocket; const aHost, aPort, aUser, aPass: string): integer; +begin + Result := 0; +end; + +{ Negotiates a client connection with a socks5 proxy ON A BLOCKING SOCKET! } +{ aUser, aPass are optional, if Socks5 server requests them for an User/Pass auth. } +{ Returns 0 on success, SOCKET_ERROR on winsock error, or a >0 value for Socks5 error. } +{ Supports NoAuth and User/Pass. } +function NegotiateSocks5(const aSocket: TSocket; const aHost, aPort, aUser, aPass: string): integer; + + function IsError(const aErr: integer): Boolean; + begin + if (aErr <= 0) or (aErr = SOCKET_ERROR) then + Result := True + else + Result := False; + end; + +var + Buff : array of Byte; + host : ansistring; + port : Word; + uname: ansistring; + pword: ansistring; +begin + // Send auth methods. + SetLength(Buff, 4); + Buff[0] := $05; // Socks version, must be $05. + Buff[1] := $02; // Num of methods supported. + Buff[2] := $00; // Method 1 - No auth. + Buff[3] := $02; // Method 2 - Username/Password. + Result := send(aSocket, Buff[0], Length(Buff), 0); + if IsError(Result) then + Exit(SOCKET_ERROR); + + // Recieve selected Auth method. + SetLength(Buff, 2); + ZeroMemory(@Buff[0], 2); + Result := recv(aSocket, Buff[0], Length(Buff), MSG_WAITALL); + if IsError(Result) then + Exit(SOCKET_ERROR); + + // Check reply version. + if (Buff[0] <> $05) then // Socks version, must be $05. + Exit(1); + + // Do User/Pass auth. + if (Buff[1] = 2) then + begin + // Send Username/Password + uname := ansistring(aUser); + pword := ansistring(aPass); + + SetLength(Buff, 3 + Length(uname) + Length(pword)); + Buff[0] := $01; // Sending user:pass auth. + + // Put username + Buff[1] := Length(uname); + if (Buff[1] > 0) then + CopyMemory(@Buff[2], @uname[1], Length(uname)); + + // Put password + Buff[2 + Length(uname) + 1] := Length(pword); + if (Buff[2 + Length(uname) + 1] > 0) then + CopyMemory(@Buff[2 + Length(uname) + 1], @pword[1], Length(pword)); + + // Send Username:Password auth. + Result := send(aSocket, Buff[0], Length(Buff), 0); + if (IsError(Result)) then + Exit(SOCKET_ERROR); + + // Get auth response. + SetLength(Buff, 2); + ZeroMemory(@Buff[0], 2); + Result := recv(aSocket, Buff[0], Length(Buff), MSG_WAITALL); + if IsError(Result) then + Exit(SOCKET_ERROR); + end + else if (Buff[1] <> 0) then // Some unsupported auth method requested. + Exit(1); + + // Send connect request. + host := ansistring(aHost); + ServToPortNum(aPort, port); + SetLength(Buff, 7 + Length(host)); + Buff[0] := $05; // Socks version. + Buff[1] := $01; // Establish TCP connection. + Buff[2] := $00; // Reserved. + Buff[3] := $03; // Destination type: Domain name. + Buff[4] := Length(host); // Length of hostname + CopyMemory(@Buff[5], PAnsiChar(host), Buff[4]); // Hostname + CopyMemory(@Buff[5 + Buff[4]], @port, SizeOf(port)); // Port + + Result := send(aSocket, Buff[0], Length(Buff), 0); + if IsError(Result) then + Exit(SOCKET_ERROR); + + // Recieve connect response. + SetLength(Buff, 260); + FillChar(Buff[0], 260, 0); + Result := recv(aSocket, Buff[0], 260, 0); + if IsError(Result) then + Exit(SOCKET_ERROR); + + // Check for final "OK!". + if (Buff[1] <> $00) then + Exit(1); +end; + +{ Returns an IP string from PSockAddr in standard dotted format: byte.byte.byte.byte:word (ip:port). } +{ Supports IPv6 addresses as well, uses Winsock functions to convert data. } +function SockAddrToStr(const aSockAddr: PSockAddr; const aAddrLen: integer; var aOutString: string): Boolean; +var + buffer : array [0 .. 255] of Char; + buffersize: cardinal; +begin + if (aSockAddr = nil) or (aAddrLen = 0) then + Exit(False); + + buffersize := 256; + ZeroMemory(@buffer[0], buffersize); + if (WSAAddressToString(aSockAddr, aAddrLen, nil, buffer, buffersize) = 0) then + begin + SetString(aOutString, PChar(@buffer[0]), buffersize); + Result := True; + end + else + begin + aOutString := ''; + Result := False; + end; +end; + +{ Returns an IP string from PSockAddr in standard dotted format: byte.byte.byte.byte:word (ip:port). } +function SockAddrToStr(const aSockAddr: PSockAddr; const aAddrLen: integer): string; overload; +var + s: string; +begin + Result := ''; + if (SockAddrToStr(aSockAddr, aAddrLen, s)) then + Result := s; +end; + +{ Returns port number for a service name in net byte order. i.e. "http -> 80" } +function ServToPortNum(const aServName: string; var aPort: Word): Boolean; +var + sent: PServEnt; + code: integer; +begin + Result := False; + + sent := getservbyname(PAnsiChar(ansistring(aServName)), PAnsiChar('tcp')); + if (sent = nil) then + begin + Val(aServName, aPort, code); + if (code <> 0) then + Exit; + aPort := htons(aPort); + end + else + aPort := sent^.s_port; + + Result := True; +end; + +{ Converts in_addr to text representation. ~10x faster than inet_ntoa. } +function InAddr4ToStr(const aAddr: in_addr): string; +type + TIP4Bytes = array [0 .. 3] of byte; +var + s: shortstring; +begin + Str(TIP4Bytes(aAddr)[0], s); + Result := string(s); + Str(TIP4Bytes(aAddr)[1], s); + Result := Result + '.' + string(s); + Str(TIP4Bytes(aAddr)[2], s); + Result := Result + '.' + string(s); + Str(TIP4Bytes(aAddr)[3], s); + Result := Result + '.' + string(s); +end; + +{ Converts in6_addr to text representation. If aAbbreviate collapses leading and consecutive zeros. } +function InAddr6ToStr(const aAddr: in6_addr; const aAbbreviate: boolean = True): string; +var + i: integer; +begin + Result := ''; + + if (aAbbreviate) then + begin + for i := 0 to 7 do + begin + if (aAddr.Words[i] <> 0) then + begin + if (aAddr.Bytes[i * 2] <> 0) then + begin + Result := Result + TextIntToHex(aAddr.Bytes[i * 2], 1); + Result := Result + TextIntToHex(aAddr.Bytes[i * 2 + 1], 2); + end + else + Result := Result + TextIntToHex(aAddr.Bytes[i * 2 + 1], 1); + end; + + if not (TextEnds(Result, '::')) then + if (i <> 7) then + Result := Result + ':'; + end; + Exit; + end; + + for i := 0 to 15 do + begin + Result := Result + TextIntToHex(aAddr.Bytes[i], 2); + if (i <> 15) and (Odd(i)) then + Result := Result + ':'; + end; +end; + +{ Performs a reverse lookup on a ipv4 address. On failure result will be empty. } +function InAddr4RevLookup(const aAddr: in_addr; const aDGram: boolean = False): string; +var + addr : sockaddr_in; + hostName: array [0 .. NI_MAXHOST - 1] of ansichar; + servName: array [0 .. NI_MAXSERV - 1] of ansichar; + flags : integer; +begin + Result := CEmpty; + + if (aDGram) then + flags := NI_NAMEREQD or NI_DGRAM or NI_NUMERICHOST + else + flags := NI_NAMEREQD or NI_NUMERICHOST; + + ZeroMemory(@addr, SizeOf(addr)); + ZeroMemory(@hostName[0], Length(hostName)); + ZeroMemory(@servName[0], Length(servName)); + + addr.sin_family := AF_INET; + addr.sin_addr.S_addr := aAddr.S_addr; + addr.sin_port := 0; + + if (getnameinfo(@addr, SizeOf(addr), hostName, Length(hostName), servName, Length(servName), flags) = 0) then + Result := string(hostName); +end; + +{ Performs a reverse lookup on a ipv6 address. On failure result will be empty. } +function InAddr6RevLookup(const aAddr: in6_addr; const aDGram: boolean = False): string; +var + addr : sockaddr_in6; + hostName: array [0 .. NI_MAXHOST - 1] of ansichar; + servName: array [0 .. NI_MAXSERV - 1] of ansichar; + flags : integer; +begin + Result := CEmpty; + + if (aDGram) then + flags := NI_NAMEREQD or NI_DGRAM or NI_NUMERICHOST + else + flags := NI_NAMEREQD or NI_NUMERICHOST; + + ZeroMemory(@addr, SizeOf(addr)); + ZeroMemory(@hostName[0], Length(hostName)); + ZeroMemory(@servName[0], Length(servName)); + + addr.sin6_family := AF_INET6; + addr.sin6_addr := aAddr; + addr.sin6_port := 0; + + if (getnameinfo(@addr, SizeOf(addr), hostName, Length(hostName), servName, Length(servName), flags) = 0) then + Result := string(hostName); +end; + +{ TProxyType to string. } +function ProxyTypeToString(const aProxyType: TProxyType): string; +begin + case aProxyType of + ptNone: + Result := ''; + ptHTTP: + Result := 'HTTP'; + ptSocks4: + Result := 'Socks4'; + ptSocks5: + Result := 'Socks5'; + end; +end; + +{ TProxyType to URI scheme. } +function ProxyTypeToScheme(const aProxyType: TProxyType): string; +begin + case aProxyType of + ptNone: + Result := ''; + ptHTTP: + Result := 'http://'; + ptSocks4: + Result := 'socks4://'; + ptSocks5: + Result := 'socks5://'; + end; +end; + +{ ===================== } +{ TGetAddrPoolAsyncData } +{ ===================== } + +{ GetAddrPoolAsync thread procedure. } +class function TGetAddrPoolAsyncData.GetAddrPoolAsyncThread(aParam: pointer): DWORD; +var + data: PGetAddrPoolAsyncData; + addr: PAddrInfo; + ret : integer; +begin + Result := 0; + + data := PGetAddrPoolAsyncData(aParam); + ret := GetAddrPool(data^.host, data^.port, addr, data^.AddressFamily, data^.SocketType); + data^.ThreadHandle := 0; + if (Assigned(data^.OnResolved)) then + data^.OnResolved(addr, ret); +end; + +{ Constructor. Use this as constructor. } +procedure TGetAddrPoolAsyncData.Initialize; +begin + host := ''; + port := ''; + AddressFamily := afUnspec; + SocketType := stStream; + OnResolved := nil; + ThreadHandle := 0; +end; + +{ Aborts the thread if its running. } +procedure TGetAddrPoolAsyncData.Abort; +begin + if (ThreadHandle <> 0) then + begin + TerminateThread(ThreadHandle, 0); + ThreadHandle := 0; + end; + Initialize; +end; + +{ Tells if the resolve thread for this data is still running. } +function TGetAddrPoolAsyncData.Running: boolean; +begin + Result := (ThreadHandle <> 0); +end; + +{ Calls GetAddrInfo in a thread. } +procedure GetAddrPoolAsync(var aData: TGetAddrPoolAsyncData); +var + ThreadHandle: THandle; + threadID : cardinal; +begin + threadID := 0; + ThreadHandle := CreateThread(nil, 0, @aData.GetAddrPoolAsyncThread, @aData, CREATE_SUSPENDED, threadID); + if (ThreadHandle <> 0) then + begin + aData.ThreadHandle := ThreadHandle; + ResumeThread(ThreadHandle); + end; +end; + +end. diff --git a/EvilWorks.Api.IpHlpApi.pas b/EvilWorks.Api.IpHlpApi.pas new file mode 100644 index 0000000..64fac58 --- /dev/null +++ b/EvilWorks.Api.IpHlpApi.pas @@ -0,0 +1,500 @@ +unit EvilWorks.Api.IpHlpApi; + +interface + +uses + WinApi.Windows, + WinApi.Winsock2, + WinApi.IpHlpApi, + WinApi.IpRtrMib, + WinApi.IpExport, + System.SysUtils, + EvilWorks.Api.TcpEStats; + +const + { TCPIP_OWNING_MODULE_SIZE } + TCPIP_OWNING_MODULE_SIZE = 16; +{$EXTERNALSYM TCPIP_OWNING_MODULE_SIZE} + + +type + + TMacAddr = array [0 .. MAXLEN_PHYSADDR - 1] of byte; + PMacAddr = ^TMacAddr; + + { MIB_TCP_STATE } + MIB_TCP_STATE = ( + MIB_TCP_STATE_CLOSED = 1, + MIB_TCP_STATE_LISTEN = 2, + MIB_TCP_STATE_SYN_SENT = 3, + MIB_TCP_STATE_SYN_RCVD = 4, + MIB_TCP_STATE_ESTAB = 5, + MIB_TCP_STATE_FIN_WAIT1 = 6, + MIB_TCP_STATE_FIN_WAIT2 = 7, + MIB_TCP_STATE_CLOSE_WAIT = 8, + MIB_TCP_STATE_CLOSING = 9, + MIB_TCP_STATE_LAST_ACK = 10, + MIB_TCP_STATE_TIME_WAIT = 11, + MIB_TCP_STATE_DELETE_TCB = 12 + ); +{$EXTERNALSYM MIB_TCP_STATE} + { TCP_TABLE_CLASS } + TCP_TABLE_CLASS = ( + TCP_TABLE_BASIC_LISTENER, + TCP_TABLE_BASIC_CONNECTIONS, + TCP_TABLE_BASIC_ALL, + TCP_TABLE_OWNER_PID_LISTENER, + TCP_TABLE_OWNER_PID_CONNECTIONS, + TCP_TABLE_OWNER_PID_ALL, + TCP_TABLE_OWNER_MODULE_LISTENER, + TCP_TABLE_OWNER_MODULE_CONNECTIONS, + TCP_TABLE_OWNER_MODULE_ALL + ); +{$EXTERNALSYM TCP_TABLE_CLASS} + TTcpTableClass = TCP_TABLE_CLASS; + PTCP_TABLE_CLASS = ^TCP_TABLE_CLASS; + + { UDP_TABLE_CLASS } + UDP_TABLE_CLASS = ( + UDP_TABLE_BASIC, + UDP_TABLE_OWNER_PID, + UDP_TABLE_OWNER_MODULE + ); +{$EXTERNALSYM UDP_TABLE_CLASS} + TUdpTableClass = UDP_TABLE_CLASS; + PDUDP_TABLE_CLASS = ^UDP_TABLE_CLASS; + + { MIB_TCPROW } + MIB_TCPROW = record + State: MIB_TCP_STATE; + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwRemoteAddr: DWORD; + dwRemotePort: DWORD; + end; +{$EXTERNALSYM PMIB_TCPROW} + + PMIB_TCPROW = ^MIB_TCPROW; +{$EXTERNALSYM MIB_TCPROW} + TMibTcpRow = MIB_TCPROW; + + { MIB_TCPTABLE } + MIB_TCPTABLE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCPROW; + end; +{$EXTERNALSYM MIB_TCPTABLE} + + PMIB_TCPTABLE = ^MIB_TCPTABLE; +{$EXTERNALSYM MIB_TCPTABLE} + TMibTcpTable = MIB_TCPTABLE; + + { MIB_TCPROW_OWNER_PID } + MIB_TCPROW_OWNER_PID = record + dwState: DWORD; + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwRemoteAddr: DWORD; + dwRemotePort: DWORD; + dwOwningPid: DWORD; + end; +{$EXTERNALSYM MIB_TCPROW_OWNER_PID} + + PMIB_TCPROW_OWNER_PID = ^MIB_TCPROW_OWNER_PID; +{$EXTERNALSYM MIB_TCPROW_OWNER_PID} + TMibTcpRowOwnerPid = MIB_TCPROW_OWNER_PID; + + { MIB_TCPTABLE_OWNER_PID } + MIB_TCPTABLE_OWNER_PID = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCPROW_OWNER_PID; + end; +{$EXTERNALSYM MIB_TCPTABLE_OWNER_PID} + + PMIB_TCPTABLE_OWNER_PID = ^MIB_TCPTABLE_OWNER_PID; +{$EXTERNALSYM MIB_TCPTABLE_OWNER_PID} + TMibTcpTableOwnerPid = MIB_TCPTABLE_OWNER_PID; + + { MIB_TCPROW_OWNER_MODULE } + MIB_TCPROW_OWNER_MODULE = record + dwState: DWORD; + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwRemoteAddr: DWORD; + dwRemotePort: DWORD; + dwOwningPid: DWORD; + liCreateTimestamp: LARGE_INTEGER; + OwningModuleInfo: array [0 .. TCPIP_OWNING_MODULE_SIZE - 1] of ULONGLONG; + end; +{$EXTERNALSYM MIB_TCPROW_OWNER_MODULE} + + PMIB_TCPROW_OWNER_MODULE = ^MIB_TCPROW_OWNER_MODULE; +{$EXTERNALSYM MIB_TCPROW_OWNER_MODULE} + TMibTcpRowOwnerModule = MIB_TCPROW_OWNER_MODULE; + + { MIB_TCPTABLE_OWNER_MODULE } + MIB_TCPTABLE_OWNER_MODULE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCPROW_OWNER_MODULE; + end; +{$EXTERNALSYM MIB_TCPTABLE_OWNER_MODULE} + + PMIB_TCPTABLE_OWNER_MODULE = ^MIB_TCPTABLE_OWNER_MODULE; +{$EXTERNALSYM MIB_TCPTABLE_OWNER_MODULE} + TMibTcpTableOwnerModule = MIB_TCPTABLE_OWNER_MODULE; + + { MIB_TCP6ROW } + MIB_TCP6ROW = record + State: MIB_TCP_STATE; + LocalAddr: IN6_ADDR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + RemoteAddr: IN6_ADDR; + dwRemoteScopeId: DWORD; + dwRemotePort: DWORD; + end; +{$EXTERNALSYM MIB_TCP6ROW} + + PMIB_TCP6ROW = ^MIB_TCP6ROW; +{$EXTERNALSYM MIB_TCP6ROW} + TMibTcp6Row = MIB_TCP6ROW; + + { MIB_TCP6TABLE } + MIB_TCP6TABLE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCP6ROW; + end; +{$EXTERNALSYM MIB_TCP6TABLE} + + PMIB_TCP6TABLE = ^MIB_TCP6TABLE; +{$EXTERNALSYM MIB_TCP6TABLE} + TMibTcp6Table = MIB_TCP6TABLE; + + { MIB_TCP6ROW_OWNER_PID } + MIB_TCP6ROW_OWNER_PID = record + ucLocalAddr: array [0 .. 15] of UCHAR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + ucRemoteAddr: array [0 .. 15] of UCHAR; + dwRemoteScopeId: DWORD; + dwRemotePort: DWORD; + dwState: DWORD; + dwOwningPid: DWORD; + end; +{$EXTERNALSYM MIB_TCP6ROW_OWNER_PID} + + PMIB_TCP6ROW_OWNER_PID = ^MIB_TCP6ROW_OWNER_PID; +{$EXTERNALSYM MIB_TCP6ROW_OWNER_PID} + TMibTcp6RowOwnerPid = MIB_TCP6ROW_OWNER_PID; + + { MIB_TCP6TABLE_OWNER_PID } + MIB_TCP6TABLE_OWNER_PID = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCP6ROW_OWNER_PID; + end; +{$EXTERNALSYM MIB_TCP6TABLE_OWNER_PID} + + PMIB_TCP6TABLE_OWNER_PID = ^MIB_TCP6TABLE_OWNER_PID; +{$EXTERNALSYM MIB_TCP6ROW_OWNER_PID} + TMibTcp6TableOwnerPid = MIB_TCP6TABLE_OWNER_PID; + + { MIB_TCP6ROW_OWNER_MODULE } + MIB_TCP6ROW_OWNER_MODULE = record + ucLocalAddr: array [0 .. 15] of UCHAR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + ucRemoteAddr: array [0 .. 15] of UCHAR; + dwRemoteScopeId: DWORD; + dwRemotePort: DWORD; + dwState: DWORD; + dwOwningPid: DWORD; + liCreateTimestamp: LARGE_INTEGER; + OwningModuleInfo: array [0 .. TCPIP_OWNING_MODULE_SIZE - 1] of ULONGLONG; + end; +{$EXTERNALSYM MIB_TCP6ROW_OWNER_MODULE} + + PMIB_TCP6ROW_OWNER_MODULE = ^MIB_TCP6ROW_OWNER_MODULE; +{$EXTERNALSYM MIB_TCP6ROW_OWNER_MODULE} + TMibTcp6RowOwnerModule = MIB_TCP6ROW_OWNER_MODULE; + + { MIB_TCP6TABLE_OWNER_MODULE } + MIB_TCP6TABLE_OWNER_MODULE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_TCP6ROW_OWNER_MODULE; + end; +{$EXTERNALSYM MIB_TCP6TABLE_OWNER_MODULE} + + PMIB_TCP6TABLE_OWNER_MODULE = ^MIB_TCP6TABLE_OWNER_MODULE; +{$EXTERNALSYM MIB_TCP6TABLE_OWNER_MODULE} + TMibTcp6TableOwnerModule = MIB_TCP6TABLE_OWNER_MODULE; + + { MIB_UDPROW } + MIB_UDPROW = record + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + end; +{$EXTERNALSYM MIB_UDPROW} + + TMibUdpRow = MIB_UDPROW; + PMIB_UDPROW = ^MIB_UDPROW; + + { MIB_UDPTABLE } + MIB_UDPTABLE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDPROW; + end; +{$EXTERNALSYM MIB_UDPTABLE} + + TMibUdpTable = MIB_UDPTABLE; + PMIB_UDPTABLE = ^MIB_UDPTABLE; + + { MIB_UDPROW_OWNER_PID } + MIB_UDPROW_OWNER_PID = record + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwOwningPid: DWORD; + end; +{$EXTERNALSYM MIB_UDPROW_OWNER_PID} + + TMibUdpRowOwnerPid = MIB_UDPROW_OWNER_PID; + PMIB_UDPROW_OWNER_PID = ^MIB_UDPROW_OWNER_PID; + + { MIB_UDPTABLE_OWNER_PID } + MIB_UDPTABLE_OWNER_PID = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDPROW_OWNER_PID; + end; +{$EXTERNALSYM MIB_UDPTABLE_OWNER_PID} + + TMibUdpTableOwnerPid = MIB_UDPTABLE_OWNER_PID; + PMIB_UDPTABLE_OWNER_PID = ^MIB_UDPTABLE_OWNER_PID; + + { MIB_UDPROW_OWNER_MODULE } + MIB_UDPROW_OWNER_MODULE = record + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwOwningPid: DWORD; + liCreateTimestamp: LARGE_INTEGER; + dwFlags: integer; + OwningModuleInfo: array [0 .. TCPIP_OWNING_MODULE_SIZE - 1] of ULONGLONG; + end; +{$EXTERNALSYM MIB_UDPROW_OWNER_MODULE} + + TMibUdpRowOwnerModule = MIB_UDPROW_OWNER_MODULE; + PMIB_UDPROW_OWNER_MODULE = ^MIB_UDPROW_OWNER_MODULE; + + { MIB_UDPTABLE_OWNER_MODULE } + MIB_UDPTABLE_OWNER_MODULE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDPROW_OWNER_MODULE; + end; +{$EXTERNALSYM MIB_UDPTABLE_OWNER_MODULE} + + TMibUdpTableOwnerModule = MIB_UDPTABLE_OWNER_MODULE; + PMIB_UDPTABLE_OWNER_MODULE = ^MIB_UDPTABLE_OWNER_MODULE; + + { MIB_UDP6ROW } + MIB_UDP6ROW = record + dwLocalAddr: IN6_ADDR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + end; +{$EXTERNALSYM MIB_UDP6ROW} + + TMibUdp6Row = MIB_UDP6ROW; + PMIB_UDP6ROW = ^MIB_UDP6ROW; + + { MIB_UDP6TABLE } + MIB_UDP6TABLE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDP6ROW; + end; +{$EXTERNALSYM MIB_UDP6TABLE} + + TMibUdp6Table = MIB_UDP6TABLE; + PMIB_UDP6TABLE = ^MIB_UDP6TABLE; + + { MIB_UDPROW_OWNER_PID } + MIB_UDP6ROW_OWNER_PID = record + ucLocalAddr: array [0 .. 15] of UCHAR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + dwOwningPid: DWORD; + end; +{$EXTERNALSYM MIB_UDP6ROW_OWNER_PID} + + TMibUdp6RowOwnerPid = MIB_UDP6ROW_OWNER_PID; + PMIB_UDP6ROW_OWNER_PID = ^MIB_UDP6ROW_OWNER_PID; + + { MIB_UDP6TABLE_OWNER_PID } + MIB_UDP6TABLE_OWNER_PID = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDP6ROW_OWNER_PID; + end; +{$EXTERNALSYM MIB_UDP6TABLE_OWNER_PID} + + TMibUdp6TableOwnerPid = MIB_UDP6TABLE_OWNER_PID; + PMIB_UDP6TABLE_OWNER_PID = ^MIB_UDP6TABLE_OWNER_PID; + + { MIB_UDP6ROW_OWNER_MODULE } + MIB_UDP6ROW_OWNER_MODULE = record + ucLocalAddr: array [0 .. 15] of UCHAR; + dwLocalScopeId: DWORD; + dwLocalPort: DWORD; + dwOwningPid: DWORD; + liCreateTimestamp: LARGE_INTEGER; + dwFlags: integer; + OwningModuleInfo: array [0 .. TCPIP_OWNING_MODULE_SIZE - 1] of ULONGLONG; + end; +{$EXTERNALSYM MIB_UDP6ROW_OWNER_MODULE} + + TMibUdp6RowOwnerModule = MIB_UDP6ROW_OWNER_MODULE; + PMIB_UDP6ROW_OWNER_MODULE = ^MIB_UDP6ROW_OWNER_MODULE; + + { MIB_UDP6TABLE_OWNER_MODULE } + MIB_UDP6TABLE_OWNER_MODULE = record + dwNumEntries: DWORD; + table: array [0 .. 0] of MIB_UDP6ROW_OWNER_MODULE; + end; +{$EXTERNALSYM MIB_UDP6TABLE_OWNER_MODULE} + + TMibUdp6TableOwnerModule = MIB_UDP6TABLE_OWNER_MODULE; + PMIB_UDP6TABLE_OWNER_MODULE = ^MIB_UDP6TABLE_OWNER_MODULE; + + TGetPerTcpConnectionEStats = function(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; stdcall; + TSetPerTcpConnectionEStats = function(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; stdcall; + TGetPerTcp6ConnectionEStats = function(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; stdcall; + TSetPerTcp6ConnectionEStats = function(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; stdcall; + +function GetExtendedTcpTable( + pTcpTable: pointer; var dwSize: DWORD; bOrder: BOOL; ulAf: ULONG; + TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetExtendedTcpTable} + +function GetExtendedUdpTable( + pUdpTable: pointer; var dwSize: DWORD; bOrder: BOOL; ulAf: ULONG; + TableClass: UDP_TABLE_CLASS; Reserved: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetExtendedUdpTable} + +function GetPerTcpConnectionEStats(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; stdcall; +{$EXTERNALSYM GetPerTcpConnectionEStats} + +function SetPerTcpConnectionEStats(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; stdcall; +{$EXTERNALSYM SetPerTcpConnectionEStats} + +function GetPerTcp6ConnectionEStats(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; stdcall; +{$EXTERNALSYM GetPerTcp6ConnectionEStats} + +function SetPerTcp6ConnectionEStats(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; stdcall; +{$EXTERNALSYM SetPerTcp6ConnectionEStats} + +function MacAddr2Str(const aMacAddr: TMacAddr; aSize: integer): string; + +implementation + +const + iphlpapilib = 'iphlpapi.dll'; + +var + hIpHlpApi : THandle; + _GetPerTcpConnectionEStats : TGetPerTcpConnectionEStats; + _SetPerTcpConnectionEStats : TSetPerTcpConnectionEStats; + _GetPerTcp6ConnectionEStats: TGetPerTcp6ConnectionEStats; + _SetPerTcp6ConnectionEStats: TSetPerTcp6ConnectionEStats; + +function CheckStubsLoaded: boolean; +begin + if (hIpHlpApi = 0) then + begin + hIpHlpApi := LoadLibrary(iphlpapilib); + if (hIpHlpApi < 32) then + begin + hIpHlpApi := 0; + Result := False; + Exit; + end; + @_GetPerTcpConnectionEStats := GetProcAddress(hIpHlpApi, 'GetPerTcpConnectionEStats'); + @_SetPerTcpConnectionEStats := GetProcAddress(hIpHlpApi, 'SetPerTcpConnectionEStats'); + @_GetPerTcp6ConnectionEStats := GetProcAddress(hIpHlpApi, 'GetPerTcp6ConnectionEStats'); + @_SetPerTcp6ConnectionEStats := GetProcAddress(hIpHlpApi, 'SetPerTcp6ConnectionEStats'); + end; + Result := True; +end; + +{ converts numerical MAC-address to ww-xx-yy-zz string } +function MacAddr2Str(const aMacAddr: TMacAddr; aSize: integer): string; +var + i: integer; +begin + if (aSize = 0) then + begin + Result := '00-00-00-00-00-00'; + Exit; + end + else + Result := ''; + + for i := 1 to aSize do + begin + Result := Result + IntToHex(aMacAddr[i], 2); + if (i <> aSize) then + Result := Result + '-'; + end; +end; + +function GetExtendedTcpTable; external iphlpapilib name 'GetExtendedTcpTable'; +function GetExtendedUdpTable; external iphlpapilib name 'GetExtendedUdpTable'; + +function GetPerTcpConnectionEStats(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; +begin + if (CheckStubsLoaded) then + Result := _GetPerTcpConnectionEStats(Row, EstatsType, Rw, RwVersion, RwSize, Ros, + RosVersion, RosSize, Rod, RodVersion, RodSize) + else + Result := 0; +end; + +function SetPerTcpConnectionEStats(Row: PMIB_TCPROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; +begin + if (CheckStubsLoaded) then + Result := _SetPerTcpConnectionEStats(Row, EstatsType, Rw, RwVersion, RwSize, Offset) + else + Result := 0; +end; + +function GetPerTcp6ConnectionEStats(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Ros: PUCHAR; RosVersion: ULONG; + RosSize: ULONG; Rod: PUCHAR; RodVersion: ULONG; RodSize: ULONG): ULONG; +begin + if (CheckStubsLoaded) then + Result := _GetPerTcp6ConnectionEStats(Row, EstatsType, Rw, RwVersion, RwSize, Ros, + RosVersion, RosSize, Rod, RodVersion, RodSize) + else + Result := 0; +end; + +function SetPerTcp6ConnectionEStats(Row: PMIB_TCP6ROW; EstatsType: TCP_ESTATS_TYPE; + Rw: PUCHAR; RwVersion: ULONG; RwSize: ULONG; Offset: ULONG): ULONG; +begin + if (CheckStubsLoaded) then + Result := _SetPerTcp6ConnectionEStats(Row, EstatsType, Rw, RwVersion, RwSize, Offset) + else + Result := 0; +end; + +end. diff --git a/EvilWorks.Api.OpenSSL.pas b/EvilWorks.Api.OpenSSL.pas new file mode 100644 index 0000000..121fd26 --- /dev/null +++ b/EvilWorks.Api.OpenSSL.pas @@ -0,0 +1,416 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.Api.OpenSSL +// Description: Basic imports from OpenSSL library and a few helpers. +// File last change date: October 1st. 2012 +// File version: Dev 0.0.0 +// Licence: Free. +// + +unit EvilWorks.Api.OpenSSL; + +interface + +uses + Winapi.Windows, + EvilWorks.Api.Winsock2; + +const + ssleay32 = 'ssleay32.dll'; + libeay32 = 'libeay32.dll'; + +const + 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; + SSL_ERROR_ZERO_RETURN = 6; + SSL_ERROR_WANT_CONNECT = 7; + SSL_ERROR_WANT_ACCEPT = 8; + + SSL_ST_CONNECT = $1000; + SSL_ST_ACCEPT = $2000; + SSL_ST_MASK = $0FFF; + SSL_ST_INIT = SSL_ST_CONNECT or SSL_ST_ACCEPT; + SSL_ST_BEFORE = $4000; + SSL_ST_OK = $03; + SSL_ST_RENEGOTIATE = $04 or SSL_ST_INIT; + + SSL_OP_ALL = $80000BFF; + + SSL_OP_NO_SSLv2 = $01000000; + SSL_OP_NO_SSLv3 = $02000000; + SSL_OP_NO_TLSv1 = $04000000; + SSL_OP_NO_TLSv1_2 = $08000000; + SSL_OP_NO_TLSv1_1 = $10000000; + + SSL_CTRL_OPTIONS = 32; + SSL_CTRL_MODE = 33; + + SSL_MODE_AUTO_RETRY = $00000004; + + SSL_VERIFY_NONE = $00; + SSL_VERIFY_PEER = $01; + SSL_VERIFY_FAIL_IF_NO_PEER_CERT = $02; + SSL_VERIFY_CLIENT_ONCE = $04; + + X509_FILETYPE_PEM = 1; + X509_FILETYPE_ASN1 = 2; + X509_FILETYPE_DEFAULT = 3; + + SSL_FILETYPE_ASN1 = X509_FILETYPE_ASN1; + SSL_FILETYPE_PEM = X509_FILETYPE_PEM; + + BIO_NOCLOSE = $00; + BIO_CLOSE = $01; + + BIO_CTRL_RESET = 1; // opt - rewind/zero etc */ + BIO_CTRL_EOF = 2; // opt - are we at the eof */ + BIO_CTRL_INFO = 3; // opt - extra tit-bits */ + BIO_CTRL_SET = 4; // man - set the 'IO' type */ + BIO_CTRL_GET = 5; // man - get the 'IO' type */ + BIO_CTRL_PUSH = 6; // opt - internal, used to signify change */ + BIO_CTRL_POP = 7; // opt - internal, used to signify change */ + BIO_CTRL_GET_CLOSE = 8; // man - set the 'close' on free */ + BIO_CTRL_SET_CLOSE = 9; // man - set the 'close' on free */ + BIO_CTRL_PENDING = 10; // opt - is their more data buffered */ + BIO_CTRL_FLUSH = 11; // opt - 'flush' buffered output */ + BIO_CTRL_DUP = 12; // man - extra stuff for 'duped' BIO */ + BIO_CTRL_WPENDING = 13; // opt - number of bytes still to write */ + + BIO_FLAGS_READ = $01; + BIO_FLAGS_WRITE = $02; + BIO_FLAGS_IO_SPECIAL = $04; + BIO_FLAGS_RWS = BIO_FLAGS_READ or BIO_FLAGS_WRITE or BIO_FLAGS_IO_SPECIAL; + BIO_FLAGS_SHOULD_RETRY = $08; + + SSL_NOTHING = 1; + SSL_WRITING = 2; + SSL_READING = 3; + SSL_X509_LOOKUP = 4; + +type + // lol dem all pointers + SslPtr = Pointer; + PSSL = SslPtr; + PSSL_CTX = SslPtr; + PSSL_METHOD = SslPtr; + PBIO = SslPtr; + PBIO_METHOD = SslPtr; + X509 = SslPtr; + PX509 = ^X509; + X509_STORE_CTX = SslPtr; + X509_NAME = SslPtr; // record! + PSSL_CIPHER = SslPtr; + + TVerify_Callback = function(ok: integer; store: Pointer): integer; + +const + X509_V_OK = 0; + +function SSL_library_init: integer; cdecl; external ssleay32 name 'SSL_library_init'; +procedure SSL_load_error_strings; cdecl; external ssleay32 name 'SSL_load_error_strings'; +function SSL_state_string_long(const s: PSSL): pansichar; cdecl; external ssleay32 name 'SSL_state_string_long'; + +function SSL_new(pCTX: PSSL_CTX): PSSL; cdecl; external ssleay32 name 'SSL_new'; +procedure SSL_free(aSSL: PSSL); cdecl; external ssleay32 name 'SSL_free'; + +function SSL_state(const ssl: PSSL): integer; cdecl; external ssleay32 name 'SSL_state'; +function SSL_get_error(const s: PSSL; ret_code: integer): integer; cdecl; external ssleay32 name 'SSL_get_error'; + +function SSL_connect(ssl: PSSL): integer; cdecl; external ssleay32 name 'SSL_connect'; +function SSL_accept(ssl: PSSL): integer; cdecl; external ssleay32 name 'SSL_accept'; +function SSL_read(ssl: PSSL; buf: Pointer; num: integer): integer; cdecl; external ssleay32 name 'SSL_read'; +function SSL_write(ssl: PSSL; const buf: Pointer; num: integer): integer; cdecl; external ssleay32 name 'SSL_write'; +function SSL_pending(ssl: PSSL): integer; cdecl; external ssleay32 name 'SSL_pending'; +function SSL_shutdown(ssl: PSSL): integer; cdecl; external ssleay32 name 'SSL_shutdown'; +function SSL_peek(s: PSSL; buf: Pointer; num: integer): integer; cdecl; external ssleay32 name 'SSL_peek'; + +function SSL_set_fd(ssl: PSSL; fd: integer): integer; cdecl; external ssleay32 name 'SSL_set_fd'; +procedure SSL_set_connect_state(s: PSSL); cdecl; external ssleay32 name 'SSL_set_connect_state'; +procedure SSL_set_accept_state(s: PSSL); cdecl; external ssleay32 name 'SSL_set_accept_state'; +procedure SSL_set_bio(s: PSSL; rbio, wbio: PBIO); cdecl; external ssleay32 name 'SSL_set_bio'; +procedure SSL_set_shutdown(s: PSSL; mode: integer); cdecl; external ssleay32 name 'SSL_set_shutdown'; +function SSL_get_shutdown(s: PSSL): integer; cdecl; external ssleay32 name 'SSL_get_shutdown'; + +function SSL_want(const s: PSSL): integer; cdecl; external ssleay32 name 'SSL_want'; + +function SSL_get_peer_certificate(const ssl: PSSL): PX509; +cdecl external ssleay32 name 'SSL_get_peer_certificate'; + +function SSL_CTX_new(pMeth: PSSL_METHOD): PSSL_CTX; cdecl; external ssleay32 name 'SSL_CTX_new'; +procedure SSL_CTX_free(pCTX: PSSL_CTX); cdecl; external ssleay32 name 'SSL_CTX_free'; + +function SSL_CTX_ctrl(ctx: PSSL_CTX; cmd: integer; larg: LongInt; parg: Pointer): LongInt; cdecl; + external ssleay32 name 'SSL_CTX_ctrl'; +function SSL_CTX_set_cipher_list(ctx: PSSL_CTX; const str: pansichar): integer; cdecl; + external ssleay32 name 'SSL_CTX_set_cipher_list'; + +//procedure SSL_CTX_set_default_passwd_cb(ctx: PSSL_CTX, pem_password_cb * cb); cdecl; +// external ssleay32 name 'SSL_CTX_set_default_passwd_cb'; +//procedure SSL_CTX_set_default_passwd_cb_userdata(SSL_CTX * ctx, void * u); cdecl; +// external ssleay32 name 'SSL_CTX_set_default_passwd_cb_userdata'; + +procedure SSL_CTX_set_default_passwd_cb(ctx: PSSL_CTX; cb: pointer); cdecl; + external ssleay32 name 'SSL_CTX_set_default_passwd_cb'; +procedure SSL_CTX_set_default_passwd_cb_userdata(ctx: PSSL_CTX; u: pointer); cdecl; + external ssleay32 name 'SSL_CTX_set_default_passwd_cb_userdata'; + +procedure SSL_CTX_set_verify(ctx: PSSL_CTX; mode: integer; callback: TVerify_Callback); cdecl; + external ssleay32 name 'SSL_CTX_set_verify'; +procedure SSL_CTX_set_verify_depth(ctx: PSSL_CTX; depth: integer); cdecl; + external ssleay32 name 'SSL_CTX_set_verify_depth'; + +function SSL_CTX_use_RSAPrivateKey_file(ctx: PSSL_CTX; const filename: pansichar; typ: integer): integer; + cdecl; external ssleay32 name 'SSL_CTX_use_RSAPrivateKey_file'; +function SSL_CTX_use_certificate_file(pCTX: PSSL_CTX; const aFile: pansichar; typ: integer): integer; cdecl; + external ssleay32 name 'SSL_CTX_use_certificate_file'; +function SSL_CTX_load_verify_locations(ctx: PSSL_CTX; const CAFile, CAPath: pansichar): integer; cdecl; + external ssleay32 name 'SSL_CTX_load_verify_locations'; +function SSL_CTX_set_default_verify_paths(ctx: PSSL_CTX): integer; cdecl; + external ssleay32 name 'SSL_CTX_set_default_verify_paths'; +function SSL_CTX_use_certificate_chain_file(ctx: PSSL_CTX; const aFile: pansichar): integer; cdecl; + external ssleay32 name 'SSL_CTX_use_certificate_chain_file'; +function SSL_CTX_use_PrivateKey_file(ssl: PSSL; const aFile: pansichar; typ: integer): integer; cdecl; + external ssleay32 name 'SSL_CTX_use_PrivateKey_file'; +function SSL_CTX_check_private_key(const ctx: PSSL_CTX): integer; cdecl; + external ssleay32 name 'SSL_CTX_check_private_key'; + +function SSL_get_current_cipher(const s: PSSL): PSSL_CIPHER; cdecl; external ssleay32 name 'SSL_get_current_cipher'; +function SSL_CIPHER_get_name(const c: PSSL_CIPHER): pansichar; cdecl; external ssleay32 name 'SSL_CIPHER_get_name'; + +procedure SSL_set_verify_result(ssl: PSSL; v: long); cdecl; external ssleay32 name 'SSL_set_verify_result'; +function SSL_get_verify_result(ssl: PSSL): long; cdecl; external ssleay32 name 'SSL_get_verify_result'; + +function SSLv2_method: PSSL_METHOD; cdecl; external ssleay32 name 'SSLv2_method'; +function SSLv23_method: PSSL_METHOD; cdecl; external ssleay32 name 'SSLv23_method'; +function SSLv3_method: PSSL_METHOD; cdecl; external ssleay32 name 'SSLv3_method'; +function TLSv1_method: PSSL_METHOD; cdecl; external ssleay32 name 'TLSv1_method'; + +function BIO_new(b: PBIO_METHOD): PBIO; cdecl; external libeay32 name 'BIO_new'; +function BIO_new_socket(sock, close_flag: integer): PBIO; cdecl; external libeay32 name 'BIO_new_socket'; +function BIO_free(b: PBIO): integer; cdecl; external libeay32 name 'BIO_free'; + +function BIO_push(b: PBIO; append: PBIO): PBIO; cdecl; external libeay32 name 'BIO_push'; +function BIO_pop(b: PBIO): PBIO; cdecl; external libeay32 name 'BIO_pop'; + +function BIO_read(b: PBIO; buf: Pointer; len: integer): integer; cdecl; external libeay32 name 'BIO_read'; +function BIO_write(b: PBIO; const buf: Pointer; len: integer): integer; cdecl; external libeay32 name 'BIO_write'; +function BIO_ctrl(b: PBIO; cmd: integer; larg: long; parg: Pointer): long; cdecl; external libeay32 name 'BIO_ctrl'; + +function BIO_s_mem: PBIO_METHOD; cdecl; external libeay32 name 'BIO_s_mem'; +function BIO_s_socket: PBIO_METHOD; cdecl; external libeay32 name 'BIO_s_socket'; + +procedure BIO_set_flags(b: PBIO; flags: integer); cdecl; external libeay32 name 'BIO_set_flags'; +function BIO_test_flags(const b: PBIO; flags: integer): integer; cdecl; external libeay32 name 'BIO_test_flags'; +procedure BIO_clear_flags(b: PBIO; flags: integer); cdecl; external libeay32 name 'BIO_clear_flags'; + +function X509_STORE_CTX_get_current_cert(ctx: X509_STORE_CTX): X509; cdecl; + external libeay32 name 'X509_STORE_CTX_get_current_cert'; +function X509_STORE_CTX_get_error_depth(ctx: X509_STORE_CTX): integer; cdecl; + external libeay32 name 'X509_STORE_CTX_get_error_depth'; +function X509_STORE_CTX_get_error(ctx: X509_STORE_CTX): integer; cdecl; + external libeay32 name 'X509_STORE_CTX_get_error'; + +function X509_NAME_oneline(a: X509_NAME; buf: pansichar; size: integer): pansichar; cdecl; + external libeay32 name 'X509_NAME_oneline'; + +function X509_get_issuer_name(a: X509): X509_NAME; cdecl; external libeay32 name 'X509_get_issuer_name'; +function X509_get_subject_name(a: X509): X509_NAME; cdecl; external libeay32 name 'X509_get_issuer_name'; + +function X509_verify_cert_error_string(n: LongInt): pansichar; cdecl; + external libeay32 name 'X509_verify_cert_error_string'; + +procedure ERR_print_errors(bp: PBIO); cdecl; external libeay32 name 'ERR_print_errors'; +procedure ERR_print_errors_fp(aFilePointer: THandle); cdecl; external libeay32 name 'ERR_print_errors_fp'; + +procedure ERR_free_strings; cdecl; external libeay32 name 'ERR_free_strings'; +function ERR_get_error: LongInt; cdecl; external libeay32 name 'ERR_get_error'; +function ERR_error_string(e: LongInt; buf: pansichar): pansichar; cdecl; external libeay32 name 'ERR_error_string'; +procedure ERR_error_string_n(e: LongInt; buf: pansichar; len: longword); cdecl; external libeay32 name 'ERR_error_string_n'; + +function ERR_lib_error_string(e: LongInt): pansichar; cdecl; external libeay32 name 'ERR_lib_error_string'; +function ERR_func_error_string(e: LongInt): pansichar; cdecl; external libeay32 name 'ERR_func_error_string'; +function ERR_reason_error_string(e: LongInt): pansichar; cdecl; external libeay32 name 'ERR_reason_error_string'; + +procedure OPENSSL_add_all_algorithms_noconf; cdecl; external libeay32 name 'OPENSSL_add_all_algorithms_noconf'; +procedure OPENSSL_add_all_algorithms_conf; cdecl; external libeay32 name 'OPENSSL_add_all_algorithms_conf'; +procedure OpenSSL_add_all_digests; cdecl; external libeay32 name 'OpenSSL_add_all_digests'; +procedure OpenSSL_add_all_ciphers; cdecl; external libeay32 name 'OpenSSL_add_all_ciphers'; +procedure EVP_cleanup; cdecl; external libeay32 name 'EVP_cleanup'; + +procedure CRYPTO_free(p: Pointer); cdecl; external libeay32 name 'CRYPTO_free'; + +{ Macros } +function SSL_get_state(ssl: PSSL): integer; +function SSL_is_init_finished(ssl: PSSL): boolean; +function SSL_in_init(ssl: PSSL): boolean; +function SSL_in_before(ssl: PSSL): boolean; +function SSL_in_connect_init(ssl: PSSL): boolean; +function SSL_in_accept_init(ssl: PSSL): boolean; + +function SSL_want_nothing(const s: PSSL): boolean; +function SSL_want_read(const s: PSSL): boolean; +function SSL_want_write(const s: PSSL): boolean; +function SSL_want_x509_lookup(const s: PSSL): boolean; + +function BIO_pending(b: PBIO): integer; + +function BIO_should_read(const b: PBIO): integer; +function BIO_should_write(const b: PBIO): integer; +function BIO_should_io_special(const b: PBIO): integer; +function BIO_retry_type(const b: PBIO): integer; +function BIO_should_retry(const b: PBIO): integer; + +procedure OPENSSL_free(p: Pointer); + +function SSL_CTX_set_options(ctx: PSSL_CTX; op: LongInt): LongInt; + +{ ============================================================ } +{ ====================== Helper types ======================== } +{ ============================================================ } + +type + TSSLMethod = (smSSLv2, smSSLv23, smSSLv3, smTLSv1); + +{ ============================================================ } +{ ==================== Helper functions ====================== } +{ ============================================================ } + +{ Extra 'macros' } +function SSL_in_renegotiation(ssl: PSSL): boolean; + +{ Error functions } +function GetSSLErrorText(const aErr: integer): string; +function GetLastOpenSSLErrorText: string; + +implementation + +function SSL_get_state(ssl: PSSL): integer; +begin + Result := SSL_state(ssl); +end; + +function SSL_is_init_finished(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) = SSL_ST_OK); +end; + +function SSL_in_init(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) and SSL_ST_INIT <> 0); +end; + +function SSL_in_before(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) and SSL_ST_BEFORE <> 0); +end; + +function SSL_in_connect_init(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) and SSL_ST_CONNECT <> 0); +end; + +function SSL_in_accept_init(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) and SSL_ST_ACCEPT <> 0); +end; + +function SSL_want_nothing(const s: PSSL): boolean; +begin + Result := (SSL_want(s) = SSL_NOTHING); +end; + +function SSL_want_read(const s: PSSL): boolean; +begin + Result := (SSL_want(s) = SSL_READING); +end; + +function SSL_want_write(const s: PSSL): boolean; +begin + Result := (SSL_want(s) = SSL_WRITING); +end; + +function SSL_want_x509_lookup(const s: PSSL): boolean; +begin + Result := (SSL_want(s) = SSL_X509_LOOKUP); +end; + +function BIO_pending(b: PBIO): integer; +begin + Result := BIO_ctrl(b, BIO_CTRL_PENDING, 0, nil); +end; + +function BIO_should_read(const b: PBIO): integer; +begin + Result := BIO_test_flags(b, BIO_FLAGS_READ); +end; + +function BIO_should_write(const b: PBIO): integer; +begin + Result := BIO_test_flags(b, BIO_FLAGS_WRITE); +end; + +function BIO_should_io_special(const b: PBIO): integer; +begin + Result := BIO_test_flags(b, BIO_FLAGS_IO_SPECIAL); +end; + +function BIO_retry_type(const b: PBIO): integer; +begin + Result := BIO_test_flags(b, BIO_FLAGS_RWS); +end; + +function BIO_should_retry(const b: PBIO): integer; +begin + Result := BIO_test_flags(b, BIO_FLAGS_SHOULD_RETRY); +end; + +procedure OPENSSL_free(p: Pointer); +begin + CRYPTO_free(p); +end; + +function SSL_CTX_set_options(ctx: PSSL_CTX; op: LongInt): LongInt; +begin + Result := SSL_CTX_ctrl(ctx, SSL_CTRL_OPTIONS, op, nil); +end; + +function SSL_in_renegotiation(ssl: PSSL): boolean; +begin + Result := (SSL_state(ssl) and SSL_ST_RENEGOTIATE <> 0); +end; + +function GetLastOpenSSLErrorText: string; +begin + Result := string(ERR_error_string(ERR_get_error, nil)); +end; + +function GetSSLErrorText(const aErr: integer): string; +begin + case aErr of + SSL_ERROR_NONE: + Result := 'SSL_ERROR_NONE'; + SSL_ERROR_SSL: + Result := 'SSL_ERROR_SSL'; + SSL_ERROR_WANT_READ: + Result := 'SSL_ERROR_WANT_READ'; + SSL_ERROR_WANT_WRITE: + Result := 'SSL_ERROR_WANT_WRITE'; + SSL_ERROR_WANT_X509_LOOKUP: + Result := 'SSL_ERROR_WANT_X509_LOOKUP'; + SSL_ERROR_SYSCALL: + Result := 'SSL_ERROR_SYSCALL'; + SSL_ERROR_ZERO_RETURN: + Result := 'SSL_ERROR_ZERO_RETURN'; + SSL_ERROR_WANT_CONNECT: + Result := 'SSL_ERROR_WANT_CONNECT'; + SSL_ERROR_WANT_ACCEPT: + Result := 'SSL_ERROR_WANT_ACCEPT'; + end; +end; + +end. diff --git a/EvilWorks.Api.PowrProf.pas b/EvilWorks.Api.PowrProf.pas new file mode 100644 index 0000000..bba6dcf --- /dev/null +++ b/EvilWorks.Api.PowrProf.pas @@ -0,0 +1,72 @@ +unit EvilWorks.Api.PowrProf; + +interface + +uses + WinApi.Windows; + +type + +{$EXTERNALSYM POWER_DATA_ACCESSOR} + POWER_DATA_ACCESSOR = ( + // Used by read/write and enumeration engines + ACCESS_AC_POWER_SETTING_INDEX = 0, + ACCESS_DC_POWER_SETTING_INDEX, + ACCESS_FRIENDLY_NAME, + ACCESS_DESCRIPTION, + ACCESS_POSSIBLE_POWER_SETTING, + ACCESS_POSSIBLE_POWER_SETTING_FRIENDLY_NAME, + ACCESS_POSSIBLE_POWER_SETTING_DESCRIPTION, + ACCESS_DEFAULT_AC_POWER_SETTING, + ACCESS_DEFAULT_DC_POWER_SETTING, + ACCESS_POSSIBLE_VALUE_MIN, + ACCESS_POSSIBLE_VALUE_MAX, + ACCESS_POSSIBLE_VALUE_INCREMENT, + ACCESS_POSSIBLE_VALUE_UNITS, + ACCESS_ICON_RESOURCE, + ACCESS_DEFAULT_SECURITY_DESCRIPTOR, + ACCESS_ATTRIBUTES, + + // Used by enumeration engine. + ACCESS_SCHEME, + ACCESS_SUBGROUP, + ACCESS_INDIVIDUAL_SETTING, + + // Used by access check + ACCESS_ACTIVE_SCHEME, + ACCESS_CREATE_SCHEME, + + // Used by override ranges. + ACCESS_AC_POWER_SETTING_MAX, + ACCESS_DC_POWER_SETTING_MAX, + ACCESS_AC_POWER_SETTING_MIN, + ACCESS_DC_POWER_SETTING_MIN + + ); + PPOWER_DATA_ACCESSOR = ^POWER_DATA_ACCESSOR; + +const + powrproflib = 'powrprof.dll'; + +{$EXTERNALSYM PowerEnumerate} +function PowerEnumerate(RootPowerKey: HKEY; + SchemeGuid: PGUID; + SubGroupOfPowerSettingsGuid: PGUID; + AccessFlags: POWER_DATA_ACCESSOR; + Index: ULONG; + Buffer: PUCHAR; + var BufferSize: DWORD + ): DWORD; stdcall; external powrproflib name 'PowerEnumerate'; + +{$EXTERNALSYM PowerReadFriendlyName} +function PowerReadFriendlyName(RootPowerKey: HKEY; + SchemeGuid: PGUID; + SubGroupOfPowerSettingsGuid: PGUID; + PowerSettingGuid: PGUID; + Buffer: PUCHAR; + var BufferSize: DWORD + ): DWORD; stdcall; external powrproflib name 'PowerReadFriendlyName'; + +implementation + +end. diff --git a/EvilWorks.Api.TcpEStats.pas b/EvilWorks.Api.TcpEStats.pas new file mode 100644 index 0000000..ca2c20e --- /dev/null +++ b/EvilWorks.Api.TcpEStats.pas @@ -0,0 +1,364 @@ +unit EvilWorks.Api.TcpEStats; + +interface + +uses + WinApi.Windows; + +type + + // + // Please don't change the order of this enum. The order defined in this + // enum needs to match the order in EstatsToTcpObjectMappingTable. + // + + TCP_ESTATS_TYPE = ( + TcpConnectionEstatsSynOpts, + TcpConnectionEstatsData, + TcpConnectionEstatsSndCong, + TcpConnectionEstatsPath, + TcpConnectionEstatsSendBuff, + TcpConnectionEstatsRec, + TcpConnectionEstatsObsRec, + TcpConnectionEstatsBandwidth, + TcpConnectionEstatsFineRtt, + TcpConnectionEstatsMaximum + ); + PTCP_ESTATS_TYPE = ^TCP_ESTATS_TYPE; + + // + // TCP_BOOLEAN_OPTIONAL + // + // Define the states that a caller can specify when updating a boolean field. + // + + TCP_BOOLEAN_OPTIONAL = ( + TcpBoolOptDisabled = 0, + TcpBoolOptEnabled, + TcpBoolOptUnchanged = - 1 + ); + PTCP_BOOLEAN_OPTIONAL = ^TCP_BOOLEAN_OPTIONAL; + + // + // TCP_ESTATS_SYN_OPTS_ROS + // + // Define extended SYN-exchange information maintained for TCP connections. + // + + TCP_ESTATS_SYN_OPTS_ROS_v0 = record + ActiveOpen: BOOLEAN; + MssRcvd: ULONG; + MssSent: ULONG; + end; + PTCP_ESTATS_SYN_OPTS_ROS_v0 = ^TCP_ESTATS_SYN_OPTS_ROS_v0; + + // + // TCP_SOFT_ERROR + // + // Enumerate the non-fatal errors recorded on each connection. + // + + TCP_SOFT_ERROR = ( + TcpErrorNone = 0, + TcpErrorBelowDataWindow, + TcpErrorAboveDataWindow, + TcpErrorBelowAckWindow, + TcpErrorAboveAckWindow, + TcpErrorBelowTsWindow, + TcpErrorAboveTsWindow, + TcpErrorDataChecksumError, + TcpErrorDataLengthError, + TcpErrorMaxSoftError + ); + PTCP_SOFT_ERROR = ^TCP_SOFT_ERROR; + + // + // TCP_ESTATS_DATA_ROD + // + // Define extended data-transfer information for TCP connections. + // + + TCP_ESTATS_DATA_ROD_v0 = record + DataBytesOut: ULONG64; + DataSegsOut: ULONG64; + DataBytesIn: ULONG64; + DataSegsIn: ULONG64; + SegsOut: ULONG64; + SegsIn: ULONG64; + SoftErrors: ULONG; + SoftErrorReason: ULONG; + SndUna: ULONG; + SndNxt: ULONG; + SndMax: ULONG; + ThruBytesAcked: ULONG64; + RcvNext: ULONG; + ThruBytesReceived: ULONG64; + end; + PTCP_ESTATS_DATA_ROD_v0 = ^TCP_ESTATS_DATA_ROD_v0; + + // + // TCP_ESTATS_DATA_RW + // + // Define structure for enabling extended data-transfer information. + // + + TCP_ESTATS_DATA_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_DATA_RW_v0 = ^TCP_ESTATS_DATA_RW_v0; + + // + // TCP_ESTATS_SND_CONG_ROD + // + // Define extended sender-congestion information for TCP connections. + // + + TCP_ESTATS_SND_CONG_ROD_v0 = record + SndLimTransRwin: ULONG; + SndLimTimeRwin: ULONG; + SndLimBytesRwin: SIZE_T; + SndLimTransCwnd: ULONG; + SndLimTimeCwnd: ULONG; + SndLimBytesCwnd: SIZE_T; + SndLimTransSnd: ULONG; + SndLimTimeSnd: ULONG; + SndLimBytesSnd: SIZE_T; + SlowStart: ULONG; + CongAvoid: ULONG; + OtherReductions: ULONG; + CurCwnd: ULONG; + MaxSsCwnd: ULONG; + MaxCaCwnd: ULONG; + CurSsthresh: ULONG; + MaxSsthresh: ULONG; + MinSsthresh: ULONG; + end; + PTCP_ESTATS_SND_CONG_ROD_v0 = ^TCP_ESTATS_SND_CONG_ROD_v0; + + // + // TCP_ESTATS_SND_CONG_ROS + // + // Define static extended sender-congestion information for TCP connections. + + TCP_ESTATS_SND_CONG_ROS_v0 = record + LimCwnd: ULONG; + end; + PTCP_ESTATS_SND_CONG_ROS_v0 = ^TCP_ESTATS_SND_CONG_ROS_v0; + + // + // TCP_ESTATS_SND_CONG_RW + // + // Define structure for enabling extended sender-congestion information. + // + + TCP_ESTATS_SND_CONG_RW = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_SND_CONG_RW = ^TCP_ESTATS_SND_CONG_RW; + + // + // TCP_ESTATS_PATH_ROD + // + // Define extended path-measurement information for TCP connections. + // + + TCP_ESTATS_PATH_ROD_v0 = record + FastRetran: ULONG; + Timeouts: ULONG; + SubsequentTimeouts: ULONG; + CurTimeoutCount: ULONG; + AbruptTimeouts: ULONG; + PktsRetrans: ULONG; + BytesRetrans: ULONG; + DupAcksIn: ULONG; + SacksRcvd: ULONG; + SackBlocksRcvd: ULONG; + CongSignals: ULONG; + PreCongSumCwnd: ULONG; + PreCongSumRtt: ULONG; + PostCongSumRtt: ULONG; + PostCongCountRtt: ULONG; + EcnSignals: ULONG; + EceRcvd: ULONG; + SendStall: ULONG; + QuenchRcvd: ULONG; + RetranThresh: ULONG; + SndDupAckEpisodes: ULONG; + SumBytesReordered: ULONG; + NonRecovDa: ULONG; + NonRecovDaEpisodes: ULONG; + AckAfterFr: ULONG; + DsackDups: ULONG; + SampleRtt: ULONG; + SmoothedRtt: ULONG; + RttVar: ULONG; + MaxRtt: ULONG; + MinRtt: ULONG; + SumRtt: ULONG; + CountRtt: ULONG; + CurRto: ULONG; + MaxRto: ULONG; + MinRto: ULONG; + CurMss: ULONG; + MaxMss: ULONG; + MinMss: ULONG; + SpuriousRtoDetections: ULONG; + + end; + PTCP_ESTATS_PATH_ROD_v0 = ^TCP_ESTATS_PATH_ROD_v0; + + // + // TCP_ESTATS_PATH_ROS + // + // Define structure for enabling path-measurement information. + // + + TCP_ESTATS_PATH_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_PATH_RW_v0 = ^TCP_ESTATS_PATH_RW_v0; + + // + // TCP_ESTATS_SEND_BUFF_ROD + // + // Define extended output-queuing information for TCP connections. + // + + TCP_ESTATS_SEND_BUFF_ROD_v0 = record + CurRetxQueue: SIZE_T; + MaxRetxQueue: SIZE_T; + CurAppWQueue: SIZE_T; + MaxAppWQueue: SIZE_T; + end; + PTCP_ESTATS_SEND_BUFF_ROD_v0 = ^TCP_ESTATS_SEND_BUFF_ROD_v0; + + // + // TCP_ESTATS_SEND_BUFF_RW + // + // Define structure for enabling output-queuing information. + // + + TCP_ESTATS_SEND_BUFF_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_SEND_BUFF_RW_v0 = ^TCP_ESTATS_SEND_BUFF_RW_v0; + + // + // TCP_ESTATS_REC_ROD + // + // Define extended local-receiver information for TCP connections. + // + + TCP_ESTATS_REC_ROD_v0 = record + CurRwinSent: ULONG; + MaxRwinSent: ULONG; + MinRwinSent: ULONG; + LimRwin: ULONG; + DupAckEpisodes: ULONG; + DupAcksOut: ULONG; + CeRcvd: ULONG; + EcnSent: ULONG; + EcnNoncesRcvd: ULONG; + CurReasmQueue: ULONG; + MaxReasmQueue: ULONG; + CurAppRQueue: SIZE_T; + MaxAppRQueue: SIZE_T; + WinScaleSent: UCHAR; + end; + PTCP_ESTATS_REC_ROD_v0 = ^TCP_ESTATS_REC_ROD_v0; + + // + // TCP_ESTATS_REC_RW + // + // Define structure for enabling local-receiver information. + // + + TCP_ESTATS_REC_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_REC_RW_v0 = ^TCP_ESTATS_REC_RW_v0; + + // + // TCP_ESTATS_OBS_REC_ROD + // + // Define extended remote-receiver information for TCP connections. + // + + TCP_ESTATS_OBS_REC_ROD_v0 = record + CurRwinRcvd: ULONG; + MaxRwinRcvd: ULONG; + MinRwinRcvd: ULONG; + WinScaleRcvd: UCHAR; + end; + PTCP_ESTATS_OBS_REC_ROD_v0 = ^TCP_ESTATS_OBS_REC_ROD_v0; + + // + // TCP_ESTATS_OBS_REC_RW + // + // Define structure for enabling remote-receiver information. + // + + TCP_ESTATS_OBS_REC_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_OBS_REC_RW_v0 = ^TCP_ESTATS_OBS_REC_RW_v0; + + // + // TCP_ESTATS_BW_RW + // + // Define the structure for enabling bandwidth estimation for TCP connections. + // + + TCP_ESTATS_BANDWIDTH_RW_v0 = record + EnableCollectionOutbound: TCP_BOOLEAN_OPTIONAL; + EnableCollectionInbound: TCP_BOOLEAN_OPTIONAL; + end; + PTCP_ESTATS_BANDWIDTH_RW_v0 = ^TCP_ESTATS_BANDWIDTH_RW_v0; + + // + // TCP_ESTATS_BW_ROD + // + // Define bandwidth estimation statistics for TCP connections. + // + // Bandwidth and Instability metrics are expressed as bits per second. + // + + TCP_ESTATS_BANDWIDTH_ROD_v0 = record + OutboundBandwidth: ULONG64; + InboundBandwidth: ULONG64; + OutboundInstability: ULONG64; + InboundInstability: ULONG64; + OutboundBandwidthPeaked: BOOLEAN; + InboundBandwidthPeaked: BOOLEAN; + end; + PTCP_ESTATS_BANDWIDTH_ROD_v0 = ^TCP_ESTATS_BANDWIDTH_ROD_v0; + + // + // TCP_ESTATS_FINE_RTT_RW + // + // Define the structure for enabling fine-grained RTT estimation for TCP + // connections. + // + + TCP_ESTATS_FINE_RTT_RW_v0 = record + EnableCollection: BOOLEAN; + end; + PTCP_ESTATS_FINE_RTT_RW_v0 = ^TCP_ESTATS_FINE_RTT_RW_v0; + + // + // TCP_ESTATS_FINE_RTT_ROD + // + // Define fine-grained RTT estimation statistics for TCP connections. + // + + TCP_ESTATS_FINE_RTT_ROD_v0 = record + RttVar: ULONG; + MaxRtt: ULONG; + MinRtt: ULONG; + SumRtt: ULONG; + end; + PTCP_ESTATS_FINE_RTT_ROD_v0 = ^TCP_ESTATS_FINE_RTT_ROD_v0; + +implementation + +end. diff --git a/EvilWorks.Api.WinPCap.Bpf.pas b/EvilWorks.Api.WinPCap.Bpf.pas new file mode 100644 index 0000000..0faf0d8 --- /dev/null +++ b/EvilWorks.Api.WinPCap.Bpf.pas @@ -0,0 +1,922 @@ +unit EvilWorks.Api.WinPCap.Bpf; + +// Translated from v1.4.2.11 + +interface + +uses + WinApi.Windows, + EvilWorks.Api.Winsock2; // you can remove this and use WinApi.Winsock instead. Required for u_int, etc + +type + bpf_int32 = integer; + bpf_u_int32 = u_int; + pbpf_u_int32 = ^bpf_u_int32; + +const + BPF_MAXBUFSIZE = $8000; + BPF_MINBUFSIZE = 32; + + // Current version number of filter architecture. + BPF_MAJOR_VERSION = 1; + BPF_MINOR_VERSION = 1; + + // + // Alignment macros. BPF_WORDALIGN rounds up to the next + // even multiple of BPF_ALIGNMENT. + // + BPF_ALIGNMENT = sizeof(bpf_int32); + + // + // Number of scratch memory words (for BPF_LD|BPF_MEM and BPF_ST). + // + BPF_MEMWORDS = 16; + +function BPF_WORDALIGN(x: integer): integer; + +type + + // + // The instruction data structure. + // + pbpf_insn = ^bpf_insn; + + bpf_insn = record + code: u_short; + jt: u_char; + jf: u_char; + k: bpf_u_int32; + end; + + // + // Structure for "pcap_compile()", "pcap_setfilter()", etc.. + // + + { bpf_program } + pbpf_program = ^bpf_program; + + bpf_program = record + bf_len: u_int; + bf_insns: pbpf_insn; + end; + + // + // Struct return by BIOCVERSION. This represents the version number of + // the filter language described by the instruction encodings below. + // bpf understands a program iff kernel_major == filter_major && + // kernel_minor >= filter_minor, that is, if the value returned by the + // running kernel has the same major number and a minor number equal + // equal to or less than the filter being downloaded. Otherwise, the + // results are undefined, meaning an error may be returned or packets + // may be accepted haphazardly. + // It has nothing to do with the source code version. + // + { bpf_version } + pbpf_version = ^bpf_version; + + bpf_version = record + bv_major: u_short; + bv_minor: u_short; + end; + +const + + // + // Data-link level type codes. + // + // Do//NOT* add new values to this list without asking + // "tcpdump-workers@lists.tcpdump.org" for a value. Otherwise, you run + // the risk of using a value that's already being used for some other + // purpose, and of having tools that read libpcap-format captures not + // being able to handle captures with your new DLT_ value, with no hope + // that they will ever be changed to do so (as that would destroy their + // ability to read captures using that value for that other purpose). + // + + // + // These are the types that are the same on all platforms, and that + // have been defined by for ages. + // + DLT_NULL = 0; // BSD loopback encapsulation// + DLT_EN10MB = 1; // Ethernet (10Mb)// + DLT_EN3MB = 2; // Experimental Ethernet (3Mb)// + DLT_AX25 = 3; // Amateur Radio AX.25// + DLT_PRONET = 4; // Proteon ProNET Token Ring// + DLT_CHAOS = 5; // Chaos// + DLT_IEEE802 = 6; // 802.5 Token Ring// + DLT_ARCNET = 7; // ARCNET, with BSD-style header// + DLT_SLIP = 8; // Serial Line IP// + DLT_PPP = 9; // Point-to-point Protocol// + DLT_FDDI = 10; // FDDI// + + // + // These are types that are different on some platforms, and that + // have been defined by for ages. We use #ifdefs to + // detect the BSDs that define them differently from the traditional + // libpcap + // + // XXX - DLT_ATM_RFC1483 is 13 in BSD/OS, and DLT_RAW is 14 in BSD/OS, + // but I don't know what the right #define is for BSD/OS. + // + DLT_ATM_RFC1483 = 11; // LLC-encapsulated ATM + DLT_RAW = 12; // raw IP + + // + // Given that the only OS that currently generates BSD/OS SLIP or PPP + // is, well, BSD/OS, arguably everybody should have chosen its values + // for DLT_SLIP_BSDOS and DLT_PPP_BSDOS, which are 15 and 16, but they + // didn't. So it goes. + // + DLT_SLIP_BSDOS = 15; // BSD/OS Serial Line IP// + DLT_PPP_BSDOS = 16; // BSD/OS Point-to-point Protocol// + // + // 17 is used for DLT_OLD_PFLOG in OpenBSD; + // OBSOLETE: DLT_PFLOG is 117 in OpenBSD now as well. See below. + // 18 is used for DLT_PFSYNC in OpenBSD; don't use it for anything else. + // + + DLT_ATM_CLIP = 19; // Linux Classical-IP over ATM// + + // + // Apparently Redback uses this for its SmartEdge 400/800. I hope + // nobody else decided to use it, too. + // + DLT_REDBACK_SMARTEDGE = 32; + + // + // These values are defined by NetBSD; other platforms should refrain from + // using them for other purposes, so that NetBSD savefiles with link + // types of 50 or 51 can be read as this type on all platforms. + // + DLT_PPP_SERIAL = 50; // PPP over serial with HDLC encapsulation// + DLT_PPP_ETHER = 51; // PPP over Ethernet// + + // + // The Axent Raptor firewall - now the Symantec Enterprise Firewall - uses + // a link-layer type of 99 for the tcpdump it supplies. The link-layer + // header has 6 bytes of unknown data, something that appears to be an + // Ethernet type, and 36 bytes that appear to be 0 in at least one capture + // I've seen. + // + DLT_SYMANTEC_FIREWALL = 99; + + // + // Values between 100 and 103 are used in capture file headers as + // link-layer types corresponding to DLT_ types that differ + // between platforms; don't use those values for new DLT_ new types. + // + + // + // This value was defined by libpcap 0.5; platforms that have defined + // it with a different value should define it here with that value - + // a link type of 104 in a save file will be mapped to DLT_C_HDLC, + // whatever value that happens to be, so programs will correctly + // handle files with that link type regardless of the value of + // DLT_C_HDLC. + // + // The name DLT_C_HDLC was used by BSD/OS; we use that name for source + // compatibility with programs written for BSD/OS. + // + // libpcap 0.5 defined it as DLT_CHDLC; we define DLT_CHDLC as well, + // for source compatibility with programs written for libpcap 0.5. + // + DLT_C_HDLC = 104; // Cisco HDLC// + DLT_CHDLC = DLT_C_HDLC; + + DLT_IEEE802_11 = 105; // IEEE 802.11 wireless// + + // + // 106 is reserved for Linux Classical IP over ATM; it's like DLT_RAW, + // except when it isn't. (I.e., sometimes it's just raw IP, and + // sometimes it isn't.) We currently handle it as DLT_LINUX_SLL, + // so that we don't have to worry about the link-layer header.) + // + + // + // Frame Relay; BSD/OS has a DLT_FR with a value of 11, but that collides + // with other values. + // DLT_FR and DLT_FRELAY packets start with the Q.922 Frame Relay header + // (DLCI, etc.). + // + DLT_FRELAY = 107; + + // + // OpenBSD DLT_LOOP, for loopback devices; it's like DLT_NULL, except + // that the AF_ type in the link-layer header is in network byte order. + // + // DLT_LOOP is 12 in OpenBSD, but that's DLT_RAW in other OSes, so + // we don't use 12 for it in OSes other than OpenBSD. + // + DLT_LOOP = 108; + + // + // Encapsulated packets for IPsec; DLT_ENC is 13 in OpenBSD, but that's + // DLT_SLIP_BSDOS in NetBSD, so we don't use 13 for it in OSes other + // than OpenBSD. + // + DLT_ENC = 109; + + // + // Values between 110 and 112 are reserved for use in capture file headers + // as link-layer types corresponding to DLT_ types that might differ + // between platforms; don't use those values for new DLT_ types + // other than the corresponding DLT_ types. + // + + // + // This is for Linux cooked sockets. + // + DLT_LINUX_SLL = 113; + + // + // Apple LocalTalk hardware. + // + DLT_LTALK = 114; + + // + // Acorn Econet. + // + DLT_ECONET = 115; + + // + // Reserved for use with OpenBSD ipfilter. + // + DLT_IPFILTER = 116; + + // + // OpenBSD DLT_PFLOG; DLT_PFLOG is 17 in OpenBSD, but that's DLT_LANE8023 + // in SuSE 6.3, so we can't use 17 for it in capture-file headers. + // + // XXX: is there a conflict with DLT_PFSYNC 18 as well? + // + DLT_PFLOG = 117; + + // + // Registered for Cisco-internal use. + // + DLT_CISCO_IOS = 118; + + // + // For 802.11 cards using the Prism II chips, with a link-layer + // header including Prism monitor mode information plus an 802.11 + // header. + // + DLT_PRISM_HEADER = 119; + + // + // Reserved for Aironet 802.11 cards, with an Aironet link-layer header + // (see Doug Ambrisko's FreeBSD patches). + // + DLT_AIRONET_HEADER = 120; + + // + // Reserved for Siemens HiPath HDLC. + // + DLT_HHDLC = 121; + + // + // This is for RFC 2625 IP-over-Fibre Channel. + // + // This is not for use with raw Fibre Channel, where the link-layer + // header starts with a Fibre Channel frame header; it's for IP-over-FC, + // where the link-layer header starts with an RFC 2625 Network_Header + // field. + // + DLT_IP_OVER_FC = 122; + + // + // This is for Full Frontal ATM on Solaris with SunATM, with a + // pseudo-header followed by an AALn PDU. + // + // There may be other forms of Full Frontal ATM on other OSes, + // with different pseudo-headers. + // + // If ATM software returns a pseudo-header with VPI/VCI information + // (and, ideally, packet type information, e.g. signalling, ILMI, + // LANE, LLC-multiplexed traffic, etc.), it should not use + // DLT_ATM_RFC1483, but should get a new DLT_ value, so tcpdump + // and the like don't have to infer the presence or absence of a + // pseudo-header and the form of the pseudo-header. + // + DLT_SUNATM = 123; // Solaris+SunATM// + + // + // Reserved as per request from Kent Dahlgren + // for private use. + // + DLT_RIO = 124; // RapidIO// + DLT_PCI_EXP = 125; // PCI Express// + DLT_AURORA = 126; // Xilinx Aurora link layer// + + // + // Header for 802.11 plus a number of bits of link-layer information + // including radio information, used by some recent BSD drivers as + // well as the madwifi Atheros driver for Linux. + // + DLT_IEEE802_11_RADIO = 127; // 802.11 plus radiotap radio header// + + // + // Reserved for the TZSP encapsulation, as per request from + // Chris Waters + // TZSP is a generic encapsulation for any other link type, + // which includes a means to include meta-information + // with the packet, e.g. signal strength and channel + // for 802.11 packets. + // + DLT_TZSP = 128; // Tazmen Sniffer Protocol// + + // + // BSD's ARCNET headers have the source host, destination host, + // and type at the beginning of the packet; that's what's handed + // up to userland via BPF. + // + // Linux's ARCNET headers, however, have a 2-byte offset field + // between the host IDs and the type; that's what's handed up + // to userland via PF_PACKET sockets. + // + // We therefore have to have separate DLT_ values for them. + // + DLT_ARCNET_LINUX = 129; // ARCNET// + + // + // Juniper-private data link types, as per request from + // Hannes Gredler . The DLT_s are used + // for passing on chassis-internal metainformation such as + // QOS profiles, etc.. + // + DLT_JUNIPER_MLPPP = 130; + DLT_JUNIPER_MLFR = 131; + DLT_JUNIPER_ES = 132; + DLT_JUNIPER_GGSN = 133; + DLT_JUNIPER_MFR = 134; + DLT_JUNIPER_ATM2 = 135; + DLT_JUNIPER_SERVICES = 136; + DLT_JUNIPER_ATM1 = 137; + + // + // Apple IP-over-IEEE 1394, as per a request from Dieter Siegmund + // . The header that's presented is an Ethernet-like + // header: + // + // FIREWIRE_EUI64_LEN = 8; + // struct firewire_header { + // u_char firewire_dhost[FIREWIRE_EUI64_LEN]; + // u_char firewire_shost[FIREWIRE_EUI64_LEN]; + // u_short firewire_type; + // }; + // + // with "firewire_type" being an Ethernet type value, rather than, + // for example, raw GASP frames being handed up. + // + DLT_APPLE_IP_OVER_IEEE1394 = 138; + + // + // Various SS7 encapsulations, as per a request from Jeff Morriss + // and subsequent discussions. + // + DLT_MTP2_WITH_PHDR = 139; // pseudo-header with various info, followed by MTP2// + DLT_MTP2 = 140; // MTP2, without pseudo-header// + DLT_MTP3 = 141; // MTP3, without pseudo-header or MTP2// + DLT_SCCP = 142; // SCCP, without pseudo-header or MTP2 or MTP3// + + // + // DOCSIS MAC frames. + // + DLT_DOCSIS = 143; + + // + // Linux-IrDA packets. Protocol defined at http://www.irda.org. + // Those packets include IrLAP headers and above (IrLMP...), but + // don't include Phy framing (SOF/EOF/CRC & byte stuffing), because Phy + // framing can be handled by the hardware and depend on the bitrate. + // This is exactly the format you would get capturing on a Linux-IrDA + // interface (irdaX), but not on a raw serial port. + // Note the capture is done in "Linux-cooked" mode, so each packet include + // a fake packet header (struct sll_header). This is because IrDA packet + // decoding is dependant on the direction of the packet (incomming or + // outgoing). + // When/if other platform implement IrDA capture, we may revisit the + // issue and define a real DLT_IRDA... + // Jean II + // + DLT_LINUX_IRDA = 144; + + // + // Reserved for IBM SP switch and IBM Next Federation switch. + // + DLT_IBM_SP = 145; + DLT_IBM_SN = 146; + + // + // Reserved for private use. If you have some link-layer header type + // that you want to use within your organization, with the capture files + // using that link-layer header type not ever be sent outside your + // organization, you can use these values. + // + // No libpcap release will use these for any purpose, nor will any + // tcpdump release use them, either. + // + // Do//NOT* use these in capture files that you expect anybody not using + // your private versions of capture-file-reading tools to read; in + // particular, do//NOT* use them in products, otherwise you may find that + // people won't be able to use tcpdump, or snort, or Ethereal, or... to + // read capture files from your firewall/intrusion detection/traffic + // monitoring/etc. appliance, or whatever product uses that DLT_ value, + // and you may also find that the developers of those applications will + // not accept patches to let them read those files. + // + // Also, do not use them if somebody might send you a capture using them + // for//their* private type and tools using them for//your* private type + // would have to read them. + // + // Instead, ask "tcpdump-workers@lists.tcpdump.org" for a new DLT_ value, + // as per the comment above, and use the type you're given. + // + DLT_USER0 = 147; + DLT_USER1 = 148; + DLT_USER2 = 149; + DLT_USER3 = 150; + DLT_USER4 = 151; + DLT_USER5 = 152; + DLT_USER6 = 153; + DLT_USER7 = 154; + DLT_USER8 = 155; + DLT_USER9 = 156; + DLT_USER10 = 157; + DLT_USER11 = 158; + DLT_USER12 = 159; + DLT_USER13 = 160; + DLT_USER14 = 161; + DLT_USER15 = 162; + + // + // For future use with 802.11 captures - defined by AbsoluteValue + // Systems to store a number of bits of link-layer information + // including radio information: + // + // http://www.shaftnet.org/~pizza/software/capturefrm.txt + // + // but it might be used by some non-AVS drivers now or in the + // future. + // + DLT_IEEE802_11_RADIO_AVS = 163; // 802.11 plus AVS radio header// + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . The DLT_s are used + // for passing on chassis-internal metainformation such as + // QOS profiles, etc.. + // + DLT_JUNIPER_MONITOR = 164; + + // + // Reserved for BACnet MS/TP. + // + DLT_BACNET_MS_TP = 165; + + // + // Another PPP variant as per request from Karsten Keil . + // + // This is used in some OSes to allow a kernel socket filter to distinguish + // between incoming and outgoing packets, on a socket intended to + // supply pppd with outgoing packets so it can do dial-on-demand and + // hangup-on-lack-of-demand; incoming packets are filtered out so they + // don't cause pppd to hold the connection up (you don't want random + // input packets such as port scans, packets from old lost connections, + // etc. to force the connection to stay up). + // + // The first byte of the PPP header (0xff03) is modified to accomodate + // the direction - 0x00 = IN, 0x01 = OUT. + // + DLT_PPP_PPPD = 166; + + // + // Names for backwards compatibility with older versions of some PPP + // software; new software should use DLT_PPP_PPPD. + // + DLT_PPP_WITH_DIRECTION = DLT_PPP_PPPD; + DLT_LINUX_PPP_WITHDIRECTION = DLT_PPP_PPPD; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . The DLT_s are used + // for passing on chassis-internal metainformation such as + // QOS profiles, cookies, etc.. + // + DLT_JUNIPER_PPPOE = 167; + DLT_JUNIPER_PPPOE_ATM = 168; + + DLT_GPRS_LLC = 169; // GPRS LLC// + DLT_GPF_T = 170; // GPF-T (ITU-T G.7041/Y.1303)// + DLT_GPF_F = 171; // GPF-F (ITU-T G.7041/Y.1303)// + + // + // Requested by Oolan Zimmer for use in Gcom's T1/E1 line + // monitoring equipment. + // + DLT_GCOM_T1E1 = 172; + DLT_GCOM_SERIAL = 173; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . The DLT_ is used + // for internal communication to Physical Interface Cards (PIC) + // + DLT_JUNIPER_PIC_PEER = 174; + + // + // Link types requested by Gregor Maier of Endace + // Measurement Systems. They add an ERF header (see + // http://www.endace.com/support/EndaceRecordFormat.pdf) in front of + // the link-layer header. + // + DLT_ERF_ETH = 175; // Ethernet// + DLT_ERF_POS = 176; // Packet-over-SONET// + + // + // Requested by Daniele Orlandi for raw LAPD + // for vISDN (http://www.orlandi.com/visdn/). Its link-layer header + // includes additional information before the LAPD header, so it's + // not necessarily a generic LAPD header. + // + DLT_LINUX_LAPD = 177; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . + // The DLT_ are used for prepending meta-information + // like interface index, interface name + // before standard Ethernet, PPP, Frelay & C-HDLC Frames + // + DLT_JUNIPER_ETHER = 178; + DLT_JUNIPER_PPP = 179; + DLT_JUNIPER_FRELAY = 180; + DLT_JUNIPER_CHDLC = 181; + + // + // Multi Link Frame Relay (FRF.16) + // + DLT_MFR = 182; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . + // The DLT_ is used for internal communication with a + // voice Adapter Card (PIC) + // + DLT_JUNIPER_VP = 183; + + // + // Arinc 429 frames. + // DLT_ requested by Gianluca Varenni . + // Every frame contains a 32bit A429 label. + // More documentation on Arinc 429 can be found at + // http://www.condoreng.com/support/downloads/tutorials/ARINCTutorial.pdf + // + DLT_A429 = 184; + + // + // Arinc 653 Interpartition Communication messages. + // DLT_ requested by Gianluca Varenni . + // Please refer to the A653-1 standard for more information. + // + DLT_A653_ICM = 185; + + // + // USB packets, beginning with a USB setup header; requested by + // Paolo Abeni . + // + DLT_USB = 186; + + // + // Bluetooth HCI UART transport layer (part H:4); requested by + // Paolo Abeni. + // + DLT_BLUETOOTH_HCI_H4 = 187; + + // + // IEEE 802.16 MAC Common Part Sublayer; requested by Maria Cruz + // . + // + DLT_IEEE802_16_MAC_CPS = 188; + + // + // USB packets, beginning with a Linux USB header; requested by + // Paolo Abeni . + // + DLT_USB_LINUX = 189; + + // + // Controller Area Network (CAN) v. 2.0B packets. + // DLT_ requested by Gianluca Varenni . + // Used to dump CAN packets coming from a CAN Vector board. + // More documentation on the CAN v2.0B frames can be found at + // http://www.can-cia.org/downloads/?269 + // + DLT_CAN20B = 190; + + // + // IEEE 802.15.4, with address fields padded, as is done by Linux + // drivers; requested by Juergen Schimmer. + // + DLT_IEEE802_15_4_LINUX = 191; + + // + // Per Packet Information encapsulated packets. + // DLT_ requested by Gianluca Varenni . + // + DLT_PPI = 192; + + // + // Header for 802.16 MAC Common Part Sublayer plus a radiotap radio header; + // requested by Charles Clancy. + // + DLT_IEEE802_16_MAC_CPS_RADIO = 193; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . + // The DLT_ is used for internal communication with a + // integrated service module (ISM). + // + DLT_JUNIPER_ISM = 194; + + // + // IEEE 802.15.4, exactly as it appears in the spec (no padding, no + // nothing); requested by Mikko Saarnivala . + // + DLT_IEEE802_15_4 = 195; + + // + // Various link-layer types, with a pseudo-header, for SITA + // (http://www.sita.aero/); requested by Fulko Hew (fulko.hew@gmail.com). + // + DLT_SITA = 196; + + // + // Various link-layer types, with a pseudo-header, for Endace DAG cards; + // encapsulates Endace ERF records. Requested by Stephen Donnelly + // . + // + DLT_ERF = 197; + + // + // Special header prepended to Ethernet packets when capturing from a + // u10 Networks board. Requested by Phil Mulholland + // . + // + DLT_RAIF1 = 198; + + // + // IPMB packet for IPMI, beginning with the I2C slave address, followed + // by the netFn and LUN, etc.. Requested by Chanthy Toeung + // . + // + DLT_IPMB = 199; + + // + // Juniper-private data link type, as per request from + // Hannes Gredler . + // The DLT_ is used for capturing data on a secure tunnel interface. + // + DLT_JUNIPER_ST = 200; + + // + // Bluetooth HCI UART transport layer (part H:4), with pseudo-header + // that includes direction information; requested by Paolo Abeni. + // + DLT_BLUETOOTH_HCI_H4_WITH_PHDR = 201; + + // + // AX.25 packet with a 1-byte KISS header; see + // + // http://www.ax25.net/kiss.htm + // + // as per Richard Stearn . + // + DLT_AX25_KISS = 202; + + // + // LAPD packets from an ISDN channel, starting with the address field, + // with no pseudo-header. + // Requested by Varuna De Silva . + // + DLT_LAPD = 203; + + // + // Variants of various link-layer headers, with a one-byte direction + // pseudo-header prepended - zero means "received by this host", + // non-zero (any non-zero value) means "sent by this host" - as per + // Will Barker . + // + DLT_PPP_WITH_DIR = 204; // PPP - don't confuse with DLT_PPP_WITH_DIRECTION// + DLT_C_HDLC_WITH_DIR = 205; // Cisco HDLC// + DLT_FRELAY_WITH_DIR = 206; // Frame Relay// + DLT_LAPB_WITH_DIR = 207; // LAPB// + + // + // 208 is reserved for an as-yet-unspecified proprietary link-layer + // type, as requested by Will Barker. + // + + // + // IPMB with a Linux-specific pseudo-header; as requested by Alexey Neyman + // . + // + DLT_IPMB_LINUX = 209; + + // + // FlexRay automotive bus - http://www.flexray.com/ - as requested + // by Hannes Kaelber . + // + DLT_FLEXRAY = 210; + + // + // Media Oriented Systems Transport (MOST) bus for multimedia + // transport - http://www.mostcooperation.com/ - as requested + // by Hannes Kaelber . + // + DLT_MOST = 211; + + // + // Local Interconnect Network (LIN) bus for vehicle networks - + // http://www.lin-subbus.org/ - as requested by Hannes Kaelber + // . + // + DLT_LIN = 212; + + // + // X2E-private data link type used for serial line capture, + // as requested by Hannes Kaelber . + // + DLT_X2E_SERIAL = 213; + + // + // X2E-private data link type used for the Xoraya data logger + // family, as requested by Hannes Kaelber . + // + DLT_X2E_XORAYA = 214; + + // + // IEEE 802.15.4, exactly as it appears in the spec (no padding, no + // nothing), but with the PHY-level data for non-ASK PHYs (4 octets + // of 0 as preamble, one octet of SFD, one octet of frame length+ + // reserved bit, and then the MAC-layer data, starting with the + // frame control field). + // + // Requested by Max Filippov . + // + DLT_IEEE802_15_4_NONASK_PHY = 215; + + // + // NetBSD-specific generic "raw" link type. The class value indicates + // that this is the generic raw type, and the lower 16 bits are the + // address family we're dealing with. Those values are NetBSD-specific; + // do not assume that they correspond to AF_ values for your operating + // system. + // + DLT_CLASS_NETBSD_RAWAF = $02240000; + + // + // The instruction encodings. + // + + // instruction classes + BPF_LD = $00; + BPF_LDX = $01; + BPF_ST = $02; + BPF_STX = $03; + BPF_ALU = $04; + BPF_JMP = $05; + BPF_RET = $06; + BPF_MISC = $07; + + // ld/ldx fields + BPF_W = $00; + BPF_H = $08; + BPF_B = $10; + BPF_IMM = $00; + BPF_ABS = $20; + BPF_IND = $40; + BPF_MEM = $60; + BPF_LEN = $80; + BPF_MSH = $A0; + + // alu/jmp fields + BPF_ADD = $00; + BPF_SUB = $10; + BPF_MUL = $20; + BPF_DIV = $30; + BPF_OR = $40; + BPF_AND = $50; + BPF_LSH = $60; + BPF_RSH = $70; + BPF_NEG = $80; + BPF_JA = $00; + BPF_JEQ = $10; + BPF_JGT = $20; + BPF_JGE = $30; + BPF_JSET = $40; + BPF_K = $00; + BPF_X = $08; + + // ret - BPF_K and BPF_X also apply + BPF_A = $10; + + // misc + BPF_TAX = $00; + BPF_TXA = $80; + + // + // DLT and savefile link type values are split into a class and + // a member of that class. A class value of 0 indicates a regular + // DLT_/LINKTYPE_ value. + // +function DLT_CLASS(c: u_int): u_int; + +function DLT_NETBSD_RAWAF(af: u_int): u_int; +function DLT_NETBSD_RAWAF_AF(c: u_int): u_int; +function DLT_IS_NETBSD_RAWAF(c: u_int): boolean; + +function BPF_CLASS(code: word): word; +function BPF_SIZE(code: word): word; +function BPF_MODE(code: word): word; +function BPF_OP(code: word): word; +function BPF_SRC(code: word): word; +function BPF_RVAL(code: word): word; +function BPF_MISCOP(code: word): word; + +// +// Macros for insn array initializers. +// +// #define BPF_STMT(code, k) { (u_short)(code), 0, 0, k } +// #define BPF_JUMP(code, k, jt, jf) { (u_short)(code), jt, jf, k } + +implementation + +function BPF_WORDALIGN(x: integer): integer; +begin + Result := (x + BPF_ALIGNMENT - 1) and not (BPF_ALIGNMENT - 1); +end; + +function DLT_CLASS(c: u_int): u_int; +begin + Result := (c and $03FF0000); +end; + +function DLT_NETBSD_RAWAF(af: u_int): u_int; +begin + Result := (DLT_CLASS_NETBSD_RAWAF or af); +end; + +function DLT_NETBSD_RAWAF_AF(c: u_int): u_int; +begin + Result := (c and $0000FFFF) +end; + +function DLT_IS_NETBSD_RAWAF(c: u_int): boolean; +begin + Result := (DLT_CLASS(c) = DLT_CLASS_NETBSD_RAWAF); +end; + +function BPF_CLASS(code: word): word; +begin + Result := (code and $07); +end; + +function BPF_SIZE(code: word): word; +begin + Result := (code and $18); +end; + +function BPF_MODE(code: word): word; +begin + Result := (code and $E0); + +end; + +function BPF_OP(code: word): word; +begin + Result := (code and $F0); + +end; + +function BPF_SRC(code: word): word; +begin + Result := (code and $08); + +end; + +function BPF_RVAL(code: word): word; +begin + Result := (code and $18); + +end; + +function BPF_MISCOP(code: word): word; +begin + Result := (code and $F8); + +end; + +end. diff --git a/EvilWorks.Api.WinPCap.pas b/EvilWorks.Api.WinPCap.pas new file mode 100644 index 0000000..ff8d915 --- /dev/null +++ b/EvilWorks.Api.WinPCap.pas @@ -0,0 +1,372 @@ +unit EvilWorks.Api.WinPCap; + +// Translated from v1.4.2.11 + +interface + +uses + WinApi.Windows, + EvilWorks.Api.Winsock2, // you can remove this and use WinApi.Winsock instead. Required for u_int, etc + EvilWorks.Api.WinPCap.Bpf; + +const + SWinPcap = 'wpcap.dll'; + + PCAP_SRC_IF_STRING = 'rpcap://'; + + PCAP_VERSION_MAJOR = 2; + PCAP_VERSION_MINOR = 4; + + PCAP_ERRBUF_SIZE = 256; + PCAP_IF_LOOPBACK = $00000001; // interface is loopback + + // + // Error codes for the pcap API. + // These will all be negative, so you can check for the success or + // failure of a call that returns these codes by checking for a + // negative value. + // + + PCAP_ERROR = - 1; // generic error code + PCAP_ERROR_BREAK = - 2; // loop terminated by pcap_breakloop + PCAP_ERROR_NOT_ACTIVATED = - 3; // the capture needs to be activated + PCAP_ERROR_ACTIVATED = - 4; // the operation can't be performed on already activated captures + PCAP_ERROR_NO_SUCH_DEVICE = - 5; // no such device exists + PCAP_ERROR_RFMON_NOTSUP = - 6; // this device doesn't support rfmon (monitor) mode + PCAP_ERROR_NOT_RFMON = - 7; // operation supported only in monitor mode + PCAP_ERROR_PERM_DENIED = - 8; // no permission to open the device + PCAP_ERROR_IFACE_NOT_UP = - 9; // interface isn't up + + // + // Warning codes for the pcap API. + // These will all be positive and non-zero, so they won't look like + // errors. + // + + PCAP_WARNING = 1; // generic warning code */ + PCAP_WARNING_PROMISC_NOTSUP = 2; // this device doesn't support promiscuous mode */ + + MODE_CAPT = 0; + MODE_STAT = 1; + MODE_MON = 2; + + PCAP_OPENFLAG_PROMISCUOUS = 1; + +type + // extra data types. + pu_char = ^u_char; + ppu_char = ^pu_char; + + ppinteger = ^pinteger; + + // pcap_t = pcap; + Pcap = pointer; + ppcap = ^Pcap; + pcap_t = Pcap; + ppcap_t = ^pcap_t; + + // pcap_dumper_t = pcap_dumper; + pcap_dumper = pointer; + ppcap_dumper = ^pcap_dumper; + + pcap_dumper_t = pcap_dumper; + ppcap_dumper_t = ^pcap_dumper_t; + + // pcap_if_t = pcap_if; + // pcap_addr_t = pcap_addr; + + // The first record in the file contains saved values for some + // of the flags used in the printout phases of tcpdump. + // Many fields here are 32 bit ints so compilers won't insert unwanted + // padding; these files need to be interchangeable across architectures. + // + // Do not change the layout of this structure, in any way (this includes + // changes that only affect the length of fields in this structure). + // + // Also, do not change the interpretation of any of the members of this + // structure, in any way (this includes using values other than + // LINKTYPE_ values, as defined in "savefile.c", in the "linktype" + // field). + // + // Instead: + // + // introduce a new structure for the new format, if the layout + // of the structure changed; + // + // send mail to "tcpdump-workers@lists.tcpdump.org", requesting + // a new magic number for your new capture file format, and, when + // you get the new magic number, put it in "savefile.c"; + // + // use that magic number for save files with the changed file + // header; + // + // make the code in "savefile.c" capable of reading files with + // the old file header as well as files with the new file header + // (using the magic number to determine the header format). + // + // Then supply the changes as a patch at + // + // http://sourceforge.net/projects/libpcap/ + // + // so that future versions of libpcap and programs that use it (such as + // tcpdump) will be able to read your new capture file format. + + { pcap_file_header } + pcap_file_header = record + magic: bpf_u_int32; + version_major: u_short; + version_minor: u_short; + thiszone: bpf_int32; // gmt to local correction + sigfigs: bpf_u_int32; // accuracy of timestamps + snaplen: bpf_u_int32; // max length saved portion of each pkt + linktype: bpf_u_int32; // data link type (LINKTYPE_*) + end; + + { pcap_direction_t } + pcap_direction_t = ( + PCAP_D_INOUT = 0, + PCAP_D_IN, + PCAP_D_OUT + ); + + // + // Generic per-packet information, as supplied by libpcap. + // + // The time stamp can and should be a "struct timeval", regardless of + // whether your system supports 32-bit tv_sec in "struct timeval", + // 64-bit tv_sec in "struct timeval", or both if it supports both 32-bit + // and 64-bit applications. The on-disk format of savefiles uses 32-bit + // tv_sec (and tv_usec); this structure is irrelevant to that. 32-bit + // and 64-bit versions of libpcap, even if they're on the same platform, + // should supply the appropriate version of "struct timeval", even if + // that's not what the underlying packet capture mechanism supplies. + // + + { pcap_pkthdr } + ppcap_pkthdr = ^pcap_pkthdr; + pppcap_pkthdr = ^ppcap_pkthdr; + + pcap_pkthdr = record + ts: timeval; // time stamp */ + caplen: bpf_u_int32; // length of portion present */ + len: bpf_u_int32; // length this packet (off wire) */ + end; + + // + // As returned by the pcap_stats() + // + + { pcap_stat } + ppcap_stat = ^pcap_stat; + + pcap_stat = record + ps_recv: u_int; // number of packets received + ps_drop: u_int; // number of packets dropped + ps_ifdrop: u_int; // drops by interface XXX not yet supported + { #ifdef HAVE_REMOTE } + ps_capt: u_int; // number of packets that are received by the application; please get rid off the Win32 ifdef + ps_sent: u_int; // number of packets sent by the server on the network + ps_netdrop: u_int; // number of packets lost on the network + { #endif HAVE_REMOTE } + end; + + // + // As returned by the pcap_stats_ex() + // + + { pcap_stat_ex } + ppcap_stat_ex = ^pcap_stat_ex; + + pcap_stat_ex = record + rx_packets: u_long; // total packets received + tx_packets: u_long; // total packets transmitted + rx_bytes: u_long; // total bytes received + tx_bytes: u_long; // total bytes transmitted + rx_errors: u_long; // bad packets received + tx_errors: u_long; // packet transmit problems + rx_dropped: u_long; // no space in Rx buffers + tx_dropped: u_long; // no space available for Tx + multicast: u_long; // multicast packets received + collisions: u_long; + + // detailed rx_errors + rx_length_errors: u_long; + rx_over_errors: u_long; // receiver ring buff overflow + rx_crc_errors: u_long; // recv'd pkt with crc error + rx_frame_errors: u_long; // recv'd frame alignment error + rx_fifo_errors: u_long; // recv'r fifo overrun + rx_missed_errors: u_long; // recv'r missed packet + + // detailed tx_errors + tx_aborted_errors: u_long; + tx_carrier_errors: u_long; + tx_fifo_errors: u_long; + tx_heartbeat_errors: u_long; + tx_window_errors: u_long; + end; + + { pcap_addr } + ppcap_addr = ^pcap_addr; + + pcap_addr = record + next: ppcap_addr; + addr: psockaddr; // address + netmask: psockaddr; // netmask for that address + broadaddr: psockaddr; // broadcast address for that address + dstaddr: psockaddr; // P2P destination address for that address + end; + + pcap_addr_t = ppcap_addr; + ppcap_addr_t = ^pcap_addr_t; + + ppcap_handler = ^pcap_handler; + pcap_handler = procedure(c: pu_char; h: ppcap_pkthdr; r: pu_char); + + // + // Item in a list of interfaces. + // + + { pcap_if } + ppcap_if = ^pcap_if; + pppcap_if_t = ^ppcap_if_t; + + pcap_if = record + next: ppcap_if; + name: pansichar; // name to hand to "pcap_open_live() + description: pansichar; // textual description of interface, or NULL + addresses: ppcap_addr; + flags: bpf_u_int32; // PCAP_IF_ interface flags + end; + + pcap_if_t = pcap_if; + ppcap_if_t = ^pcap_if_t; + + { pcap_rmtauth } + ppcap_rmtauth = ^pcap_rmtauth; + + pcap_rmtauth = record + typ: integer; + username: pansichar; + password: pansichar; + end; + +function pcap_lookupdev(errbuff: pansichar): pansichar; cdecl; external SWinPcap name 'pcap_lookupdev'; +function pcap_lookupnet(const device: pansichar; netp: bpf_u_int32; maskp: bpf_u_int32; errbuf: pansichar): integer; cdecl; external SWinPcap name 'pcap_lookupnet'; + +function pcap_create(const a: pansichar; b: pansichar): ppcap_t; cdecl; external SWinPcap name 'pcap_create'; +function pcap_set_snaplen(p: ppcap_t; v: integer): integer; cdecl; external SWinPcap name 'pcap_set_snaplen'; +function pcap_set_promisc(p: ppcap_t; v: integer): integer; cdecl; external SWinPcap name 'pcap_set_promisc'; +function pcap_can_set_rfmon(p: ppcap_t): integer; cdecl; external SWinPcap name 'pcap_can_set_rfmon'; +function pcap_set_rfmon(p: ppcap_t; v: integer): integer; cdecl; external SWinPcap name 'pcap_set_rfmon'; +function pcap_set_timeout(p: ppcap_t; v: integer): integer; cdecl; external SWinPcap name 'pcap_set_timeout'; +function pcap_set_buffer_size(p: ppcap_t; v: integer): integer; cdecl; external SWinPcap name 'pcap_set_buffer_size'; +function pcap_activate(p: ppcap_t): integer; cdecl; external SWinPcap name 'pcap_activate'; + +function pcap_open_live(const device: pansichar; snaplen, promisc, to_ms: integer; ebuf: pansichar): ppcap_t; cdecl; external SWinPcap name 'pcap_open_live'; +function pcap_open_dead(linktype, snaplen: integer): ppcap_t; cdecl; external SWinPcap name 'pcap_open_dead'; +function pcap_open_offline(const fname: pansichar; errbuf: pansichar): ppcap_t; cdecl; external SWinPcap name 'pcap_open_offline'; +function pcap_hopen_offline(p: intptr; c: pansichar): ppcap_t; cdecl; external SWinPcap name 'pcap_hopen_offline'; + +procedure pcap_close(p: ppcap_t); cdecl; external SWinPcap name 'pcap_close'; +function pcap_loop(p: ppcap_t; cnt: integer; callback: pcap_handler; user: pu_char): integer; cdecl; external SWinPcap name 'pcap_loop'; +function pcap_dispatch(p: ppcap_t; cnt: integer; callback: pcap_handler; user: pu_char): integer; cdecl; external SWinPcap name 'pcap_dispatch'; +function pcap_next(p: ppcap_t; pkt_header: ppcap_pkthdr): pu_char; cdecl; external SWinPcap name 'pcap_next'; + +function pcap_next_ex(p: ppcap_t; pkt_header: pppcap_pkthdr; const pkt_data: ppu_char): integer; cdecl; external SWinPcap name 'pcap_next_ex'; +procedure pcap_breakloop(p: ppcap_t); cdecl; external SWinPcap name 'pcap_breakloop'; +function pcap_stats(p: ppcap_t; ps: ppcap_stat): integer; cdecl; external SWinPcap name 'pcap_stats'; +function pcap_setfilter(p: ppcap_t; prg: pbpf_program): integer; cdecl; external SWinPcap name 'pcap_setfilter'; +function pcap_setdirection(p: ppcap_t; dir: pcap_direction_t): integer; cdecl; external SWinPcap name 'pcap_setdirection'; + +function pcap_getnonblock(p: ppcap_t; errbuf: pansichar): integer; cdecl; external SWinPcap name 'pcap_getnonblock'; +function pcap_setnonblock(p: ppcap_t; nonblock: integer; errbuf: pansichar): integer; cdecl; external SWinPcap name 'pcap_setnonblock'; +function pcap_inject(p: ppcap_t; const data: pointer; size: size_t): integer; cdecl; external SWinPcap name 'pcap_inject'; +function pcap_sendpacket(p: ppcap_t; const buf: pu_char; size: integer): integer; cdecl; external SWinPcap name 'pcap_sendpacket'; + +function pcap_statustostr(code: integer): pansichar; cdecl; external SWinPcap name 'pcap_statustostr'; +function pcap_strerror(code: integer): pansichar; cdecl; external SWinPcap name 'pcap_strerror'; +function pcap_geterr(p: ppcap_t): pansichar; cdecl; external SWinPcap name 'pcap_geterr'; +procedure pcap_perror(p: ppcap_t; buff: pansichar); cdecl; external SWinPcap name 'pcap_perror'; + +function pcap_compile(p: ppcap_t; fp: pbpf_program; const str: pansichar; optimize: integer; netmask: bpf_u_int32): integer; cdecl; external SWinPcap name 'pcap_compile'; +function pcap_compile_nopcap(snaplen_arg, linktype_arg: integer; progrm: pbpf_program; const buf: pansichar; optimize: integer; mask: bpf_u_int32): integer; cdecl; + external SWinPcap name 'pcap_compile_nopcap'; +procedure pcap_freecode(prg: pbpf_program); cdecl; external SWinPcap name 'pcap_freecode'; + +function pcap_offline_filter(fp: pbpf_program; const pkt_hdr: ppcap_pkthdr; const pkt_data: pu_char): integer; cdecl; external SWinPcap name 'pcap_offline_filter'; + +function pcap_datalink(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_datalink'; +function pcap_datalink_ext(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_datalink_ext'; +function pcap_list_datalinks(p: ppcap; i: ppinteger): integer; cdecl; external SWinPcap name 'pcap_list_datalinks'; +function pcap_set_datalink(p: ppcap; i: integer): integer; cdecl; external SWinPcap name 'pcap_set_datalink'; +function pcap_datalink_name_to_val(const name: pansichar): integer; cdecl; external SWinPcap name 'pcap_datalink_name_to_val'; +function pcap_datalink_val_to_name(i: integer): pansichar; cdecl; external SWinPcap name 'pcap_datalink_val_to_name'; +function pcap_datalink_val_to_description(i: integer): pansichar; cdecl; external SWinPcap name 'pcap_datalink_val_to_description'; +procedure pcap_free_datalinks(i: integer); cdecl; external SWinPcap name 'pcap_free_datalinks'; + +function pcap_snapshot(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_snapshot'; +function pcap_is_swapped(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_is_swapped'; +function pcap_major_version(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_major_version'; +function pcap_minor_version(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_minor_version'; + +// XXX +function pcap_file(p: ppcap): PHandle; cdecl; external SWinPcap name 'pcap_file'; +function pcap_fileno(p: ppcap): integer; cdecl; external SWinPcap name 'pcap_fileno'; + +function pcap_dump_open(p: ppcap_t; const data: pansichar): pcap_dumper_t; cdecl; external SWinPcap name 'pcap_dump_open'; +function pcap_dump_fopen(p: ppcap_t; fp: PHandle): pcap_dumper_t; cdecl; external SWinPcap name 'pcap_dump_fopen'; +function pcap_dump_file(dmp: ppcap_dumper_t): PHandle; cdecl; external SWinPcap name 'pcap_dump_file'; +function pcap_dump_ftell(dmp: ppcap_dumper_t): long; cdecl; external SWinPcap name 'pcap_dump_ftell'; +function pcap_dump_flush(dmp: ppcap_dumper_t): integer; cdecl; external SWinPcap name 'pcap_dump_flush'; +procedure pcap_dump_close(dmp: ppcap_dumper_t); cdecl; external SWinPcap name 'pcap_dump_close'; +procedure pcap_dump(p: pu_char; const h: ppcap_pkthdr; const sp: pu_char); cdecl; external SWinPcap name 'pcap_dump'; + +function pcap_findalldevs(devs: pppcap_if_t; errbuf: pansichar): integer; cdecl; external SWinPcap name 'pcap_findalldevs'; +function pcap_findalldevs_ex(source: pansichar; auth: ppcap_rmtauth; alldevs: pppcap_if_t; errbuff: pansichar): integer; cdecl; external SWinPcap name 'pcap_findalldevs_ex'; +procedure pcap_freealldevs(devs: ppcap_if_t); cdecl; external SWinPcap name 'pcap_freealldevs'; + +function pcap_lib_version: pansichar; cdecl; external SWinPcap name 'pcap_lib_version'; + +// XXX this guy lives in the Bpf tree +function bpf_filter(const struct: pbpf_insn; const flt: pu_char; a, b: u_int): u_int; cdecl; external SWinPcap name 'bpf_filter'; +function bpf_validate(const struct: pbpf_insn; i: integer): integer; cdecl; external SWinPcap name 'bpf_validate'; +function bpf_image(const struct: pbpf_insn; a: integer): pansichar; cdecl; external SWinPcap name 'bpf_image'; +procedure bpf_dump(const struct: pbpf_program; a: integer); cdecl; external SWinPcap name 'bpf_dump'; + +// +// Win32 definitions +// +function pcap_setbuff(p: ppcap_t; dim: integer): integer; cdecl; external SWinPcap name 'pcap_setbuff'; +function pcap_setmode(p: ppcap_t; mode: integer): integer; cdecl; external SWinPcap name 'pcap_setmode'; +function pcap_setmintocopy(p: ppcap_t; size: integer): integer; cdecl; external SWinPcap name 'pcap_setmintocopy'; + +function pcap_open(const source: pansichar; snaplen, flags, read_timeout: integer; auth: ppcap_rmtauth; errbuf: pansichar): ppcap_t; cdecl; external SWinPcap name 'pcap_open'; + +// +// Macros for the value returned by pcap_datalink_ext(). +// +// If LT_FCS_LENGTH_PRESENT(x) is true, the LT_FCS_LENGTH(x) macro +// gives the FCS length of packets in the capture. +// +function LT_FCS_LENGTH_PRESENT(x: u_int): u_int; +function LT_FCS_LENGTH(x: u_int): u_int; +function LT_FCS_DATALINK_EXT(x: u_int): u_int; + +implementation + +function LT_FCS_LENGTH_PRESENT(x: u_int): u_int; +begin + Result := (x and $04000000); +end; + +function LT_FCS_LENGTH(x: u_int): u_int; +begin + Result := ((x and $F0000000) shr 28); +end; + +function LT_FCS_DATALINK_EXT(x: u_int): u_int; +begin + Result := (((x and $F) shl 28) or $04000000); +end; + +end. diff --git a/EvilWorks.Api.ZLib.pas b/EvilWorks.Api.ZLib.pas new file mode 100644 index 0000000..1a317ba --- /dev/null +++ b/EvilWorks.Api.ZLib.pas @@ -0,0 +1,327 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.Api.ZLib +// Description: ZLib header. Taken from ZLibExApi.pas 1.2.7 by Brent Sherwood. +// File last change date: October 20th. 2012 +// File version: Dev 0.0.0 +// Licence: See below. +// +// Original author Brent Sherwood - http://www.base2ti.com +// Original file ZLibExApi.pas 1.2.7 +// Original copyright copyright (c) 2000-2012 base2 technologies +// copyright (c) 1995-2002 Borland Software Corporation +// + +unit EvilWorks.Api.ZLib; + +interface + +const + + // + // Version IDs + // + + ZLIB_VERSION: PAnsiChar = '1.2.7'; + + ZLIB_VERNUM = $1270; + + ZLIB_VER_MAJOR = 1; + ZLIB_VER_MINOR = 2; + ZLIB_VER_REVISION = 7; + ZLIB_VER_SUBREVISION = 0; + + // + // Compression methods + // + + Z_DEFLATED = 8; + + // + // Information flags + // + + Z_INFO_FLAG_SIZE = $1; + Z_INFO_FLAG_CRC = $2; + Z_INFO_FLAG_ADLER = $4; + + Z_INFO_NONE = 0; + Z_INFO_DEFAULT = Z_INFO_FLAG_SIZE or Z_INFO_FLAG_CRC; + + // + // Flush constants + // + + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; + Z_BLOCK = 5; + Z_TREES = 6; + + // + // Return codes + // + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = ( - 1); + Z_STREAM_ERROR = ( - 2); + Z_DATA_ERROR = ( - 3); + Z_MEM_ERROR = ( - 4); + Z_BUF_ERROR = ( - 5); + Z_VERSION_ERROR = ( - 6); + + // + // Compression levels + // + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = ( - 1); + + // + // Compression strategies + // + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_RLE = 3; + Z_FIXED = 4; + Z_DEFAULT_STRATEGY = 0; + + // + // Data types + // + + Z_BINARY = 0; + Z_ASCII = 1; + Z_TEXT = Z_ASCII; + Z_UNKNOWN = 2; + + // + // Return code messages + // + + z_errmsg: array [0 .. 9] of string = ( + 'Need dictionary', // Z_NEED_DICT (2) + 'Stream end', // Z_STREAM_END (1) + 'OK', // Z_OK (0) + 'File error', // Z_ERRNO (-1) + 'Stream error', // Z_STREAM_ERROR (-2) + 'Data error', // Z_DATA_ERROR (-3) + 'Insufficient memory', // Z_MEM_ERROR (-4) + 'Buffer error', // Z_BUF_ERROR (-5) + 'Incompatible version', // Z_VERSION_ERROR (-6) + '' + ); + +type + TZAlloc = function(opaque: Pointer; items, size: Integer): Pointer; cdecl; + TZFree = procedure(opaque, block: Pointer); cdecl; + + // + // TZStreamRec + // + + TZStreamRec = packed record + next_in: PByte; // next input byte + avail_in: Cardinal; // number of bytes available at next_in + total_in: Longword; // total nb of input bytes read so far + + next_out: PByte; // next output byte should be put here + avail_out: Cardinal; // remaining free space at next_out + total_out: Longword; // total nb of bytes output so far + + msg: PAnsiChar; // last error message, NULL if no error + state: Pointer; // not visible by applications + + zalloc: TZAlloc; // used to allocate the internal state + zfree: TZFree; // used to free the internal state + opaque: Pointer; // private data object passed to zalloc and zfree + + data_type: Integer; // best guess about the data type: ascii or binary + adler: Longword; // adler32 value of the uncompressed data + reserved: Longword; // reserved for future use + end; + +{ Macros } +function deflateInit(var strm: TZStreamRec; level: Integer): Integer; inline; +function deflateInit2(var strm: TZStreamRec; level, method, windowBits, memLevel, strategy: Integer): Integer; inline; +function inflateInit(var strm: TZStreamRec): Integer; inline; +function inflateInit2(var strm: TZStreamRec; windowBits: Integer): Integer; inline; + +{ External routines } +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; recsize: Integer): Integer; +function deflateInit2_(var strm: TZStreamRec; level, method, windowBits, memLevel, strategy: Integer; version: PAnsiChar; recsize: Integer): Integer; +function deflate(var strm: TZStreamRec; flush: Integer): Integer; +function deflateEnd(var strm: TZStreamRec): Integer; +function deflateReset(var strm: TZStreamRec): Integer; +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; recsize: Integer): Integer; +function inflateInit2_(var strm: TZStreamRec; windowBits: Integer; version: PAnsiChar; recsize: Integer): Integer; +function inflate(var strm: TZStreamRec; flush: Integer): Integer; +function inflateEnd(var strm: TZStreamRec): Integer; +function inflateReset(var strm: TZStreamRec): Integer; +function adler32(adler: Longint; const buf; len: Integer): Longint; +function crc32(crc: Longint; const buf; len: Integer): Longint; + +{ Utilities } +function ZResultToString(const aResult: integer): string; + +implementation + +function ZResultToString(const aResult: integer): string; +begin + case aResult of + Z_OK: + Result := 'Z_OK'; + Z_STREAM_END: + Result := 'Z_STREAM_END'; + Z_NEED_DICT: + Result := 'Z_NEED_DICT'; + Z_ERRNO: + Result := 'Z_ERRNO'; + Z_STREAM_ERROR: + Result := 'Z_STREAM_ERROR'; + Z_DATA_ERROR: + Result := 'Z_DATA_ERROR'; + Z_MEM_ERROR: + Result := 'Z_MEM_ERROR'; + Z_BUF_ERROR: + Result := 'Z_BUF_ERROR'; + Z_VERSION_ERROR: + Result := 'Z_VERSION_ERROR'; + else + Result := 'Unknown return value.'; + end; +end; + +{************************************************************************************************* +* link zlib code * +* * +* bcc32 flags * +* -c -O2 -Ve -X -pr -a8 -b -d -k- -vi -tWM -u- * +* * +* note: do not reorder the following -- doing so will result in external * +* functions being undefined * +*************************************************************************************************} + +{$IFDEF WIN64} +{$L ..\Lib\ZLib\win64\deflate.obj} +{$L ..\Lib\ZLib\win64\inflate.obj} +{$L ..\Lib\ZLib\win64\inftrees.obj} +{$L ..\Lib\ZLib\win64\infback.obj} +{$L ..\Lib\ZLib\win64\inffast.obj} +{$L ..\Lib\ZLib\win64\trees.obj} +{$L ..\Lib\ZLib\win64\compress.obj} +{$L ..\Lib\ZLib\win64\adler32.obj} +{$L ..\Lib\ZLib\win64\crc32.obj} +{$ELSE} +{$L ..\Lib\ZLib\win32\deflate.obj} +{$L ..\Lib\ZLib\win32\inflate.obj} +{$L ..\Lib\ZLib\win32\inftrees.obj} +{$L ..\Lib\ZLib\win32\infback.obj} +{$L ..\Lib\ZLib\win32\inffast.obj} +{$L ..\Lib\ZLib\win32\trees.obj} +{$L ..\Lib\ZLib\win32\compress.obj} +{$L ..\Lib\ZLib\win32\adler32.obj} +{$L ..\Lib\ZLib\win32\crc32.obj} +{$ENDIF} + +{ ====== } +{ Macros } +{ ====== } + +function deflateInit(var strm: TZStreamRec; level: Integer): Integer; +begin + result := deflateInit_(strm, level, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +function deflateInit2(var strm: TZStreamRec; level, method, windowBits, memLevel, strategy: Integer): Integer; +begin + result := deflateInit2_(strm, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +function inflateInit(var strm: TZStreamRec): Integer; +begin + result := inflateInit_(strm, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +function inflateInit2(var strm: TZStreamRec; windowBits: Integer): Integer; +begin + result := inflateInit2_(strm, windowBits, ZLIB_VERSION, SizeOf(TZStreamRec)); +end; + +{ ================= } +{ External routines } +{ ================= } + +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PAnsiChar; recsize: Integer): Integer; external; + +function deflateInit2_(var strm: TZStreamRec; level, method, windowBits, memLevel, strategy: Integer; version: PAnsiChar; recsize: Integer): Integer; external; + +function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; + +function deflateEnd(var strm: TZStreamRec): Integer; external; + +function deflateReset(var strm: TZStreamRec): Integer; external; + +function inflateInit_(var strm: TZStreamRec; version: PAnsiChar; recsize: Integer): Integer; external; + +function inflateInit2_(var strm: TZStreamRec; windowBits: Integer; version: PAnsiChar; recsize: Integer): Integer; external; + +function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; + +function inflateEnd(var strm: TZStreamRec): Integer; external; + +function inflateReset(var strm: TZStreamRec): Integer; external; + +function adler32(adler: Longint; const buf; len: Integer): Longint; external; + +function crc32(crc: Longint; const buf; len: Integer): Longint; external; + +{ ============================= } +{ ZLib function implementations } +{ ============================= } + +function zcalloc(opaque: Pointer; items, size: Integer): Pointer; +begin + GetMem(result, items * size); +end; + +procedure zcfree(opaque, block: Pointer); +begin + FreeMem(block); +end; + +{ ========================== } +{ C function implementations } +{ ========================== } + +function memset(p: Pointer; b: Byte; count: Integer): Pointer; cdecl; +begin + FillChar(p^, count, b); + + result := p; +end; + +procedure memcpy(dest, source: Pointer; count: Integer); cdecl; +begin + Move(source^, dest^, count); +end; + +{$IFNDEF WIN64} + + +procedure _llmod; +asm + jmp System.@_llmod; +end; + +{$ENDIF} + +end. diff --git a/EvilWorks.Crypto.HMAC_SHA1.pas b/EvilWorks.Crypto.HMAC_SHA1.pas new file mode 100644 index 0000000..59e72c9 --- /dev/null +++ b/EvilWorks.Crypto.HMAC_SHA1.pas @@ -0,0 +1,4018 @@ +(*============================================================================================================ + + EvilLibrary by Vedran Vuk 2010-2012 + + Name: EvilWorks.Crypto.HMAC_SHA1 + Description: HMAC_SHA1 hasher. Taken from "Fundamentals 4.00" chash.pas library version 4.15. + Original Copyright: Copyright © 1999-2011, David J Butler + Original Home page: http://fundementals.sourceforge.net + Original Forum: http://sourceforge.net/forum/forum.php?forum_id=2117 + Original E-mail: fundamentalslib at gmail.com + File last change date: August 15th. 2012 + File version: 0.0.1 + Licence: Free as in beer. + + ===========================================================================================================*) + +unit EvilWorks.Crypto.HMAC_SHA1; + +{$EXTENDEDSYNTAX ON} +{$IOCHECKS ON} +{$LONGSTRINGS ON} +{$BOOLEVAL OFF} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$OPTIMIZATION ON} +{$INLINE ON} +{$HIGHCHARUNICODE OFF} + +{ } +{ Windows platform } +{ } +{$IFDEF DOT_NET} +{$DEFINE WindowsPlatform} +{$ENDIF} +{$IFDEF OS_WIN32} +{$DEFINE WindowsPlatform} +{$ENDIF} +{$IFDEF OS_WIN64} +{$DEFINE WindowsPlatform} +{$ENDIF} + +{ } +{ CPU type } +{ } +{$IFNDEF ManagedCode} +{$DEFINE NativeCode} +{$ENDIF} +{$IFDEF CPU386} +{$DEFINE INTEL386} +{$DEFINE CPU_INTEL386} +{$ENDIF} +{$IFDEF CPUX64} +{$DEFINE CPU_X86_64} +{$ENDIF} +{$IFDEF CPU86_64} +{$DEFINE CPU_X86_64} +{$ENDIF} +{$IFDEF CPU68K} +{$DEFINE CPU_68K} +{$ENDIF} +{$IFDEF CPUPPC} +{$DEFINE CPU_POWERPC} +{$ENDIF} +{$IFDEF CPUPPC64} +{$DEFINE CPU_POWERPC64} +{$ENDIF} +{$IFDEF CPUARM} +{$DEFINE CPU_ARM} +{$ENDIF} + +{ } +{ Assembler style } +{ } +{$IFNDEF PurePascal} +{$IFNDEF ManagedCode} +{$IFDEF CPU_X86_64} +{$DEFINE ASMX86_64} +{$ENDIF} +{$IFDEF CPU_INTEL386} +{$DEFINE ASM386} +{$IFDEF DELPHI}{$IFDEF OS_WIN32} +{$DEFINE ASM386_DELPHI} +{$IFNDEF UseInline} {$DEFINE ASM386_DELPHI_INLINE_OFF} {$ENDIF} +{$ENDIF}{$ENDIF} +{$IFDEF FREEPASCAL2_UP} +{$DEFINE ASM386_FREEPASCAL} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ } +{ Function inlining } +{ } +{$IFDEF SupportInline} +{$IFNDEF SupportInlineIsBuggy} +{$IFNDEF PurePascal} +{$DEFINE UseInline} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ } +{ Standard compiler directives } +{ } +{$EXTENDEDSYNTAX ON} +{$IOCHECKS ON} +{$LONGSTRINGS ON} +{$BOOLEVAL OFF} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IFDEF DEBUG} +{$ASSERTIONS ON} +{$DEBUGINFO ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$WARNINGS ON} +{$HINTS ON} +{$ELSE} +{$ASSERTIONS OFF} +{$DEBUGINFO OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$WARNINGS OFF} +{$HINTS OFF} +{$ENDIF} +{$IFDEF CLR} +{$UNSAFECODE OFF} +{$ENDIF} +{$IFDEF DELPHI} +{$OPTIMIZATION ON} +{$ENDIF} +{$IFDEF DELPHI2005_UP} +{$INLINE ON} +{$ENDIF} +{$IFDEF DELPHI2009_UP} +{$HIGHCHARUNICODE OFF} +{$ENDIF} + +{ } +{ Compiler warnings } +{ } +{$IFDEF DELPHI7} +{$WARN UNSAFE_CODE OFF} +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} + +{$IFDEF DELPHI2007} +{$IFNDEF DOT_NET} +{$WARN UNSAFE_CODE OFF} +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} +{$ENDIF} + +{$IFDEF DOT_NET} +{$WARN UNIT_PLATFORM OFF} +{$ENDIF} + +{$IFNDEF DEBUG} +{$IFDEF DELPHI6_UP} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNIT_PLATFORM OFF} +{$WARN UNIT_DEPRECATED OFF} +{$ENDIF} +{$ENDIF} + +interface + +uses + WinApi.Windows, + System.SysUtils, + EvilWorks.System.SysUtils; + +{ } +{ Hash digests } +{ } +type + Word64 = packed record + case Integer of + 0: + (Bytes: array [0 .. 7] of Byte); + 1: + (Words: array [0 .. 3] of Word); + 2: + (LongWords: array [0 .. 1] of LongWord); + end; + + PWord64 = ^Word64; + + T128BitDigest = record + case integer of + 0: + (Int64s: array [0 .. 1] of Int64); + 1: + (Longs: array [0 .. 3] of LongWord); + 2: + (Words: array [0 .. 7] of Word); + 3: + (Bytes: array [0 .. 15] of Byte); + end; + + P128BitDigest = ^T128BitDigest; + + T160BitDigest = record + case integer of + 0: + (Longs: array [0 .. 4] of LongWord); + 1: + (Words: array [0 .. 9] of Word); + 2: + (Bytes: array [0 .. 19] of Byte); + end; + + P160BitDigest = ^T160BitDigest; + + T224BitDigest = record + case integer of + 0: + (Longs: array [0 .. 6] of LongWord); + 1: + (Words: array [0 .. 13] of Word); + 2: + (Bytes: array [0 .. 27] of Byte); + end; + + P224BitDigest = ^T224BitDigest; + + T256BitDigest = record + case integer of + 0: + (Longs: array [0 .. 7] of LongWord); + 1: + (Words: array [0 .. 15] of Word); + 2: + (Bytes: array [0 .. 31] of Byte); + end; + + P256BitDigest = ^T256BitDigest; + + T384BitDigest = record + case integer of + 0: + (Word64s: array [0 .. 5] of Word64); + 1: + (Longs: array [0 .. 11] of LongWord); + 2: + (Words: array [0 .. 23] of Word); + 3: + (Bytes: array [0 .. 47] of Byte); + end; + + P384BitDigest = ^T384BitDigest; + + T512BitDigest = record + case integer of + 0: + (Word64s: array [0 .. 7] of Word64); + 1: + (Longs: array [0 .. 15] of LongWord); + 2: + (Words: array [0 .. 31] of Word); + 3: + (Bytes: array [0 .. 63] of Byte); + end; + + P512BitDigest = ^T512BitDigest; + T512BitBuf = array [0 .. 63] of Byte; + T1024BitBuf = array [0 .. 127] of Byte; + +const + MaxHashDigestSize = Sizeof(T160BitDigest); + +procedure DigestToHexBufA(const Digest; const Size: Integer; const Buf); +procedure DigestToHexBufW(const Digest; const Size: Integer; const Buf); +function DigestToHexA(const Digest; const Size: Integer): AnsiString; +function DigestToHexW(const Digest; const Size: Integer): WideString; +function Digest128Equal(const Digest1, Digest2: T128BitDigest): Boolean; +function Digest160Equal(const Digest1, Digest2: T160BitDigest): Boolean; +function Digest224Equal(const Digest1, Digest2: T224BitDigest): Boolean; +function Digest256Equal(const Digest1, Digest2: T256BitDigest): Boolean; +function Digest384Equal(const Digest1, Digest2: T384BitDigest): Boolean; +function Digest512Equal(const Digest1, Digest2: T512BitDigest): Boolean; + +{ } +{ Hash errors } +{ } +const + hashNoError = 0; + hashInternalError = 1; + hashInvalidHashType = 2; + hashInvalidBuffer = 3; + hashInvalidBufferSize = 4; + hashInvalidDigest = 5; + hashInvalidKey = 6; + hashInvalidFileName = 7; + hashFileOpenError = 8; + hashFileSeekError = 9; + hashFileReadError = 10; + hashNotKeyedHashType = 11; + hashTooManyOpenHandles = 12; + hashInvalidHandle = 13; + hashMAX_ERROR = 13; + +function GetHashErrorMessage(const ErrorCode: LongWord): PChar; + +type + EHashError = class(Exception) + protected + FErrorCode: LongWord; + + public + constructor Create(const ErrorCode: LongWord; const Msg: string = ''); + property ErrorCode: LongWord read FErrorCode; + end; + +{ } +{ Secure memory clear } +{ Used to clear keys and other sensitive data from memory } +{ } +procedure SecureClear(var Buf; const BufSize: Integer); +procedure SecureClear512(var Buf: T512BitBuf); +procedure SecureClear1024(var Buf: T1024BitBuf); +procedure SecureClearStrA(var S: AnsiString); +procedure SecureClearStrW(var S: WideString); + +{ } +{ Checksum hashing } +{ } +function CalcChecksum32(const Buf; const BufSize: Integer): LongWord; overload; +function CalcChecksum32(const Buf: AnsiString): LongWord; overload; + +{ } +{ XOR hashing } +{ } +function CalcXOR8(const Buf; const BufSize: Integer): Byte; overload; +function CalcXOR8(const Buf: AnsiString): Byte; overload; + +function CalcXOR16(const Buf; const BufSize: Integer): Word; overload; +function CalcXOR16(const Buf: AnsiString): Word; overload; + +function CalcXOR32(const Buf; const BufSize: Integer): LongWord; overload; +function CalcXOR32(const Buf: AnsiString): LongWord; overload; + +{ } +{ CRC 16 hashing } +{ } +{ The theory behind CCITT V.41 CRCs: } +{ } +{ 1. Select the magnitude of the CRC to be used (typically 16 or 32 } +{ bits) and choose the polynomial to use. In the case of 16 bit } +{ CRCs, the CCITT polynomial is recommended and is } +{ } +{ 16 12 5 } +{ G(x) = x + x + x + 1 } +{ } +{ This polynomial traps 100% of 1 bit, 2 bit, odd numbers of bit } +{ errors, 100% of <= 16 bit burst errors and over 99% of all } +{ other errors. } +{ } +{ 2. The CRC is calculated as } +{ r } +{ D(x) = (M(x) * 2 ) mod G(x) } +{ } +{ This may be better described as : Add r bits (0 content) to } +{ the end of M(x). Divide this by G(x) and the remainder is the } +{ CRC. } +{ } +{ 3. Tag the CRC onto the end of M(x). } +{ } +{ 4. To check it, calculate the CRC of the new message D(x), using } +{ the same process as in 2. above. The newly calculated CRC } +{ should be zero. } +{ } +{ This effectively means that using CRCs, it is possible to calculate a } +{ series of bits to tag onto the data which makes the data an exact } +{ multiple of the polynomial. } +{ } +procedure CRC16Init(var CRC16: Word); +function CRC16Byte(const CRC16: Word; const Octet: Byte): Word; +function CRC16Buf(const CRC16: Word; const Buf; const BufSize: Integer): Word; + +function CalcCRC16(const Buf; const BufSize: Integer): Word; overload; +function CalcCRC16(const Buf: AnsiString): Word; overload; + +{ } +{ CRC 32 hashing } +{ } +procedure SetCRC32Poly(const Poly: LongWord); + +procedure CRC32Init(var CRC32: LongWord); +function CRC32Byte(const CRC32: LongWord; const Octet: Byte): LongWord; +function CRC32Buf(const CRC32: LongWord; const Buf; const BufSize: Integer): LongWord; +function CRC32BufNoCase(const CRC32: LongWord; const Buf; const BufSize: Integer): LongWord; + +function CalcCRC32(const Buf; const BufSize: Integer): LongWord; overload; +function CalcCRC32(const Buf: AnsiString): LongWord; overload; + +{ } +{ Adler 32 hashing } +{ } +procedure Adler32Init(var Adler32: LongWord); +function Adler32Byte(const Adler32: LongWord; const Octet: Byte): LongWord; +function Adler32Buf(const Adler32: LongWord; const Buf; const BufSize: Integer): LongWord; + +function CalcAdler32(const Buf; const BufSize: Integer): LongWord; overload; +function CalcAdler32(const Buf: AnsiString): LongWord; overload; + +{ } +{ ELF hashing } +{ } +procedure ELFInit(var Digest: LongWord); +function ELFBuf(const Digest: LongWord; const Buf; const BufSize: Integer): LongWord; + +function CalcELF(const Buf; const BufSize: Integer): LongWord; overload; +function CalcELF(const Buf: AnsiString): LongWord; overload; + +{ } +{ ISBN checksum } +{ } +function IsValidISBN(const S: AnsiString): Boolean; + +{ } +{ LUHN checksum } +{ } +{ The LUHN forumula (also known as mod-10) is used in major credit card } +{ account numbers for validity checking. } +{ } +function IsValidLUHN(const S: AnsiString): Boolean; + +{ } +{ Knuth hash } +{ General purpose string hashing function proposed by Donald E Knuth in } +{ 'The Art of Computer Programming Vol 3'. } +{ } +function KnuthHashA(const S: AnsiString): LongWord; +function KnuthHashW(const S: WideString): LongWord; + +{ } +{ MD5 hash } +{ } +{ MD5 is an Internet standard secure hashing function, that was } +{ developed by Professor Ronald L. Rivest in 1991. Subsequently it has } +{ been placed in the public domain. } +{ MD5 was developed to be more secure after MD4 was 'broken'. } +{ Den Boer and Bosselaers estimate that if a custom machine were to be } +{ built specifically to find collisions for MD5 (costing $10m in 1994) it } +{ would on average take 24 days to find a collision. } +{ } +procedure MD5InitDigest(var Digest: T128BitDigest); +procedure MD5Buf(var Digest: T128BitDigest; const Buf; const BufSize: Integer); +procedure MD5FinalBuf(var Digest: T128BitDigest; const Buf; const BufSize: Integer; + const TotalSize: Int64); + +function CalcMD5(const Buf; const BufSize: Integer): T128BitDigest; overload; +function CalcMD5(const Buf: AnsiString): T128BitDigest; overload; + +function MD5DigestToStrA(const Digest: T128BitDigest): AnsiString; +function MD5DigestToHexA(const Digest: T128BitDigest): AnsiString; +function MD5DigestToHexW(const Digest: T128BitDigest): WideString; + +{ } +{ SHA1 Hashing } +{ } +{ Specification at http://www.itl.nist.gov/fipspubs/fip180-1.htm } +{ Also see RFC 3174. } +{ SHA1 was developed by NIST and is specified in the Secure Hash Standard } +{ (SHS, FIPS 180) and corrects an unpublished flaw the original SHA } +{ algorithm. } +{ SHA1 produces a 160-bit digest and is considered more secure than MD5. } +{ SHA1 has a similar design to the MD4-family of hash functions. } +{ } +procedure SHA1InitDigest(var Digest: T160BitDigest); +procedure SHA1Buf(var Digest: T160BitDigest; const Buf; const BufSize: Integer); +procedure SHA1FinalBuf(var Digest: T160BitDigest; const Buf; const BufSize: Integer; + const TotalSize: Int64); + +function CalcSHA1(const Buf; const BufSize: Integer): T160BitDigest; overload; +function CalcSHA1(const Buf: AnsiString): T160BitDigest; overload; + +function SHA1DigestToStrA(const Digest: T160BitDigest): AnsiString; +function SHA1DigestToHexA(const Digest: T160BitDigest): AnsiString; +function SHA1DigestToHexW(const Digest: T160BitDigest): WideString; + +{ } +{ SHA224 Hashing } +{ } +{ 224 bit SHA-2 hash } +{ http://en.wikipedia.org/wiki/SHA-2 } +{ SHA-224 is based on SHA-256 } +{ } +procedure SHA224InitDigest(var Digest: T256BitDigest); +procedure SHA224Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +procedure SHA224FinalBuf(var Digest: T256BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64; + var OutDigest: T224BitDigest); + +function CalcSHA224(const Buf; const BufSize: Integer): T224BitDigest; overload; +function CalcSHA224(const Buf: AnsiString): T224BitDigest; overload; + +function SHA224DigestToStrA(const Digest: T224BitDigest): AnsiString; +function SHA224DigestToHexA(const Digest: T224BitDigest): AnsiString; +function SHA224DigestToHexW(const Digest: T224BitDigest): WideString; + +{ } +{ SHA256 Hashing } +{ 256 bit SHA-2 hash } +{ } +procedure SHA256InitDigest(var Digest: T256BitDigest); +procedure SHA256Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +procedure SHA256FinalBuf(var Digest: T256BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcSHA256(const Buf; const BufSize: Integer): T256BitDigest; overload; +function CalcSHA256(const Buf: AnsiString): T256BitDigest; overload; + +function SHA256DigestToStrA(const Digest: T256BitDigest): AnsiString; +function SHA256DigestToHexA(const Digest: T256BitDigest): AnsiString; +function SHA256DigestToHexW(const Digest: T256BitDigest): WideString; + +{ } +{ SHA384 Hashing } +{ 384 bit SHA-2 hash } +{ SHA-384 is based on SHA-512 } +{ } +procedure SHA384InitDigest(var Digest: T512BitDigest); +procedure SHA384Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +procedure SHA384FinalBuf(var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64; var OutDigest: T384BitDigest); + +function CalcSHA384(const Buf; const BufSize: Integer): T384BitDigest; overload; +function CalcSHA384(const Buf: AnsiString): T384BitDigest; overload; + +function SHA384DigestToStrA(const Digest: T384BitDigest): AnsiString; +function SHA384DigestToHexA(const Digest: T384BitDigest): AnsiString; +function SHA384DigestToHexW(const Digest: T384BitDigest): WideString; + +{ } +{ SHA512 Hashing } +{ 512 bit SHA-2 hash } +{ } +procedure SHA512InitDigest(var Digest: T512BitDigest); +procedure SHA512Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +procedure SHA512FinalBuf(var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcSHA512(const Buf; const BufSize: Integer): T512BitDigest; overload; +function CalcSHA512(const Buf: AnsiString): T512BitDigest; overload; + +function SHA512DigestToStrA(const Digest: T512BitDigest): AnsiString; +function SHA512DigestToHexA(const Digest: T512BitDigest): AnsiString; +function SHA512DigestToHexW(const Digest: T512BitDigest): WideString; + +{ } +{ HMAC-MD5 keyed hashing } +{ } +{ HMAC allows secure keyed hashing (hashing with a password). } +{ HMAC was designed to meet the requirements of the IPSEC working group in } +{ the IETF, and is now a standard. } +{ HMAC, are proven to be secure as long as the underlying hash function } +{ has some reasonable cryptographic strengths. } +{ See RFC 2104 for details on HMAC. } +{ } +procedure HMAC_MD5Init(const Key: Pointer; const KeySize: Integer; + var Digest: T128BitDigest; var K: T512BitBuf); +procedure HMAC_MD5Buf(var Digest: T128BitDigest; const Buf; const BufSize: Integer); +procedure HMAC_MD5FinalBuf(const K: T512BitBuf; var Digest: T128BitDigest; + const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcHMAC_MD5(const Key: Pointer; const KeySize: Integer; + const Buf; const BufSize: Integer): T128BitDigest; overload; +function CalcHMAC_MD5(const Key: AnsiString; const Buf; const BufSize: Integer): T128BitDigest; overload; +function CalcHMAC_MD5(const Key, Buf: AnsiString): T128BitDigest; overload; + +{ } +{ HMAC-SHA1 keyed hashing } +{ } +procedure HMAC_SHA1Init(const Key: Pointer; const KeySize: Integer; + var Digest: T160BitDigest; var K: T512BitBuf); +procedure HMAC_SHA1Buf(var Digest: T160BitDigest; const Buf; const BufSize: Integer); +procedure HMAC_SHA1FinalBuf(const K: T512BitBuf; var Digest: T160BitDigest; + const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcHMAC_SHA1(const Key: Pointer; const KeySize: Integer; + const Buf; const BufSize: Integer): T160BitDigest; overload; +function CalcHMAC_SHA1(const Key: AnsiString; const Buf; const BufSize: Integer): T160BitDigest; overload; +function CalcHMAC_SHA1(const Key, Buf: AnsiString): T160BitDigest; overload; + +{ } +{ HMAC-SHA256 keyed hashing } +{ } +procedure HMAC_SHA256Init(const Key: Pointer; const KeySize: Integer; + var Digest: T256BitDigest; var K: T512BitBuf); +procedure HMAC_SHA256Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +procedure HMAC_SHA256FinalBuf(const K: T512BitBuf; var Digest: T256BitDigest; + const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcHMAC_SHA256(const Key: Pointer; const KeySize: Integer; + const Buf; const BufSize: Integer): T256BitDigest; overload; +function CalcHMAC_SHA256(const Key: AnsiString; const Buf; const BufSize: Integer): T256BitDigest; overload; +function CalcHMAC_SHA256(const Key, Buf: AnsiString): T256BitDigest; overload; + +{ } +{ HMAC-SHA512 keyed hashing } +{ } +procedure HMAC_SHA512Init(const Key: Pointer; const KeySize: Integer; var Digest: T512BitDigest; var K: T1024BitBuf); +procedure HMAC_SHA512Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +procedure HMAC_SHA512FinalBuf(const K: T1024BitBuf; var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); + +function CalcHMAC_SHA512(const Key: Pointer; const KeySize: Integer; + const Buf; const BufSize: Integer): T512BitDigest; overload; +function CalcHMAC_SHA512(const Key: AnsiString; const Buf; const BufSize: Integer): T512BitDigest; overload; +function CalcHMAC_SHA512(const Key, Buf: AnsiString): T512BitDigest; overload; + +{ } +{ Hash class wrappers } +{ } +type + { AHash } + { Base class for hash classes. } + AHash = class + protected + FDigest : Pointer; + FTotalSize: Int64; + + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); virtual; abstract; + procedure ProcessBuf(const Buf; const BufSize: Integer); virtual; abstract; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); virtual; + + public + class function DigestSize: Integer; virtual; abstract; + class function BlockSize: Integer; virtual; + + procedure Init(const Digest: Pointer; const Key: Pointer = nil; + const KeySize: Integer = 0); overload; + procedure Init(const Digest: Pointer; const Key: AnsiString = ''); overload; + + procedure HashBuf(const Buf; const BufSize: Integer; const FinalBuf: Boolean); + procedure HashFile(const FileName: string; const Offset: Int64 = 0; + const MaxCount: Int64 = - 1); + end; + + THashClass = class of AHash; + + { TChecksum32Hash } + TChecksum32Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TXOR8Hash } + TXOR8Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TXOR16Hash } + TXOR16Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TXOR32Hash } + TXOR32Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TCRC16Hash } + TCRC16Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TCRC32Hash } + TCRC32Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TAdler32Hash } + TAdler32Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TELFHash } + TELFHash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + + public + class function DigestSize: Integer; override; + end; + + { TMD5Hash } + TMD5Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + end; + + { TSHA1Hash } + TSHA1Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + end; + + { TSHA256Hash } + TSHA256Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + end; + + { TSHA512Hash } + TSHA512Hash = class(AHash) + protected + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + end; + + { THMAC_MD5Hash } + THMAC_MD5Hash = class(AHash) + protected + FKey: T512BitBuf; + + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + + destructor Destroy; override; + end; + + { THMAC_SHA1Hash } + THMAC_SHA1Hash = class(AHash) + protected + FKey: T512BitBuf; + + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + + destructor Destroy; override; + end; + + { THMAC_SHA256Hash } + THMAC_SHA256Hash = class(AHash) + protected + FKey: T512BitBuf; + + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + + destructor Destroy; override; + end; + + { THMAC_SHA512Hash } + THMAC_SHA512Hash = class(AHash) + protected + FKey: T1024BitBuf; + + procedure InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); override; + procedure ProcessBuf(const Buf; const BufSize: Integer); override; + procedure ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); override; + + public + class function DigestSize: Integer; override; + class function BlockSize: Integer; override; + + destructor Destroy; override; + end; + +{ } +{ THashType } +{ } +type + THashType = ( + hashChecksum32, hashXOR8, hashXOR16, hashXOR32, + hashCRC16, hashCRC32, + hashAdler32, + hashELF, + hashMD5, hashSHA1, hashSHA256, hashSHA512, + hashHMAC_MD5, hashHMAC_SHA1, hashHMAC_SHA256, hashHMAC_SHA512); + +{ } +{ GetHashClassByType } +{ } +function GetHashClassByType(const HashType: THashType): THashClass; +function GetDigestSize(const HashType: THashType): Integer; + +{ } +{ CalculateHash } +{ } +procedure CalculateHash(const HashType: THashType; + const Buf; const BufSize: Integer; const Digest: Pointer; + const Key: Pointer = nil; const KeySize: Integer = 0); overload; +procedure CalculateHash(const HashType: THashType; + const Buf; const BufSize: Integer; + const Digest: Pointer; const Key: AnsiString = ''); overload; +procedure CalculateHash(const HashType: THashType; + const Buf: AnsiString; const Digest: Pointer; + const Key: AnsiString = ''); overload; + +{ } +{ HashString } +{ } +{ HashString is a fast general purpose ASCII string hashing function. } +{ It returns a 32 bit value in the range 0 to Slots - 1. If Slots = 0 then } +{ the full 32 bit value is returned. } +{ If CaseSensitive = False then HashString will return the same hash value } +{ regardless of the case of the characters in the string. } +{ } +{ The implementation is based on CRC32. It uses up to 48 characters from } +{ the string (first 16 characters, last 16 characters and 16 characters } +{ uniformly sampled from the remaining characters) to calculate the hash } +{ value. } +{ } +function HashString(const StrBuf: Pointer; const StrLength: Integer; + const Slots: LongWord = 0; const CaseSensitive: Boolean = True): LongWord; overload; +function HashString(const S: AnsiString; const Slots: LongWord = 0; + const CaseSensitive: Boolean = True): LongWord; overload; + +implementation + +{ } +{ Hash errors } +{ } +const + hashErrorMessages: array [0 .. hashMAX_ERROR] of string = ( + '', + 'Internal error', + 'Invalid hash type', + 'Invalid buffer', + 'Invalid buffer size', + 'Invalid digest', + 'Invalid key', + 'Invalid file name', + 'File open error', + 'File seek error', + 'File read error', + 'Not a keyed hash type', + 'Too many open handles', + 'Invalid handle'); + +function GetHashErrorMessage(const ErrorCode: LongWord): PChar; +begin + if (ErrorCode = hashNoError) or (ErrorCode > hashMAX_ERROR) then + Result := nil + else + Result := PChar(hashErrorMessages[ErrorCode]); +end; + +{ } +{ EHashError } +{ } +constructor EHashError.Create(const ErrorCode: LongWord; const Msg: string); +begin + FErrorCode := ErrorCode; + if (Msg = '') and (ErrorCode <= hashMAX_ERROR) then + inherited Create(hashErrorMessages[ErrorCode]) + else + inherited Create(Msg); +end; + +{ } +{ Secure memory clear } +{ } +procedure SecureClear(var Buf; const BufSize: Integer); +begin + if BufSize <= 0 then + exit; + FillChar(Buf, BufSize, #$00); +end; + +procedure SecureClear512(var Buf: T512BitBuf); +begin + SecureClear(Buf, SizeOf(Buf)); +end; + +procedure SecureClear1024(var Buf: T1024BitBuf); +begin + SecureClear(Buf, SizeOf(Buf)); +end; + +procedure SecureClearStrA(var S: AnsiString); +var + L: Integer; +begin + L := Length(S); + if L = 0 then + exit; + SecureClear(S[1], L); + S := ''; +end; + +procedure SecureClearStrW(var S: WideString); +var + L: Integer; +begin + L := Length(S); + if L = 0 then + exit; + SecureClear(S[1], L * SizeOf(WideChar)); + S := ''; +end; + +{ } +{ Checksum hashing } +{ } +{$IFDEF ASM386_DELPHI} + + +function CalcChecksum32(const Buf; const BufSize: Integer): LongWord; +asm + or eax, eax //eax = Buf + jz @fin + or edx, edx //edx = BufSize + jbe @finz + push esi + mov esi, eax + add esi, edx + xor eax, eax + xor ecx, ecx +@l1: + dec esi + mov cl, [esi] + add eax, ecx + dec edx + jnz @l1 + pop esi +@fin: + ret +@finz: + xor eax, eax +end; +{$ELSE} + + +function CalcChecksum32(const Buf; const BufSize: Integer): LongWord; +var + I: Integer; + P: PByte; +begin + Result := 0; + P := @Buf; + for I := 1 to BufSize do + begin + Inc(Result, P^); + Inc(P); + end; +end; +{$ENDIF} + + +function CalcChecksum32(const Buf: AnsiString): LongWord; +begin + Result := CalcChecksum32(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ XOR hashing } +{ } +{$IFDEF ASM386_DELPHI} + + +function XOR32Buf(const Buf; const BufSize: Integer): LongWord; +Asm + or eax, eax + jz @fin + or edx, edx + jz @finz + + push esi + mov esi, eax + xor eax, eax + + mov ecx, edx + shr ecx, 2 + jz @rest + +@l1: + xor eax, [esi] + add esi, 4 + dec ecx + jnz @l1 + +@rest: + and edx, 3 + jz @finp + xor al, [esi] + dec edx + jz @finp + inc esi + xor ah, [esi] + dec edx + jz @finp + inc esi + mov dl, [esi] + shl edx, 16 + xor eax, edx + +@finp: + pop esi + ret +@finz: + xor eax, eax +@fin: + ret +end; +{$ELSE} + + +function XOR32Buf(const Buf; const BufSize: Integer): LongWord; +var + I: Integer; + L: Byte; + P: PAnsiChar; +begin + Result := 0; + L := 0; + P := @Buf; + for I := 1 to BufSize do + begin + Result := Result xor (Byte(P^) shl L); + Inc(L, 8); + if L = 32 then + L := 0; + Inc(P); + end; +end; +{$ENDIF} + + +function CalcXOR8(const Buf; const BufSize: Integer): Byte; +var + L: LongWord; +begin + L := XOR32Buf(Buf, BufSize); + Result := Byte(L) xor + Byte(L shr 8) xor + Byte(L shr 16) xor + Byte(L shr 24); +end; + +function CalcXOR8(const Buf: AnsiString): Byte; +begin + Result := CalcXOR8(Pointer(Buf)^, Length(Buf)); +end; + +function CalcXOR16(const Buf; const BufSize: Integer): Word; +var + L: LongWord; +begin + L := XOR32Buf(Buf, BufSize); + Result := Word(L) xor + Word(L shr 16); +end; + +function CalcXOR16(const Buf: AnsiString): Word; +begin + Result := CalcXOR16(Pointer(Buf)^, Length(Buf)); +end; + +function CalcXOR32(const Buf; const BufSize: Integer): LongWord; +begin + Result := XOR32Buf(Buf, BufSize); +end; + +function CalcXOR32(const Buf: AnsiString): LongWord; +begin + Result := XOR32Buf(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ CRC 16 hashing } +{ } +const + CRC16Table: array [Byte] of Word = ( + $0000, $1021, $2042, $3063, $4084, $50A5, $60C6, $70E7, + $8108, $9129, $A14A, $B16B, $C18C, $D1AD, $E1CE, $F1EF, + $1231, $0210, $3273, $2252, $52B5, $4294, $72F7, $62D6, + $9339, $8318, $B37B, $A35A, $D3BD, $C39C, $F3FF, $E3DE, + $2462, $3443, $0420, $1401, $64E6, $74C7, $44A4, $5485, + $A56A, $B54B, $8528, $9509, $E5EE, $F5CF, $C5AC, $D58D, + $3653, $2672, $1611, $0630, $76D7, $66F6, $5695, $46B4, + $B75B, $A77A, $9719, $8738, $F7DF, $E7FE, $D79D, $C7BC, + $48C4, $58E5, $6886, $78A7, $0840, $1861, $2802, $3823, + $C9CC, $D9ED, $E98E, $F9AF, $8948, $9969, $A90A, $B92B, + $5AF5, $4AD4, $7AB7, $6A96, $1A71, $0A50, $3A33, $2A12, + $DBFD, $CBDC, $FBBF, $EB9E, $9B79, $8B58, $BB3B, $AB1A, + $6CA6, $7C87, $4CE4, $5CC5, $2C22, $3C03, $0C60, $1C41, + $EDAE, $FD8F, $CDEC, $DDCD, $AD2A, $BD0B, $8D68, $9D49, + $7E97, $6EB6, $5ED5, $4EF4, $3E13, $2E32, $1E51, $0E70, + $FF9F, $EFBE, $DFDD, $CFFC, $BF1B, $AF3A, $9F59, $8F78, + $9188, $81A9, $B1CA, $A1EB, $D10C, $C12D, $F14E, $E16F, + $1080, $00A1, $30C2, $20E3, $5004, $4025, $7046, $6067, + $83B9, $9398, $A3FB, $B3DA, $C33D, $D31C, $E37F, $F35E, + $02B1, $1290, $22F3, $32D2, $4235, $5214, $6277, $7256, + $B5EA, $A5CB, $95A8, $8589, $F56E, $E54F, $D52C, $C50D, + $34E2, $24C3, $14A0, $0481, $7466, $6447, $5424, $4405, + $A7DB, $B7FA, $8799, $97B8, $E75F, $F77E, $C71D, $D73C, + $26D3, $36F2, $0691, $16B0, $6657, $7676, $4615, $5634, + $D94C, $C96D, $F90E, $E92F, $99C8, $89E9, $B98A, $A9AB, + $5844, $4865, $7806, $6827, $18C0, $08E1, $3882, $28A3, + $CB7D, $DB5C, $EB3F, $FB1E, $8BF9, $9BD8, $ABBB, $BB9A, + $4A75, $5A54, $6A37, $7A16, $0AF1, $1AD0, $2AB3, $3A92, + $FD2E, $ED0F, $DD6C, $CD4D, $BDAA, $AD8B, $9DE8, $8DC9, + $7C26, $6C07, $5C64, $4C45, $3CA2, $2C83, $1CE0, $0CC1, + $EF1F, $FF3E, $CF5D, $DF7C, $AF9B, $BFBA, $8FD9, $9FF8, + $6E17, $7E36, $4E55, $5E74, $2E93, $3EB2, $0ED1, $1EF0); + +function CRC16Byte(const CRC16: Word; const Octet: Byte): Word; +begin + Result := CRC16Table[Byte(Hi(CRC16) xor Octet)] xor Word(CRC16 shl 8); +end; + +function CRC16Buf(const CRC16: Word; const Buf; const BufSize: Integer): Word; +var + I: Integer; + P: PByte; +begin + Result := CRC16; + P := @Buf; + for I := 1 to BufSize do + begin + Result := CRC16Byte(Result, P^); + Inc(P); + end; +end; + +procedure CRC16Init(var CRC16: Word); +begin + CRC16 := $FFFF; +end; + +function CalcCRC16(const Buf; const BufSize: Integer): Word; +begin + CRC16Init(Result); + Result := CRC16Buf(Result, Buf, BufSize); +end; + +function CalcCRC16(const Buf: AnsiString): Word; +begin + Result := CalcCRC16(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ CRC 32 hashing } +{ } +var + CRC32TableInit: Boolean = False; + CRC32Table : array [Byte] of LongWord; + CRC32Poly : LongWord = $EDB88320; + +procedure InitCRC32Table; +var + I, J: Byte; + R : LongWord; +begin + for I := $00 to $FF do + begin + R := I; + for J := 8 downto 1 do + if R and 1 <> 0 then + R := (R shr 1) xor CRC32Poly + else + R := R shr 1; + CRC32Table[I] := R; + end; + CRC32TableInit := True; +end; + +procedure SetCRC32Poly(const Poly: LongWord); +begin + CRC32Poly := Poly; + CRC32TableInit := False; +end; + +function CalcCRC32Byte(const CRC32: LongWord; const Octet: Byte): LongWord; {$IFDEF UseInline}inline; {$ENDIF} +begin + Result := CRC32Table[Byte(CRC32) xor Octet] xor ((CRC32 shr 8) and $00FFFFFF); +end; + +function CRC32Byte(const CRC32: LongWord; const Octet: Byte): LongWord; +begin + if not CRC32TableInit then + InitCRC32Table; + Result := CalcCRC32Byte(CRC32, Octet); +end; + +function CRC32Buf(const CRC32: LongWord; const Buf; const BufSize: Integer): LongWord; +var + P: PByte; + I: Integer; +begin + if not CRC32TableInit then + InitCRC32Table; + P := @Buf; + Result := CRC32; + for I := 1 to BufSize do + begin + Result := CalcCRC32Byte(Result, P^); + Inc(P); + end; +end; + +function CRC32BufNoCase(const CRC32: LongWord; const Buf; const BufSize: Integer): LongWord; +var + P: PByte; + I: Integer; + C: Byte; +begin + if not CRC32TableInit then + InitCRC32Table; + P := @Buf; + Result := CRC32; + for I := 1 to BufSize do + begin + C := P^; + if AnsiChar(C) in ['A' .. 'Z'] then + C := C or 32; + Result := CalcCRC32Byte(Result, C); + Inc(P); + end; +end; + +procedure CRC32Init(var CRC32: LongWord); +begin + CRC32 := $FFFFFFFF; +end; + +function CalcCRC32(const Buf; const BufSize: Integer): LongWord; +begin + CRC32Init(Result); + Result := not CRC32Buf(Result, Buf, BufSize); +end; + +function CalcCRC32(const Buf: AnsiString): LongWord; +begin + Result := CalcCRC32(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ Adler 32 hashing } +{ } +procedure Adler32Init(var Adler32: LongWord); +begin + Adler32 := $00000001; +end; + +const + Adler32Mod = 65521; // largest prime smaller than 65536 + +function Adler32Byte(const Adler32: LongWord; const Octet: Byte): LongWord; +var + A, B: LongWord; +begin + A := Adler32 and $0000FFFF; + B := Adler32 shr 16; + Inc(A, Octet); + Inc(B, A); + if A >= Adler32Mod then + Dec(A, Adler32Mod); + if B >= Adler32Mod then + Dec(B, Adler32Mod); + Result := A or (B shl 16); +end; + +function Adler32Buf(const Adler32: LongWord; const Buf; const BufSize: Integer): LongWord; +var + A, B: LongWord; + P : PByte; + I : Integer; +begin + A := Adler32 and $0000FFFF; + B := Adler32 shr 16; + P := @Buf; + for I := 1 to BufSize do + begin + Inc(A, P^); + Inc(B, A); + if A >= Adler32Mod then + Dec(A, Adler32Mod); + if B >= Adler32Mod then + Dec(B, Adler32Mod); + Inc(P); + end; + Result := A or (B shl 16); +end; + +function CalcAdler32(const Buf; const BufSize: Integer): LongWord; +begin + Adler32Init(Result); + Result := Adler32Buf(Result, Buf, BufSize); +end; + +function CalcAdler32(const Buf: AnsiString): LongWord; +begin + Result := CalcAdler32(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ ELF hashing } +{ } +procedure ELFInit(var Digest: LongWord); +begin + Digest := 0; +end; + +function ELFBuf(const Digest: LongWord; const Buf; const BufSize: Integer): LongWord; +var + I: Integer; + P: PByte; + X: LongWord; +begin + Result := Digest; + P := @Buf; + for I := 1 to BufSize do + begin + Result := (Result shl 4) + P^; + Inc(P); + X := Result and $F0000000; + if X <> 0 then + Result := Result xor (X shr 24); + Result := Result and (not X); + end; +end; + +function CalcELF(const Buf; const BufSize: Integer): LongWord; +begin + Result := ELFBuf(0, Buf, BufSize); +end; + +function CalcELF(const Buf: AnsiString): LongWord; +begin + Result := CalcELF(Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ ISBN checksum } +{ } +function IsValidISBN(const S: AnsiString): Boolean; +var + I, L, M, D, C: Integer; + P : PAnsiChar; +begin + L := Length(S); + if L < 10 then // too few digits + begin + Result := False; + exit; + end; + M := 10; + C := 0; + P := Pointer(S); + for I := 1 to L do + begin + if (P^ in ['0' .. '9']) or ((M = 1) and (P^ in ['x', 'X'])) then + begin + if M = 0 then // too many digits + begin + Result := False; + exit; + end; + if P^ in ['x', 'X'] then + D := 10 + else + D := Ord(P^) - Ord('0'); + Inc(C, M * D); + Dec(M); + end; + Inc(P); + end; + if M > 0 then // too few digits + begin + Result := False; + exit; + end; + Result := C mod 11 = 0; +end; + +{ } +{ LUHN checksum } +{ } +function IsValidLUHN(const S: AnsiString): Boolean; +var + P : PAnsiChar; + I, L, M, C, D: Integer; + R : Boolean; +begin + L := Length(S); + if L = 0 then + begin + Result := False; + exit; + end; + P := Pointer(S); + Inc(P, L - 1); + C := 0; + M := 0; + R := False; + for I := 1 to L do + begin + if P^ in ['0' .. '9'] then + begin + D := Ord(P^) - Ord('0'); + if R then + begin + D := D * 2; + D := (D div 10) + (D mod 10); + end; + Inc(C, D); + Inc(M); + R := not R; + end; + Dec(P); + end; + Result := (M >= 1) and (C mod 10 = 0); +end; + +{ } +{ Knuth Hash } +{ } +function KnuthHashA(const S: AnsiString): LongWord; +var + I, L: Integer; + H : LongWord; +begin + L := Length(S); + H := L; + for I := 1 to L do + H := ((H shr 5) xor (H shl 27)) xor Ord(S[I]); + Result := H; +end; + +function KnuthHashW(const S: WideString): LongWord; +var + I, L: Integer; + H : LongWord; +begin + L := Length(S); + H := L; + for I := 1 to L do + H := ((H shr 5) xor (H shl 27)) xor Ord(S[I]); + Result := H; +end; + +{ } +{ Digests } +{ } +const + s_HexDigitsLower: string[16] = '0123456789abcdef'; + +procedure DigestToHexBufA(const Digest; const Size: Integer; const Buf); +var + I: Integer; + P: PAnsiChar; + Q: PByte; +begin + P := @Buf;; + Assert(Assigned(P)); + Q := @Digest; + Assert(Assigned(Q)); + for I := 0 to Size - 1 do + begin + P^ := s_HexDigitsLower[Q^ shr 4 + 1]; + Inc(P); + P^ := s_HexDigitsLower[Q^ and 15 + 1]; + Inc(P); + Inc(Q); + end; +end; + +procedure DigestToHexBufW(const Digest; const Size: Integer; const Buf); +var + I: Integer; + P: PWideChar; + Q: PByte; +begin + P := @Buf;; + Assert(Assigned(P)); + Q := @Digest; + Assert(Assigned(Q)); + for I := 0 to Size - 1 do + begin + P^ := WideChar(s_HexDigitsLower[Q^ shr 4 + 1]); + Inc(P); + P^ := WideChar(s_HexDigitsLower[Q^ and 15 + 1]); + Inc(P); + Inc(Q); + end; +end; + +function DigestToHexA(const Digest; const Size: Integer): AnsiString; +begin + SetLength(Result, Size * 2); + DigestToHexBufA(Digest, Size, Pointer(Result)^); +end; + +function DigestToHexW(const Digest; const Size: Integer): WideString; +begin + SetLength(Result, Size * 2); + DigestToHexBufW(Digest, Size, Pointer(Result)^); +end; + +function Digest128Equal(const Digest1, Digest2: T128BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 3 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +function Digest160Equal(const Digest1, Digest2: T160BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 4 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +function Digest224Equal(const Digest1, Digest2: T224BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 6 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +function Digest256Equal(const Digest1, Digest2: T256BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 7 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +function Digest384Equal(const Digest1, Digest2: T384BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 11 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +function Digest512Equal(const Digest1, Digest2: T512BitDigest): Boolean; +var + I: Integer; +begin + for I := 0 to 15 do + if Digest1.Longs[I] <> Digest2.Longs[I] then + begin + Result := False; + exit; + end; + Result := True; +end; + +{ } +{ ReverseMem } +{ Utility function to reverse order of data in buffer. } +{ } +procedure ReverseMem(var Buf; const BufSize: Integer); +var + I: Integer; + P: PByte; + Q: PByte; + T: Byte; +begin + P := @Buf; + Q := P; + Inc(Q, BufSize - 1); + for I := 1 to BufSize div 2 do + begin + T := P^; + P^ := Q^; + Q^ := T; + Inc(P); + Dec(Q); + end; +end; + +{ } +{ StdFinalBuf } +{ Utility function to prepare final buffer(s). } +{ Fills Buf1 and potentially Buf2 from Buf (FinalBufCount = 1 or 2). } +{ Used by MD5, SHA1, SHA256, SHA512. } +{ } +procedure StdFinalBuf512( + const Buf; const BufSize: Integer; const TotalSize: Int64; + var Buf1, Buf2: T512BitBuf; + var FinalBufs: Integer; + const SwapEndian: Boolean); +var + P, Q: PByte; + I : Integer; + L : Int64; +begin + Assert(BufSize < 64, 'Final BufSize must be less than 64 bytes'); + Assert(TotalSize >= BufSize, 'TotalSize >= BufSize'); + + P := @Buf; + Q := @Buf1[0]; + if BufSize > 0 then + begin + Move(P^, Q^, BufSize); + Inc(Q, BufSize); + end; + Q^ := $80; + Inc(Q); + +{$IFDEF DELPHI5} + // Delphi 5 sometimes reports fatal error (internal error C1093) when compiling: + // L := TotalSize * 8 + L := TotalSize; + L := L * 8; +{$ELSE} + L := TotalSize * 8; +{$ENDIF} + if SwapEndian then + ReverseMem(L, 8); + if BufSize + 1 > 64 - Sizeof(Int64) then + begin + FillChar(Q^, 64 - BufSize - 1, #0); + Q := @Buf2[0]; + FillChar(Q^, 64 - Sizeof(Int64), #0); + Inc(Q, 64 - Sizeof(Int64)); + PInt64(Q)^ := L; + FinalBufs := 2; + end + else + begin + I := 64 - Sizeof(Int64) - BufSize - 1; + FillChar(Q^, I, #0); + Inc(Q, I); + PInt64(Q)^ := L; + FinalBufs := 1; + end; +end; + +procedure StdFinalBuf1024( + const Buf; const BufSize: Integer; const TotalSize: Int64; + var Buf1, Buf2: T1024BitBuf; + var FinalBufs: Integer; + const SwapEndian: Boolean); +var + P, Q: PByte; + I : Integer; + L : Int64; +begin + Assert(BufSize < 128, 'Final BufSize must be less than 128 bytes'); + Assert(TotalSize >= BufSize, 'TotalSize >= BufSize'); + + P := @Buf; + Q := @Buf1[0]; + if BufSize > 0 then + begin + Move(P^, Q^, BufSize); + Inc(Q, BufSize); + end; + Q^ := $80; + Inc(Q); + +{$IFDEF DELPHI5} + // Delphi 5 sometimes reports fatal error (internal error C1093) when compiling: + // L := TotalSize * 8 + L := TotalSize; + L := L * 8; +{$ELSE} + L := TotalSize * 8; +{$ENDIF} + if SwapEndian then + ReverseMem(L, 8); + if BufSize + 1 > 128 - Sizeof(Int64) * 2 then + begin + FillChar(Q^, 128 - BufSize - 1, #0); + Q := @Buf2[0]; + FillChar(Q^, 128 - Sizeof(Int64) * 2, #0); + Inc(Q, 128 - Sizeof(Int64) * 2); + PInt64(Q)^ := 0; + Inc(Q, 8); + PInt64(Q)^ := L; + FinalBufs := 2; + end + else + begin + I := 128 - Sizeof(Int64) * 2 - BufSize - 1; + FillChar(Q^, I, #0); + Inc(Q, I); + PInt64(Q)^ := 0; + Inc(Q, 8); + PInt64(Q)^ := L; + FinalBufs := 1; + end; +end; + +{ } +{ Utility functions SwapEndian, RotateLeftBits, RotateRightBits. } +{ Used by SHA1 and SHA256. } +{ } +{$IFDEF ASM386} + + +function SwapEndian(const Value: LongWord): LongWord; register; assembler; +asm + XCHG AH, AL + ROL EAX, 16 + XCHG AH, AL +end; +{$ELSE} + + +function SwapEndian(const Value: LongWord): LongWord; +begin + Result := ((Value and $000000FF) shl 24) or + ((Value and $0000FF00) shl 8) or + ((Value and $00FF0000) shr 8) or + ((Value and $FF000000) shr 24); +end; +{$ENDIF} + + +procedure SwapEndianBuf(var Buf; const Count: Integer); +var + P: PLongWord; + I: Integer; +begin + P := @Buf; + for I := 1 to Count do + begin + P^ := SwapEndian(P^); + Inc(P); + end; +end; + +{$IFDEF ASM386_DELPHI} + + +function RotateLeftBits(const Value: LongWord; const Bits: Byte): LongWord; +asm + MOV CL, DL + ROL EAX, CL +end; +{$ELSE} + + +function RotateLeftBits(const Value: LongWord; const Bits: Byte): LongWord; +var + I: Integer; +begin + Result := Value; + for I := 1 to Bits do + if Result and $80000000 = 0 then + Result := Value shl 1 + else + Result := (Value shl 1) or 1; +end; +{$ENDIF} + +{$IFDEF ASM386_DELPHI} + + +function RotateRightBits(const Value: LongWord; const Bits: Byte): LongWord; +asm + MOV CL, DL + ROR EAX, CL +end; +{$ELSE} + + +function RotateRightBits(const Value: LongWord; const Bits: Byte): LongWord; +var + I, B: Integer; +begin + Result := Value; + if Bits >= 32 then + B := Bits mod 32 + else + B := Bits; + for I := 1 to B do + if Result and 1 = 0 then + Result := Result shr 1 + else + Result := (Result shr 1) or $80000000; +end; +{$ENDIF} + + +{ } +{ Utility functions for Word64 arithmetic } +{ Used by SHA-512 } +{ } +procedure Word64InitZero(var A: Word64); +begin + A.LongWords[0] := 0; + A.LongWords[1] := 0; +end; + +procedure Word64Not(var A: Word64); +begin + A.LongWords[0] := not A.LongWords[0]; + A.LongWords[1] := not A.LongWords[1]; +end; + +procedure Word64AndWord64(var A: Word64; const B: Word64); +begin + A.LongWords[0] := A.LongWords[0] and B.LongWords[0]; + A.LongWords[1] := A.LongWords[1] and B.LongWords[1]; +end; + +procedure Word64XorWord64(var A: Word64; const B: Word64); +begin + A.LongWords[0] := A.LongWords[0] xor B.LongWords[0]; + A.LongWords[1] := A.LongWords[1] xor B.LongWords[1]; +end; + +procedure Word64AddWord64(var A: Word64; const B: Word64); +var + C, D: Int64; +begin + C := Int64(A.LongWords[0]) + B.LongWords[0]; + D := Int64(A.LongWords[1]) + B.LongWords[1]; + if C >= $100000000 then + Inc(D); + A.LongWords[0] := C and $FFFFFFFF; + A.LongWords[1] := D and $FFFFFFFF; +end; + +procedure Word64Shr(var A: Word64; const B: Byte); +var + C: Byte; +begin + if B = 0 then + exit; + if B >= 64 then + Word64InitZero(A) + else + if B < 32 then + begin + C := 32 - B; + A.LongWords[0] := (A.LongWords[0] shr B) or (A.LongWords[1] shl C); + A.LongWords[1] := A.LongWords[1] shr B; + end + else + begin + C := B - 32; + A.LongWords[0] := A.LongWords[1] shr C; + A.LongWords[1] := 0; + end; +end; + +procedure Word64Ror(var A: Word64; const B: Byte); +var + C, D: Byte; + E, F: LongWord; +begin + C := B mod 64; + if C = 0 then + exit; + if C < 32 then + begin + D := 32 - C; + E := (A.LongWords[1] shr C) or (A.LongWords[0] shl D); + F := (A.LongWords[0] shr C) or (A.LongWords[1] shl D); + end + else + begin + Dec(C, 32); + D := 32 - C; + E := (A.LongWords[0] shr C) or (A.LongWords[1] shl D); + F := (A.LongWords[1] shr C) or (A.LongWords[0] shl D); + end; + A.LongWords[1] := E; + A.LongWords[0] := F; +end; + +procedure Word64SwapEndian(var A: Word64); +var + B: Word64; + I: Integer; +begin + B := A; + for I := 0 to 7 do + A.Bytes[I] := B.Bytes[7 - I]; +end; + +procedure SwapEndianBuf64(var Buf; const Count: Integer); +var + P: PWord64; + I: Integer; +begin + P := @Buf; + for I := 1 to Count do + begin + Word64SwapEndian(P^); + Inc(P); + end; +end; + +{ } +{ MD5 hashing } +{ } +const + MD5Table_1: array [0 .. 15] of LongWord = ( + $D76AA478, $E8C7B756, $242070DB, $C1BDCEEE, + $F57C0FAF, $4787C62A, $A8304613, $FD469501, + $698098D8, $8B44F7AF, $FFFF5BB1, $895CD7BE, + $6B901122, $FD987193, $A679438E, $49B40821); + MD5Table_2: array [0 .. 15] of LongWord = ( + $F61E2562, $C040B340, $265E5A51, $E9B6C7AA, + $D62F105D, $02441453, $D8A1E681, $E7D3FBC8, + $21E1CDE6, $C33707D6, $F4D50D87, $455A14ED, + $A9E3E905, $FCEFA3F8, $676F02D9, $8D2A4C8A); + MD5Table_3: array [0 .. 15] of LongWord = ( + $FFFA3942, $8771F681, $6D9D6122, $FDE5380C, + $A4BEEA44, $4BDECFA9, $F6BB4B60, $BEBFBC70, + $289B7EC6, $EAA127FA, $D4EF3085, $04881D05, + $D9D4D039, $E6DB99E5, $1FA27CF8, $C4AC5665); + MD5Table_4: array [0 .. 15] of LongWord = ( + $F4292244, $432AFF97, $AB9423A7, $FC93A039, + $655B59C3, $8F0CCC92, $FFEFF47D, $85845DD1, + $6FA87E4F, $FE2CE6E0, $A3014314, $4E0811A1, + $F7537E82, $BD3AF235, $2AD7D2BB, $EB86D391); + +{ Calculates a MD5 Digest (16 bytes) given a Buffer (64 bytes) } +{$IFOPT Q+}{$DEFINE QOn}{$Q-}{$ELSE}{$UNDEF QOn}{$ENDIF} + + +procedure TransformMD5Buffer(var Digest: T128BitDigest; const Buffer); +var + A, B, C, D: LongWord; + P : PLongWord; + I : Integer; + J : Byte; + Buf : array [0 .. 15] of LongWord absolute Buffer; +begin + A := Digest.Longs[0]; + B := Digest.Longs[1]; + C := Digest.Longs[2]; + D := Digest.Longs[3]; + + P := @MD5Table_1; + for I := 0 to 3 do + begin + J := I * 4; + Inc(A, Buf[J] + P^ + (D xor (B and (C xor D)))); + A := A shl 7 or A shr 25 + B; + Inc(P); + Inc(D, Buf[J + 1] + P^ + (C xor (A and (B xor C)))); + D := D shl 12 or D shr 20 + A; + Inc(P); + Inc(C, Buf[J + 2] + P^ + (B xor (D and (A xor B)))); + C := C shl 17 or C shr 15 + D; + Inc(P); + Inc(B, Buf[J + 3] + P^ + (A xor (C and (D xor A)))); + B := B shl 22 or B shr 10 + C; + Inc(P); + end; + + P := @MD5Table_2; + for I := 0 to 3 do + begin + J := I * 4; + Inc(A, Buf[J + 1] + P^ + (C xor (D and (B xor C)))); + A := A shl 5 or A shr 27 + B; + Inc(P); + Inc(D, Buf[(J + 6) mod 16] + P^ + (B xor (C and (A xor B)))); + D := D shl 9 or D shr 23 + A; + Inc(P); + Inc(C, Buf[(J + 11) mod 16] + P^ + (A xor (B and (D xor A)))); + C := C shl 14 or C shr 18 + D; + Inc(P); + Inc(B, Buf[J] + P^ + (D xor (A and (C xor D)))); + B := B shl 20 or B shr 12 + C; + Inc(P); + end; + + P := @MD5Table_3; + for I := 0 to 3 do + begin + J := 16 - (I * 4); + Inc(A, Buf[(J + 5) mod 16] + P^ + (B xor C xor D)); + A := A shl 4 or A shr 28 + B; + Inc(P); + Inc(D, Buf[(J + 8) mod 16] + P^ + (A xor B xor C)); + D := D shl 11 or D shr 21 + A; + Inc(P); + Inc(C, Buf[(J + 11) mod 16] + P^ + (D xor A xor B)); + C := C shl 16 or C shr 16 + D; + Inc(P); + Inc(B, Buf[(J + 14) mod 16] + P^ + (C xor D xor A)); + B := B shl 23 or B shr 9 + C; + Inc(P); + end; + + P := @MD5Table_4; + for I := 0 to 3 do + begin + J := 16 - (I * 4); + Inc(A, Buf[J mod 16] + P^ + (C xor (B or not D))); + A := A shl 6 or A shr 26 + B; + Inc(P); + Inc(D, Buf[(J + 7) mod 16] + P^ + (B xor (A or not C))); + D := D shl 10 or D shr 22 + A; + Inc(P); + Inc(C, Buf[(J + 14) mod 16] + P^ + (A xor (D or not B))); + C := C shl 15 or C shr 17 + D; + Inc(P); + Inc(B, Buf[(J + 5) mod 16] + P^ + (D xor (C or not A))); + B := B shl 21 or B shr 11 + C; + Inc(P); + end; + + Inc(Digest.Longs[0], A); + Inc(Digest.Longs[1], B); + Inc(Digest.Longs[2], C); + Inc(Digest.Longs[3], D); +end; +{$IFDEF QOn}{$Q+}{$ENDIF} + + +procedure MD5InitDigest(var Digest: T128BitDigest); +begin + Digest.Longs[0] := $67452301; + Digest.Longs[1] := $EFCDAB89; + Digest.Longs[2] := $98BADCFE; + Digest.Longs[3] := $10325476; +end; + +procedure MD5Buf(var Digest: T128BitDigest; const Buf; const BufSize: Integer); +var + P : PByte; + I, J: Integer; +begin + I := BufSize; + if I <= 0 then + exit; + Assert(I mod 64 = 0, 'BufSize must be multiple of 64 bytes'); + P := @Buf; + for J := 0 to I div 64 - 1 do + begin + TransformMD5Buffer(Digest, P^); + Inc(P, 64); + end; +end; + +procedure MD5FinalBuf(var Digest: T128BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + B1, B2: T512BitBuf; + C : Integer; +begin + StdFinalBuf512(Buf, BufSize, TotalSize, B1, B2, C, False); + TransformMD5Buffer(Digest, B1); + if C > 1 then + TransformMD5Buffer(Digest, B2); + SecureClear512(B1); + if C > 1 then + SecureClear512(B2); +end; + +function CalcMD5(const Buf; const BufSize: Integer): T128BitDigest; +var + I, J: Integer; + P : PByte; +begin + MD5InitDigest(Result); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + MD5Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + MD5FinalBuf(Result, P^, I, BufSize); +end; + +function CalcMD5(const Buf: AnsiString): T128BitDigest; +begin + Result := CalcMD5(Pointer(Buf)^, Length(Buf)); +end; + +function MD5DigestToStrA(const Digest: T128BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function MD5DigestToHexA(const Digest: T128BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function MD5DigestToHexW(const Digest: T128BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ SHA hashing } +{ } +procedure SHA1InitDigest(var Digest: T160BitDigest); +begin + Digest.Longs[0] := $67452301; + Digest.Longs[1] := $EFCDAB89; + Digest.Longs[2] := $98BADCFE; + Digest.Longs[3] := $10325476; + Digest.Longs[4] := $C3D2E1F0; +end; + +{ Calculates a SHA Digest (20 bytes) given a Buffer (64 bytes) } +{$IFOPT Q+}{$DEFINE QOn}{$Q-}{$ELSE}{$UNDEF QOn}{$ENDIF} + + +procedure TransformSHABuffer(var Digest: T160BitDigest; const Buffer; const SHA1: Boolean); +var + A, B, C, D, E: LongWord; + W : array [0 .. 79] of LongWord; + P, Q : PLongWord; + I : Integer; + J : LongWord; +begin + P := @Buffer; + Q := @W; + for I := 0 to 15 do + begin + Q^ := SwapEndian(P^); + Inc(P); + Inc(Q); + end; + for I := 0 to 63 do + begin + P := Q; + Dec(P, 16); + J := P^; + Inc(P, 2); + J := J xor P^; + Inc(P, 6); + J := J xor P^; + Inc(P, 5); + J := J xor P^; + if SHA1 then + J := RotateLeftBits(J, 1); + Q^ := J; + Inc(Q); + end; + + A := Digest.Longs[0]; + B := Digest.Longs[1]; + C := Digest.Longs[2]; + D := Digest.Longs[3]; + E := Digest.Longs[4]; + + P := @W; + for I := 0 to 3 do + begin + Inc(E, (A shl 5 or A shr 27) + (D xor (B and (C xor D))) + P^ + $5A827999); + B := B shr 2 or B shl 30; + Inc(P); + Inc(D, (E shl 5 or E shr 27) + (C xor (A and (B xor C))) + P^ + $5A827999); + A := A shr 2 or A shl 30; + Inc(P); + Inc(C, (D shl 5 or D shr 27) + (B xor (E and (A xor B))) + P^ + $5A827999); + E := E shr 2 or E shl 30; + Inc(P); + Inc(B, (C shl 5 or C shr 27) + (A xor (D and (E xor A))) + P^ + $5A827999); + D := D shr 2 or D shl 30; + Inc(P); + Inc(A, (B shl 5 or B shr 27) + (E xor (C and (D xor E))) + P^ + $5A827999); + C := C shr 2 or C shl 30; + Inc(P); + end; + + for I := 0 to 3 do + begin + Inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + P^ + $6ED9EBA1); + B := B shr 2 or B shl 30; + Inc(P); + Inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + P^ + $6ED9EBA1); + A := A shr 2 or A shl 30; + Inc(P); + Inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + P^ + $6ED9EBA1); + E := E shr 2 or E shl 30; + Inc(P); + Inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + P^ + $6ED9EBA1); + D := D shr 2 or D shl 30; + Inc(P); + Inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + P^ + $6ED9EBA1); + C := C shr 2 or C shl 30; + Inc(P); + end; + + for I := 0 to 3 do + begin + Inc(E, (A shl 5 or A shr 27) + ((B and C) or (D and (B or C))) + P^ + $8F1BBCDC); + B := B shr 2 or B shl 30; + Inc(P); + Inc(D, (E shl 5 or E shr 27) + ((A and B) or (C and (A or B))) + P^ + $8F1BBCDC); + A := A shr 2 or A shl 30; + Inc(P); + Inc(C, (D shl 5 or D shr 27) + ((E and A) or (B and (E or A))) + P^ + $8F1BBCDC); + E := E shr 2 or E shl 30; + Inc(P); + Inc(B, (C shl 5 or C shr 27) + ((D and E) or (A and (D or E))) + P^ + $8F1BBCDC); + D := D shr 2 or D shl 30; + Inc(P); + Inc(A, (B shl 5 or B shr 27) + ((C and D) or (E and (C or D))) + P^ + $8F1BBCDC); + C := C shr 2 or C shl 30; + Inc(P); + end; + + for I := 0 to 3 do + begin + Inc(E, (A shl 5 or A shr 27) + (D xor B xor C) + P^ + $CA62C1D6); + B := B shr 2 or B shl 30; + Inc(P); + Inc(D, (E shl 5 or E shr 27) + (C xor A xor B) + P^ + $CA62C1D6); + A := A shr 2 or A shl 30; + Inc(P); + Inc(C, (D shl 5 or D shr 27) + (B xor E xor A) + P^ + $CA62C1D6); + E := E shr 2 or E shl 30; + Inc(P); + Inc(B, (C shl 5 or C shr 27) + (A xor D xor E) + P^ + $CA62C1D6); + D := D shr 2 or D shl 30; + Inc(P); + Inc(A, (B shl 5 or B shr 27) + (E xor C xor D) + P^ + $CA62C1D6); + C := C shr 2 or C shl 30; + Inc(P); + end; + + Inc(Digest.Longs[0], A); + Inc(Digest.Longs[1], B); + Inc(Digest.Longs[2], C); + Inc(Digest.Longs[3], D); + Inc(Digest.Longs[4], E); +end; +{$IFDEF QOn}{$Q+}{$ENDIF} + + +procedure SHA1Buf(var Digest: T160BitDigest; const Buf; const BufSize: Integer); +var + P : PByte; + I, J: Integer; +begin + I := BufSize; + if I <= 0 then + exit; + Assert(I mod 64 = 0, 'BufSize must be multiple of 64 bytes'); + P := @Buf; + for J := 0 to I div 64 - 1 do + begin + TransformSHABuffer(Digest, P^, True); + Inc(P, 64); + end; +end; + +procedure SHA1FinalBuf(var Digest: T160BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + B1, B2: T512BitBuf; + C : Integer; +begin + StdFinalBuf512(Buf, BufSize, TotalSize, B1, B2, C, True); + TransformSHABuffer(Digest, B1, True); + if C > 1 then + TransformSHABuffer(Digest, B2, True); + SwapEndianBuf(Digest, Sizeof(Digest) div Sizeof(LongWord)); + SecureClear512(B1); + if C > 1 then + SecureClear512(B2); +end; + +function CalcSHA1(const Buf; const BufSize: Integer): T160BitDigest; +var + I, J: Integer; + P : PByte; +begin + SHA1InitDigest(Result); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + SHA1Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + SHA1FinalBuf(Result, P^, I, BufSize); +end; + +function CalcSHA1(const Buf: AnsiString): T160BitDigest; +begin + Result := CalcSHA1(Pointer(Buf)^, Length(Buf)); +end; + +function SHA1DigestToStrA(const Digest: T160BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function SHA1DigestToHexA(const Digest: T160BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function SHA1DigestToHexW(const Digest: T160BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ SHA224 Hashing } +{ } +{ SHA-224 is identical to SHA-256, except that: } +{ - the initial variable values h0 through h7 are different, and } +{ - the output is constructed by omitting h7 } +{ } +procedure SHA224InitDigest(var Digest: T256BitDigest); +begin + // The second 32 bits of the fractional parts of the square roots of the 9th through 16th primes 23..53 + Digest.Longs[0] := $C1059ED8; + Digest.Longs[1] := $367CD507; + Digest.Longs[2] := $3070DD17; + Digest.Longs[3] := $F70E5939; + Digest.Longs[4] := $FFC00B31; + Digest.Longs[5] := $68581511; + Digest.Longs[6] := $64F98FA7; + Digest.Longs[7] := $BEFA4FA4; +end; + +procedure SHA224Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +begin + SHA256Buf(Digest, Buf, BufSize); +end; + +procedure SHA224FinalBuf(var Digest: T256BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64; + var OutDigest: T224BitDigest); +begin + SHA256FinalBuf(Digest, Buf, BufSize, TotalSize); + Move(Digest.Longs[0], OutDigest.Longs[0], SizeOf(T224BitDigest)); +end; + +function CalcSHA224(const Buf; const BufSize: Integer): T224BitDigest; +var + D : T256BitDigest; + I, J: Integer; + P : PByte; +begin + SHA224InitDigest(D); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + SHA224Buf(D, P^, J); + Inc(P, J); + Dec(I, J); + end; + SHA224FinalBuf(D, P^, I, BufSize, Result); +end; + +function CalcSHA224(const Buf: AnsiString): T224BitDigest; +begin + Result := CalcSHA224(Pointer(Buf)^, Length(Buf)); +end; + +function SHA224DigestToStrA(const Digest: T224BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function SHA224DigestToHexA(const Digest: T224BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function SHA224DigestToHexW(const Digest: T224BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ SHA256 hashing } +{ } +procedure SHA256InitDigest(var Digest: T256BitDigest); +begin + Digest.Longs[0] := $6A09E667; + Digest.Longs[1] := $BB67AE85; + Digest.Longs[2] := $3C6EF372; + Digest.Longs[3] := $A54FF53A; + Digest.Longs[4] := $510E527F; + Digest.Longs[5] := $9B05688C; + Digest.Longs[6] := $1F83D9AB; + Digest.Longs[7] := $5BE0CD19; +end; + +function SHA256Transform1(const A: LongWord): LongWord; +begin + Result := RotateRightBits(A, 7) xor RotateRightBits(A, 18) xor (A shr 3); +end; + +function SHA256Transform2(const A: LongWord): LongWord; +begin + Result := RotateRightBits(A, 17) xor RotateRightBits(A, 19) xor (A shr 10); +end; + +function SHA256Transform3(const A: LongWord): LongWord; +begin + Result := RotateRightBits(A, 2) xor RotateRightBits(A, 13) xor RotateRightBits(A, 22); +end; + +function SHA256Transform4(const A: LongWord): LongWord; +begin + Result := RotateRightBits(A, 6) xor RotateRightBits(A, 11) xor RotateRightBits(A, 25); +end; + +const + // first 32 bits of the fractional parts of the cube roots of the first 64 primes 2..311 + SHA256K: array [0 .. 63] of LongWord = ( + $428A2F98, $71374491, $B5C0FBCF, $E9B5DBA5, $3956C25B, $59F111F1, $923F82A4, $AB1C5ED5, + $D807AA98, $12835B01, $243185BE, $550C7DC3, $72BE5D74, $80DEB1FE, $9BDC06A7, $C19BF174, + $E49B69C1, $EFBE4786, $0FC19DC6, $240CA1CC, $2DE92C6F, $4A7484AA, $5CB0A9DC, $76F988DA, + $983E5152, $A831C66D, $B00327C8, $BF597FC7, $C6E00BF3, $D5A79147, $06CA6351, $14292967, + $27B70A85, $2E1B2138, $4D2C6DFC, $53380D13, $650A7354, $766A0ABB, $81C2C92E, $92722C85, + $A2BFE8A1, $A81A664B, $C24B8B70, $C76C51A3, $D192E819, $D6990624, $F40E3585, $106AA070, + $19A4C116, $1E376C08, $2748774C, $34B0BCB5, $391C0CB3, $4ED8AA4A, $5B9CCA4F, $682E6FF3, + $748F82EE, $78A5636F, $84C87814, $8CC70208, $90BEFFFA, $A4506CEB, $BEF9A3F7, $C67178F2 + ); + +{$IFOPT Q+}{$DEFINE QOn}{$Q-}{$ELSE}{$UNDEF QOn}{$ENDIF} + + +procedure TransformSHA256Buffer(var Digest: T256BitDigest; const Buf); +var + I : Integer; + W : array [0 .. 63] of LongWord; + P : PLongWord; + S0, S1, Maj, T1, T2, Ch: LongWord; + H : array [0 .. 7] of LongWord; +begin + P := @Buf; + for I := 0 to 15 do + begin + W[I] := SwapEndian(P^); + Inc(P); + end; + for I := 16 to 63 do + begin + S0 := SHA256Transform1(W[I - 15]); + S1 := SHA256Transform2(W[I - 2]); + W[I] := W[I - 16] + S0 + W[I - 7] + S1; + end; + for I := 0 to 7 do + H[I] := Digest.Longs[I]; + for I := 0 to 63 do + begin + S0 := SHA256Transform3(H[0]); + Maj := (H[0] and H[1]) xor (H[0] and H[2]) xor (H[1] and H[2]); + T2 := S0 + Maj; + S1 := SHA256Transform4(H[4]); + Ch := (H[4] and H[5]) xor ((not H[4]) and H[6]); + T1 := H[7] + S1 + Ch + SHA256K[I] + W[I]; + H[7] := H[6]; + H[6] := H[5]; + H[5] := H[4]; + H[4] := H[3] + T1; + H[3] := H[2]; + H[2] := H[1]; + H[1] := H[0]; + H[0] := T1 + T2; + end; + for I := 0 to 7 do + Inc(Digest.Longs[I], H[I]); +end; +{$IFDEF QOn}{$Q+}{$ENDIF} + + +procedure SHA256Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +var + P : PByte; + I, J: Integer; +begin + I := BufSize; + if I <= 0 then + exit; + Assert(I mod 64 = 0, 'BufSize must be multiple of 64 bytes'); + P := @Buf; + for J := 0 to I div 64 - 1 do + begin + TransformSHA256Buffer(Digest, P^); + Inc(P, 64); + end; +end; + +procedure SHA256FinalBuf(var Digest: T256BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + B1, B2: T512BitBuf; + C : Integer; +begin + StdFinalBuf512(Buf, BufSize, TotalSize, B1, B2, C, True); + TransformSHA256Buffer(Digest, B1); + if C > 1 then + TransformSHA256Buffer(Digest, B2); + SwapEndianBuf(Digest, Sizeof(Digest) div Sizeof(LongWord)); + SecureClear512(B1); + if C > 1 then + SecureClear512(B2); +end; + +function CalcSHA256(const Buf; const BufSize: Integer): T256BitDigest; +var + I, J: Integer; + P : PByte; +begin + SHA256InitDigest(Result); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + SHA256Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + SHA256FinalBuf(Result, P^, I, BufSize); +end; + +function CalcSHA256(const Buf: AnsiString): T256BitDigest; +begin + Result := CalcSHA256(Pointer(Buf)^, Length(Buf)); +end; + +function SHA256DigestToStrA(const Digest: T256BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function SHA256DigestToHexA(const Digest: T256BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function SHA256DigestToHexW(const Digest: T256BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ SHA384 Hashing } +{ } +procedure SHA384InitDigest(var Digest: T512BitDigest); +begin + Digest.Word64s[0].LongWords[0] := $C1059ED8; + Digest.Word64s[0].LongWords[1] := $CBBB9D5D; + Digest.Word64s[1].LongWords[0] := $367CD507; + Digest.Word64s[1].LongWords[1] := $629A292A; + Digest.Word64s[2].LongWords[0] := $3070DD17; + Digest.Word64s[2].LongWords[1] := $9159015A; + Digest.Word64s[3].LongWords[0] := $F70E5939; + Digest.Word64s[3].LongWords[1] := $152FECD8; + Digest.Word64s[4].LongWords[0] := $FFC00B31; + Digest.Word64s[4].LongWords[1] := $67332667; + Digest.Word64s[5].LongWords[0] := $68581511; + Digest.Word64s[5].LongWords[1] := $8EB44A87; + Digest.Word64s[6].LongWords[0] := $64F98FA7; + Digest.Word64s[6].LongWords[1] := $DB0C2E0D; + Digest.Word64s[7].LongWords[0] := $BEFA4FA4; + Digest.Word64s[7].LongWords[1] := $47B5481D; +end; + +procedure SHA384Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +begin + SHA512Buf(Digest, Buf, BufSize); +end; + +procedure SHA384FinalBuf(var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64; var OutDigest: T384BitDigest); +begin + SHA512FinalBuf(Digest, Buf, BufSize, TotalSize); + Move(Digest, OutDigest, SizeOf(OutDigest)); +end; + +function CalcSHA384(const Buf; const BufSize: Integer): T384BitDigest; +var + I, J: Integer; + P : PByte; + D : T512BitDigest; +begin + SHA384InitDigest(D); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 128) * 128; + if J > 0 then + begin + SHA384Buf(D, P^, J); + Inc(P, J); + Dec(I, J); + end; + SHA384FinalBuf(D, P^, I, BufSize, Result); +end; + +function CalcSHA384(const Buf: AnsiString): T384BitDigest; +begin + Result := CalcSHA384(Pointer(Buf)^, Length(Buf)); +end; + +function SHA384DigestToStrA(const Digest: T384BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function SHA384DigestToHexA(const Digest: T384BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function SHA384DigestToHexW(const Digest: T384BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ SHA512 Hashing } +{ } +procedure SHA512InitDigest(var Digest: T512BitDigest); +begin + Digest.Word64s[0].LongWords[0] := $F3BCC908; + Digest.Word64s[0].LongWords[1] := $6A09E667; + Digest.Word64s[1].LongWords[0] := $84CAA73B; + Digest.Word64s[1].LongWords[1] := $BB67AE85; + Digest.Word64s[2].LongWords[0] := $FE94F82B; + Digest.Word64s[2].LongWords[1] := $3C6EF372; + Digest.Word64s[3].LongWords[0] := $5F1D36F1; + Digest.Word64s[3].LongWords[1] := $A54FF53A; + Digest.Word64s[4].LongWords[0] := $ADE682D1; + Digest.Word64s[4].LongWords[1] := $510E527F; + Digest.Word64s[5].LongWords[0] := $2B3E6C1F; + Digest.Word64s[5].LongWords[1] := $9B05688C; + Digest.Word64s[6].LongWords[0] := $FB41BD6B; + Digest.Word64s[6].LongWords[1] := $1F83D9AB; + Digest.Word64s[7].LongWords[0] := $137E2179; + Digest.Word64s[7].LongWords[1] := $5BE0CD19; +end; + +// BSIG0(x) = ROTR^28(x) XOR ROTR^34(x) XOR ROTR^39(x) +function SHA512Transform1(const A: Word64): Word64; +var + T1, T2, T3: Word64; +begin + T1 := A; + T2 := A; + T3 := A; + Word64Ror(T1, 28); + Word64Ror(T2, 34); + Word64Ror(T3, 39); + Word64XorWord64(T1, T2); + Word64XorWord64(T1, T3); + Result := T1; +end; + +// BSIG1(x) = ROTR^14(x) XOR ROTR^18(x) XOR ROTR^41(x) +function SHA512Transform2(const A: Word64): Word64; +var + T1, T2, T3: Word64; +begin + T1 := A; + T2 := A; + T3 := A; + Word64Ror(T1, 14); + Word64Ror(T2, 18); + Word64Ror(T3, 41); + Word64XorWord64(T1, T2); + Word64XorWord64(T1, T3); + Result := T1; +end; + +// SSIG0(x) = ROTR^1(x) XOR ROTR^8(x) XOR SHR^7(x) +function SHA512Transform3(const A: Word64): Word64; +var + T1, T2, T3: Word64; +begin + T1 := A; + T2 := A; + T3 := A; + Word64Ror(T1, 1); + Word64Ror(T2, 8); + Word64Shr(T3, 7); + Word64XorWord64(T1, T2); + Word64XorWord64(T1, T3); + Result := T1; +end; + +// SSIG1(x) = ROTR^19(x) XOR ROTR^61(x) XOR SHR^6(x) +function SHA512Transform4(const A: Word64): Word64; +var + T1, T2, T3: Word64; +begin + T1 := A; + T2 := A; + T3 := A; + Word64Ror(T1, 19); + Word64Ror(T2, 61); + Word64Shr(T3, 6); + Word64XorWord64(T1, T2); + Word64XorWord64(T1, T3); + Result := T1; +end; + +// CH( x, y, z) = (x AND y) XOR ( (NOT x) AND z) +function SHA512Transform5(const X, Y, Z: Word64): Word64; +var + T1, T2: Word64; +begin + T1 := X; + Word64AndWord64(T1, Y); + T2 := X; + Word64Not(T2); + Word64AndWord64(T2, Z); + Word64XorWord64(T1, T2); + Result := T1; +end; + +// MAJ( x, y, z) = (x AND y) XOR (x AND z) XOR (y AND z) +function SHA512Transform6(const X, Y, Z: Word64): Word64; +var + T1, T2, T3: Word64; +begin + T1 := X; + Word64AndWord64(T1, Y); + T2 := X; + Word64AndWord64(T2, Z); + T3 := Y; + Word64AndWord64(T3, Z); + Word64XorWord64(T1, T2); + Word64XorWord64(T1, T3); + Result := T1; +end; + +const + // first 64 bits of the fractional parts of the cube roots of the first eighty prime numbers + // (stored High LongWord first then Low LongWord) + SHA512K: array [0 .. 159] of LongWord = ( + $428A2F98, $D728AE22, $71374491, $23EF65CD, $B5C0FBCF, $EC4D3B2F, $E9B5DBA5, $8189DBBC, + $3956C25B, $F348B538, $59F111F1, $B605D019, $923F82A4, $AF194F9B, $AB1C5ED5, $DA6D8118, + $D807AA98, $A3030242, $12835B01, $45706FBE, $243185BE, $4EE4B28C, $550C7DC3, $D5FFB4E2, + $72BE5D74, $F27B896F, $80DEB1FE, $3B1696B1, $9BDC06A7, $25C71235, $C19BF174, $CF692694, + $E49B69C1, $9EF14AD2, $EFBE4786, $384F25E3, $0FC19DC6, $8B8CD5B5, $240CA1CC, $77AC9C65, + $2DE92C6F, $592B0275, $4A7484AA, $6EA6E483, $5CB0A9DC, $BD41FBD4, $76F988DA, $831153B5, + $983E5152, $EE66DFAB, $A831C66D, $2DB43210, $B00327C8, $98FB213F, $BF597FC7, $BEEF0EE4, + $C6E00BF3, $3DA88FC2, $D5A79147, $930AA725, $06CA6351, $E003826F, $14292967, $0A0E6E70, + $27B70A85, $46D22FFC, $2E1B2138, $5C26C926, $4D2C6DFC, $5AC42AED, $53380D13, $9D95B3DF, + $650A7354, $8BAF63DE, $766A0ABB, $3C77B2A8, $81C2C92E, $47EDAEE6, $92722C85, $1482353B, + $A2BFE8A1, $4CF10364, $A81A664B, $BC423001, $C24B8B70, $D0F89791, $C76C51A3, $0654BE30, + $D192E819, $D6EF5218, $D6990624, $5565A910, $F40E3585, $5771202A, $106AA070, $32BBD1B8, + $19A4C116, $B8D2D0C8, $1E376C08, $5141AB53, $2748774C, $DF8EEB99, $34B0BCB5, $E19B48A8, + $391C0CB3, $C5C95A63, $4ED8AA4A, $E3418ACB, $5B9CCA4F, $7763E373, $682E6FF3, $D6B2B8A3, + $748F82EE, $5DEFB2FC, $78A5636F, $43172F60, $84C87814, $A1F0AB72, $8CC70208, $1A6439EC, + $90BEFFFA, $23631E28, $A4506CEB, $DE82BDE9, $BEF9A3F7, $B2C67915, $C67178F2, $E372532B, + $CA273ECE, $EA26619C, $D186B8C7, $21C0C207, $EADA7DD6, $CDE0EB1E, $F57D4F7F, $EE6ED178, + $06F067AA, $72176FBA, $0A637DC5, $A2C898A6, $113F9804, $BEF90DAE, $1B710B35, $131C471B, + $28DB77F5, $23047D84, $32CAAB7B, $40C72493, $3C9EBE0A, $15C9BEBC, $431D67C4, $9C100D4C, + $4CC5D4BE, $CB3E42B6, $597F299C, $FC657E2A, $5FCB6FAB, $3AD6FAEC, $6C44198C, $4A475817 + ); + +{$IFOPT Q+}{$DEFINE QOn}{$Q-}{$ELSE}{$UNDEF QOn}{$ENDIF} + + +procedure TransformSHA512Buffer(var Digest: T512BitDigest; const Buf); +var + I : Integer; + P : PWord64; + W : array [0 .. 79] of Word64; + T1, T2, T3, T4, K: Word64; + H : array [0 .. 7] of Word64; +begin + P := @Buf; + for I := 0 to 15 do + begin + W[I] := P^; + Word64SwapEndian(W[I]); + Inc(P); + end; + for I := 16 to 79 do + begin + T1 := SHA512Transform4(W[I - 2]); + T2 := W[I - 7]; + T3 := SHA512Transform3(W[I - 15]); // bug in RFC (specifies I-5 instead of W[I-5]) + T4 := W[I - 16]; + Word64AddWord64(T1, T2); + Word64AddWord64(T1, T3); + Word64AddWord64(T1, T4); + W[I] := T1; + end; + for I := 0 to 7 do + H[I] := Digest.Word64s[I]; + for I := 0 to 79 do + begin + // T1 = h + BSIG1(e) + CH(e,f,g) + Kt + Wt + T1 := H[7]; + Word64AddWord64(T1, SHA512Transform2(H[4])); + Word64AddWord64(T1, SHA512Transform5(H[4], H[5], H[6])); + K.LongWords[0] := SHA512K[I * 2 + 1]; + K.LongWords[1] := SHA512K[I * 2]; + Word64AddWord64(T1, K); + Word64AddWord64(T1, W[I]); + // T2 = BSIG0(a) + MAJ(a,b,c) + T2 := SHA512Transform1(H[0]); + Word64AddWord64(T2, SHA512Transform6(H[0], H[1], H[2])); + // h = g g = f + // f = e e = d + T1 + // d = c c = b + // b = a a = T1 + T2 + H[7] := H[6]; + H[6] := H[5]; + H[5] := H[4]; + H[4] := H[3]; + Word64AddWord64(H[4], T1); + H[3] := H[2]; + H[2] := H[1]; + H[1] := H[0]; + H[0] := T1; + Word64AddWord64(H[0], T2); + end; + for I := 0 to 7 do + Word64AddWord64(Digest.Word64s[I], H[I]); +end; +{$IFDEF QOn}{$Q+}{$ENDIF} + + +procedure SHA512Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +var + P : PByte; + I, J: Integer; +begin + I := BufSize; + if I <= 0 then + exit; + Assert(I mod 128 = 0, 'BufSize must be multiple of 128 bytes'); + P := @Buf; + for J := 0 to I div 128 - 1 do + begin + TransformSHA512Buffer(Digest, P^); + Inc(P, 128); + end; +end; + +procedure SHA512FinalBuf(var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + B1, B2: T1024BitBuf; + C : Integer; +begin + StdFinalBuf1024(Buf, BufSize, TotalSize, B1, B2, C, True); + TransformSHA512Buffer(Digest, B1); + if C > 1 then + TransformSHA512Buffer(Digest, B2); + SwapEndianBuf64(Digest, Sizeof(Digest) div Sizeof(Word64)); + SecureClear1024(B1); + if C > 1 then + SecureClear1024(B2); +end; + +function CalcSHA512(const Buf; const BufSize: Integer): T512BitDigest; +var + I, J: Integer; + P : PByte; +begin + SHA512InitDigest(Result); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 128) * 128; + if J > 0 then + begin + SHA512Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + SHA512FinalBuf(Result, P^, I, BufSize); +end; + +function CalcSHA512(const Buf: AnsiString): T512BitDigest; +begin + Result := CalcSHA512(Pointer(Buf)^, Length(Buf)); +end; + +function SHA512DigestToStrA(const Digest: T512BitDigest): AnsiString; +begin + SetLength(Result, Sizeof(Digest)); + Move(Digest, Pointer(Result)^, Sizeof(Digest)); +end; + +function SHA512DigestToHexA(const Digest: T512BitDigest): AnsiString; +begin + Result := DigestToHexA(Digest, Sizeof(Digest)); +end; + +function SHA512DigestToHexW(const Digest: T512BitDigest): WideString; +begin + Result := DigestToHexW(Digest, Sizeof(Digest)); +end; + +{ } +{ HMAC utility functions } +{ } +procedure HMAC_KeyBlock512(const Key; const KeySize: Integer; var Buf: T512BitBuf); +var + P: PAnsiChar; +begin + Assert(KeySize <= 64); + P := @Buf; + if KeySize > 0 then + begin + Move(Key, P^, KeySize); + Inc(P, KeySize); + end; + FillChar(P^, 64 - KeySize, #0); +end; + +procedure HMAC_KeyBlock1024(const Key; const KeySize: Integer; var Buf: T1024BitBuf); +var + P: PAnsiChar; +begin + Assert(KeySize <= 128); + P := @Buf; + if KeySize > 0 then + begin + Move(Key, P^, KeySize); + Inc(P, KeySize); + end; + FillChar(P^, 128 - KeySize, #0); +end; + +procedure XORBlock512(var Buf: T512BitBuf; const XOR8: Byte); +var + I: Integer; +begin + for I := 0 to SizeOf(Buf) - 1 do + Buf[I] := Buf[I] xor XOR8; +end; + +procedure XORBlock1024(var Buf: T1024BitBuf; const XOR8: Byte); +var + I: Integer; +begin + for I := 0 to SizeOf(Buf) - 1 do + Buf[I] := Buf[I] xor XOR8; +end; + +{ } +{ HMAC-MD5 keyed hashing } +{ } +procedure HMAC_MD5Init(const Key: Pointer; const KeySize: Integer; var Digest: T128BitDigest; var K: T512BitBuf); +var + S: T512BitBuf; + D: T128BitDigest; +begin + MD5InitDigest(Digest); + + if KeySize > 64 then + begin + D := CalcMD5(Key^, KeySize); + HMAC_KeyBlock512(D, Sizeof(D), K); + end + else + HMAC_KeyBlock512(Key^, KeySize, K); + + Move(K, S, SizeOf(K)); + XORBlock512(S, $36); + TransformMD5Buffer(Digest, S); + SecureClear512(S); +end; + +procedure HMAC_MD5Buf(var Digest: T128BitDigest; const Buf; const BufSize: Integer); +begin + MD5Buf(Digest, Buf, BufSize); +end; + +procedure HMAC_MD5FinalBuf(const K: T512BitBuf; var Digest: T128BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + FinBuf: packed record + K : T512BitBuf; + D : T128BitDigest; +end; +begin + MD5FinalBuf(Digest, Buf, BufSize, TotalSize + 64); + Move(K, FinBuf.K, SizeOf(K)); + XORBlock512(FinBuf.K, $5C); + Move(Digest, FinBuf.D, SizeOf(Digest)); + Digest := CalcMD5(FinBuf, SizeOf(FinBuf)); + SecureClear(FinBuf, SizeOf(FinBuf)); +end; + +function CalcHMAC_MD5(const Key: Pointer; const KeySize: Integer; const Buf; const BufSize: Integer): T128BitDigest; +var + I, J: Integer; + P : PByte; + K : T512BitBuf; +begin + HMAC_MD5Init(Key, KeySize, Result, K); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + HMAC_MD5Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + HMAC_MD5FinalBuf(K, Result, P^, I, BufSize); + SecureClear512(K); +end; + +function CalcHMAC_MD5(const Key: AnsiString; const Buf; const BufSize: Integer): T128BitDigest; +begin + Result := CalcHMAC_MD5(Pointer(Key), Length(Key), Buf, BufSize); +end; + +function CalcHMAC_MD5(const Key, Buf: AnsiString): T128BitDigest; +begin + Result := CalcHMAC_MD5(Key, Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ HMAC-SHA1 keyed hashing } +{ } +procedure HMAC_SHA1Init(const Key: Pointer; const KeySize: Integer; var Digest: T160BitDigest; var K: T512BitBuf); +var + D: T160BitDigest; + S: T512BitBuf; +begin + SHA1InitDigest(Digest); + + if KeySize > 64 then + begin + D := CalcSHA1(Key^, KeySize); + HMAC_KeyBlock512(D, Sizeof(D), K); + end + else + HMAC_KeyBlock512(Key^, KeySize, K); + + Move(K, S, SizeOf(K)); + XORBlock512(S, $36); + TransformSHABuffer(Digest, S, True); + SecureClear512(S); +end; + +procedure HMAC_SHA1Buf(var Digest: T160BitDigest; const Buf; const BufSize: Integer); +begin + SHA1Buf(Digest, Buf, BufSize); +end; + +procedure HMAC_SHA1FinalBuf(const K: T512BitBuf; var Digest: T160BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + FinBuf: packed record + K : T512BitBuf; + D : T160BitDigest; +end; +begin + SHA1FinalBuf(Digest, Buf, BufSize, TotalSize + 64); + Move(K, FinBuf.K, SizeOf(K)); + XORBlock512(FinBuf.K, $5C); + Move(Digest, FinBuf.D, SizeOf(Digest)); + Digest := CalcSHA1(FinBuf, SizeOf(FinBuf)); + SecureClear(FinBuf, SizeOf(FinBuf)); +end; + +function CalcHMAC_SHA1(const Key: Pointer; const KeySize: Integer; const Buf; const BufSize: Integer): T160BitDigest; +var + I, J: Integer; + P : PByte; + K : T512BitBuf; +begin + HMAC_SHA1Init(Key, KeySize, Result, K); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + HMAC_SHA1Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + HMAC_SHA1FinalBuf(K, Result, P^, I, BufSize); + SecureClear512(K); +end; + +function CalcHMAC_SHA1(const Key: AnsiString; const Buf; const BufSize: Integer): T160BitDigest; +begin + Result := CalcHMAC_SHA1(Pointer(Key), Length(Key), Buf, BufSize); +end; + +function CalcHMAC_SHA1(const Key, Buf: AnsiString): T160BitDigest; +begin + Result := CalcHMAC_SHA1(Key, Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ HMAC-SHA256 keyed hashing } +{ } +procedure HMAC_SHA256Init(const Key: Pointer; const KeySize: Integer; var Digest: T256BitDigest; var K: T512BitBuf); +var + D: T256BitDigest; + S: T512BitBuf; +begin + SHA256InitDigest(Digest); + + if KeySize > 64 then + begin + D := CalcSHA256(Key^, KeySize); + HMAC_KeyBlock512(D, Sizeof(D), K); + end + else + HMAC_KeyBlock512(Key^, KeySize, K); + + Move(K, S, SizeOf(K)); + XORBlock512(S, $36); + TransformSHA256Buffer(Digest, S); + SecureClear512(S); +end; + +procedure HMAC_SHA256Buf(var Digest: T256BitDigest; const Buf; const BufSize: Integer); +begin + SHA256Buf(Digest, Buf, BufSize); +end; + +procedure HMAC_SHA256FinalBuf(const K: T512BitBuf; var Digest: T256BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + FinBuf: packed record + K : T512BitBuf; + D : T256BitDigest; +end; +begin + SHA256FinalBuf(Digest, Buf, BufSize, TotalSize + 64); + Move(K, FinBuf.K, SizeOf(K)); + XORBlock512(FinBuf.K, $5C); + Move(Digest, FinBuf.D, SizeOf(Digest)); + Digest := CalcSHA256(FinBuf, SizeOf(FinBuf)); + SecureClear(FinBuf, SizeOf(FinBuf)); +end; + +function CalcHMAC_SHA256(const Key: Pointer; const KeySize: Integer; const Buf; const BufSize: Integer): T256BitDigest; +var + I, J: Integer; + P : PByte; + K : T512BitBuf; +begin + HMAC_SHA256Init(Key, KeySize, Result, K); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 64) * 64; + if J > 0 then + begin + HMAC_SHA256Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + HMAC_SHA256FinalBuf(K, Result, P^, I, BufSize); + SecureClear512(K); +end; + +function CalcHMAC_SHA256(const Key: AnsiString; const Buf; const BufSize: Integer): T256BitDigest; +begin + Result := CalcHMAC_SHA256(Pointer(Key), Length(Key), Buf, BufSize); +end; + +function CalcHMAC_SHA256(const Key, Buf: AnsiString): T256BitDigest; +begin + Result := CalcHMAC_SHA256(Key, Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ HMAC-SHA512 keyed hashing } +{ } +procedure HMAC_SHA512Init(const Key: Pointer; const KeySize: Integer; var Digest: T512BitDigest; var K: T1024BitBuf); +var + D: T512BitDigest; + S: T1024BitBuf; +begin + SHA512InitDigest(Digest); + + if KeySize > 128 then + begin + D := CalcSHA512(Key^, KeySize); + HMAC_KeyBlock1024(D, Sizeof(D), K); + end + else + HMAC_KeyBlock1024(Key^, KeySize, K); + + Move(K, S, SizeOf(K)); + XORBlock1024(S, $36); + TransformSHA512Buffer(Digest, S); + SecureClear1024(S); +end; + +procedure HMAC_SHA512Buf(var Digest: T512BitDigest; const Buf; const BufSize: Integer); +begin + SHA512Buf(Digest, Buf, BufSize); +end; + +procedure HMAC_SHA512FinalBuf(const K: T1024BitBuf; var Digest: T512BitDigest; const Buf; const BufSize: Integer; const TotalSize: Int64); +var + FinBuf: packed record + K : T1024BitBuf; + D : T512BitDigest; +end; +begin + SHA512FinalBuf(Digest, Buf, BufSize, TotalSize + 128); + Move(K, FinBuf.K, SizeOf(K)); + XORBlock1024(FinBuf.K, $5C); + Move(Digest, FinBuf.D, SizeOf(Digest)); + Digest := CalcSHA512(FinBuf, SizeOf(FinBuf)); + SecureClear(FinBuf, SizeOf(FinBuf)); +end; + +function CalcHMAC_SHA512(const Key: Pointer; const KeySize: Integer; const Buf; const BufSize: Integer): T512BitDigest; +var + I, J: Integer; + P : PByte; + K : T1024BitBuf; +begin + HMAC_SHA512Init(Key, KeySize, Result, K); + P := @Buf; + if BufSize <= 0 then + I := 0 + else + I := BufSize; + J := (I div 128) * 128; + if J > 0 then + begin + HMAC_SHA512Buf(Result, P^, J); + Inc(P, J); + Dec(I, J); + end; + HMAC_SHA512FinalBuf(K, Result, P^, I, BufSize); + SecureClear1024(K); +end; + +function CalcHMAC_SHA512(const Key: AnsiString; const Buf; const BufSize: Integer): T512BitDigest; +begin + Result := CalcHMAC_SHA512(Pointer(Key), Length(Key), Buf, BufSize); +end; + +function CalcHMAC_SHA512(const Key, Buf: AnsiString): T512BitDigest; +begin + Result := CalcHMAC_SHA512(Key, Pointer(Buf)^, Length(Buf)); +end; + +{ } +{ CalculateHash } +{ } +procedure CalculateHash(const HashType: THashType; + const Buf; const BufSize: Integer; + const Digest: Pointer; + const Key: Pointer; const KeySize: Integer); +begin + if KeySize > 0 then + case HashType of + hashHMAC_MD5: + P128BitDigest(Digest)^ := CalcHMAC_MD5(Key, KeySize, Buf, BufSize); + hashHMAC_SHA1: + P160BitDigest(Digest)^ := CalcHMAC_SHA1(Key, KeySize, Buf, BufSize); + hashHMAC_SHA256: + P256BitDigest(Digest)^ := CalcHMAC_SHA256(Key, KeySize, Buf, BufSize); + hashHMAC_SHA512: + P512BitDigest(Digest)^ := CalcHMAC_SHA512(Key, KeySize, Buf, BufSize); + else + raise EHashError.Create(hashNotKeyedHashType); + end + else + case HashType of + hashChecksum32: + PLongWord(Digest)^ := CalcChecksum32(Buf, BufSize); + hashXOR8: + PByte(Digest)^ := CalcXOR8(Buf, BufSize); + hashXOR16: + PWord(Digest)^ := CalcXOR16(Buf, BufSize); + hashXOR32: + PLongWord(Digest)^ := CalcXOR32(Buf, BufSize); + hashCRC16: + PWord(Digest)^ := CalcCRC16(Buf, BufSize); + hashCRC32: + PLongWord(Digest)^ := CalcCRC32(Buf, BufSize); + hashMD5: + P128BitDigest(Digest)^ := CalcMD5(Buf, BufSize); + hashSHA1: + P160BitDigest(Digest)^ := CalcSHA1(Buf, BufSize); + hashSHA256: + P256BitDigest(Digest)^ := CalcSHA256(Buf, BufSize); + hashSHA512: + P512BitDigest(Digest)^ := CalcSHA512(Buf, BufSize); + hashHMAC_MD5: + P128BitDigest(Digest)^ := CalcHMAC_MD5(nil, 0, Buf, BufSize); + hashHMAC_SHA1: + P160BitDigest(Digest)^ := CalcHMAC_SHA1(nil, 0, Buf, BufSize); + hashHMAC_SHA256: + P256BitDigest(Digest)^ := CalcHMAC_SHA256(nil, 0, Buf, BufSize); + hashHMAC_SHA512: + P512BitDigest(Digest)^ := CalcHMAC_SHA512(nil, 0, Buf, BufSize); + else + raise EHashError.Create(hashInvalidHashType); + end; +end; + +procedure CalculateHash(const HashType: THashType; const Buf; const BufSize: Integer; const Digest: Pointer; const Key: AnsiString); +begin + CalculateHash(HashType, Buf, BufSize, Digest, Pointer(Key), Length(Key)); +end; + +procedure CalculateHash(const HashType: THashType; const Buf: AnsiString; const Digest: Pointer; const Key: AnsiString); +begin + CalculateHash(HashType, Pointer(Buf)^, Length(Buf), Digest, Key); +end; + +{ } +{ System helper functions } +{ } +resourcestring + SSystemError = 'System error #%s'; + +{ } +{ AHash } +{ } +class function AHash.BlockSize: Integer; +begin + Result := - 1; +end; + +procedure AHash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + ProcessBuf(Buf, BufSize); +end; + +procedure AHash.Init(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + Assert(Assigned(Digest)); + FDigest := Digest; + FTotalSize := 0; + InitHash(Digest, Key, KeySize); +end; + +procedure AHash.Init(const Digest: Pointer; const Key: AnsiString); +begin + Init(Digest, Pointer(Key), Length(Key)); +end; + +procedure AHash.HashBuf(const Buf; const BufSize: Integer; const FinalBuf: Boolean); +var + I, D: Integer; + P : PAnsiChar; +begin + Inc(FTotalSize, BufSize); + + D := BlockSize; + if D < 0 then + D := 64; + P := @Buf; + I := (BufSize div D) * D; + if I > 0 then + begin + ProcessBuf(P^, I); + Inc(P, I); + end; + + I := BufSize mod D; + if FinalBuf then + ProcessFinalBuf(P^, I, FTotalSize) + else + if I > 0 then + raise EHashError.Create(hashInvalidBufferSize, 'Non final buffer must be multiple of block size'); +end; + +procedure AHash.HashFile(const FileName: string; const Offset: Int64; const MaxCount: Int64); +const + ChunkSize = 8192; +var + Handle: Integer; + Buf : Pointer; + I, C : Integer; + Left : Int64; + Fin : Boolean; +begin + if FileName = '' then + raise EHashError.Create(hashInvalidFileName); + Handle := FileOpen(FileName, fmOpenReadWrite or fmShareDenyNone); + if Handle = - 1 then + raise EHashError.Create(hashFileOpenError, GetLastErrorText); + if Offset > 0 then + I := FileSeek(Handle, Offset, 0) + else + if Offset < 0 then + I := FileSeek(Handle, Offset, 2) + else + I := 0; + if I = - 1 then + raise EHashError.Create(hashFileSeekError, GetLastErrorText); + try + GetMem(Buf, ChunkSize); + try + if MaxCount < 0 then + Left := high(Int64) + else + Left := MaxCount; + repeat + if Left > ChunkSize then + C := ChunkSize + else + C := Left; + if C = 0 then + begin + I := 0; + Fin := True; + end else + begin + I := FileRead(Handle, Buf^, C); + if I = - 1 then + raise EHashError.Create(hashFileReadError, GetLastErrorText); + Dec(Left, I); + Fin := (I < C) or (Left <= 0); + end; + HashBuf(Buf^, I, Fin); + until Fin; + finally + FreeMem(Buf, ChunkSize); + end; + finally + FileClose(Handle); + end; +end; + +{ } +{ TChecksum32Hash } +{ } +procedure TChecksum32Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + PLongWord(Digest)^ := 0; +end; + +procedure TChecksum32Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PLongWord(FDigest)^ := PLongWord(FDigest)^ + CalcChecksum32(Buf, BufSize); +end; + +class function TChecksum32Hash.DigestSize: Integer; +begin + Result := 4; +end; + +{ } +{ TXOR8Hash } +{ } +procedure TXOR8Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + PByte(Digest)^ := 0; +end; + +procedure TXOR8Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PByte(FDigest)^ := PByte(FDigest)^ xor CalcXOR8(Buf, BufSize); +end; + +class function TXOR8Hash.DigestSize: Integer; +begin + Result := 1; +end; + +{ } +{ TXOR16Hash } +{ } +procedure TXOR16Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + PWord(Digest)^ := 0; +end; + +procedure TXOR16Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PWord(FDigest)^ := PWord(FDigest)^ xor CalcXOR16(Buf, BufSize); +end; + +class function TXOR16Hash.DigestSize: Integer; +begin + Result := 2; +end; + +{ } +{ TXOR32Hash } +{ } +procedure TXOR32Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + PLongWord(Digest)^ := 0; +end; + +procedure TXOR32Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PLongWord(FDigest)^ := PLongWord(FDigest)^ xor CalcXOR32(Buf, BufSize); +end; + +class function TXOR32Hash.DigestSize: Integer; +begin + Result := 4; +end; + +{ } +{ TCRC16Hash } +{ } +procedure TCRC16Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + CRC16Init(PWord(Digest)^); +end; + +procedure TCRC16Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PWord(FDigest)^ := CRC16Buf(PWord(FDigest)^, Buf, BufSize); +end; + +class function TCRC16Hash.DigestSize: Integer; +begin + Result := 2; +end; + +{ } +{ TCRC32Hash } +{ } +procedure TCRC32Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + CRC32Init(PLongWord(Digest)^); +end; + +procedure TCRC32Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PLongWord(FDigest)^ := CRC32Buf(PLongWord(FDigest)^, Buf, BufSize); +end; + +class function TCRC32Hash.DigestSize: Integer; +begin + Result := 4; +end; + +{ } +{ TAdler32Hash } +{ } +procedure TAdler32Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + Adler32Init(PLongWord(Digest)^); +end; + +procedure TAdler32Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PLongWord(FDigest)^ := Adler32Buf(PLongWord(FDigest)^, Buf, BufSize); +end; + +class function TAdler32Hash.DigestSize: Integer; +begin + Result := 4; +end; + +{ } +{ TELFHash } +{ } +procedure TELFHash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + ELFInit(PLongWord(Digest)^); +end; + +procedure TELFHash.ProcessBuf(const Buf; const BufSize: Integer); +begin + PLongWord(FDigest)^ := ELFBuf(PLongWord(FDigest)^, Buf, BufSize); +end; + +class function TELFHash.DigestSize: Integer; +begin + Result := 4; +end; + +{ } +{ TMD5Hash } +{ } +procedure TMD5Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + MD5InitDigest(P128BitDigest(FDigest)^); +end; + +procedure TMD5Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + MD5Buf(P128BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure TMD5Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + MD5FinalBuf(P128BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function TMD5Hash.DigestSize: Integer; +begin + Result := 16; +end; + +class function TMD5Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ TSHA1Hash } +{ } +procedure TSHA1Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + SHA1InitDigest(P160BitDigest(FDigest)^); +end; + +procedure TSHA1Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + SHA1Buf(P160BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure TSHA1Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + SHA1FinalBuf(P160BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function TSHA1Hash.DigestSize: Integer; +begin + Result := 20; +end; + +class function TSHA1Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ TSHA256Hash } +{ } +procedure TSHA256Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + SHA256InitDigest(P256BitDigest(FDigest)^); +end; + +procedure TSHA256Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + SHA256Buf(P256BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure TSHA256Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + SHA256FinalBuf(P256BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function TSHA256Hash.DigestSize: Integer; +begin + Result := 32; +end; + +class function TSHA256Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ TSHA512Hash } +{ } +procedure TSHA512Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + SHA512InitDigest(P512BitDigest(FDigest)^); +end; + +procedure TSHA512Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + SHA512Buf(P512BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure TSHA512Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + SHA512FinalBuf(P512BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function TSHA512Hash.DigestSize: Integer; +begin + Result := 64; +end; + +class function TSHA512Hash.BlockSize: Integer; +begin + Result := 128; +end; + +{ } +{ THMAC_MD5Hash } +{ } +destructor THMAC_MD5Hash.Destroy; +begin + SecureClear512(FKey); + inherited Destroy; +end; + +procedure THMAC_MD5Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + HMAC_MD5Init(Key, KeySize, P128BitDigest(FDigest)^, FKey); +end; + +procedure THMAC_MD5Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + HMAC_MD5Buf(P128BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure THMAC_MD5Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + HMAC_MD5FinalBuf(FKey, P128BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function THMAC_MD5Hash.DigestSize: Integer; +begin + Result := 16; +end; + +class function THMAC_MD5Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ THMAC_SHA1Hash } +{ } +destructor THMAC_SHA1Hash.Destroy; +begin + SecureClear512(FKey); + inherited Destroy; +end; + +procedure THMAC_SHA1Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + HMAC_SHA1Init(Key, KeySize, P160BitDigest(FDigest)^, FKey); +end; + +procedure THMAC_SHA1Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + HMAC_SHA1Buf(P160BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure THMAC_SHA1Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + HMAC_SHA1FinalBuf(FKey, P160BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function THMAC_SHA1Hash.DigestSize: Integer; +begin + Result := 20; +end; + +class function THMAC_SHA1Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ THMAC_SHA256Hash } +{ } +destructor THMAC_SHA256Hash.Destroy; +begin + SecureClear512(FKey); + inherited Destroy; +end; + +procedure THMAC_SHA256Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + HMAC_SHA256Init(Key, KeySize, P256BitDigest(FDigest)^, FKey); +end; + +procedure THMAC_SHA256Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + HMAC_SHA256Buf(P256BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure THMAC_SHA256Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + HMAC_SHA256FinalBuf(FKey, P256BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function THMAC_SHA256Hash.DigestSize: Integer; +begin + Result := 32; +end; + +class function THMAC_SHA256Hash.BlockSize: Integer; +begin + Result := 64; +end; + +{ } +{ THMAC_SHA512Hash } +{ } +destructor THMAC_SHA512Hash.Destroy; +begin + SecureClear1024(FKey); + inherited Destroy; +end; + +procedure THMAC_SHA512Hash.InitHash(const Digest: Pointer; const Key: Pointer; const KeySize: Integer); +begin + HMAC_SHA512Init(Key, KeySize, P512BitDigest(FDigest)^, FKey); +end; + +procedure THMAC_SHA512Hash.ProcessBuf(const Buf; const BufSize: Integer); +begin + HMAC_SHA512Buf(P512BitDigest(FDigest)^, Buf, BufSize); +end; + +procedure THMAC_SHA512Hash.ProcessFinalBuf(const Buf; const BufSize: Integer; const TotalSize: Int64); +begin + HMAC_SHA512FinalBuf(FKey, P512BitDigest(FDigest)^, Buf, BufSize, TotalSize); +end; + +class function THMAC_SHA512Hash.DigestSize: Integer; +begin + Result := 64; +end; + +class function THMAC_SHA512Hash.BlockSize: Integer; +begin + Result := 128; +end; + +{ } +{ HashString } +{ } +function HashString(const StrBuf: Pointer; const StrLength: Integer; const Slots: LongWord; const CaseSensitive: Boolean): LongWord; +var + P : PAnsiChar; + I, J: Integer; + + procedure CRC32StrBuf(const Size: Integer); + begin + if CaseSensitive then + Result := CRC32Buf(Result, P^, Size) + else + Result := CRC32BufNoCase(Result, P^, Size); + end; + +begin + // Return 0 for an empty string + Result := 0; + if (StrLength <= 0) or not Assigned(StrBuf) then + exit; + + if not CRC32TableInit then + InitCRC32Table; + Result := $FFFFFFFF; + P := StrBuf; + + if StrLength <= 48 then // Hash everything for short strings + CRC32StrBuf(StrLength) + else + begin + // Hash first 16 bytes + CRC32StrBuf(16); + + // Hash last 16 bytes + Inc(P, StrLength - 16); + CRC32StrBuf(16); + + // Hash 16 bytes sampled from rest of string + I := (StrLength - 48) div 16; + P := StrBuf; + Inc(P, 16); + for J := 1 to 16 do + begin + CRC32StrBuf(1); + Inc(P, I + 1); + end; + end; + + // Mod into slots + if (Slots <> 0) and (Slots <> high(LongWord)) then + Result := Result mod Slots; +end; + +function HashString(const S: AnsiString; const Slots: LongWord; const CaseSensitive: Boolean): LongWord; +begin + Result := HashString(Pointer(S), Length(S), Slots, CaseSensitive); +end; + +{ } +{ Hash by THashType } +{ } +const + HashTypeClasses: array [THashType] of THashClass = ( + TChecksum32Hash, TXOR8Hash, TXOR16Hash, TXOR32Hash, + TCRC16Hash, TCRC32Hash, + TAdler32Hash, + TELFHash, + TMD5Hash, TSHA1Hash, TSHA256Hash, TSHA512Hash, + THMAC_MD5Hash, THMAC_SHA1Hash, THMAC_SHA256Hash, THMAC_SHA512Hash); + +function GetHashClassByType(const HashType: THashType): THashClass; +begin + Result := HashTypeClasses[HashType]; +end; + +function GetDigestSize(const HashType: THashType): Integer; +begin + Result := GetHashClassByType(HashType).DigestSize; +end; + +end. diff --git a/EvilWorks.Design.HTTPHeadersEditor.dfm b/EvilWorks.Design.HTTPHeadersEditor.dfm new file mode 100644 index 0000000..e91e6c1 --- /dev/null +++ b/EvilWorks.Design.HTTPHeadersEditor.dfm @@ -0,0 +1,165 @@ +object HTTPHeadersPropertyEditorForm: THTTPHeadersPropertyEditorForm + Left = 0 + Top = 0 + BorderIcons = [biSystemMenu] + Caption = 'Edit headers...' + ClientHeight = 347 + ClientWidth = 465 + Color = clWindow + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Segoe UI' + Font.Style = [] + OldCreateOrder = False + Position = poOwnerFormCenter + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignSize = ( + 465 + 347) + PixelsPerInch = 96 + TextHeight = 13 + object bvlFooter: TBevel + Left = 0 + Top = 312 + Width = 465 + Height = 2 + Align = alBottom + ExplicitLeft = 192 + ExplicitTop = 136 + ExplicitWidth = 50 + end + object lblValue: TLabel + Left = 192 + Top = 232 + Width = 32 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Value:' + FocusControl = EdtValue + end + object lblKey: TLabel + Left = 8 + Top = 232 + Width = 20 + Height = 13 + Anchors = [akLeft, akBottom] + Caption = '&Key:' + FocusControl = EdtKey + end + object lblHeaders: TLabel + Left = 8 + Top = 8 + Width = 45 + Height = 13 + Caption = '&Headers:' + FocusControl = lvHeaders + end + object pnlFooter: TPanel + Left = 0 + Top = 314 + Width = 465 + Height = 33 + Align = alBottom + BevelOuter = bvNone + ParentBackground = False + TabOrder = 0 + object btnOK: TButton + AlignWithMargins = True + Left = 305 + Top = 5 + Width = 75 + Height = 23 + Margins.Left = 0 + Margins.Top = 5 + Margins.Right = 5 + Margins.Bottom = 5 + Align = alRight + Caption = '&OK' + Default = True + ModalResult = 1 + TabOrder = 0 + end + object btnCancel: TButton + AlignWithMargins = True + Left = 385 + Top = 5 + Width = 75 + Height = 23 + Margins.Left = 0 + Margins.Top = 5 + Margins.Right = 5 + Margins.Bottom = 5 + Align = alRight + Cancel = True + Caption = '&Cancel' + ModalResult = 2 + TabOrder = 1 + end + end + object lvHeaders: TListView + Left = 8 + Top = 24 + Width = 449 + Height = 193 + Anchors = [akLeft, akTop, akRight, akBottom] + Columns = < + item + Caption = 'Key' + Width = 180 + end + item + Caption = 'Value' + Width = 240 + end> + GridLines = True + ReadOnly = True + RowSelect = True + TabOrder = 1 + ViewStyle = vsReport + end + object BtnClear: TButton + Left = 384 + Top = 280 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'C&lear' + TabOrder = 2 + end + object BtnDelete: TButton + Left = 88 + Top = 280 + Width = 75 + Height = 25 + Anchors = [akLeft, akBottom] + Caption = '&Delete' + TabOrder = 3 + end + object BtnAdd: TButton + Left = 8 + Top = 280 + Width = 75 + Height = 25 + Anchors = [akLeft, akBottom] + Caption = '&Add' + TabOrder = 4 + end + object EdtValue: TEdit + Left = 192 + Top = 248 + Width = 265 + Height = 21 + Anchors = [akLeft, akRight, akBottom] + TabOrder = 5 + end + object EdtKey: TEdit + Left = 8 + Top = 248 + Width = 177 + Height = 21 + Anchors = [akLeft, akBottom] + TabOrder = 6 + end +end diff --git a/EvilWorks.Design.HTTPHeadersEditor.pas b/EvilWorks.Design.HTTPHeadersEditor.pas new file mode 100644 index 0000000..00cd0eb --- /dev/null +++ b/EvilWorks.Design.HTTPHeadersEditor.pas @@ -0,0 +1,124 @@ +unit EvilWorks.Design.HTTPHeadersEditor; + +{$R *.dfm} + +interface + +uses + Winapi.Windows, + Winapi.Messages, + System.SysUtils, + System.Variants, + System.Classes, + Vcl.Graphics, + Vcl.Controls, + Vcl.Forms, + Vcl.Dialogs, + Vcl.StdCtrls, + Vcl.ComCtrls, + Vcl.ExtCtrls, + DesignEditors, + DesignIntf, + EvilWorks.Web.HTTP; + +type + { } + THTTPHeadersProperty = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + { } + THTTPHeadersPropertyEditorForm = class(TForm) + pnlFooter: TPanel; + btnOK: TButton; + btnCancel: TButton; + bvlFooter: TBevel; + lvHeaders: TListView; + BtnClear: TButton; + BtnDelete: TButton; + BtnAdd: TButton; + EdtValue: TEdit; + EdtKey: TEdit; + lblValue: TLabel; + lblKey: TLabel; + lblHeaders: TLabel; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + FHeaders: THTTPMessage; + public + procedure ReloadHeaders; + property HTTPHeaders: THTTPMessage read FHeaders write FHeaders; + end; + +implementation + +{ ==================== } +{ THTTPHeadersProperty } +{ ==================== } + +{ } +procedure THTTPHeadersProperty.Edit; +var + frm: THTTPHeadersPropertyEditorForm; +begin + Application.CreateForm(THTTPHeadersPropertyEditorForm, frm); + try + frm.Caption := Self.GetName; + frm.HTTPHeaders.Assign(THTTPMessage(GetOrdValue)); + frm.ReloadHeaders; + if (frm.ShowModal = mrOk) then + begin + THTTPMessage(GetOrdValue).Assign(frm.HTTPHeaders); + Modified; + end; + finally + frm.Free; + end; +end; + +{ } +function THTTPHeadersProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paDialog, paMultiSelect, paAutoUpdate]; +end; + +{ ============================== } +{ THTTPHeadersPropertyEditorForm } +{ ============================== } + +{ } +procedure THTTPHeadersPropertyEditorForm.FormCreate(Sender: TObject); +begin + FHeaders := THTTPMessage.Create; +end; + +{ } +procedure THTTPHeadersPropertyEditorForm.FormDestroy(Sender: TObject); +begin + FHeaders.Free; +end; + +{ } +procedure THTTPHeadersPropertyEditorForm.ReloadHeaders; +var + i : integer; + li: TListItem; +begin + lvHeaders.Items.BeginUpdate; + try + lvHeaders.Clear; + for i := 0 to HTTPHeaders.Count - 1 do + begin + li := lvHeaders.Items.Add; + li.Caption := HTTPHeaders[i].Key; + li.SubItems.Add(HTTPHeaders[i].Val); + end; + finally + lvHeaders.Items.EndUpdate; + end; +end; + +end. diff --git a/EvilWorks.Generics.AVLTree.pas b/EvilWorks.Generics.AVLTree.pas new file mode 100644 index 0000000..4758ffc --- /dev/null +++ b/EvilWorks.Generics.AVLTree.pas @@ -0,0 +1,632 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.DataStructures.AVLTree +// Description: An Generic AVL tree implementation. +// Largely a translation from C by Julienne Walker but implemented as a generic class +// with independant Key (Node key) and Val (Node data). +// http://eternallyconfuzzled.com/tuts/datastructures/jsw_tut_avl.aspx +// File last change date: November 16th. 2012 +// File version: Dev 0.0.0 +// Licence: Free. +// + +unit EvilWorks.Generics.AVLTree; + +interface + +uses + System.SysUtils; + +type + { Exceptions } + EAVLTree = class(Exception); // Base exception + EAVLTreeItemNotFound = class(EAVLTree); // Used in GetItem(). + + { TAVLTree } + { A Generic balanced binary tree implementation. } + TAVLTree = class + private const + HEIGHT_LIMIT = 65536; + public type + TCompareFunc = reference to function(const aKeyA, aKeyB: TKey): integer; + TReleaseKeyProc = reference to procedure(var aKey: TKey); + TReleaseValProc = reference to procedure(var aVal: TVal); + private type + + { TAVLNode } + PAVLNode = ^TAVLNode; + + TAVLNode = record + Key: TKey; + Val: TVal; + Bal: integer; + Lnk: array [boolean] of PAVLNode; + end; + + { TTokensEnumerator } + TAVLTreeEnumerator = class + private + FTree: TAVLTree; + FCurr: PAVLNode; + FPath: array [0 .. HEIGHT_LIMIT] of PAVLNode; + FTop : cardinal; + public + constructor Create(aTree: TAVLTree); + function GetCurrent: TVal; inline; + function MoveNext: Boolean; inline; + property Current: TVal read GetCurrent; + end; + + private + FRoot : PAVLNode; + FCount : cardinal; + FCompare : TCompareFunc; + FReleaseKey: TReleaseKeyProc; + FReleaseVal: TReleaseValProc; + function GetCount: integer; + function GetItem(const aKey: TKey): TVal; + procedure SetItem(const aKey: TKey; const aVal: TVal); + protected + procedure RotateSingle(var aRoot: PAVLNode; aDir: boolean); + procedure RotateDouble(var aRoot: PAVLNode; aDir: boolean); + procedure AdjustBalance(var aRoot: PAVLNode; aDir: boolean; aBalance: integer); + procedure BalanceAfterInsert(var aRoot: PAVLNode; aDir: boolean); + procedure BalanceAfterRemove(var aRoot: PAVLNode; aDir: boolean; var aDone: boolean); + procedure RemoveNode(const aKey: TKey; const aFreeData: boolean; var aSaveKey: TKey; var aSaveVal: TVal); + function Find(const aKey: TKey): PAVLNode; + public + constructor Create(const aCompare: TCompareFunc; const aReleaseKey: TReleaseKeyProc; const aReleaseVal: TReleaseValProc); + destructor Destroy; override; + procedure Assign(const aSource: TAVLTree); + + function GetEnumerator: TAVLTreeEnumerator; + + procedure Insert(const aKey: TKey; const aVal: TVal); + procedure Delete(const aKey: TKey); + procedure ReKey(const aOldKey, aNewKey: TKey); + procedure Clear; + + property Items[const aKey: TKey]: TVal read GetItem write SetItem; default; + property Count: integer read GetCount; + function Exists(const aKey: TKey): boolean; + end; + +implementation + +{ ======================================= } +{ TAVLTree.TAVLTreeEnumerator } +{ ======================================= } + +{ Constructor. } +constructor TAVLTree.TAVLTreeEnumerator.Create(aTree: TAVLTree); +begin + FTree := aTree; + FCurr := nil; + FTop := 0; +end; + +{ Gets curent item for the iterator. } +function TAVLTree.TAVLTreeEnumerator.GetCurrent: TVal; +begin + Result := FCurr^.Val; +end; + +{ Advances to next item for the iterator. } +function TAVLTree.TAVLTreeEnumerator.MoveNext: Boolean; +var + last: PAVLNode; +begin + if (FCurr = nil) then + begin + FCurr := FTree.FRoot; + FTop := 0; + + // build a path to work with + if (FCurr <> nil) then + begin + while (FCurr^.Lnk[False] <> nil) do + begin + FPath[FTop] := FCurr; + Inc(FTop); + FCurr := FCurr^.Lnk[False]; + end; + end; + end + else + begin + if (FCurr^.Lnk[True] <> nil) then + begin + // continue down this branch + FPath[FTop] := FCurr; + Inc(FTop); + FCurr := FCurr^.Lnk[True]; + + while (FCurr^.Lnk[not True] <> nil) do + begin + FPath[FTop] := FCurr; + Inc(FTop); + FCurr := FCurr^.Lnk[not True]; + end; + end + else + begin + // move to the next branch + repeat + if (FTop = 0) then + begin + FCurr := nil; + Break; + end; + + last := FCurr; + Dec(FTop); + FCurr := FPath[FTop]; + until (last <> FCurr^.Lnk[True]); + end; + end; + Result := (FCurr <> nil); +end; + +{ ==================== } +{ TAVLTree } +{ ==================== } + +{ Constructor. aCompare compares two TVal items, aReleaseKey disposes of TKey, aReleaseVal of TVal. } +constructor TAVLTree.Create(const aCompare: TCompareFunc; const aReleaseKey: TReleaseKeyProc; const aReleaseVal: TReleaseValProc); +begin + FRoot := nil; + FCompare := aCompare; + FReleaseKey := aReleaseKey; + FReleaseVal := aReleaseVal; + FCount := 0 +end; + +{ Destructor. } +destructor TAVLTree.Destroy; +begin + Clear; + inherited; +end; + +{ Assign from an instance of the same type. } +procedure TAVLTree.Assign(const aSource: TAVLTree); +begin + +end; + +{ Implements GetEnumerator for for in iterator. } +function TAVLTree.GetEnumerator: TAVLTreeEnumerator; +begin + Result := TAVLTreeEnumerator.Create(Self); +end; + +{ Performs a single rotation. } +procedure TAVLTree.RotateSingle(var aRoot: PAVLNode; aDir: boolean); +var + save: PAVLNode; +begin + save := aRoot^.Lnk[not aDir]; + aRoot^.Lnk[not aDir] := save^.Lnk[aDir]; + save^.Lnk[aDir] := aRoot; + aRoot := save; +end; + +{ Performs a double rotation. } +procedure TAVLTree.RotateDouble(var aRoot: PAVLNode; aDir: boolean); +var + save: PAVLNode; +begin + save := aRoot^.Lnk[not aDir]^.Lnk[aDir]; + aRoot^.Lnk[not aDir]^.Lnk[aDir] := save^.Lnk[not aDir]; + save^.Lnk[not aDir] := aRoot^.Lnk[not aDir]; + aRoot^.Lnk[not aDir] := save; + save := aRoot^.Lnk[not aDir]; + aRoot^.Lnk[not aDir] := save^.Lnk[aDir]; + save^.Lnk[aDir] := aRoot; + aRoot := save; +end; + +{ Balances the tree height. } +procedure TAVLTree.AdjustBalance(var aRoot: PAVLNode; aDir: boolean; aBalance: integer); +var + n, nn: PAVLNode; +begin + n := aRoot^.Lnk[aDir]; + nn := n^.Lnk[not aDir]; + if (nn^.Bal = 0) then + begin + aRoot^.Bal := 0; + n^.Bal := 0; + end + else if (nn^.Bal = aBalance) then + begin + aRoot^.Bal := - aBalance; + n^.Bal := 0; + end + else + begin + aRoot^.Bal := 0; + n^.Bal := aBalance; + end; + nn^.Bal := 0; +end; + +{ Balances the tree height after insertion. } +procedure TAVLTree.BalanceAfterInsert(var aRoot: PAVLNode; aDir: boolean); +var + n : PAVLNode; + bal: integer; +begin + n := aRoot^.Lnk[aDir]; + if (not aDir) then + bal := - 1 + else + bal := + 1; + if (n^.Bal = bal) then + begin + aRoot^.Bal := 0; + n^.Bal := 0; + RotateSingle(aRoot, not aDir); + end + else + begin + AdjustBalance(aRoot, aDir, bal); + RotateDouble(aRoot, not aDir); + end; +end; + +{ Balances the tree height after deletion. } +procedure TAVLTree.BalanceAfterRemove(var aRoot: PAVLNode; aDir: boolean; var aDone: boolean); +var + n : PAVLNode; + bal: integer; +begin + n := aRoot^.Lnk[not aDir]; + if (not aDir) then + bal := - 1 + else + bal := + 1; + if (n^.Bal = - bal) then + begin + aRoot^.Bal := 0; + n^.Bal := 0; + RotateSingle(aRoot, aDir); + end + else if (n^.Bal = bal) then + begin + AdjustBalance(aRoot, not aDir, - bal); + RotateDouble(aRoot, aDir); + end + else + begin + aRoot^.Bal := - bal; + n^.Bal := bal; + RotateSingle(aRoot, aDir); + aDone := True; + end; +end; + +{ Internal function for removing a node. if aFreeData frees node, Key and Val, } +{ otherwise returns Key in aSaveKey and Val in aSaveVal then removes the node. } +procedure TAVLTree.RemoveNode(const aKey: TKey; const aFreeData: boolean; var aSaveKey: TKey; var aSaveVal: TVal); +var + it : PAVLNode; + heir: PAVLNode; + save: TVal; + up : array [0 .. HEIGHT_LIMIT] of PAVLNode; + upd : array [0 .. HEIGHT_LIMIT - 1] of boolean; + top : integer; + done: boolean; + dir : boolean; +begin + top := 0; + done := boolean(0); + if (FRoot <> nil) then + begin + it := FRoot; + + // Search down the tree and save path + while (True) do + begin + if (it = nil) then + Exit + else if (FCompare(it^.Key, aKey) = 0) then + Break; + + // Push direction and node onto stack + upd[top] := (FCompare(it^.Key, aKey) < 0); + up[top] := it; + it := it^.Lnk[upd[top]]; + Inc(top); + end; + + // Remove the node + if (it^.Lnk[False] = nil) or (it^.Lnk[True] = nil) then + begin + // Which child is not nil? + dir := (it^.Lnk[False] = nil); + + // Fix parent + if (top <> 0) then + up[top - 1]^.Lnk[upd[top - 1]] := it^.Lnk[dir] + else + FRoot := it^.Lnk[dir]; + + if (aFreeData) then + begin + FReleaseKey(it^.Key); + FReleaseVal(it^.Val); + end + else + begin + aSaveKey := it^.Key; + aSaveVal := it^.Val; + end; + FreeMem(it); + end + else + begin + // Find the inorder successor + heir := it^.Lnk[True]; + + // Save this path too + upd[top] := True; + up[top] := it; + Inc(top); + + while (heir^.Lnk[False] <> nil) do + begin + upd[top] := False; + up[top] := heir; + Inc(top); + heir := heir^.Lnk[False]; + end; + + // Swap data + save := it^.Val; + it^.Val := heir^.Val; + heir^.Val := save; + + // Unlink successor and fix parent + up[top - 1]^.Lnk[(up[top - 1] = it)] := heir^.Lnk[True]; + + if (aFreeData) then + begin + FReleaseKey(it^.Key); + FReleaseVal(it^.Val); + end + else + begin + aSaveKey := it^.Key; + aSaveVal := it^.Val; + end; + FreeMem(heir); + end; + + // Walk back up the search path + Dec(top); + while (top >= 0) and (not done) do + begin + // Update balance factors + if (upd[top]) then + up[top]^.Bal := up[top]^.Bal - 1 + else + up[top]^.Bal := up[top]^.Bal + 1; + + // Terminate or rebalance as neccesary + if (Abs(up[top]^.Bal) = 1) then + Break + else if (Abs(up[top]^.Bal) > 1) then + begin + BalanceAfterRemove(up[top], upd[top], done); + + // Fix parent + if (top <> 0) then + up[top - 1]^.Lnk[upd[top - 1]] := up[top] + else + FRoot := up[0]; + end; + Dec(top); + end; + Dec(FCount); + end; +end; + +{ Searches for a node keyed with aKey. } +function TAVLTree.Find(const aKey: TKey): PAVLNode; +var + it : PAVLNode; + cmp: integer; +begin + it := FRoot; + + while (it <> nil) do + begin + cmp := FCompare(it^.Key, aKey); + if (cmp = 0) then + Break; + it := it^.Lnk[cmp < 0]; + end; + Result := it; +end; + +{ Inserts a new node keyed with aey with value aVal. } +procedure TAVLTree.Insert(const aKey: TKey; const aVal: TVal); +var + head : TAVLNode; + s, t, p, q: PAVLNode; + dir : boolean; +begin + if (FRoot = nil) then + begin + FRoot := AllocMem(SizeOf(TAVLNode)); + if (FRoot = nil) then + Exit; + FRoot^.Key := aKey; + FRoot^.Val := aVal; + end + else + begin + // If node of aKey exists, update its Val and exit. + s := Find(aKey); + if (s <> nil) then + begin + s^.Val := aVal; + Exit; + end; + + // Set up false root to ease maintenance + FillChar(head, SizeOf(head), 0); + t := @head; + t^.Lnk[True] := FRoot; + + // Search down the tree, saving rebalance points + s := t.Lnk[True]; + p := t.Lnk[True]; + while (True) do + begin + dir := (FCompare(p^.Key, aKey) < 0); + q := p^.Lnk[dir]; + + if (q = nil) then + Break; + + if (q^.Bal <> 0) then + begin + t := p; + s := q; + end; + + p := q; + end; + + q := AllocMem(SizeOf(TAVLNode)); + q^.Key := aKey; + q^.Val := aVal; + p^.Lnk[dir] := q; + + if (q = nil) then + Exit; + + // Update balance factors + p := s; + while (p <> q) do + begin + dir := (FCompare(p^.Key, aKey) < 0); + + if (not dir) then + p^.Bal := p^.Bal - 1 + else + p^.Bal := p^.Bal + 1; + + p := p^.Lnk[dir]; + end; + + q := s; // Save rebalance point for parent fix + + // Rebalance if necessary + if (Abs(s^.Bal) > 1) then + begin + dir := (FCompare(s^.Key, aKey) < 0); + BalanceAfterInsert(s, dir); + end; + + // Fix parent + if (q = head.Lnk[True]) then + FRoot := s + else + t^.Lnk[(q = t^.Lnk[True])] := s; + end; + Inc(FCount); +end; + +{ Deletes a node keyed with aKey. } +procedure TAVLTree.Delete(const aKey: TKey); +var + tempKey: TKey; + tempVal: TVal; +begin + RemoveNode(aKey, True, tempKey, tempVal); +end; + +{ Changes the Key of a node. } +procedure TAVLTree.ReKey(const aOldKey, aNewKey: TKey); +var + tempKey: TKey; + tempVal: TVal; +begin + RemoveNode(aOldKey, False, tempKey, tempVal); + FReleaseKey(tempKey); + Insert(aNewKey, tempVal); +end; + +{ Clears the tree. Disposition methods called for every node. } +procedure TAVLTree.Clear; +var + it : PAVLNode; + save: PAVLNode; +begin + it := FRoot; + + // Destruction by rotation + while (it <> nil) do + begin + if (it^.Lnk[False] = nil) then + begin + // Remove node + save := it^.Lnk[True]; + FReleaseKey(it^.Key); + FReleaseVal(it^.Val); + FreeMem(it); + end + else + begin + // Rotate right + save := it^.Lnk[False]; + it^.Lnk[False] := save^.Lnk[True]; + save^.Lnk[True] := it; + end; + it := save; + end; + FRoot := nil; + FCount := 0; +end; + +{ Checks if a node keyed with aKey exists. } +function TAVLTree.Exists(const aKey: TKey): boolean; +begin + Result := (Find(aKey) <> nil); +end; + +{ Returns the count of tree nodes. } +function TAVLTree.GetCount: integer; +begin + Result := integer(FCount); +end; + +{ Item getter. If not found raises EAVLTreeItemNotFound. } +function TAVLTree.GetItem(const aKey: TKey): TVal; +var + node: PAVLNode; +begin + node := Find(aKey); + if (node = nil) then + raise EAVLTreeItemNotFound.Create('Item not found.'); + + Result := node^.Val; +end; + +{ Item setter. If not found inserts new item. } +procedure TAVLTree.SetItem(const aKey: TKey; const aVal: TVal); +var + node: PAVLNode; +begin + node := Find(aKey); + if (node <> nil) then + node^.Val := aVal + else + Insert(aKey, aVal); +end; + +end. diff --git a/EvilWorks.Generics.List.pas b/EvilWorks.Generics.List.pas new file mode 100644 index 0000000..ca73761 --- /dev/null +++ b/EvilWorks.Generics.List.pas @@ -0,0 +1,354 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.DataStructures.AVLTree +// Description: A Generic list implementation. +// File last change date: November 17th. 2012 +// File version: Dev 0.0.0 +// Licence: Free. +// + +unit EvilWorks.Generics.List; + +interface + +uses + System.SysUtils; + +type + EList = class(Exception); + EListIndexOutOfBounds = class(EList); + + { TList } + { A Generic list. } + TList = class + public type + TCreateFunc = reference to function: T; + TDestroyProc = reference to procedure(var aItem: T); + TAssignProc = reference to procedure(const aFromItem: T; var aToItem: T); + TCompareFunc = reference to function(const aItemA, aItemB: T): integer; + private type + + { TListEnumerator } + TListEnumerator = class + private + FIndex : integer; + FList: TList; + public + constructor Create(aList: TList); + function GetCurrent: T; inline; + function MoveNext: Boolean; inline; + property Current: T read GetCurrent; + end; + + private + FItems : array of T; + FCount : integer; + FSorted : boolean; + FCreate : TCreateFunc; + FCompare: TCompareFunc; + FAssign : TAssignProc; + FDestroy: TDestroyProc; + function GetT(const aIndex: integer): T; + procedure SetT(const aIndex: integer; const Value: T); + protected + procedure QuickSort(const aStart, aEnd: integer); + public + constructor Create(const aCreate: TCreateFunc; const aDestroy: TDestroyProc; const aAssign: TAssignProc; const aCompare: TCompareFunc); + destructor Destroy; override; + procedure Assign(const aSource: TList); + function GetEnumerator: TListEnumerator; + + function Add: T; overload; + function Add(const aItem: T): T; overload; + function AddSorted: T; overload; + function AddSorted(const aItem: T): T; overload; + function Insert(const aIndex: integer): T; overload; + function Insert(const aIndex: integer; const aItem: T): T; overload; + procedure Exchange(const aIndexA, aIndexB: integer); + procedure Delete(const aIndex: integer); + procedure Clear; + + procedure Sort; + function IndexOf(const aVal: T): integer; + + property Items[const aIndex: integer]: T read GetT write SetT; default; + property Count: integer read FCount; + property Sorted: boolean read FSorted; + end; + +implementation + +{ ======================== } +{ TList.TListEnumerator } +{ ======================== } + +{ Constructor. } +constructor TList.TListEnumerator.Create(aList: TList); +begin + inherited Create; + FIndex := - 1; + FList := aList; +end; + +{ Gets curent item for the iterator. } +function TList.TListEnumerator.GetCurrent: T; +begin + Result := FList[FIndex]; +end; + +{ Advances to next item for the iterator. } +function TList.TListEnumerator.MoveNext: Boolean; +begin + Result := (FIndex < FList.Count - 1); + if Result then + Inc(FIndex); +end; + +{ ======== } +{ TList } +{ ======== } + +{ Constructor. } +constructor TList.Create(const aCreate: TCreateFunc; const aDestroy: TDestroyProc; const aAssign: TAssignProc; const aCompare: TCompareFunc); +begin + FCount := 0; + FSorted := False; + FCreate := aCreate; + FDestroy := aDestroy; + FAssign := aAssign; + FCompare := aCompare; +end; + +{ Destructor. } +destructor TList.Destroy; +begin + Clear; + inherited; +end; + +{ Assign from an instance of the same type. } +procedure TList.Assign(const aSource: TList); +var + i: integer; + c: T; +begin + Clear; + for i := 0 to aSource.Count - 1 do + begin + c := Add; + FAssign(aSource[i], c); + end; +end; + +{ Implements GetEnumerator. } +function TList.GetEnumerator: TListEnumerator; +begin + Result := TListEnumerator.Create(Self); +end; + +{ Add a new item to the list. Uses aCreate function from constructor to create a new item. } +function TList.Add: T; +begin + Result := Add(FCreate); +end; + +{ Add aItem to the list. } +function TList.Add(const aItem: T): T; +begin + Result := Insert(FCount, aItem); +end; + +{ Add a new item to the list, sort if not already sorted. Adding is done using partitioning, fast. } +{ Uses aCreate function from constructor to create a new item. } +function TList.AddSorted: T; +begin + Result := AddSorted(FCreate); +end; + +{ Add aItem to the list, sort if not already sorted. Adding is done using partitioning, fast. } +function TList.AddSorted(const aItem: T): T; +var + loIdx, hiIdx, i: integer; +begin + Sort; + + if (FCount <> 0) then + begin + loIdx := 0; + hiIdx := FCount; + while (loIdx < hiIdx) do + begin + i := ((loIdx + hiIdx) shr 1); + if (FCompare(aItem, FItems[i]) = - 1) then + hiIdx := i + else + loIdx := i + 1; + end; + i := loIdx; + end + else + i := 0; + + Insert(i, aItem); + // Insert unmarks FSorted, but the insert index is found using + // bisection and is 'sorted', so just re-mark as sorted. + FSorted := True; +end; + +{ Add a new item to the list at aIndex. Uses aCreate function from constructor to create a new item. } +{ If the list is sorted, Sorted state is broken and needs to be sorted again. } +function TList.Insert(const aIndex: integer): T; +begin + Result := Insert(FCount, FCreate); +end; + +{ Add aItem to the list at aIndex. } +{ If the list was sorted, Sorted state is broken and needs to be sorted again. } +function TList.Insert(const aIndex: integer; const aItem: T): T; +begin + if (aIndex < 0) or (aIndex > FCount) then + raise EArgumentOutOfRangeException.Create(Format('Index %d out of bounds %d.', [aIndex, FCount])); + + SetLength(FItems, FCount + 1); + if (aIndex < FCount) then + System.Move(FItems[aIndex], FItems[aIndex + 1], (FCount - aIndex) * SizeOf(T)); + FItems[aIndex] := aItem; + Inc(FCount); + FSorted := False; +end; + +{ Exchange position of items at aIndexA and aIndexB. } +{ If the list was sorted, Sorted state is broken and needs to be sorted again. } +procedure TList.Exchange(const aIndexA, aIndexB: integer); +var + temp: T; +begin + temp := FItems[aIndexB]; + FItems[aIndexB] := FItems[aIndexA]; + FItems[aIndexA] := temp; + FSorted := False; +end; + +{ Delete an item from the list at aIndex. Uses aDestroy from constructor to free the item. } +procedure TList.Delete(const aIndex: integer); +begin + if (aIndex < 0) or (aIndex > FCount) then + raise EArgumentOutOfRangeException.Create(Format('Index %d out of bounds %d.', [aIndex, FCount])); + + FDestroy(FItems[aIndex]); + Dec(FCount); + if (aIndex < FCount) then + System.Move(FItems[aIndex + 1], FItems[aIndex], (FCount - aIndex) * SizeOf(T)); +end; + +{ Clear the list. Uses aDestroy from constructor to free each item. } +procedure TList.Clear; +var + i: integer; +begin + for i := 0 to FCount - 1 do + FDestroy(FItems[i]); + SetLength(FItems, 0); + FCount := 0; +end; + +{ Internal QuickSort function. Uses aCompare function from constructor to compare items when sorting. } +procedure TList.QuickSort(const aStart, aEnd: integer); +var + a: Integer; + i: Integer; + j: Integer; + p: Integer; +begin + if (FCount <= 1) then + Exit; + a := aStart; + repeat + i := a; + j := aEnd; + p := (a + aEnd) shr 1; + repeat + while (FCompare(FItems[i], FItems[p]) < 0) do + Inc(i); + while (FCompare(FItems[j], FItems[p]) > 0) do + Dec(j); + if (i <= j) then + begin + if (i <> j) then + Exchange(i, j); + if (p = i) then + p := j + else if (p = j) then + p := i; + Inc(i); + Dec(j); + end; + until (i > j); + if (a < j) then + QuickSort(a, j); + a := i; + until (i >= aEnd); +end; + +{ Sort the list. } +procedure TList.Sort; +begin + if (FSorted) then + Exit; + + QuickSort(0, FCount - 1); + FSorted := True; +end; + +{ Find the index of aVal. } +function TList.IndexOf(const aVal: T): integer; +var + loIdx, hiIdx, cnt, i: integer; +begin + Result := - 1; + if (FSorted) then + begin + loIdx := 0; + hiIdx := (FCount - 1); + while (loIdx <= hiIdx) do + begin + cnt := ((loIdx + hiIdx) shr 1); + i := FCompare(FItems[cnt], aVal); + if (i < 0) then + loIdx := (cnt + 1) + else + begin + hiIdx := (cnt - 1); + if (i = 0) then + Exit(loIdx); + end; + end; + end + else + begin + for i := 0 to FCount - 1 do + if (FCompare(FItems[i], aVal) = 0) then + Exit(i); + end; +end; + +{ Items getter. } +function TList.GetT(const aIndex: integer): T; +begin + if (aIndex < 0) or (aIndex >= FCount) then + raise EListIndexOutOfBounds.Create(Format('Index %d out of bounds %d.', [aIndex, FCount])); + + Result := FItems[aIndex]; +end; + +{ Items setter. } +procedure TList.SetT(const aIndex: integer; const Value: T); +begin + if (aIndex < 0) or (aIndex >= FCount) then + raise EListIndexOutOfBounds.Create(Format('Index %d out of bounds %d.', [aIndex, FCount])); + + FAssign(Value, FItems[aIndex]); +end; + +end. diff --git a/EvilWorks.System.CRT.pas b/EvilWorks.System.CRT.pas new file mode 100644 index 0000000..d09492f --- /dev/null +++ b/EvilWorks.System.CRT.pas @@ -0,0 +1,916 @@ +unit EvilWorks.System.CRT; + +{$IFDEF CONDITIONALEXPRESSIONS} +{$IF CompilerVersion >= 17.0}{$DEFINE INLINES}{$IFEND} +{$IF RTLVersion >= 14.0}{$DEFINE HASERROUTPUT}{$IFEND} +{$ENDIF} + +interface + +uses + WinApi.Windows; + +const + // Background and foreground colors + Black = 0; + Blue = 1; + Green = 2; + Cyan = 3; + Red = 4; + Magenta = 5; + Brown = 6; + LightGray = 7; + + // Foreground colors + DarkGray = 8; + LightBlue = 9; + LightGreen = 10; + LightCyan = 11; + LightRed = 12; + LightMagenta = 13; + Yellow = 14; + White = 15; + + // Blink attribute, to be or-ed with background colors. + Blink = 128; + + // Text modes: + BW40 = 0; // 40x25 B/W on Color Adapter + CO40 = 1; // 40x25 Color on Color Adapter + BW80 = 2; // 80x25 B/W on Color Adapter + CO80 = 3; // 80x25 Color on Color Adapter + Mono = 7; // 80x25 on Monochrome Adapter + Font8x8 = 256; // Add-in for ROM font + + // Mode constants for 3.0 compatibility of original CRT unit } + C40 = CO40; + C80 = CO80; + + + // Turbo/Borland Pascal Crt routines: + + // Waits for keypress and returns the key pressed. If the key is not an ASCII + // key, #0 is returned, and a successive ReadKey will give the extended key + // code of the key. +function ReadKey: Char; + +// Checks whether a key was pressed. +function KeyPressed: Boolean; + +// Puts the cursor at the given coordinates on the screen. +procedure GotoXY(X, Y: Smallint); + +// Returns the current X position of the cursor. +function WhereX: Integer; + +// Returns the current Y position of the cursor. +function WhereY: Integer; + +// Sets text foreground color. +procedure TextColor(Color: Byte); overload; + +// Gets text forground color. +function TextColor: Byte; overload; + +// Sets text background color. +procedure TextBackground(Color: Byte); overload; + +// Gets text background color. +function TextBackground: Byte; overload; + +// Sets text mode. +procedure TextMode(Mode: Word); + +// Sets text colors to low intensity +procedure LowVideo; + +// Sets text colors to high intensity +procedure HighVideo; + +// Sets text attribute to value at startup. +procedure NormVideo; + +// Clears the entire screen, or, if a window is set, the entire window, +// in the current background color. +procedure ClrScr; + +// Clears until the end of the line, in the current background color. +procedure ClrEol; + +// Inserts a line at the current cursor position. +procedure InsLine; + +// Deletes the line at the current cursor position. +procedure DelLine; + +// Sets a window, into which all successive output will go. You can reset the +// window to full screen by calling Window with a zero or negative value +// for Left. +procedure Window(Left, Top, Right, Bottom: Integer); + +type + // Plays a sound at the given frequency (in Herz). + TSoundProc = procedure(Frequency: Smallint); + + // Stops the sound started with Sound. + TNoSoundProc = procedure; + + // Delays for the given amount of milliseconds, or as close as possible. + TDelayProc = procedure(Millisecs: Integer); + + // Plays a sound at the given frequency (in Hz) and duration (in ms). + TBeepProc = procedure(Frequency, Duration: Smallint); + +var + Sound : TSoundProc; + NoSound: TNoSoundProc; + Delay : TDelayProc; + Beep : TBeepProc; + + // Additional routines: + +function ScreenWidth: Smallint; +function ScreenHeight: Smallint; +function BufferWidth: Smallint; +function BufferHeight: Smallint; + +var + TextWindow : TSmallRect; + TextAttr : Byte; + DefaultAttr : Byte; + ScreenMode : Byte; + BufferSize : TCoord; + ScreenSize : TCoord; + StdIn, StdOut: THandle; + StdErr : THandle; + LastMode : Word; + WindMin : Word; + WindMax : Word; + CheckBreak : Boolean; + +implementation + +uses SysUtils; + +type + PKey = ^TKey; + + TKey = record + KeyCode: Smallint; + Normal: Smallint; + Shift: Smallint; + Ctrl: Smallint; + Alt: Smallint; + end; + +const + CKeys: array [0 .. 88] of TKey = ( + (KeyCode: VK_BACK; Normal: $8; Shift: $8; Ctrl: $7F; Alt: $10E;), + (KeyCode: VK_TAB; Normal: $9; Shift: $10F; Ctrl: $194; Alt: $1A5;), + (KeyCode: VK_RETURN; Normal: $D; Shift: $D; Ctrl: $A; Alt: $1A6), + (KeyCode: VK_ESCAPE; Normal: $1B; Shift: $1B; Ctrl: $1B; Alt: $101), + (KeyCode: VK_SPACE; Normal: $20; Shift: $20; Ctrl: $103; Alt: $20), + (KeyCode: Ord('0'); Normal: Ord('0'); Shift: Ord(')'); Ctrl: - 1; Alt: $181), + (KeyCode: Ord('1'); Normal: Ord('1'); Shift: Ord('!'); Ctrl: - 1; Alt: $178), + (KeyCode: Ord('2'); Normal: Ord('2'); Shift: Ord('@'); Ctrl: $103; Alt: $179), + (KeyCode: Ord('3'); Normal: Ord('3'); Shift: Ord('#'); Ctrl: - 1; Alt: $17A), + (KeyCode: Ord('4'); Normal: Ord('4'); Shift: Ord('$'); Ctrl: - 1; Alt: $17B), + (KeyCode: Ord('5'); Normal: Ord('5'); Shift: Ord('%'); Ctrl: - 1; Alt: $17C), + (KeyCode: Ord('6'); Normal: Ord('6'); Shift: Ord('^'); Ctrl: $1E; Alt: $17D), + (KeyCode: Ord('7'); Normal: Ord('7'); Shift: Ord('&'); Ctrl: - 1; Alt: $17E), + (KeyCode: Ord('8'); Normal: Ord('8'); Shift: Ord('*'); Ctrl: - 1; Alt: $17F), + (KeyCode: Ord('9'); Normal: Ord('9'); Shift: Ord('('); Ctrl: - 1; Alt: $180), + (KeyCode: Ord('A'); Normal: Ord('a'); Shift: Ord('A'); Ctrl: $1; Alt: $11E), + (KeyCode: Ord('B'); Normal: Ord('b'); Shift: Ord('B'); Ctrl: $2; Alt: $130), + (KeyCode: Ord('C'); Normal: Ord('c'); Shift: Ord('C'); Ctrl: $3; Alt: $12E), + (KeyCode: Ord('D'); Normal: Ord('d'); Shift: Ord('D'); Ctrl: $4; Alt: $120), + (KeyCode: Ord('E'); Normal: Ord('e'); Shift: Ord('E'); Ctrl: $5; Alt: $112), + (KeyCode: Ord('F'); Normal: Ord('f'); Shift: Ord('F'); Ctrl: $6; Alt: $121), + (KeyCode: Ord('G'); Normal: Ord('g'); Shift: Ord('G'); Ctrl: $7; Alt: $122), + (KeyCode: Ord('H'); Normal: Ord('h'); Shift: Ord('H'); Ctrl: $8; Alt: $123), + (KeyCode: Ord('I'); Normal: Ord('i'); Shift: Ord('I'); Ctrl: $9; Alt: $117), + (KeyCode: Ord('J'); Normal: Ord('j'); Shift: Ord('J'); Ctrl: $A; Alt: $124), + (KeyCode: Ord('K'); Normal: Ord('k'); Shift: Ord('K'); Ctrl: $B; Alt: $125), + (KeyCode: Ord('L'); Normal: Ord('l'); Shift: Ord('L'); Ctrl: $C; Alt: $126), + (KeyCode: Ord('M'); Normal: Ord('m'); Shift: Ord('M'); Ctrl: $D; Alt: $132), + (KeyCode: Ord('N'); Normal: Ord('n'); Shift: Ord('N'); Ctrl: $E; Alt: $131), + (KeyCode: Ord('O'); Normal: Ord('o'); Shift: Ord('O'); Ctrl: $F; Alt: $118), + (KeyCode: Ord('P'); Normal: Ord('p'); Shift: Ord('P'); Ctrl: $10; Alt: $119), + (KeyCode: Ord('Q'); Normal: Ord('q'); Shift: Ord('Q'); Ctrl: $11; Alt: $110), + (KeyCode: Ord('R'); Normal: Ord('r'); Shift: Ord('R'); Ctrl: $12; Alt: $113), + (KeyCode: Ord('S'); Normal: Ord('s'); Shift: Ord('S'); Ctrl: $13; Alt: $11F), + (KeyCode: Ord('T'); Normal: Ord('t'); Shift: Ord('T'); Ctrl: $14; Alt: $114), + (KeyCode: Ord('U'); Normal: Ord('u'); Shift: Ord('U'); Ctrl: $15; Alt: $116), + (KeyCode: Ord('V'); Normal: Ord('v'); Shift: Ord('V'); Ctrl: $16; Alt: $12F), + (KeyCode: Ord('W'); Normal: Ord('w'); Shift: Ord('W'); Ctrl: $17; Alt: $111), + (KeyCode: Ord('X'); Normal: Ord('x'); Shift: Ord('X'); Ctrl: $18; Alt: $12D), + (KeyCode: Ord('Y'); Normal: Ord('y'); Shift: Ord('Y'); Ctrl: $19; Alt: $115), + (KeyCode: Ord('Z'); Normal: Ord('z'); Shift: Ord('Z'); Ctrl: $1A; Alt: $12C), + (KeyCode: VK_PRIOR; Normal: $149; Shift: $149; Ctrl: $184; Alt: $199), + (KeyCode: VK_NEXT; Normal: $151; Shift: $151; Ctrl: $176; Alt: $1A1), + (KeyCode: VK_END; Normal: $14F; Shift: $14F; Ctrl: $175; Alt: $19F), + (KeyCode: VK_HOME; Normal: $147; Shift: $147; Ctrl: $177; Alt: $197), + (KeyCode: VK_LEFT; Normal: $14B; Shift: $14B; Ctrl: $173; Alt: $19B), + (KeyCode: VK_UP; Normal: $148; Shift: $148; Ctrl: $18D; Alt: $198), + (KeyCode: VK_RIGHT; Normal: $14D; Shift: $14D; Ctrl: $174; Alt: $19D), + (KeyCode: VK_DOWN; Normal: $150; Shift: $150; Ctrl: $191; Alt: $1A0), + (KeyCode: VK_INSERT; Normal: $152; Shift: $152; Ctrl: $192; Alt: $1A2), + (KeyCode: VK_DELETE; Normal: $153; Shift: $153; Ctrl: $193; Alt: $1A3), + (KeyCode: VK_NUMPAD0; Normal: Ord('0'); Shift: $152; Ctrl: $192; Alt: - 1), + (KeyCode: VK_NUMPAD1; Normal: Ord('1'); Shift: $14F; Ctrl: $175; Alt: - 1), + (KeyCode: VK_NUMPAD2; Normal: Ord('2'); Shift: $150; Ctrl: $191; Alt: - 1), + (KeyCode: VK_NUMPAD3; Normal: Ord('3'); Shift: $151; Ctrl: $176; Alt: - 1), + (KeyCode: VK_NUMPAD4; Normal: Ord('4'); Shift: $14B; Ctrl: $173; Alt: - 1), + (KeyCode: VK_NUMPAD5; Normal: Ord('5'); Shift: $14C; Ctrl: $18F; Alt: - 1), + (KeyCode: VK_NUMPAD6; Normal: Ord('6'); Shift: $14D; Ctrl: $174; Alt: - 1), + (KeyCode: VK_NUMPAD7; Normal: Ord('7'); Shift: $147; Ctrl: $177; Alt: - 1), + (KeyCode: VK_NUMPAD8; Normal: Ord('8'); Shift: $148; Ctrl: $18D; Alt: - 1), + (KeyCode: VK_NUMPAD9; Normal: Ord('9'); Shift: $149; Ctrl: $184; Alt: - 1), + (KeyCode: VK_MULTIPLY; Normal: Ord('*'); Shift: Ord('*'); Ctrl: $196; Alt: $137), + (KeyCode: VK_ADD; Normal: Ord('+'); Shift: Ord('+'); Ctrl: $190; Alt: $14E), + (KeyCode: VK_SUBTRACT; Normal: Ord('-'); Shift: Ord('-'); Ctrl: $18E; Alt: $14A), + (KeyCode: VK_DECIMAL; Normal: Ord('.'); Shift: Ord('.'); Ctrl: $153; Alt: $193), + (KeyCode: VK_DIVIDE; Normal: Ord('/'); Shift: Ord('/'); Ctrl: $195; Alt: $1A4), + (KeyCode: VK_F1; Normal: $13B; Shift: $154; Ctrl: $15E; Alt: $168), + (KeyCode: VK_F2; Normal: $13C; Shift: $155; Ctrl: $15F; Alt: $169), + (KeyCode: VK_F3; Normal: $13D; Shift: $156; Ctrl: $160; Alt: $16A), + (KeyCode: VK_F4; Normal: $13E; Shift: $157; Ctrl: $161; Alt: $16B), + (KeyCode: VK_F5; Normal: $13F; Shift: $158; Ctrl: $162; Alt: $16C), + (KeyCode: VK_F6; Normal: $140; Shift: $159; Ctrl: $163; Alt: $16D), + (KeyCode: VK_F7; Normal: $141; Shift: $15A; Ctrl: $164; Alt: $16E), + (KeyCode: VK_F8; Normal: $142; Shift: $15B; Ctrl: $165; Alt: $16F), + (KeyCode: VK_F9; Normal: $143; Shift: $15C; Ctrl: $166; Alt: $170), + (KeyCode: VK_F10; Normal: $144; Shift: $15D; Ctrl: $167; Alt: $171), + (KeyCode: VK_F11; Normal: $185; Shift: $187; Ctrl: $189; Alt: $18B), + (KeyCode: VK_F12; Normal: $186; Shift: $188; Ctrl: $18A; Alt: $18C), + (KeyCode: $DC; Normal: Ord('\'); Shift: Ord('|'); Ctrl: $1C; Alt: $12B), + (KeyCode: $BF; Normal: Ord('/'); Shift: Ord('?'); Ctrl: - 1; Alt: $135), + (KeyCode: $BD; Normal: Ord('-'); Shift: Ord('_'); Ctrl: $1F; Alt: $182), + (KeyCode: $BB; Normal: Ord('='); Shift: Ord('+'); Ctrl: - 1; Alt: $183), + (KeyCode: $DB; Normal: Ord('['); Shift: Ord('{'); Ctrl: $1B; Alt: $11A), + (KeyCode: $DD; Normal: Ord(']'); Shift: Ord('}'); Ctrl: $1D; Alt: $11B), + (KeyCode: $BA; Normal: Ord(';'); Shift: Ord(':'); Ctrl: - 1; Alt: $127), + (KeyCode: $DE; Normal: Ord(''''); Shift: Ord('"'); Ctrl: - 1; Alt: $128), + (KeyCode: $BC; Normal: Ord(','); Shift: Ord('<'); Ctrl: - 1; Alt: $133), + (KeyCode: $BE; Normal: Ord('.'); Shift: Ord('>'); Ctrl: - 1; Alt: $134), + (KeyCode: $C0; Normal: Ord('`'); Shift: Ord('~'); Ctrl: - 1; Alt: $129) + ); + +var + ExtendedChar: Char = #0; + +function FindKeyCode(KeyCode: Smallint): PKey; {$IFDEF INLINES}inline; {$ENDIF} +var + I: Integer; +begin + for I := 0 to high(CKeys) do + if CKeys[I].KeyCode = KeyCode then + begin + Result := @CKeys[I]; + Exit; + end; + Result := nil; +end; + +// This has a complexity of 11, because of the if else ladder. +// That bugs me a bit. Looking for something more elegant. +function TranslateKey(const Rec: TInputRecord; State: Integer; Key: PKey; KeyCode: Integer): Smallint; +begin + if State and (RIGHT_ALT_PRESSED or LEFT_ALT_PRESSED) <> 0 then + Result := Key^.Alt + else if State and (RIGHT_CTRL_PRESSED or LEFT_CTRL_PRESSED) <> 0 then + Result := Key^.Ctrl + else if State and SHIFT_PRESSED <> 0 then + Result := Key^.Shift + else if KeyCode in [Ord('A') .. Ord('Z')] then + Result := Ord(Rec.Event.KeyEvent.AsciiChar) + else + Result := Key^.Normal; +end; + +function ConvertKey(const Rec: TInputRecord; Key: PKey): Smallint; +{$IFDEF INLINES}inline; {$ENDIF} +begin + if Assigned(Key) then + Result := TranslateKey(Rec, Rec.Event.KeyEvent.dwControlKeyState, + Key, Rec.Event.KeyEvent.wVirtualKeyCode) + else + Result := - 1 +end; + +function ReadKey: Char; +var + InputRec: TInputRecord; + NumRead : Cardinal; + KeyMode : DWORD; + KeyCode : Smallint; +begin + if ExtendedChar <> #0 then + begin + Result := ExtendedChar; + ExtendedChar := #0; + Exit; + end + else + begin + Result := #$FF; + GetConsoleMode(StdIn, KeyMode); + SetConsoleMode(StdIn, 0); + repeat + ReadConsoleInput(StdIn, InputRec, 1, NumRead); + if (InputRec.EventType and KEY_EVENT <> 0) and + InputRec.Event.KeyEvent.bKeyDown then + begin + if InputRec.Event.KeyEvent.AsciiChar <> #0 then + begin + // From Delphi 2009 on, Result is WideChar + Result := Chr(Ord(InputRec.Event.KeyEvent.AsciiChar)); + Break; + end; + KeyCode := ConvertKey(InputRec, + FindKeyCode(InputRec.Event.KeyEvent.wVirtualKeyCode)); + if KeyCode > $FF then + begin + ExtendedChar := Chr(KeyCode and $FF); + Result := #0; + Break; + end; + end; + until False; + SetConsoleMode(StdIn, KeyMode); + end; +end; + +function KeyPressed: Boolean; +var + InputRecArray: array of TInputRecord; + NumRead : DWORD; + NumEvents : DWORD; + I : Integer; + KeyCode : Word; +begin + Result := False; + GetNumberOfConsoleInputEvents(StdIn, NumEvents); + if NumEvents = 0 then + Exit; + SetLength(InputRecArray, NumEvents); + PeekConsoleInput(StdIn, InputRecArray[0], NumEvents, NumRead); + for I := 0 to high(InputRecArray) do + begin + if (InputRecArray[I].EventType and KEY_EVENT <> 0) and + InputRecArray[I].Event.KeyEvent.bKeyDown then + begin + KeyCode := InputRecArray[I].Event.KeyEvent.wVirtualKeyCode; + if not (KeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL]) then + begin + if ConvertKey(InputRecArray[I], FindKeyCode(KeyCode)) <> - 1 then + begin + Result := True; + Exit; + end; + end; + end; + end; +end; + +procedure TextColor(Color: Byte); +begin + LastMode := TextAttr; + TextAttr := (TextAttr and $F0) or (Color and $0F); + SetConsoleTextAttribute(StdOut, TextAttr); +end; + +procedure TextBackground(Color: Byte); +begin + LastMode := TextAttr; + TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0); + SetConsoleTextAttribute(StdOut, TextAttr); +end; + +procedure LowVideo; +begin + LastMode := TextAttr; + TextAttr := TextAttr and $F7; + SetConsoleTextAttribute(StdOut, TextAttr); +end; + +procedure HighVideo; +begin + LastMode := TextAttr; + TextAttr := TextAttr or $08; + SetConsoleTextAttribute(StdOut, TextAttr); +end; + +procedure NormVideo; +begin + TextAttr := DefaultAttr; + SetConsoleTextAttribute(StdOut, TextAttr); +end; + +// The following functions are independent of TextWindow. + +function GetCursorX: Integer; {$IFDEF INLINES}inline; {$ENDIF} +var + BufferInfo: TConsoleScreenBufferInfo; +begin + GetConsoleSCreenBufferInfo(StdOut, BufferInfo); + Result := BufferInfo.dwCursorPosition.X; +end; + +function GetCursorY: Integer; {$IFDEF INLINES}inline; {$ENDIF} +var + BufferInfo: TConsoleScreenBufferInfo; +begin + GetConsoleSCreenBufferInfo(StdOut, BufferInfo); + Result := BufferInfo.dwCursorPosition.Y; +end; + +procedure SetCursorPos(X, Y: Smallint); +var + NewPos: TCoord; +begin + NewPos.X := X; + NewPos.Y := Y; + SetConsoleCursorPosition(StdOut, NewPos); +end; + +// The following functions are relative to TextWindow. + +procedure ClrScr; +var + StartPos : TCoord; + Len, NumWritten: DWORD; + I : Integer; +begin + if (TextWindow.Left = 0) and (TextWindow.Top = 0) and + (TextWindow.Right = BufferSize.X - 1) and + (TextWindow.Bottom = BufferSize.Y - 1) then + begin + StartPos.X := 0; + StartPos.Y := 0; + Len := BufferSize.X * BufferSize.Y; + FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten); + FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten); + if NumWritten < Len then + begin + ScreenSize.X := ScreenWidth; + ScreenSize.Y := ScreenHeight; + end; + end + else + begin + Len := TextWindow.Right - TextWindow.Left + 1; + StartPos.X := TextWindow.Left; + for I := TextWindow.Top to TextWindow.Bottom do + begin + StartPos.Y := I; + FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten); + FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten); + end; + end; + GotoXY(1, 1); +end; + +procedure GotoXY(X, Y: Smallint); +begin + Inc(X, TextWindow.Left - 1); + Inc(Y, TextWindow.Top - 1); + if (X >= TextWindow.Left) and (X <= TextWindow.Right) and + (Y >= TextWindow.Top) and (Y <= TextWindow.Bottom) then + SetCursorPos(X, Y); +end; + +procedure ClrEol; +var + Len : Integer; + Pos : TCoord; + NumWritten: DWORD; +begin + Len := TextWindow.Right - GetCursorX + 1; + Pos.X := GetCursorX; + Pos.Y := GetCursorY; + FillConsoleOutputCharacterA(StdOut, ' ', Len, Pos, NumWritten); + FillConsoleOutputAttribute(StdOut, TextAttr, Len, Pos, NumWritten); +end; + +procedure Scroll(Left, Top, Right, Bottom: Integer; Distance: Integer = 0); +var + Rect : TSmallRect; + Fill : TCharInfo; + NewPos: TCoord; +begin + Fill.AsciiChar := ' '; + Fill.Attributes := TextAttr; + if Distance = 0 then + Distance := Bottom - Top + 1; + Rect.Left := Left; + Rect.Right := Right; + Rect.Top := Top; + Rect.Bottom := Bottom; + NewPos.X := Left; + NewPos.Y := Top + Distance; + ScrollConsoleScreenBufferA(StdOut, Rect, @Rect, NewPos, Fill); +end; + +procedure InsLine; +begin + Scroll(TextWindow.Left, GetCursorY, + TextWindow.Right, TextWindow.Bottom, 1); +end; + +procedure DelLine; +begin + Scroll(TextWindow.Left, GetCursorY, + TextWindow.Right, TextWindow.Bottom, - 1); +end; + +function Validate(X1, Y1, X2, Y2: Integer): Boolean; +{$IFDEF INLINES}inline; {$ENDIF} +begin + Result := (X1 < X2) and (Y1 < Y2) and + (X1 >= 0) and (X2 < BufferSize.X) and + (Y1 >= 0) and (Y2 < BufferSize.Y); +end; + +procedure WriteText(Line: PAnsiChar; Len: Integer); +var + NumWritten: DWORD; +begin + SetConsoleTextAttribute(StdOut, TextAttr); + WriteConsoleA(StdOut, Line, Len, NumWritten, nil); +end; + +// Replacement for TTextRec.InOutFunc and TTextRec.FlushFunc for the Output +// and ErrOutput pseudo-textfiles. +// This is generally only used if a text window is set, otherwise this is +// handled by the runtime library. +function NewTextOut(var T: TTextRec): Integer; +var + ReadPtr, WritePtr: PAnsiChar; + Line : AnsiString; + DistanceToEdge : Integer; + + // Moves cursor to start of line, updates DistanceToEdge. + procedure CarriageReturn; + begin + SetCursorPos(TextWindow.Left, GetCursorY); + DistanceToEdge := TextWindow.Right - TextWindow.Left + 1; + end; + +// Moves cursor down one line. If necessary, scrolls window. + procedure LineFeed; {$IFDEF INLINES}inline; {$ENDIF} + begin + if GetCursorY < TextWindow.Bottom then + SetCursorPos(GetCursorX, GetCursorY + 1) + else + Scroll(TextWindow.Left, TextWindow.Top, TextWindow.Right, + TextWindow.Bottom, - 1); + end; + +// Store one char in write buffer. + procedure CharToWriteBuffer(C: AnsiChar); + begin + WritePtr^ := C; + Inc(WritePtr); + Dec(DistanceToEdge); + end; + +// True if at right edge of window. + function WriteLine: Boolean; + begin + WritePtr^ := #0; + WriteText(PAnsiChar(Line), WritePtr - PAnsiChar(Line)); + Result := DistanceToEdge = 0; + WritePtr := PAnsiChar(Line); + DistanceToEdge := TextWindow.Right - TextWindow.Left + 1; + end; + +// Converts tabs to spaces, since WriteConsole will do its own tabbing when +// it encounters a #9, which is of course independent of this unit's +// TextWindow settings. + procedure ProcessTab; + var + Num, I: Integer; + begin + Num := 8 - (WritePtr - PAnsiChar(Line)) mod 8; + if Num > DistanceToEdge then + Num := DistanceToEdge; + for I := 1 to Num do + CharToWriteBuffer(' '); + end; + +begin + SetLength(Line, BufferSize.X); // Line only contains one line of windowed text. + WritePtr := PAnsiChar(Line); + ReadPtr := T.BufPtr; + DistanceToEdge := TextWindow.Right - GetCursorX + 1; + while T.BufPos > 0 do + begin + while (T.BufPos > 0) and (DistanceToEdge > 0) do + begin + case ReadPtr^ of + #7: + Beep(800, 200); // this is what my internal speaker uses. + #8: + begin + Dec(WritePtr); + Inc(DistanceToEdge); + end; + #9: + ProcessTab; + // LineFeed is not just a line feed, it takes the function of #13#10 + #10: + begin + WriteLine; + CarriageReturn; + LineFeed; + end; + #13: + begin + WriteLine; + CarriageReturn; + end; + else + CharToWriteBuffer(ReadPtr^); + end; + Inc(ReadPtr); + Dec(T.BufPos); + end; + if WriteLine then + begin + CarriageReturn; + // If TexWindow.Right is at the edge of the screen, WriteConsole will + // already do a linefeed. + if TextWindow.Right <> ScreenWidth - 1 then + LineFeed; + end; + end; + Result := 0; +end; + +var + OldInOutFunc: Pointer; + OldFlushFunc: Pointer; + +procedure Window(Left, Top, Right, Bottom: Integer); +begin + Dec(Left); + Dec(Top); + Dec(Right); + Dec(Bottom); + if Validate(Left, Top, Right, Bottom) then + begin + TextWindow.Left := Left; + TextWindow.Top := Top; + TextWindow.Right := Right; + TextWindow.Bottom := Bottom; + if (Left > 0) or (Top > 0) or + (Right < BufferSize.X - 1) or (Bottom < BufferSize.Y - 1) then + // Text must be contained in window + begin + OldInOutFunc := TTextRec(Output).InOutFunc; + OldFlushFunc := TTextRec(Output).FlushFunc; + TTextRec(Output).InOutFunc := @NewTextOut; + TTextRec(Output).FlushFunc := @NewTextOut; + SetCursorPos(Left, Top); + end; + end + else + begin + TextWindow.Left := 0; + TextWindow.Right := BufferSize.X - 1; + TextWindow.Top := 0; + TextWindow.Bottom := BufferSize.Y - 1; + SetCursorPos(0, 0); + if Assigned(OldInOutFunc) then + begin + TTextRec(Output).InOutFunc := OldInOutFunc; + OldInOutFunc := nil; + end; + if Assigned(OldFlushFunc) then + begin + TTextRec(Output).FlushFunc := OldFlushFunc; + OldFlushFunc := nil; + end; + end; + WindMin := (TextWindow.Left and $FF) or (TextWindow.Top and $FF) shl 8; + WindMax := (TextWindow.Right and $FF) or (TextWindow.Bottom and $FF) shl 8; +end; + +procedure HardwareSound(Frequency: Smallint); +asm + CMP AX,37 + JB @@1 + MOV CX,AX + MOV AL,$B6 + OUT $43,AL + MOV AX,$3540 + MOV DX,$0012 + DIV CX + OUT $42,AL + MOV AL,AH + OUT $42,AL + MOV AL,3 + OUT $61,AL +@@1: +end; + +procedure HardwareNoSound; +asm + MOV AL,0 + OUT $61,AL +end; + +procedure HardwareDelay(Millisecs: Integer); +begin + Sleep(Millisecs); +end; + +procedure HardwareBeep(Frequency, Duration: Smallint); +begin + Sound(Frequency); + Delay(Duration); + NoSound; +end; + +type + TSoundState = (ssPending, ssPlaying, ssFreed); + +var + CurrentFrequency: Integer; + SoundState : TSoundState; + + // On Windows NT and later, direct port access is prohibited, so there is + // no way to use HardwareSound and HardwareNoSound. + // + // Since probably every note played by Sound will be delimited by some kind + // of Delay, the playing of the note is deferred to Delay. Sound only stores + // the frequency and sets the SoundState to ssPending. Delay now knows both + // parameters, and can use Windows.Beep. + // + // Note that such code is not reentrant. + +procedure SoftwareSound(Frequency: Smallint); +begin + // $123540 div Frequency must be <= $7FFF, so Frequency must be >= 37. + if Frequency >= 37 then + begin + CurrentFrequency := Frequency; + SoundState := ssPending; + end; +end; + +procedure SoftwareDelay(Millisecs: Integer); +begin + if SoundState = ssPending then + begin + SoundState := ssPlaying; + Beep(CurrentFrequency, Millisecs); + SoundState := ssFreed; + end + else + Sleep(Millisecs); +end; + +procedure SoftwareBeep(Frequency, Duration: Smallint); +begin + if Frequency >= 37 then + begin + SoundState := ssPlaying; + Beep(Frequency, Duration); + SoundState := ssFreed; + end; +end; + +procedure SoftwareNoSound; +begin + Beep(CurrentFrequency, 0); + SoundState := ssFreed; +end; + +function WhereX: Integer; +begin + Result := GetCursorX - TextWindow.Left + 1; +end; + +function WhereY: Integer; +begin + Result := GetCursorY - TextWindow.Top + 1; +end; + +procedure GetScreenSizes(var Width, Height: Smallint); +var + BufferInfo: TConsoleScreenBufferInfo; +begin + GetConsoleSCreenBufferInfo(StdOut, BufferInfo); + Width := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1; + Height := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1; +end; + +function ScreenWidth: Smallint; +var + Height: Smallint; +begin + GetScreenSizes(Result, Height); +end; + +function ScreenHeight: Smallint; +var + Width: Smallint; +begin + GetScreenSizes(Width, Result); +end; + +procedure GetBufferSizes(var Width, Height: Smallint); +var + BufferInfo: TConsoleScreenBufferInfo; +begin + GetConsoleSCreenBufferInfo(StdOut, BufferInfo); + Width := BufferInfo.dwSize.X; + Height := BufferInfo.dwSize.Y; +end; + +function BufferWidth: Smallint; +var + Height: Smallint; +begin + GetBufferSizes(Result, Height); +end; + +function BufferHeight: Smallint; +var + Width: Smallint; +begin + GetBufferSizes(Width, Result); +end; + +function TextColor: Byte; +begin + Result := TextAttr and $0F; +end; + +function TextBackground: Byte; +begin + Result := (TextAttr and $F0) shr 4; +end; + +procedure TextMode(Mode: Word); +begin + Window(0, 0, 0, 0); + NormVideo; +end; + +procedure InitScreenMode; +var + BufferInfo: TConsoleScreenBufferInfo; +begin + Reset(Input); + Rewrite(Output); + StdIn := TTextRec(Input).Handle; + StdOut := TTextRec(Output).Handle; +{$IFDEF HASERROUTPUT} + Rewrite(ErrOutput); + StdErr := TTextRec(ErrOutput).Handle; +{$ELSE} + StdErr := GetStdHandle(STD_ERROR_HANDLE); +{$ENDIF} + if not GetConsoleSCreenBufferInfo(StdOut, BufferInfo) then + begin + SetInOutRes(GetLastError); + Exit; + end; + TextWindow.Left := 0; + TextWindow.Top := 0; + TextWindow.Right := BufferInfo.dwSize.X - 1; + TextWindow.Bottom := BufferInfo.dwSize.Y - 1; + TextAttr := BufferInfo.wAttributes and $FF; + DefaultAttr := TextAttr; + BufferSize := BufferInfo.dwSize; + ScreenSize.X := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1; + ScreenSize.Y := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1; + WindMin := 0; + WindMax := (ScreenSize.X and $FF) or (ScreenSize.Y and $FF) shl 8; + LastMode := CO80; + OldInOutFunc := nil; + OldFlushFunc := nil; + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Sound := SoftwareSound; + NoSound := SoftwareNoSound; + Delay := SoftwareDelay; + Beep := SoftwareBeep; + end + else + begin + Sound := HardwareSound; + NoSound := HardwareNoSound; + Delay := HardwareDelay; + Beep := HardwareBeep; + end; +end; + +initialization + +InitScreenMode; + +end. diff --git a/EvilWorks.System.CommandLine.pas b/EvilWorks.System.CommandLine.pas new file mode 100644 index 0000000..879cb82 --- /dev/null +++ b/EvilWorks.System.CommandLine.pas @@ -0,0 +1,126 @@ +unit EvilWorks.System.CommandLine; + +interface + +uses + Winapi.Windows, + EvilWorks.System.StrUtils; + +type + { TCmdLine } + { Gets current command line and splits it into Tokens. Switch prefixes ARE "-" OR "/". } + { Call Parse to split, Result indicates success. Double quotes around stuff mean ONE token. } + { -switch1 param1 -switch2 "param 2" -"switch 3" param3 -switch4 -"switch 5" ... } + TCmdLine = record + public type + PCmdLineItem = ^TCmdLineItem; + TCmdLineItem = record + Switch: string; + Param: string; + end; + private + FApp : string; + FItems: array of TCmdLineItem; + function GetItem(aIndex: integer): TCmdLineItem; + function GetCount: integer; + function GetSwitch(const aName: string): TCmdLineItem; + public + function Parse: boolean; + + function SwitchExists(const aSwitch: string): boolean; + function SwitchIs(const aIndex: integer; const aText: string): boolean; + + property App: string read FApp; // First item in command line, application path + property Items[aIndex: integer]: TCmdLineItem read GetItem; default; + property Switch[const aName: string]: TCmdLineItem read GetSwitch; + property Count: integer read GetCount; // Does not count first param (app path) + end; + +implementation + +{ TCmdLine } + +function TCmdLine.Parse: boolean; +var + tokens: TTokens; + item : PCmdLineItem; + i : integer; +begin + Result := False; + + tokens := TextTokenize(GetCommandLine, CSpace, CDoubleQuote, [soCSSep, soQuoted, soCSQot]); + if (tokens.Count = 0) then + Exit; + FApp := tokens[0]; + i := 1; + while (i < tokens.Count) do + begin + if (TextLeft(tokens[i], 1) = CMinus) or (TextLeft(tokens[i], 1) = CFrontSlash) then + begin + SetLength(FItems, Length(FItems) + 1); + item := @FItems[Length(FItems) - 1]; + item^.Switch := TextUnquote(TextRight(tokens[i], Length(tokens[i]) - 1)); + if (tokens[i + 1] <> CEmpty) then + begin + if (TextLeft(tokens[i + 1], 1) <> CMinus) and (TextLeft(tokens[i + 1], 1) <> CFrontSlash) then + begin + item^.Param := TextUnquote(tokens[i + 1]); + Inc(i, 2); + end + else + Inc(i, 1); + end + else + Break; + end + else + Exit; + end; + Result := True; +end; + +function TCmdLine.SwitchExists(const aSwitch: string): boolean; +var + i: integer; +begin + Result := False; + for i := 0 to GetCount - 1 do + if (TextEquals(FItems[i].Switch, aSwitch)) then + Exit(True); +end; + +function TCmdLine.SwitchIs(const aIndex: integer; const aText: string): boolean; +begin + Result := TextEquals(GetItem(aIndex).Switch, aText); +end; + +function TCmdLine.GetCount: integer; +begin + Result := Length(FItems); +end; + +function TCmdLine.GetItem(aIndex: integer): TCmdLineItem; +begin + if (aIndex < 0) or (aIndex >= Count) then + begin + Result.Param := ''; + Result.Switch := ''; + end + else + Result := FItems[aIndex]; +end; + +function TCmdLine.GetSwitch(const aName: string): TCmdLineItem; +var + i: integer; +begin + for i := 0 to Count - 1 do + begin + if (TextEquals(FItems[i].Switch, aName)) then + Exit(FItems[i]); + end; + Result.Switch := ''; + Result.Param := ''; +end; + +end. diff --git a/EvilWorks.System.DateUtils.pas b/EvilWorks.System.DateUtils.pas new file mode 100644 index 0000000..ad3b319 --- /dev/null +++ b/EvilWorks.System.DateUtils.pas @@ -0,0 +1,119 @@ +unit EvilWorks.System.DateUtils; + +interface + +uses + WinApi.Windows, + System.SysUtils, + System.DateUtils; + +function DateNowUTC: TDateTime; +function DateTimeFromFileTime(aFileTime: TFileTime): TDateTime; +function DateHTTPTimestamp: string; +function DateTimeFromTwitterTimestamp(const aTimeStamp: string; var aDateTime: TDateTime): boolean; + +var + EnUsFormatSettings: TFormatSettings; + +implementation + +uses + EvilWorks.System.StrUtils; + +{ Now() equivalent returns time in UTC/GMT timezone. } +function DateNowUTC: TDateTime; +var + sysTime: TSystemTime; +begin + GetSystemTime(sysTime); + Result := SystemTimeToDateTime(sysTime); +end; + +{ Converts TFileTime to TDateTime. } +function DateTimeFromFileTime(aFileTime: TFileTime): TDateTime; +var + temp : TDateTime; + localFileTime : TFileTime; + localSystemTime: TSystemTime; +begin + FileTimeToLocalFileTime(aFileTime, localFileTime); + FileTimeToSystemTime(localFileTime, localSystemTime); + TryEncodeDate(localSystemTime.wYear, localSystemTime.wMonth, localSystemTime.wDay, temp); + Result := temp; + TryEncodeTime(localSystemTime.wHour, localSystemTime.wMinute, localSystemTime.wSecond, localSystemTime.wMilliseconds, temp); + Result := Result + temp; +end; + +{ Creates a HTTP timestamp. } +function DateHTTPTimestamp: string; +begin + Result := FormatDateTime('ddd, dd mmm yyyy hh:nn:ss', DateNowUTC, EnUsFormatSettings) + ' GMT'; +end; + +{ Converts Twitter's timestamp string to TDateTime. Don't look at the code when you look at the code. } +function DateTimeFromTwitterTimestamp(const aTimeStamp: string; var aDateTime: TDateTime): boolean; +var + tokens: TTokens; + eYear, eMonth, eDay, eHour, eMinute, eSecond: word; + eOffset, i: integer; +begin + Result := False; + if (aTimeStamp = '') then + Exit; + + tokens := TextTokenize(aTimeStamp); + if (tokens.Count <> 6) then + Exit; + + eMonth := $FFFF; + for i := 1 to high(EnUsFormatSettings.ShortMonthNames) do + begin + if (SameText(tokens[1], EnUsFormatSettings.ShortMonthNames[i])) then + begin + eMonth := i; + Break; + end; + end; + if (eMonth = $FFFF) then + Exit; + + eDay := TextToInt(tokens[2], $FFFF); + if (eday = $FFFF) then + Exit; + + eOffset := TextToInt(tokens[4], MaxInt); + if (eOffset = maxInt) then + Exit; + + eYear := TextToInt(tokens[5], $FFFF); + if (eYear = $FFFF) then + Exit; + + tokens := TextTokenize(tokens[3], ':'); + if (tokens.Count <> 3) then + Exit; + + eHour := TextToInt(tokens[0], $FFFF); + if (eHour = $FFFF) then + Exit; + + eMinute := TextToInt(tokens[1], $FFFF); + if (eMinute = $FFFF) then + Exit; + + eSecond := TextToInt(tokens[2], $FFFF); + if (eSecond = $FFFF) then + Exit; + + if (TryEncodeDateTime(eYear, eMonth, eDay, eHour, eMinute, eSecond, 0, aDateTime) = False) then + Exit; + + aDateTime := IncHour(aDateTime, eOffset); + Result := True; +end; + +initialization + +EnUsFormatSettings := TFormatSettings.Create('en-us'); + +end. diff --git a/EvilWorks.System.MsgApp.pas b/EvilWorks.System.MsgApp.pas new file mode 100644 index 0000000..9569f50 --- /dev/null +++ b/EvilWorks.System.MsgApp.pas @@ -0,0 +1,48 @@ +unit EvilWorks.System.MsgApp; + +interface + +uses + System.Classes; + +type + { TMsgApp } + TMsgApp = class + private + procedure InitWindow; + procedure FinWindow; + public + constructor Create; + destructor Destroy; override; + end; + +implementation + +{ TMsgApp } + +constructor TMsgApp.Create; +begin + +end; + +destructor TMsgApp.Destroy; +begin + + inherited; +end; + +procedure TMsgApp.FinWindow; +begin + +end; + +procedure TMsgApp.InitWindow; +begin + +end; + +initialization + +finalization + +end. diff --git a/EvilWorks.System.ProcessUtils.pas b/EvilWorks.System.ProcessUtils.pas new file mode 100644 index 0000000..38e949d --- /dev/null +++ b/EvilWorks.System.ProcessUtils.pas @@ -0,0 +1,229 @@ +unit EvilWorks.System.ProcessUtils; + +interface + +uses + WinApi.Windows, + WinApi.PsApi, + System.SysUtils; + +const +{$EXTERNALSYM PROCESS_QUERY_LIMITED_INFORMATION} + PROCESS_QUERY_LIMITED_INFORMATION = $1000; + +{$EXTERNALSYM BELOW_NORMAL_PRIORITY_CLASS} + BELOW_NORMAL_PRIORITY_CLASS = $00004000; + +{$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS} + ABOVE_NORMAL_PRIORITY_CLASS = $00008000; + +type + TGetProcessImageFileName = function(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; stdcall; + TGetProcessImageFileNameA = function(hProcess: THandle; lpImageFileName: LPSTR; nSize: DWORD): DWORD; stdcall; + TGetProcessImageFileNameW = function(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; stdcall; + +{$EXTERNALSYM GetProcessImageFileName} +function GetProcessImageFileName(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; stdcall; +{$EXTERNALSYM GetProcessImageFileNameA} +function GetProcessImageFileNameA(hProcess: THandle; lpImageFileName: LPSTR; nSize: DWORD): DWORD; stdcall; +{$EXTERNALSYM GetProcessImageFileNameW} +function GetProcessImageFileNameW(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; stdcall; + +{$EXTERNALSYM AttachConsole} +function AttachConsole(dwProcessId: DWORD): BOOL; stdcall; external kernel32 name 'AttachConsole'; + +function GetWindowModuleName(const aHandle: HWND): string; +function GetPIDModuleName(const aProcessID: DWORD): string; + +function SetWindowProcessPriorityClass(const aWindow: HWND; const aPriority: cardinal): boolean; +function GetWindowProcessPriorityClass(const aWindow: HWND): cardinal; + +function GetProcessIDs: TArray; + +implementation + +uses + EvilWorks.System.SysUtils; + +const + PsApi = 'PSAPI.dll'; + +var + hPSAPI : THandle; + hKernel32 : THandle; + _GetProcessImageFileName : TGetProcessImageFileName; + _GetProcessImageFileNameA: TGetProcessImageFileNameA; + _GetProcessImageFileNameW: TGetProcessImageFileNameW; + +function CheckStubsLoaded: boolean; +begin + if (hPSAPI = 0) then + begin + hPSAPI := LoadLibrary('PSAPI.dll'); + if (hPSAPI < 32) then + begin + hPSAPI := 0; + Result := False; + Exit; + end; + // Kernel32.lib on Windows 7 and Windows Server 2008 R2; + // Psapi.lib if PSAPI_VERSION=1 on Windows 7 and Windows Server 2008 R2; + // Psapi.lib on Windows Server 2008, Windows Vista, Windows Server 2003, and Windows XP/2000 + @_GetProcessImageFileName := GetProcAddress(hPSAPI, 'GetProcessImageFileNameW'); + @_GetProcessImageFileNameA := GetProcAddress(hPSAPI, 'GetProcessImageFileNameA'); + @_GetProcessImageFileNameW := GetProcAddress(hPSAPI, 'GetProcessImageFileNameW'); + end; + + if (Assigned(_GetProcessImageFileName) = False) then + begin + hKernel32 := LoadLibrary(kernel32); + if (hKernel32 < 32) then + begin + hKernel32 := 0; + Result := False; + Exit; + end; + @_GetProcessImageFileName := GetProcAddress(hKernel32, 'GetProcessImageFileNameW'); + @_GetProcessImageFileNameA := GetProcAddress(hKernel32, 'GetProcessImageFileNameA'); + @_GetProcessImageFileNameW := GetProcAddress(hKernel32, 'GetProcessImageFileNameW'); + end; + Result := True; +end; + +function GetProcessImageFileName(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; +begin + if (CheckStubsLoaded) then + Result := _GetProcessImageFileName(hProcess, lpImageFileName, nSize) + else + Result := 0; +end; + +function GetProcessImageFileNameA(hProcess: THandle; lpImageFileName: LPSTR; nSize: DWORD): DWORD; +begin + if (CheckStubsLoaded) then + Result := _GetProcessImageFileNameA(hProcess, lpImageFileName, nSize) + else + Result := 0; +end; + +function GetProcessImageFileNameW(hProcess: THandle; lpImageFileName: LPWSTR; nSize: DWORD): DWORD; +begin + if (CheckStubsLoaded) then + Result := _GetProcessImageFileNameW(hProcess, lpImageFileName, nSize) + else + Result := 0; +end; + +{ Gets filename of the executable to which a window belongs. } +function GetWindowModuleName(const aHandle: HWND): string; +var + processID : DWORD; + processHandle: THandle; + moduleArray : array of hModule; + arrayLen : DWORD; + len : DWORD; +begin + Result := ''; + processID := 1; + GetWindowThreadProcessId(aHandle, @processID); + processHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, processID); + if (processHandle <= 0) then + RaiseLastOSError; + EnumProcessModules(processHandle, nil, 0, arrayLen); + SetLength(moduleArray, arrayLen div SizeOf(moduleArray[0])); + if (EnumProcessModules(processHandle, PDWord(@moduleArray[0]), arrayLen, arrayLen) = False) then + RaiseLastOSError; + SetLength(Result, MAX_PATH); + len := GetModuleFileNameEx(processHandle, moduleArray[0], PChar(Result), Length(Result)); + if (len > 0) then + SetLength(Result, len); + CloseHandle(processHandle); +end; + +{ Gets filename of the executable for a Process ID. } +function GetPIDModuleName(const aProcessID: DWORD): string; +var + processHandle: THandle; + ret : DWORD; + buffer : PChar; +begin + Result := ''; + if (aProcessID = 0) then + Exit(''); + processHandle := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION or PROCESS_VM_READ, False, aProcessID); + if (processHandle <= 0) then + begin + ret := GetLastError; + if (ret = ERROR_ACCESS_DENIED) then + Exit('System'); + RaiseLastOSError; + end; + buffer := AllocMem(MAX_PATH); + ret := GetModuleFileNameEx(processHandle, 0, buffer, MAX_PATH); + CloseHandle(processHandle); + if (ret = 0) then + begin + FreeMem(buffer); + RaiseLastOSError; + end + else + begin + SetString(Result, buffer, ret); + FreeMem(buffer); + end; +end; + +{ Sets priority of the process that owns the aWindow .} +function SetWindowProcessPriorityClass(const aWindow: HWND; const aPriority: cardinal): boolean; +var + processID : DWORD; + processHandle: THandle; +begin + Result := False; + + processID := 1; + GetWindowThreadProcessId(aWindow, @processID); + + processHandle := OpenProcess(PROCESS_SET_INFORMATION, False, processID); + if (processHandle = 0) then + Exit; + + Result := SetPriorityClass(processHandle, aPriority); +end; + +{ Gets priority of the process that owns the aWindow. If failed returns 0. } +function GetWindowProcessPriorityClass(const aWindow: HWND): cardinal; +var + processID : DWORD; + processHandle: THandle; +begin + Result := 0; + + processID := 1; + GetWindowThreadProcessId(aWindow, @processID); + + if (TOSVersion.Check(6)) then + processHandle := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, processID) + else + processHandle := OpenProcess(PROCESS_QUERY_INFORMATION, False, processID); + + if (processHandle = 0) then + Exit; + + Result := GetPriorityClass(processHandle); +end; + +{ Retrieves the process identifier for each process object in the system. } +function GetProcessIDs: TArray; +var + numReturned: DWORD; +begin + SetLength(Result, 1024); + + if (EnumProcesses(@Result[0], Length(Result) * SizeOf(DWORD), numReturned) = False) then + SetLength(Result, 0) + else if (numReturned > 0) then + SetLength(Result, numReturned div SizeOf(DWORD)); +end; + +end. diff --git a/EvilWorks.System.RTTI.pas b/EvilWorks.System.RTTI.pas new file mode 100644 index 0000000..09c4ad0 --- /dev/null +++ b/EvilWorks.System.RTTI.pas @@ -0,0 +1,310 @@ +unit EvilWorks.System.RTTI; + +interface + +uses + System.Classes, + System.SysUtils, + System.TypInfo, + System.IniFiles, + System.RTTI; + +type + EEvilRTTI = class(Exception); + EMethodNotFound = class(EEvilRTTI); + +function GetTypeKindName(const aTypeKind: TTypeKind): string; +function InvokeObjectMethod(aClassInstance: TObject; const aMethod: string; const aParams: array of string): string; + +type + { Exceptions } + ERTTIIni = class(Exception); + + { TRTTIIni } + TRTTIIni = class(TPersistent) + strict private + FFileName: string; + protected + { Override to set the name of the section where properties will be written. } + { If not overiden, ClassName will be used instead. } + function GetSectionName: string; virtual; + + { Save and load to FileName. } + procedure Save; + procedure Load; + public + { Set the FileName to/from which to Save/Load. Do it before Load() or Save()... } + property FileName: string read FFileName write FFileName; + published + { Auto-Streamable properties go here. See Load() and Save() methods for supported data types. } + { If you nest TRTTIIni object properties, they get auto saved as well to FileName. You'll have } + { to declare them first (and their GetSectionName if you don't want auto-names). } + end; + +implementation + +uses + EvilWorks.System.StrUtils; + +resourcestring + SErrTypeNotFound = 'TRttiType %s not found.'; + SErrTypeMethodNotFound = 'TRttiMethod %s not found.'; + +function GetTypeKindName(const aTypeKind: TTypeKind): string; +const + TTypeKindNames: array [0 .. 21] of string = ( + 'tkUnknown', 'tkInteger', 'tkChar', 'tkEnumeration', 'tkFloat', 'tkString', 'tkSet', 'tkClass', + 'tkMethod', 'tkWChar', 'tkLString', 'tkWString', 'tkVariant', 'tkArray', 'tkRecord', 'tkInterface', + 'tkInt64', 'tkDynArray', 'tkUString', 'tkClassRef', 'tkPointer', 'tkProcedure' + ); +begin + Result := TTypeKindNames[Ord(aTypeKind)]; +end; + +function InvokeObjectMethod(aClassInstance: TObject; const aMethod: string; const aParams: array of string): string; +var + rttiCtx : TRttiContext; + rttiType : TRttiType; + rttiMethod: TRttiMethod; + + rttiParams: TArray; + rttiValues: TArray; + i : integer; + intVal : integer; +begin + rttiCtx := TRttiContext.Create; + try + rttiType := rttiCtx.GetType(aClassInstance.ClassInfo); + if (rttiType = nil) then + raise EEvilRTTI.CreateFmt(SErrTypeNotFound, [aClassInstance.ClassName]); + + rttiMethod := rttiType.GetMethod(aMethod); + if (rttiMethod = nil) then + raise EMethodNotFound.CreateFmt(SErrTypeMethodNotFound, [aMethod]); + + rttiParams := rttiMethod.GetParameters; + if (Length(rttiParams) > 0) then + begin + if (Length(rttiParams) > Length(aParams)) then + raise Exception.Create(Format('RTTIInvokeTypeMethod: Parameter counts differ: Given %d, expected %d.', [Length(aParams), Length(rttiParams)])); + + SetLength(rttiValues, Length(rttiParams)); + for i := 0 to Length(rttiParams) - 1 do + begin + case rttiParams[i].ParamType.TypeKind of + tkUnknown: + begin + raise Exception.Create(Format('RTTIInvokeTypeMethod: Unknown parameter type for Method "%s" at index %d.', [aMethod, i])); + end; + tkChar, tkWChar, tkLString, tkUString, tkString: + begin + rttiValues[i] := aParams[i]; + end; + tkWString: + begin + rttiValues[i] := TValue.From(widestring(aParams[i])); + end; + tkInteger: + begin + rttiValues[i] := StrToInt(aParams[i]); + end; + tkInt64: + begin + rttiValues[i] := StrToInt64(aParams[i]); + end; + tkFloat: + begin + rttiValues[i] := StrToFloat(aParams[i]); + end; + tkEnumeration: + begin + rttiValues[i] := TValue.FromOrdinal(rttiParams[i].ParamType.Handle, GetEnumValue(rttiParams[i].ParamType.Handle, aParams[i])); + end; + tkSet: + begin + intVal := StringToSet(rttiParams[i].ParamType.Handle, aParams[i]); + TValue.Make(@intVal, rttiParams[i].ParamType.Handle, rttiValues[i]); + end; + tkVariant: + begin + rttiValues[i] := TValue.FromVariant(variant(aParams[i])); + end; + tkMethod: + begin + + end; + tkProcedure: + begin + + end; + tkClass: + begin + + end; + tkArray: + begin + + end; + tkRecord: + begin + + end; + tkInterface: + begin + + end; + tkDynArray: + begin + + end; + tkClassRef: + begin + + end; + tkPointer: + begin + + end; + end; { case } + end; { for } + end; { if } + + Result := rttiMethod.Invoke(aClassInstance, rttiValues).ToString; + finally + rttiCtx.Free; + end; +end; + +{ TRTTIIni } + +function TRTTIIni.GetSectionName: string; +begin + Result := Self.ClassName; +end; + +procedure TRTTIIni.Load; +var + ini : TIniFile; + sub : TRTTIIni; + sl : TStringList; + i : integer; + v : integer; + def : string; + data : string; + rttiContext : TRttiContext; + rttiType : TRttiType; + rttiProperty : TRttiProperty; + rttiProperties: TArray; + rttiVal : TValue; +begin + ini := TIniFile.Create(FileName); + sl := TStringList.Create; + rttiContext := TRttiContext.Create; + try + rttiType := rttiContext.GetType(Self.ClassInfo); + if (rttiType = nil) then + raise ERTTIIni.Create('TRTTIIni.Load(): Context.GetType() failed.'); + + ini.ReadSection(GetSectionName, sl); + for i := 0 to sl.Count - 1 do + begin + rttiProperty := rttiType.GetProperty(sl[i]); + if (rttiProperty <> nil) then + begin + if (rttiProperty.Visibility <> mvPublished) or (not rttiProperty.IsWritable) or (not rttiProperty.IsReadable) then + Continue; + + def := rttiProperty.GetValue(Self).ToString; + data := ini.ReadString(GetSectionName, sl[i], def); + + case rttiProperty.GetValue(Self).Kind of + tkWChar, tkLString, tkWString, tkString, tkChar, tkUString: + rttiVal := data; + tkInteger, tkInt64: + rttiVal := StrToInt(data); + tkFloat: + rttiVal := StrToFloat(data); + tkEnumeration: + rttiVal := TValue.FromOrdinal(rttiProperty.GetValue(Self).TypeInfo, GetEnumValue(rttiProperty.GetValue(Self).TypeInfo, data)); + tkSet: + begin + v := StringToSet(rttiVal.TypeInfo, data); + TValue.Make(@v, rttiVal.TypeInfo, rttiVal); + end; + end; + rttiProperty.SetValue(Self, rttiVal); + end; + end; + + rttiProperties := rttiType.GetProperties; + for rttiProperty in rttiProperties do + begin + if (rttiProperty.Visibility <> mvPublished) or (not rttiProperty.IsReadable) or (not rttiProperty.IsWritable) then + Continue; + + if (rttiProperty.GetValue(Self).IsObject) then + begin + if (rttiProperty.GetValue(Self).AsObject is TRTTIIni) then + begin + sub := TRTTIIni(rttiProperty.GetValue(Self).AsObject); + sub.FileName := Self.FileName; + sub.Load; + end; + end; + end; + + finally + rttiContext.Free; + sl.Free; + ini.Free; + end; +end; + +procedure TRTTIIni.Save; +var + ini : TIniFile; + sub : TRTTIIni; + rttiContext : TRttiContext; + rttiType : TRttiType; + rttiProperties: TArray; + rttiProperty : TRttiProperty; +begin + if (FFileName = '') then + raise ERTTIIni.Create('TRTTIIni.Save(): FileName not specified.'); + + ini := TIniFile.Create(FileName); + rttiContext := TRttiContext.Create; + try + ForceDirectories(ExtractFileDir(FileName)); + rttiType := rttiContext.GetType(Self.ClassInfo); + if (rttiType = nil) then + raise ERTTIIni.Create('TRTTIIni.Save(): Failed to get TRTTIType.'); + + rttiProperties := rttiType.GetProperties; + for rttiProperty in rttiProperties do + begin + if (rttiProperty.Visibility <> mvPublished) or (not rttiProperty.IsReadable) or (not rttiProperty.IsWritable) then + Continue; + + if rttiProperty.GetValue(Self).Kind in [ + tkWChar, tkLString, tkWString, tkString, tkChar, tkUString, + tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet] then + ini.WriteString(GetSectionName, rttiProperty.Name, rttiProperty.GetValue(Self).ToString); + + if (rttiProperty.GetValue(Self).IsObject) then + begin + if (rttiProperty.GetValue(Self).AsObject is TRTTIIni) then + begin + sub := TRTTIIni(rttiProperty.GetValue(Self).AsObject); + sub.FileName := Self.FileName; + sub.Save; + end; + end; + end; + finally + rttiContext.Free; + ini.Free; + end; +end; + +end. diff --git a/EvilWorks.System.StrUtils.inc b/EvilWorks.System.StrUtils.inc new file mode 100644 index 0000000..b3a2647 --- /dev/null +++ b/EvilWorks.System.StrUtils.inc @@ -0,0 +1,63 @@ +const + + CEmpty = ''; + CTab = #9; + CLf = #10; + CCr = #13; + CCrLf = CCr + CLf; + CSpace = ' '; + C0 = '0'; + C1 = '1'; + C2 = '2'; + C3 = '3'; + C4 = '4'; + C5 = '5'; + C6 = '6'; + C7 = '7'; + C8 = '8'; + C9 = '9'; + CDot = '.'; + CComma = ','; + CDoubleQuote = '"'; + CSingleQuote = ''''; + CColon = ':'; + CSemiColon = ';'; + CEquals = '='; + CMonkey = '@'; + CPercent = '%'; + CPlus = '+'; + CMinus = '-'; + CLBracket = '('; + CRBracket = ')'; + CLSquareBracket = '['; + CRSquareBracket = ']'; + CLCurlyBracket = '{'; + CRCurlyBracket = '}'; + CAsterisk = '*'; + CExclam = '!'; + CLessThan = '<'; + CGreaterThan = '>'; + CLadder = '#'; + CFrontSlash = '/'; + CBackSlash = '\'; + CQuestionMark = '?'; + CAmpersand = '&'; + CDollar = '$'; + + CTrue = 'True'; + CFalse = 'False'; + CURIPrefixDelimiter = '://'; + CURISchemeDelimiter = '://'; + CComment = '//'; + + CNums = '0123456789'; + CAlphaUpper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; + CAlphaLower = 'abcdefghijklmnopqrstuvwxyz'; + CAlpha = CAlphaUpper + CAlphaLower; + CAlphaNums = CNums + CAlpha; + CVowelsLower = 'aeiou'; + CVowelsUpper = 'AEIOU'; + CVowels = CVowelsLower + CVowelsUpper; + CConsonantsLower = 'bcdfghjklmnpqrstvxyz'; + CConsonantsUpper = 'BCDFGHJKLMNPQRSTVXYZ'; + CConsonants = CConsonantsLower + CConsonantsUpper; diff --git a/EvilWorks.System.StrUtils.pas b/EvilWorks.System.StrUtils.pas new file mode 100644 index 0000000..7ea2b8e --- /dev/null +++ b/EvilWorks.System.StrUtils.pas @@ -0,0 +1,1739 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.System.StrUtils +// Description: A collection of pure pascal string parsing functions! :) +// And still ~100x faster than Python, PHP, javascript... :P +// File last change date: October 30th. 2012 +// File version: Dev 0.0.0 +// Licence: Free. +// + +unit EvilWorks.System.StrUtils; + +interface + +uses + System.SysUtils, + System.StrUtils; + +{$I EvilWorks.System.StrUtils.inc} + +type + { Forward declarations } + TTokensEnumerator = class; + + { TSplitOption } + { Options for TextSplit(), TextTokenize() } + TSplitOption = ( + soNoDelSep, // Tokens will be added to list along with their trailing separators. + soCSSep, // Token separators are treated as Case Sensitive. SPEEDS UP! parsing. + soCSQot, // Quote character/string is treated as Case Sensitive. SPEEDS UP! parsing if [soQuoted]. + soSingleSep, // Splitting will stop after the first separator; Two tokens total. + soQuoted, // Treat strings quoted/enclosed in Quote as single token. + soRemQuotes // Remove Quote from parsed out tokens. + ); + TSplitOptions = set of TSplitOption; + + { TPair } + { Your standard Key=Value pair record. } + TPair = record + Key: string; + Val: string; + end; + + { TTokens } + { A helpful text array container for all sorts of formatting and parsing. } + { Can be declared as standalone (initialize with Clear), or returned by TextTokenize(). } + TTokens = record + private + FTokens: TArray; + FCount : Integer; + function GetToken(const aIndex: Integer): string; + procedure QuickSort(aStart, aEnd: Integer); + function GetPair(const aIndex: integer): TPair; + public + function GetEnumerator: TTokensEnumerator; + + function FromToken(const aIndex: Integer; const aDelimiter: string = CSpace): string; + function ToToken(const aIndex: Integer; const aDelimiter: string = CSpace): string; + function AllTokens(const aDelimiter: string = CSpace): string; + + procedure Add(const aText: string); overload; + + procedure Add(const aKey, aVal: string); overload; + procedure Add(const aKey: string; const aVal: integer); overload; + procedure Add(const aKey: string; const aVal: boolean); overload; + + procedure AddQ(const aKey, aVal: string); overload; + procedure AddQ(const aKey: string; const aVal: integer); overload; + procedure AddQ(const aKey: string; const aVal: boolean); overload; + + procedure Exchange(aIndexA, aIndexB: Integer); + procedure Sort; + procedure Clear; + + function ToArray(const aFromToken: integer = 0; const aToToken: integer = maxint): TArray; overload; + + property Token[const aIndex: Integer]: string read GetToken; default; + property Pair[const aIndex: integer]: TPair read GetPair; + property Count: Integer read FCount; + function Empty: boolean; + end; + + { TTokensEnumerator } + { Enumerator for TTokens. } + TTokensEnumerator = class + private + FIndex : integer; + FTokens: TTokens; + public + constructor Create(aTokens: TTokens); + function GetCurrent: string; inline; + function MoveNext: Boolean; inline; + property Current: string read GetCurrent; + end; + +{ Basic string handling } +function TextPos(const aText, aSubText: string; const aCaseSens: boolean = False; const aOfs: Integer = 1): Integer; +function TextCopy(const aText: string; const aStartIdx, aCount: Integer): string; +function TextUpCase(const aText: string): string; +function TextLoCase(const aText: string): string; +function TextReplace(const aText, aSubText, aNewText: string; const aCaseSens: boolean = False): string; +procedure TextAppend(var aText: string; const aAppendWith: string); + +{ More exotic functions of basic variety } +procedure TextAppendWithFeed(var aText: string; const aAppendWith: string); +procedure TextKeyValueAppend(var aOutStr: string; const aKey, aValue: string; const aAnd: boolean = True); +function TextEscStr(const aText, aEscape: string): string; + +{ Comparison, extraction, splitting, tokenizing... } +function TextLeft(const aText: string; const aCount: Integer): string; +function TextRight(const aText: string; const aCount: Integer): string; +function TextBegins(const aText, aBeginsWith: string; aCaseSens: boolean = False): boolean; +function TextEnds(const aText, aEndsWith: string; aCaseSens: boolean = False): boolean; +function TextSame(const aTextA, aTextB: string; const aCaseSens: boolean = False): boolean; inline; +function TextEquals(const aTextA, aTextB: string; const aCaseSens: boolean = False): boolean; +function TextInText(const aText, aContainsText: string; const aCaseSens: boolean = False): boolean; +function TextInArray(const aText: string; const aArray: array of string; const aAnywhere: boolean = True; const aCaseSens: boolean = False): boolean; +function TextWildcard(const aText, aWildCard: string): boolean; +function TextEnclosed(const aText, aLeftSide, aRightSide: string; const aCaseSens: boolean = False): boolean; overload; +function TextEnclosed(const aText, aEnclosedWith: string; const aCaseSens: boolean = False): boolean; overload; +function TextEnclose(const aText, aEncloseWith: string): string; +function TextUnEnclose(const aText, aEnclosedWith: string; const aCaseSens: boolean = False): string; overload; +function TextUnEnclose(const aText, aLeftSide, aRightSide: string; const aCaseSens: boolean = False): string; overload; +function TextFindEnclosed(const aText, aEnclLeft, aEnclRight: string; const aIdx: Integer; const aRemEncl: boolean = True; const aCaseSens: boolean = False): string; overload; +function TextFindEnclosed(const aText, aEncl: string; const aIdx: Integer; const aRemEncl: boolean = True; const aCaseSens: boolean = False): string; overload; +function TextQuote(const aText: string): string; +function TextUnquote(const aText: string): string; +function TextRemoveLineFeeds(const aText: string): string; +function TextExtractLeft(var aText: string; const aSep: string; const aCaseSens: boolean = False; const aDelSep: boolean = True): string; +function TextExtractRight(var aText: string; const aSep: string; const aCaseSens: boolean = False; const aDelSep: boolean = True): string; +function TextFetchLeft(const aText, aSep: string; const aCaseSens: boolean = False; const aEmptyIfNoSep: boolean = True): string; +function TextFetchRight(const aText, aSep: string; const aCaseSens: boolean = False; const aEmptyIfNoSep: boolean = True; const aSepFromRight: boolean = True): string; +function TextFetchLine(const aText: string): string; +function TextRemoveLeft(const aText, aRemove: string; const aCaseSens: boolean = False): string; +function TextRemoveRight(const aText, aRemove: string; const aCaseSens: boolean = False): string; +function TextSplit(const aText: string; const aSep: string = CSpace; const aQotStr: string = CDoubleQuote; const aOptions: TSplitOptions = [soCSSep, soCSQot]): TArray; +function TextSplitMarkup(const aText: string; const aTrim: boolean = True): TArray; +function TextTokenize(const aText: string; const aSep: string = CSpace; const aQotStr: string = CDoubleQuote; const aOptions: TSplitOptions = [soCSSep, soCSQot]): TTokens; +function TextToken(const aText: string; const aIndex: integer; const aSeparator: string = CSpace): string; + +{ Conversion and formating rotines } +function TextToInt(const aText: string; const aDefault: Integer): Integer; +function TextFromBool(const aBoolean: boolean; const aUseBoolStrings: boolean = True): string; +function TextFromInt(const aByte: byte): string; overload; +function TextFromInt(const aInteger: integer): string; overload; +function TextFromInt(const aCardinal: cardinal): string; overload; +function TextFromInt(const aInt64: int64): string; overload; +function TextFromFloat(const aFloat: double; const aDecimals: byte = 6): string; overload; +function TextFromFloat(const aExtended: extended; const aDecimals: byte = 6): string; overload; +function TextHexToDec(const aHexStr: string): cardinal; +function TextIntToHex(const aValue, aDigits: integer): string; +function TextMake(const aArgs: array of const; const aSeparator: string = ' '): string; + +{ URI text related functions } +function TextURISplit(const aURI: string; var aPrefix, aHost, aPath: string): boolean; overload; +function TextURISplit(const aURI: string; var aPrefix, aHost, aPath, aParams: string): boolean; overload; +function TextURIGetPath(const aURI: string): string; +function TextURIExtractParams(const aURI: string): string; +function TextURIWithoutParams(const aURI: string): string; + +{ Various utility functions } +function TextDump(const aData: pByte; const aSize: integer; const aBytesPerLine: byte = 16): string; +procedure TextSave(const aText, aFileName: string); +function TextOfChar(const aChar: char; const aLength: integer): string; + +{ IRC related functions } +function SplitHostMask(const aHostMask: string; var aNickname, aIdent, aHost: string): boolean; + +{ Random string generation functions } +function RandomNum: char; +function RandomNums(const aLength: byte): string; +function RandomAlphaLower: char; +function RandomAlphaLowers(const aLength: byte): string; +function RandomAlphaUpper: char; +function RandomAlphaUppers(const aLength: byte): string; +function RandomVowelLower: char; +function RandomVowelUpper: char; +function RandomVowel: char; +function RandomConsonantLower: char; +function RandomConsonantUpper: char; +function RandomConsonant: char; +function RandomString(const aLength: Integer; const aLowerCase, aUpperCase, aNumeric: boolean): string; overload; + +type + TTextHelper = record helper for string + public + function Len: integer; + function Size: integer; inline; + function Pos(const aSubText: string; const aCaseSens: boolean = False; const aOfs: Integer = 1): Integer; + function Copy(const aStartIdx, aCount: Integer): string; + function UpCase: string; + function LoCase: string; + function Replace(const aSubText, aNewText: string; const aCaseSens: boolean = False): string; + function Append(const aAppendWith: string; const aOnlyIfNotExists: boolean = False; + const aCaseSensitive: boolean = False): string; + function Left(const aLen: integer): string; + function Right(const aLen: integer): string; + function Begins(const aWith: string; const aCaseSensitive: boolean = False): boolean; + function Ends(const aWith: string; const aCaseSensitive: boolean = False): boolean; + function Equals(const aToText: string; const aCaseSensitive: boolean = False): boolean; + function ToInt(const aDefault: integer = -1): integer; + end; + +implementation + +{ TTextHelper } + +{ Length of Self in characters. } +function TTextHelper.Len: integer; +begin + Result := Length(Self); +end; + +{ Size of Self in memory. Len * Self element size. } +function TTextHelper.Size: integer; +begin + Result := (Self.Len * StringElementSize(Self)); +end; + +{ Convert to int. Return aDefault on fail. } +function TTextHelper.ToInt(const aDefault: integer): integer; +var + code: Integer; +begin + Val(Self, Result, code); + if (code <> 0) then + Result := aDefault; +end; + +{ Get position of substring aSubText. 0 if not found. aOfs sets search start offset. } +function TTextHelper.Pos(const aSubText: string; const aCaseSens: boolean; const aOfs: Integer): Integer; +begin + Result := EvilWorks.System.StrUtils.TextPos(Self, aSubText, acaseSens, aOfs); +end; + +{ Copy part of the string defined with aStartIdx and aCount. Returns nothing on invalid params or empty. } +function TTextHelper.Copy(const aStartIdx, aCount: Integer): string; +begin + Result := EvilWorks.System.StrUtils.TextCopy(Self, aStartIdx, aCount); +end; + +{ Return UPPERCASE formatted self. } +function TTextHelper.UpCase: string; +begin + Result := EvilWorks.System.StrUtils.TextUpCase(Self); +end; + +{ Return lowercase formatted self. } +function TTextHelper.LoCase: string; +begin + Result := EvilWorks.System.StrUtils.TextLoCase(Self); +end; + +{ Replace aSubText in Self with aNewText, return result. aCaseSens sets case sensitivity of the search. } +{ If aSubText is not found Self is just copied to result. } +function TTextHelper.Replace(const aSubText, aNewText: string; const aCaseSens: boolean): string; +begin + Result := EvilWorks.System.StrUtils.TextReplace(Self, aSubText, aNewText, aCaseSens); +end; + +{ Append self with aAppendWith. If aOnlyIfExists will be appended only if Self is not already suffixed. } +{ aCaseSensitive sets case sensitivity of existing aAppendWith suffix. } +function TTextHelper.Append(const aAppendWith: string; const aOnlyIfNotExists: boolean; + const aCaseSensitive: boolean): string; +begin + if (aOnlyIfNotExists) then + if (TextEquals(Self.Right(aAppendWith.Len), aAppendWith, aCaseSensitive)) then + Exit(Self); + Result := Self + aAppendWith; +end; + +{ Return aLen chars from left of Self. If aLen > than Self.Len, just return all there is. } +function TTextHelper.Left(const aLen: integer): string; +begin + Result := TextCopy(Self, 1, aLen); +end; + +{ Return aLen chars from right of Self. If aLen > than Self.Len, just return all there is. } +function TTextHelper.Right(const aLen: integer): string; +begin + Result := Self.Copy(Self.Len - aLen + 1, aLen); +end; + +{ Checks if Self begins with aWith. aCaseSensitive sets search case sensitivity. } +function TTextHelper.Begins(const aWith: string; const aCaseSensitive: boolean): boolean; +begin + Result := TextEquals(Self.Left(aWith.Len), aWith, aCaseSensitive); +end; + +{ Checks if Self ends with aWith. aCaseSensitive sets search case sensitivity. } +function TTextHelper.Ends(const aWith: string; const aCaseSensitive: boolean): boolean; +begin + Result := TextEquals(Self.Right(aWith.Len), aWith, aCaseSensitive); +end; + +{ Checks if Self equals aToText. aCaseSensitive sets search case sensitivity. } +function TTextHelper.Equals(const aToText: string; const aCaseSensitive: boolean): boolean; +begin + if (aCaseSensitive) then + Result := (Self = aToText) + else + Result := SameText(Self, aToText); +end; + +{ Combines Pos and PosEx. } +function TextPos(const aText, aSubText: string; const aCaseSens: boolean = False; const aOfs: Integer = 1): Integer; +begin + if (aCaseSens = False) then + Result := PosEx(LowerCase(aSubText), LowerCase(aText), aOfs) + else + Result := PosEx(aSubText, aText, aOfs); +end; + +{ Safe Copy. Won't go apeshit if aStartIdx is > Length(aText), instead it just returns empty string. } +function TextCopy(const aText: string; const aStartIdx, aCount: Integer): string; +begin + { Safe Copy. Won't go apeshit if aStartIdx is > Length(aText). } + if (aStartIdx > Length(aText)) then + Exit(CEmpty); + Result := Copy(aText, aStartIdx, aCount); +end; + +{ Uppercase } +function TextUpCase(const aText: string): string; +var + i: integer; +begin + SetLength(Result, Length(aText)); + for i := 0 to Length(aText) - 1 do + Result[1] := UpCase(aText[i]); +end; + +{ Lowercase } +function TextLoCase(const aText: string): string; +begin + Result := LowerCase(aText); +end; + +{ Replaces all occurances of aSubText with aNewText in aText. } +function TextReplace(const aText, aSubText, aNewText: string; const aCaseSens: boolean = False): string; +var + i: Integer; + j: Integer; +begin + Result := CEmpty; + + if (aText = CEmpty) then + Exit; + + j := 1; + while (True) do + begin + i := TextPos(aText, aSubText, aCaseSens, j); + if (i > 0) then + begin + Result := Result + TextCopy(aText, j, i - j) + aNewText; + i := i + Length(aSubText); + j := i; + end + else + begin + Result := Result + TextRight(aText, Length(aText) - j + 1); + Exit; + end; + end; +end; + +{ Append aText with aAppendWith } +procedure TextAppend(var aText: string; const aAppendWith: string); +begin + aText := aText + aAppendWith; +end; + +{ Append aText with aAppendWith and CRLF. } +procedure TextAppendWithFeed(var aText: string; const aAppendWith: string); +begin + aText := aText + aAppendWith + CCrLf; +end; + +{ Append aKey="aValue" pair to aOutStr and add ', ' if aAnd: aKey="aValue", } +procedure TextKeyValueAppend(var aOutStr: string; const aKey, aValue: string; const aAnd: boolean = True); +begin + if (aAnd) then + aOutStr := aOutStr + aKey + '="' + aValue + '", ' + else + aOutStr := aOutStr + aKey + '="' + aValue + '"'; +end; + +{ Escape/replace all %s tokens in aText with aEscape} +function TextEscStr(const aText, aEscape: string): string; +begin + Result := TextReplace(aText, '%s', aEscape, False); +end; + +{ Copies aCount chars from Left of aText. } +function TextLeft(const aText: string; const aCount: Integer): string; +begin + Result := TextCopy(aText, 1, aCount); +end; + +{ Copies aCount chars from Right of aText. } +function TextRight(const aText: string; const aCount: Integer): string; +begin + Result := TextCopy(aText, Length(aText) - aCount + 1, aCount); +end; + +{ Checks if aText begins with aBeginsWith. } +function TextBegins(const aText, aBeginsWith: string; aCaseSens: boolean = False): boolean; +begin + if (aCaseSens) then + Result := (TextLeft(aText, Length(aBeginsWith)) = aBeginsWith) + else + Result := (SameText(TextLeft(aText, Length(aBeginsWith)), aBeginsWith)); +end; + +{ Checks if aText ends with aEndsWith. } +function TextEnds(const aText, aEndsWith: string; aCaseSens: boolean = False): boolean; +begin + if (aCaseSens) then + Result := (TextRight(aText, Length(aEndsWith)) = aEndsWith) + else + Result := (SameText(TextRight(aText, Length(aEndsWith)), aEndsWith)); +end; + +{ Checks if aTextA is same as aTextB. Alias for TextEquals. } +function TextSame(const aTextA, aTextB: string; const aCaseSens: boolean): boolean; inline; +begin + Result := TextEquals(aTextA, aTextB, aCaseSens); +end; + +{ Checks if aTextA is same as aTextB. } +function TextEquals(const aTextA, aTextB: string; const aCaseSens: boolean): boolean; +begin + if (aCaseSens) then + Result := (aTextA = aTextB) + else + Result := SameText(aTextA, aTextB); +end; + +{ Checks if aText contains aContainsText. } +function TextInText(const aText, aContainsText: string; const aCaseSens: boolean): boolean; +begin + Result := (TextPos(aText, aContainsText, aCaseSens) <> 0); +end; + +{ Checks if aText matches any entries in aArray. If aAnywhere, aText matches anywhere in an aArray item. } +function TextInArray(const aText: string; const aArray: array of string; const aAnywhere: boolean; const aCaseSens: boolean): boolean; +var + i: integer; +begin + Result := False; + for i := 0 to high(aArray) do + begin + if (aAnywhere) then + begin + if (TextInText(aArray[i], aText, aCaseSens)) then + Exit(True); + end + else + begin + if (TextEquals(aArray[i], aText, aCaseSens)) then + Exit(True); + end; + end; +end; + +{ Matches aText agains aWildCard. Case insensitive. * and ? supported. For IRC. } +function TextWildcard(const aText, aWildCard: string): boolean; +var + ps: pchar; + pw: pchar; + mp: pchar; + cp: pchar; +begin + if (aText = '') or (aWildCard = '') then + Exit(False); + + ps := @aText[1]; + pw := @aWildCard[1]; + mp := nil; + cp := nil; + + while ((ps^ <> #0) and (pw^ <> CAsterisk)) do + begin + if ((pw^ <> CQuestionMark) and (SameText(ps^, pw^) = False)) then + Exit(False); + Inc(ps); + Inc(pw); + end; + + while (ps^ <> #0) do + begin + if (pw^ = CAsterisk) then + begin + Inc(pw); + if (pw^ = #0) then + Exit(True); + mp := pw; + cp := @ps[1]; + end + else + begin + if (SameText(ps^, pw^)) or (pw^ = CQuestionMark) then + begin + Inc(ps); + Inc(pw); + end + else + begin + ps := cp; + Inc(cp); + pw := mp; + end; + end; + end; + + while (pw^ = CAsterisk) do + Inc(pw); + + Result := (pw^ = #0); +end; + +{ Checks if left of aText is prefixed with aLeftSide and right of aText is suffixed with aRightSide. } +function TextEnclosed(const aText, aLeftSide, aRightSide: string; const aCaseSens: boolean = False): boolean; +begin + if (aCaseSens) then + Result := ((TextLeft(aText, Length(aLeftSide)) = aLeftSide) and (TextRight(aText, Length(aRightSide)) = aRightSide)) + else + Result := (SameText(TextLeft(aText, Length(aLeftSide)), aLeftSide) and SameText(TextRight(aText, Length(aRightSide)), aRightSide)); +end; + +{ Checks if aText is prefixed and suffixed with aEnclosedWith. e.g. xXxTeenageDawgxXx } +function TextEnclosed(const aText, aEnclosedWith: string; const aCaseSens: boolean = False): boolean; +begin + Result := TextEnclosed(aText, aEnclosedWith, aEnclosedWith, aCaseSens); +end; + +{ Encloses a aText within aEncloseWith. } +function TextEnclose(const aText, aEncloseWith: string): string; +begin + Result := aEncloseWith + aText + aEncloseWith; +end; + +{ Removes aEnclosedWith prefix AND/OR suffix from aText. } +function TextUnEnclose(const aText, aEnclosedWith: string; const aCaseSens: boolean = False): string; +begin + Result := TextUnEnclose(aText, aEnclosedWith, aEnclosedWith, aCaseSens); +end; + +{ Removes aLeftSide prefix from Left AND/OR aRightSide suffix from Right side of aText. } +function TextUnEnclose(const aText, aLeftSide, aRightSide: string; const aCaseSens: boolean = False): string; overload; +begin + if (aCaseSens) then + begin + if (TextLeft(aText, Length(aLeftSide)) = aLeftSide) then + Result := TextCopy(aText, Length(aLeftSide) + 1, MaxInt) + else + Result := aText; + + if (TextRight(Result, Length(aRightSide)) = aRightSide) then + Delete(Result, Length(Result), Length(aRightSide)); + end + else + begin + if (SameText(TextLeft(aText, Length(aLeftSide)), aLeftSide)) then + Result := TextCopy(aText, Length(aLeftSide) + 1, MaxInt) + else + Result := aText; + + if (SameText(TextRight(Result, Length(aRightSide)), aRightSide)) then + Delete(Result, Length(Result), Length(aRightSide)); + end; +end; + +{ Find and return aIdx(th) (0-based) occurance of text in aText that is enlosed with aEnclLeft on left and } +{ aEnclRight on the right of text. If aRemEncl, aEnclLeft and aEnclRight are removed from result, aCaseSens } +{ makes the search Case-sensitive. If no enclosed text is found, result is an empty string. } +function TextFindEnclosed(const aText, aEnclLeft, aEnclRight: string; const aIdx: Integer; const aRemEncl: boolean = True; const aCaseSens: boolean = False): string; +var + a : Integer; + b : Integer; + ea: integer; + eb: integer; + l : Integer; + i : Integer; +begin + Result := CEmpty; + + if (aText = CEmpty) then + Exit; + + a := 1; + b := 1; + l := Length(aText); + ea := Length(aEnclLeft); + eb := Length(aEnclRight); + i := 0; + while (i <= aIdx) and (a < l) and (b < l) do + begin + a := TextPos(aText, aEnclLeft, aCaseSens, b); + if (a = 0) then + Exit; + + b := TextPos(aText, aEnclRight, aCaseSens, a + ea); + if (b <= a) then + Exit; + + if (i = aIdx) then + begin + if (aRemEncl) then + Result := TextCopy(aText, a + ea, b - a - ea) + else + Result := TextCopy(aText, a, b - a + eb); + end; + a := b + eb; + b := a; + Inc(i); + end; { while } +end; + +{ Find and return aIdx occurance of text in aText that is enlosed with aEncl. If aRemEncl, aEncl is removed } +{ from result. aCase sens makes the search Case-sensitive. If no enclosed text is found, result is empty. } +function TextFindEnclosed(const aText, aEncl: string; const aIdx: Integer; const aRemEncl: boolean; const aCaseSens: boolean): string; +begin + Result := TextFindEnclosed(aText, aEncl, aEncl, aIdx, aRemEncl, aCaseSens); +end; + +{ Encloses aText with Double quotes. "Got it?" } +function TextQuote(const aText: string): string; +begin + Result := TextEnclose(aText, CDoubleQuote); +end; + +{ Removes Double quote prefix AND/OR suffix from aText. } +function TextUnquote(const aText: string): string; +begin + Result := TextUnEnclose(aText, CDoubleQuote); +end; + +{ Strips $0D and $0A from end of text until it finds no more. } +function TextRemoveLineFeeds(const aText: string): string; +var + i: Integer; +begin + i := Length(aText); + while (i > 0) and ((aText[i] = CCr) or (aText[i] = CLf)) do + Dec(i); + Result := TextCopy(aText, 1, i); +end; + +{ Removes string from Left of aText to aSep. If aSep is not found, nothing is returned or removed. } +{ aSep search begins from Left of aText. If aDelSep is false returns aSep as well. } +function TextExtractLeft(var aText: string; const aSep: string; const aCaseSens: boolean = False; const aDelSep: boolean = True): string; +var + i: Integer; +begin + i := TextPos(aText, aSep, aCaseSens); + if (i > 0) then + begin + Result := TextCopy(aText, 1, i - 1); + Delete(aText, 1, i - 1); + if (aDelSep) then + Delete(aText, 1, Length(aSep)); + end; +end; + +{ Removes string from Right of aText to aSep. If aSep is not found, nothing is returned or removed. } +{ aSep search begins from Right of aText. If aDelSep is false returns aSep as well. } +function TextExtractRight(var aText: string; const aSep: string; const aCaseSens: boolean = False; const aDelSep: boolean = True): string; +var + i, ofs: Integer; +begin + i := 0; + ofs := 1; + while (ofs <> 0) do + begin + ofs := TextPos(aText, aSep, aCaseSens, ofs); + if (ofs <> 0) then + begin + i := ofs; + Inc(ofs); + end + else + Break; + end; + + if (i <> 0) then + begin + Result := TextRight(aText, Length(aText) - i); + Delete(aText, i, MaxInt); + end; +end; + +{ Copies string from Left of aText to aSep. If aSep is not found, returns nothing. } +{ aSep search begins from Left of aText. } +function TextFetchLeft(const aText, aSep: string; const aCaseSens: boolean = False; const aEmptyIfNoSep: boolean = True): string; +var + i: Integer; +begin + i := TextPos(aText, aSep, aCaseSens); + if (i > 0) then + Result := TextLeft(aText, i - 1) + else if (aEmptyIfNoSep) then + Result := CEmpty + else + Result := aText; +end; + +{ Copies string from Right of aText to aSep. If aSep is not found returns nothing. } +{ If aSepFromRight aSep search begins from Right of aText, else from left. } +function TextFetchRight(const aText, aSep: string; const aCaseSens: boolean; const aEmptyIfNoSep: boolean; const aSepFromRight: boolean): string; +var + i, ofs: Integer; +begin + if (aSepFromRight) then + begin + i := 0; + ofs := 1; + while (ofs <> 0) do + begin + ofs := TextPos(aText, aSep, aCaseSens, ofs); + if (ofs <> 0) then + begin + i := ofs; + Inc(ofs); + end + else + Break; + end; + + if (i = 0) then + if (aEmptyIfNoSep) then + Exit(CEmpty) + else + Exit(aText); + Result := TextRight(aText, Length(aText) - i - Length(aSep) + 1); + end + else + begin + i := TextPos(aText, aSep, aCaseSens); + if (i > 0) then + Result := TextRight(aText, Length(aText) - i - Length(aSep) + 1) + else if (aEmptyIfNoSep) then + Result := CEmpty + else + Result := aText; + end; +end; + +{ Copies string from Left of aText to first CRLF separator. If aSep is not found, returns nothing. } +function TextFetchLine(const aText: string): string; +begin + Result := TextFetchLeft(atext, #13#10, True); +end; + +{ Removes aRemove from the Left of aText, returns the rest. } +function TextRemoveLeft(const aText, aRemove: string; const aCaseSens: boolean = False): string; +begin + if (TextBegins(aText, aRemove, aCaseSens)) then + Result := TextCopy(aText, Length(aRemove) + 1, MaxInt) + else + Result := aText; +end; + +{ Removes aRemove from the Right of aText, returns the rest. } +function TextRemoveRight(const aText, aRemove: string; const aCaseSens: boolean = False): string; +begin + if (TextEnds(aText, aRemove, aCaseSens)) then + Result := TextCopy(aText, 1, Length(aText) - Length(aRemove)) + else + Result := aText; +end; + +{ Splits aText on aSep(s), returns an array of strings. } +function TextSplit(const aText: string; const aSep: string; const aQotStr: string; const aOptions: TSplitOptions): TArray; +var + Count: Integer; + + procedure Add(const aString: string); + begin + if (aString = CEmpty) then + Exit; + Inc(Count); + SetLength(Result, Count); + Result[Count - 1] := aString; + end; + +var + strLen: Integer; + sepLen: Integer; + qotLen: Integer; + cpyPos: Integer; + ofsPos: Integer; + tokPos: Integer; + qotPos: Integer; + +begin + if ((aText = CEmpty) or (aSep = CEmpty)) then + Exit; + + if (soQuoted in aOptions) then + if (aQotStr = CEmpty) then + Exit; + + Count := 0; + + strLen := Length(aText); + sepLen := Length(aSep); + + cpyPos := 1; + ofsPos := 1; + + if (soQuoted in aOptions) then + begin + qotLen := Length(aQotStr); + qotPos := 1; + while (True) do + begin + tokPos := TextPos(aText, aSep, (soCSSep in aOptions), ofsPos); + qotPos := TextPos(aText, aQotStr, (soCSQot in aOptions), qotPos); + if (qotPos < tokPos) and (qotPos <> 0) then + begin + qotPos := TextPos(aText, aQotStr, (soCSQot in aOptions), qotPos + qotLen); + if (qotPos <> 0) then + begin + ofsPos := qotPos; + qotPos := qotPos + qotLen; + end + else + qotPos := MaxInt; + end + else + begin + if (tokPos = 0) then + begin + Add(TextCopy(aText, cpyPos, MaxInt)); + Exit; + end + else + begin + if (soNoDelSep in aOptions) then + begin + if (soRemQuotes in aOptions) then + Add(TextUnEnclose(TextCopy(aText, cpyPos, tokPos - cpyPos + sepLen), aQotStr, (soCSQot in aOptions))) + else + Add(TextCopy(aText, cpyPos, tokPos - cpyPos + sepLen)) + end + else + begin + if (soRemQuotes in aOptions) then + Add(TextUnEnclose(TextCopy(aText, cpyPos, tokPos - cpyPos), aQotStr, (soCSQot in aOptions))) + else + Add(TextCopy(aText, cpyPos, tokPos - cpyPos)); + end; + ofsPos := tokPos + sepLen; + qotPos := ofsPos; + cpyPos := ofsPos; + end; + end; + end; + end + else + begin + while (True) do + begin + tokPos := TextPos(aText, aSep, (soCSSep in aOptions), ofsPos); + if (tokPos > 0) then + begin + if (soNoDelSep in aOptions) then + Add(TextCopy(aText, ofsPos, tokPos - ofsPos + sepLen)) + else + Add(TextCopy(aText, ofsPos, tokPos - ofsPos)); + ofsPos := tokPos + sepLen; + if (soSingleSep in aOptions) then + begin + Add(TextCopy(aText, ofsPos, MaxInt)); + Exit; + end; + end + else + begin + Add(TextRight(aText, strLen - ofsPos + 1)); + Exit; + end; + end; + end; +end; + +{ Splits the line with HTML/XML markup into a list of tokens. No pair matching performed. Example: } +{ text1text2 to , text1, , , text2 and . } +function TextSplitMarkup(const aText: string; const aTrim: boolean): TArray; +var + Count: Integer; + + procedure Add(const aString: string); + begin + if (aString = CEmpty) then + Exit; + Inc(Count); + SetLength(Result, Count); + if (aTrim) then + Result[Count - 1] := Trim(aString) + else + Result[Count - 1] := aString; + end; + +var + strLen: Integer; + cpyPos: Integer; + ofsPos: Integer; +begin + strLen := Length(aText); + if (strLen = 0) then + Exit; + + Count := 0; + ofsPos := 1; + cpyPos := 1; + + while (cpyPos <= strLen) do + begin + if (aText[cpyPos] = CLessThan) then + begin + if (ofsPos <> cpyPos) then + begin + Add(TextCopy(aText, ofsPos, cpyPos - ofsPos)); + ofsPos := cpyPos; + end + else + Inc(cpyPos); + end + else if (aText[cpyPos] = CGreaterThan) then + begin + if (ofsPos <> cpyPos) then + begin + Add(TextCopy(aText, ofsPos, cpyPos - ofsPos + 1)); + Inc(cpyPos); + ofsPos := cpyPos; + end + else + Inc(cpyPos); + end + else + Inc(cpyPos); + end; + + if (ofsPos < cpyPos) then + Add(TextCopy(aText, ofsPos, MaxInt)); +end; + +{ Splits aText on aSep(s), returns TTokens record. } +function TextTokenize(const aText: string; const aSep: string; const aQotStr: string; const aOptions: TSplitOptions): TTokens; +begin + Result.FTokens := TextSplit(aText, aSep, aQotStr, aOptions); + Result.FCount := Length(Result.FTokens); +end; + +{ Returns token at aIndex from aText split by aSeparator. } +function TextToken(const aText: string; const aIndex: integer; const aSeparator: string = CSpace): string; +var + tokens: TTokens; +begin + tokens := TextTokenize(aText); + Result := tokens[aIndex]; +end; + +{ Converts a string to an integer. } +function TextToInt(const aText: string; const aDefault: Integer): Integer; +var + code: Integer; +begin + Val(aText, Result, code); + if (code <> 0) then + Result := aDefault; +end; + +{ Converts a byte to a string. } +function TextFromInt(const aByte: byte): string; +begin +{$WARNINGS OFF} + Str(aByte, Result); +{$WARNINGS ON} +end; + +{ Converts an integer to a string. } +function TextFromInt(const aInteger: integer): string; +begin +{$WARNINGS OFF} + Str(aInteger, Result); +{$WARNINGS ON} +end; + +{ Converts a cardinal to a string. } +function TextFromInt(const aCardinal: cardinal): string; +begin +{$WARNINGS OFF} + Str(aCardinal, Result); +{$WARNINGS ON} +end; + +{ Converts an int64 to a string. } +function TextFromInt(const aInt64: int64): string; +begin +{$WARNINGS OFF} + Str(aInt64, Result); +{$WARNINGS ON} +end; + +{ Converts a boolean to string. } +function TextFromBool(const aBoolean: boolean; const aUseBoolStrings: boolean): string; +begin + if (aBoolean) then + if (aUseBoolStrings) then + Exit('True') + else + Exit('1'); + + if (aBoolean = False) then + if (aUseBoolStrings) then + Exit('False') + else + Exit('0'); +end; + +{ Converts a float to string. } +function TextFromFloat(const aFloat: double; const aDecimals: byte): string; +begin +{$WARNINGS OFF} + Str(aFloat: 1: aDecimals, Result); +{$WARNINGS ON} +end; + +{ Converts an extended to string. } +function TextFromFloat(const aExtended: extended; const aDecimals: byte = 6): string; +begin +{$WARNINGS OFF} + Str(aExtended: 1: aDecimals, Result); +{$WARNINGS ON} +end; + +{ Converts a hex string to an integer. Input example: "DEADBEEF". } +function TextHexToDec(const aHexStr: string): cardinal; +var + c: cardinal; + b: byte; +begin + Result := 0; + if (Length(aHexStr) <> 0) then + begin + c := 1; + b := Length(aHexStr) + 1; + repeat + Dec(b); + if (aHexStr[b] <= '9') then + Result := (Result + (cardinal(aHexStr[b]) - 48) * c) + else + Result := (Result + (cardinal(aHexStr[b]) - 55) * c); + + c := c * 16; + until (b = 1); + end; +end; + +{ Converts aValue to Hex string with aDigits minimum width. } +function TextIntToHex(const aValue, aDigits: integer): string; +begin + Result := IntToHex(aValue, aDigits); +end; + +{ Converts and appends all parameters together. Parameters can be of mixed types, but not constants. } +function TextMake(const aArgs: array of const; const aSeparator: string): string; +var + i: integer; +begin + Result := ''; + for i := 0 to high(aArgs) do + begin + case aArgs[i].VType of + vtInteger: + Result := Result + TextFromInt(aArgs[i].VInteger); + vtBoolean: + Result := Result + TextFromBool(aArgs[i].VBoolean); + vtChar: + Result := Result + string(aArgs[i].VChar); + vtExtended: + Result := Result + TextFromFloat(aArgs[i].VExtended^); + vtString: + Result := Result + string(aArgs[i].VString^); + vtPChar: + Result := Result + string(aArgs[i].VPChar); + vtObject: + Result := Result + aArgs[i].VObject.ClassName; + vtClass: + Result := Result + aArgs[i].VClass.ClassName; + vtAnsiString: + Result := Result + string(aArgs[i].VAnsiString); + vtUnicodeString: + Result := Result + string(aArgs[i].VUnicodeString); + vtCurrency: + Result := Result + TextFromFloat(aArgs[i].VCurrency^); + vtVariant: + Result := Result + string(aArgs[i].VVariant^); + vtInt64: + Result := Result + TextFromInt(aArgs[i].VInt64^); + end; + + if (i <> high(aArgs)) then + Result := Result + aSeparator; + end; +end; + +{ Splits an URI into parts: http://goatse.cx/images/goatse.jpg = http, goatse.cx, images/goatse.jpg } +function TextURISplit(const aURI: string; var aPrefix, aHost, aPath: string): boolean; +var + rPrefix, rHost, rPath, rParams: string; +begin + Result := TextURISplit(aURI, rPrefix, rHost, rPath, rParams); +end; + +{ Splits an URI into parts: http://goatse.cx/images/goatse.jpg = http, goatse.cx, images/goatse.jpg, par=val&par2=val2 } +function TextURISplit(const aURI: string; var aPrefix, aHost, aPath, aParams: string): boolean; overload; +var + offs: Integer; + i : Integer; +begin + Result := False; + + if (aURI = CEmpty) then + Exit; + + offs := 0; + + // Extract prefix. + i := TextPos(aURI, CURIPrefixDelimiter); + if (i > 0) then + begin + aPrefix := TextLeft(aURI, i - 1); + offs := i + Length(CURIPrefixDelimiter); + end; + + // Extract host. + if (offs = 0) then + begin + i := TextPos(aURI, CFrontSlash); + if (i > 0) then + begin + aHost := TextCopy(aURI, offs, i - 1); + offs := i; + end; + end + else + begin + i := TextPos(aURI, CFrontSlash, True, offs); + if (i > 0) then + begin + aHost := TextCopy(aURI, offs, i - offs); + offs := i; + end; + end; + + // Extract path. + if (offs = 0) then + begin + i := TextPos(aURI, CQuestionMark); + if (i > 0) then + begin + aPath := TextCopy(aURI, offs, i - 1); + // The rest are params + aParams := TextCopy(aURI, i + 1, MaxInt); + end + else + begin + aPath := TextCopy(aURI, offs, MaxInt); + Exit(True); + end; + end + else + begin + i := TextPos(aURI, CQuestionMark, True, offs); + if (i > 0) then + begin + aPath := TextCopy(aURI, offs, i - offs); + // The rest are params + aParams := TextCopy(aURI, i + 1, MaxInt); + end + else + begin + aPath := TextCopy(aURI, offs, MaxInt); + Exit(True); + end; + end; + + Result := True; +end; + +{ Extracts Path from an URL } +function TextURIGetPath(const aURI: string): string; +var + prefix, domain, path: string; +begin + if (TextURISplit(aURI, prefix, domain, path)) then + Result := path + else + Result := CEmpty; +end; + +{ Url encodes(percent encodes) a string. } +function TextURIEncode(const aText: string): string; +var + i : Integer; + Ch: char; +begin + Result := ''; + for i := 1 to Length(aText) do + begin + Ch := aText[i]; + if ((Ch >= '0') and (Ch <= '9')) or ((Ch >= 'a') and (Ch <= 'z')) or + ((Ch >= 'A') and (Ch <= 'Z')) or (Ch = '.') or (Ch = '-') or (Ch = '_') + or (Ch = '~') then + Result := Result + Ch + else + begin + Result := Result + '%' + IntToHex(Ord(Ch), 2); + end; + end; +end; + +{ Url decodes(percent decodes) a string. } +function TextURIDecode(const aText: string): string; +var + i: Integer; + l: Integer; +begin + Result := CEmpty; + + i := 1; + l := Length(aText); + while (i <= l) do + begin + if (aText[i] = CPercent) then + begin + Result := Result + Chr(TextHexToDec(aText[i + 1] + aText[i + 2])); + i := Succ(Succ(i)); + end + else + begin + if aText[i] = CPlus then + Result := (Result + CSpace) + else + Result := (Result + aText[i]); + end; + i := Succ(i); + end; +end; + +{ Returns "file.ext" from "http://www.site.com/path/here/file.ext". } +function TextURIExtractParams(const aURI: string): string; +begin + Result := TextFetchRight(aURI, '?', True); +end; + +{ Returns "http://www.site.com/path/here/" from "http://www.site.com/path/here/file.ext" } +function TextURIWithoutParams(const aURI: string): string; +var + rPrefix, rHost, rPath, rParams: string; +begin + // Have to do everything here. If we go too deep on the stack + // Delphi forgets string refcount and returns nothing :S. + if (TextPos(aURI, CQuestionMark, True) > 0) then + Exit(TextFetchLeft(aURI, CQuestionMark, True)) + else + Result := CEmpty; + + if (TextURISplit(aURI, rPrefix, rHost, rPath, rParams)) then + Result := rPrefix + CURISchemeDelimiter + rHost + rPath; +end; + +{ Returns a hex display style string from aData of aSize. } +function TextDump(const aData: pByte; const aSize: integer; const aBytesPerLine: byte): string; +var + p: pbyte; + i: integer; + h: string; + t: string; +begin + if (aData = nil) or (aSize <= 0) or (aBytesPerLine = 0) then + Exit; + + i := 0; + p := aData; + while (i < aSize) do + begin + if ((i mod aBytesPerLine = 0) and (i <> 0)) or (i = aSize) then + begin + Result := Result + h + CSpace + CMinus + CSpace + t + CCrLf; + h := CEmpty; + t := CEmpty; + end; + + if (h <> CEmpty) then + begin + if (i mod 8 = 0) then + h := h + CSpace + CSpace + else + h := h + CSpace; + end; + + h := h + IntToHex(p^, 2); + if (p^ >= 20) and (p^ <= 127) then + t := t + Chr(p^) + else + t := t + CDot; + + Inc(p); + Inc(i); + end; + + if (h <> CEmpty) then + begin + Result := Result + h; + while (i mod aBytesPerLine <> 0) do + begin + if (i mod 8 = 0) then + Result := Result + CSpace + CSpace + CSpace + CSpace + else + Result := Result + CSpace + CSpace + CSpace; + Inc(i); + end; + Result := Result + CSpace + CMinus + CSpace + t; + end; +end; + +{ Save aText to aFileName. } +procedure TextSave(const aText, aFileName: string); +var + f: TextFile; +begin + AssignFile(f, aFileName, 65001); + Rewrite(f); + write(f, aText); + CloseFile(f); +end; + +{ Returns a string of length aLength composed entirely of aChar. } +function TextOfChar(const aChar: char; const aLength: integer): string; +var + i: integer; +begin + if (aLength <= 0) then + Exit(''); + SetLength(Result, alength); + for i := 1 to aLength do + Result[i] := aChar; +end; + +{ Splits IRC hostmask nickname!ident@host.name into parts. } +function SplitHostMask(const aHostMask: string; var aNickname, aIdent, aHost: string): boolean; +begin + if (Length(aHostMask) = 0) then + Exit(False); + + aHost := aHostMask; + aIdent := TextExtractLeft(aHost, CMonkey); + aNickname := TextExtractLeft(aIdent, CExclam); + Result := (aHost <> CEmpty) and (aIdent <> CEmpty) and (aNickname <> CEmpty); +end; + +{ Returns a random number character. } +function RandomNum: char; +begin + Result := pchar(CNums)[Random(Length(CNums))]; +end; + +{ Returns a random string of number characters of aLength. } +function RandomNums(const aLength: byte): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := 0 to aLength - 1 do + Result := Result + RandomNum; +end; + +{ Returns a random lowercase letter. } +function RandomAlphaLower: char; +begin + Result := pchar(CAlphaLower)[Random(Length(CAlphaLower))]; +end; + +{ Returns a random string of lowercase letters of aLength. } +function RandomAlphaLowers(const aLength: byte): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := 0 to aLength - 1 do + Result := Result + RandomAlphaLower; +end; + +{ Returns a random uppercase letter. } +function RandomAlphaUpper: char; +begin + Result := pchar(CAlphaUpper)[Random(Length(CAlphaUpper))]; +end; + +{ Returns a random string of uppercase letters of aLength. } +function RandomAlphaUppers(const aLength: byte): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := 0 to aLength - 1 do + Result := Result + RandomAlphaUpper; +end; + +{ Returns a random lowercase vowel. } +function RandomVowelLower: char; +begin + Result := pchar(CVowelsLower)[Random(Length(CVowelsLower))]; +end; + +{ Returns a random uppercase vowel. } +function RandomVowelUpper: char; +begin + Result := pchar(CVowelsUpper)[Random(Length(CVowelsUpper))]; +end; + +{ Returns a random vowel. } +function RandomVowel: char; +begin + Result := pchar(CVowels)[Random(Length(CVowels))]; +end; + +{ Returns a random lowercase consonant. } +function RandomConsonantLower: char; +begin + Result := pchar(CConsonantsLower)[Random(Length(CConsonantsLower))]; +end; + +{ Returns a random uppercase consonant. } +function RandomConsonantUpper: char; +begin + Result := pchar(CConsonantsUpper)[Random(Length(CConsonantsUpper))]; +end; + +{ Returns a random consonant. } +function RandomConsonant: char; +begin + Result := pchar(CConsonants)[Random(Length(CConsonants))]; +end; + +{ Generates a random string of aLength. } +function RandomString(const aLength: Integer; const aLowerCase, aUpperCase, aNumeric: boolean): string; +type + TRandomFunc = function: char; + TRandomFuncs = array of TRandomFunc; +var + i: Integer; + f: TRandomFuncs; +begin + Result := CEmpty; + + if (aLowerCase) then + begin + SetLength(f, Length(f) + 1); + f[Length(f) - 1] := RandomAlphaLower; + end; + + if (aUpperCase) then + begin + SetLength(f, Length(f) + 1); + f[Length(f) - 1] := RandomAlphaUpper; + end; + + if (aNumeric) then + begin + SetLength(f, Length(f) + 1); + f[Length(f) - 1] := RandomNum; + end; + + for i := 0 to aLength - 1 do + Result := Result + f[Random(Length(f))]; +end; + +{ Returns an integer in range >= aMin and <= aMax. } +function RandomRange(const aMin, aMax: Integer): Integer; +begin + Result := Random(aMax - aMin) + aMin; +end; + +{ Returns a random boolean. Fiddy fiddy bitch money dawg yo sup sup u down. } +function RandomBool: boolean; +begin + Result := (Random > 0.5); +end; + +{ ======= } +{ TTokens } +{ ======= } + +{ GetEnumerator implement. } +function TTokens.GetEnumerator: TTokensEnumerator; +begin + Result := TTokensEnumerator.Create(Self); +end; + +{ Returns tokens from and including token at aIndex as a string delimited by aDelimiter. } +function TTokens.FromToken(const aIndex: Integer; const aDelimiter: string): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := aIndex to FCount - 1 do + begin + if (i = aIndex) then + Result := Result + GetToken(i) + else + Result := Result + aDelimiter + GetToken(i); + end; +end; + +{ Returns tokens from start to and including token at aIndex as a string delimited by aDelimiter. } +function TTokens.ToToken(const aIndex: Integer; const aDelimiter: string): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := 0 to aIndex do + begin + if (i = 0) then + Result := Result + GetToken(i) + else + Result := Result + aDelimiter + GetToken(i); + end; +end; + +{ Adds a string to the array. } +procedure TTokens.Add(const aText: string); +begin + if (aText = CEmpty) then + Exit; + Inc(FCount); + SetLength(FTokens, FCount); + FTokens[FCount - 1] := aText; +end; + +{ Adds aKey=aVal as one string to the array. String aVal overload. } +procedure TTokens.Add(const aKey, aVal: string); +begin + Add(aKey + '=' + aVal); +end; + +{ Adds aKey=aVal as one string to the array. Integer aVal overload. } +procedure TTokens.Add(const aKey: string; const aVal: integer); +begin + Add(aKey, TextFromInt(aVal)); +end; + +{ Adds aKey=aVal as one string to the array. Boolean aVal overload. } +procedure TTokens.Add(const aKey: string; const aVal: boolean); +begin + Add(aKey, TextFromBool(aVal)); +end; + +{ Adds aKey="aVal" as one string to the array. String aVal overload. } +procedure TTokens.AddQ(const aKey, aVal: string); +begin + Add(aKey + '="' + aVal + '"'); +end; + +{ Adds aKey="aVal" as one string to the array. Integer aVal overload. } +procedure TTokens.AddQ(const aKey: string; const aVal: integer); +begin + Add(aKey + '="' + TextFromInt(aVal) + '"'); +end; + +{ Adds aKey="aVal" as one string to the array. Boolean aVal overload. } +procedure TTokens.AddQ(const aKey: string; const aVal: boolean); +begin + Add(aKey + '="' + TextFromBool(aVal) + '"'); +end; + +{ Returns all tokens in one string separated by aDelimiter. } +function TTokens.AllTokens(const aDelimiter: string): string; +var + i: Integer; +begin + Result := CEmpty; + + for i := 0 to FCount - 1 do + begin + if (i = 0) then + Result := Result + GetToken(i) + else + Result := Result + aDelimiter + GetToken(i); + end; +end; + +{ Clears all tokens. } +procedure TTokens.Clear; +begin + SetLength(FTokens, 0); + Finalize(FTokens); + FCount := 0; +end; + +{ Checks if empty. } +function TTokens.Empty: boolean; +begin + Result := (FCount = 0); +end; + +{ Returns an array of string from and including token at aFromToken to and including token at aToToken. } +function TTokens.ToArray(const aFromToken, aToToken: Integer): TArray; +var + i: Integer; +begin + if (aFromToken < 0) or (aFromToken >= FCount) or (aToToken < aFromToken) then + Exit; + + SetLength(Result, FCount - (aToToken - aFromToken)); + + for i := aFromToken to aToToken do + Result[i] := Token[i]; +end; + +{ Token getter. Get as string. } +function TTokens.GetToken(const aIndex: Integer): string; +begin + if ((aIndex < 0) or (aIndex >= FCount)) then + Result := CEmpty + else + Result := FTokens[aIndex]; +end; + +{ Pair getter. Get as TPair. } +function TTokens.GetPair(const aIndex: integer): TPair; +begin + if ((aIndex < 0) or (aIndex >= FCount)) then + begin + Result.Key := ''; + Result.Val := ''; + end + else + begin + Result.Key := TextFetchLeft(FTokens[aIndex], '=', True); + Result.Val := TextFetchRight(FTokens[aIndex], '=', True, False); + end; +end; + +{ Exchanges two items in tokens. } + +procedure TTokens.Exchange(aIndexA, aIndexB: Integer); +var + temp: string; +begin + temp := FTokens[aIndexB]; + FTokens[aIndexB] := FTokens[aIndexA]; + FTokens[aIndexA] := temp; +end; + +{ QuickSorts tokens. } +procedure TTokens.QuickSort(aStart, aEnd: Integer); +var + a: Integer; + i: Integer; + j: Integer; + p: Integer; +begin + if (FCount <= 1) then + Exit; + a := aStart; + repeat + i := a; + j := aEnd; + p := (a + aEnd) shr 1; + repeat + while (CompareText(FTokens[i], FTokens[p]) < 0) do + Inc(i); + while (CompareText(FTokens[j], FTokens[p]) > 0) do + Dec(j); + if (i <= j) then + begin + if (i <> j) then + Exchange(i, j); + if (p = i) then + p := j + else + if (p = j) then + p := i; + Inc(i); + Dec(j); + end; + until (i > j); + if (a < j) then + QuickSort(a, j); + a := i; + until (i >= aEnd); +end; + +{ Sorts the items. } +procedure TTokens.Sort; +begin + QuickSort(0, FCount - 1); +end; + +{ ================= } +{ TTokensEnumerator } +{ ================= } + +{ Constructor. } +constructor TTokensEnumerator.Create(aTokens: TTokens); +begin + inherited Create; + FIndex := - 1; + FTokens := aTokens; +end; + +{ GetCurrent implementaiton. } +function TTokensEnumerator.GetCurrent: string; +begin + Result := FTokens[FIndex]; +end; + +{ MoveNext Implementation. } +function TTokensEnumerator.MoveNext: Boolean; +begin + Result := (FIndex < FTokens.Count - 1); + if Result then + Inc(FIndex); +end; + +end. diff --git a/EvilWorks.System.SysUtils.pas b/EvilWorks.System.SysUtils.pas new file mode 100644 index 0000000..2826149 --- /dev/null +++ b/EvilWorks.System.SysUtils.pas @@ -0,0 +1,1061 @@ +// +// EvilLibrary by Vedran Vuk 2010-2012 +// +// Name: EvilWorks.System.SysUtils +// Description: Stuff I'd like to see in Delphi's SysUtils. And more. +// File last change date: October 1st. 2012 +// File version: Dev 0.0.0 +// + +unit EvilWorks.System.SysUtils; + +interface + +uses + WinApi.Windows, + WinApi.Messages, + System.SysUtils; + +{ Error retrieval } + +function GetErrorText(const aError: cardinal): string; +function GetLastErrorText: string; + +{ Dialog boxes } + +procedure ShowMessage(const aMessage: string); +procedure ShowInformation(const aInformation: string); +procedure ShowWarning(const aWarning: string); +procedure ShowError(const aError: string); +procedure ShowLastError(const aCustomMessage: string = ''); + +{ Window properties } + +function GetWindowFileName(const aWindow: HWND): string; +function GetWindowCaption(const aWindow: HWND): string; +function GetWindowClassName(const aWindow: HWND): string; +function GetWindowShowState(const aWindow: HWND): integer; +function GetWindowIcon(const aWindow: HWND; const aBigIcon: boolean = False): HICON; +function GetWindowAppIcon(const aWindow: HWND; const aBigIcon: boolean = False): HICON; +function GetWindowHeight(const aWindow: HWND): integer; +function GetWindowWidth(const aWindow: HWND): integer; +function SetWindowHeight(const aWindow: HWND; const aHeight: integer): boolean; +function SetWindowWidth(const aWindow: HWND; const aWidth: integer): boolean; +function IsWindowResizeable(const aWindow: HWND): integer; + +{ Window manipulation } + +function RestoreWindowWithoutAnimations(const aWindow: HWND): boolean; +function FindChildWindow(const aParent: HWND; const aClsName, aWndName: string; const aID: integer): HWND; +function GetFileVersion(const aFileName: string): string; + +{ Keyboard shortcut utilities } + +procedure SeparateShortcut(const aShortcut: cardinal; var aKey, aModifier: Word); +function IsKeyPressed(aKey: Word): boolean; +function IsModifierPressed(aModifier: Word): boolean; +function KeyToText(aKey: Word): string; +function ModifiersToText(aModifiers: Word): string; +function ShortcutToText(const aKey, aModifiers: Word): string; overload; +function ShortcutToText(const aShortcut: cardinal): string; overload; +function IsShortcutReserved(const aModifiers, aKey: Word): boolean; overload; +function IsShortcutReserved(const aShortcut: cardinal): boolean; overload; + +{ TODO: Sort us. } + +function NumElementsInSet(var aSet): Byte; + +function RandomRange(const aMin, aMax: integer): integer; +function RandomBool: boolean; + +function HexToText(const aHexStr: string): string; +function HexToDec(const aHexStr: string): cardinal; + +function BytesToFriendlyString(Value: Dword): string; +function BitsToFriendlyString(Value: Dword): string; + +function GetSelfFileName: string; +function GetSelfFileNameOnly: string; +function GetSelfDir: string; +function GetSelfPath: string; +function GetWindowsDir: string; +function GetWindowsPath: string; +function GetSystemDir: string; +function GetSystemPath: string; + +function RemoveExtension(const aFileName: string): string; +function ExtractFileNameOnly(const aFileName: string): string; +function ExtractFileDirOnly(const aFileName: string): string; +function ExtractLastPathElement(const aFileName: string): string; +function ExtractParentDir(const aFileName: string): string; +function ExtractParentPath(const aFileName: string): string; + +function ExpandEnvironmentVariable(const aString: string): string; +function ExpandEnvironmentVariables(const aString: string): string; + +function GetLayeredWindowAttributes( + HWND: HWND; var crKey: COLORREF; var bAlpha: byte; var dwFlags: DWORD + ): BOOL; stdcall; external user32 name 'GetLayeredWindowAttributes'; + +function SetLayeredWindowAttributes( + HWND: HWND; crKey: COLORREF; bAlpha: byte; dwFlags: DWORD + ): BOOL; stdcall; external user32 name 'SetLayeredWindowAttributes'; + +type + TOnOutput = procedure(const aOutput: string) of object; + +procedure RunConsoleApp(const aTarget, aParams, aRunIn: string; aOutputProc: TOnOutput); + +implementation + +uses + EvilWorks.System.StrUtils; + +{ Retrieves description for a specified Windows error. } +function GetErrorText(const aError: cardinal): string; +var + buffer: array [0 .. 255] of char; + flags : DWORD; +begin + FillChar(buffer, 256, #0); + flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; + FormatMessage(flags, nil, aError, 0, buffer, SizeOf(buffer), nil); + Result := TextRemoveLineFeeds(buffer); +end; + +{ Retrieves last Windows error description.} +function GetLastErrorText: string; +begin + Result := GetErrorText(WinApi.Windows.GetLastError); +end; + +{ Displays a message dialog. } +procedure ShowMessage(const aMessage: string); +begin + MessageBox(0, PChar(aMessage), PChar(GetSelfFileName), MB_OK); +end; + +{ Displays an information dialog. } +procedure ShowInformation(const aInformation: string); +begin + MessageBox(0, PChar(aInformation), PChar(GetSelfFileName), MB_ICONINFORMATION or MB_OK); +end; + +{ Displays a warning dialog. } +procedure ShowWarning(const aWarning: string); +begin + MessageBox(0, PChar(aWarning), PChar(GetSelfFileName), MB_ICONWARNING or MB_OK); +end; + +{ Displays an error dialog. } +procedure ShowError(const aError: string); +begin + MessageBox(0, PChar(aError), PChar(GetSelfFileName), MB_ICONERROR or MB_OK); +end; + +{ Displays last windows error description with optional custom message. } +procedure ShowLastError(const aCustomMessage: string = ''); +begin + if (aCustomMessage <> '') then + ShowError(aCustomMessage + #13#10#10#10 + GetLastErrorText) + else + ShowError(GetLastErrorText); +end; + +{ GetWindowModuleFilename wrapper. } +function GetWindowFileName(const aWindow: HWND): string; +var + buf: PChar; + ret: integer; +begin + Result := ''; + + buf := AllocMem(MAX_PATH + 1); + if (buf = nil) then + Exit; + try + ret := GetWindowModuleFileName(aWindow, buf, MAX_PATH); + SetString(Result, buf, ret); + finally + FreeMem(buf); + end +end; + +{ Gets window caption. } +function GetWindowCaption(const aWindow: HWND): string; +var + buf: PChar; + ret: integer; +begin + Result := ''; + + buf := AllocMem(MAX_PATH + 1); + if (buf = nil) then + Exit; + try + ret := GetWindowText(aWindow, buf, MAX_PATH); + SetString(Result, buf, ret); + finally + FreeMem(buf); + end; +end; + +{ Gets window class name. } +function GetWindowClassName(const aWindow: HWND): string; +var + buf: PChar; + ret: integer; +begin + Result := ''; + + buf := AllocMem(MAX_PATH + 1); + if (buf = nil) then + Exit; + try + ret := GetClassName(aWindow, buf, MAX_PATH); + SetString(Result, buf, ret); + finally + FreeMem(buf); + end; +end; + +{ Gets window show state (SW_SHOW, SW_MINIMIZED, SW_MAXIMIZED...). Returns -1 if function failed. } +function GetWindowShowState(const aWindow: HWND): integer; +var + winPl: TWindowPlacement; +begin + winPl.Length := SizeOf(winPl); + if (GetWindowPlacement(aWindow, winPl)) then + Result := winPl.showCmd + else + Result := - 1; +end; + +{ Tries to retrieve the icon of a aWindow. } +function GetWindowIcon(const aWindow: HWND; const aBigIcon: boolean = False): HICON; +begin + if (aBigIcon) then + Result := SendMessage(aWindow, WM_GETICON, 1, 0) + else + Result := SendMessage(aWindow, WM_GETICON, 0, 0); +end; + +{ Tries to retrieve the icon of the app that owns the aWindow. } +function GetWindowAppIcon(const aWindow: HWND; const aBigIcon: boolean = False): HICON; +begin + Result := 0; +end; + +{ Gets window Height. - 1 on error. } +function GetWindowHeight(const aWindow: HWND): integer; +var + R: TRect; +begin + if (GetWindowRect(aWindow, R)) then + Result := R.Height + else + Result := - 1; +end; + +{ Gets window Width. - 1 on error. } +function GetWindowWidth(const aWindow: HWND): integer; +var + R: TRect; +begin + if (GetWindowRect(aWindow, R)) then + Result := R.Width + else + Result := - 1; +end; + +{ Sets window Height. } +function SetWindowHeight(const aWindow: HWND; const aHeight: integer): boolean; +var + w: integer; +begin + w := GetWindowWidth(aWindow); + if (w <> - 1) then + Result := SetWindowPos(aWindow, 0, 0, 0, w, aHeight, SWP_NOMOVE or SWP_NOZORDER) + else + Result := False; +end; + +{ Gets window Width. } +function SetWindowWidth(const aWindow: HWND; const aWidth: integer): boolean; +var + h: integer; +begin + h := GetWindowHeight(aWindow); + if (h <> - 1) then + Result := SetWindowPos(aWindow, 0, 0, 0, aWidth, h, SWP_NOMOVE or SWP_NOZORDER) + else + Result := False; +end; + +{ Tries to guess if the window has a sizeable border. Returns 1 if yes, 0 if no, -1 if error occured. } +function IsWindowResizeable(const aWindow: HWND): integer; +var + gwl: longint; + sb : HWND; +begin + gwl := GetWindowLong(aWindow, GWL_STYLE); + + if (gwl = 0) then + Exit( - 1); + + if (gwl and WS_SIZEBOX <> 0) or (gwl and WS_THICKFRAME <> 0) then + Exit(1); + + sb := FindWindowEx(aWindow, 0, 'ScrollBar', nil); + if (sb = 0) then + Exit(0); + + gwl := GetWindowLong(sb, GWL_EXSTYLE); + if (gwl = 0) then + Exit( - 1); + + if (gwl and SBS_SIZEGRIP <> 0) then + Result := 1 + else + Result := 0; +end; + +{ Recursively searches a window and its children for a child window. } +function FindChildWindow(const aParent: HWND; const aClsName, aWndName: string; const aID: integer): HWND; +// ----------------------------------------------------------------------------------------------------------- +// +// Recursivy searches a window and its children for a window with a matching +// ClassName, WindowName and ControlID. Any ommited parameters to be compared are +// a match by default. If all three parameters are ommited, the first child +// found is the result. +// +// aParent: HWND - Handle of the parent window to search. +// aClassName: string - Class name of the child window to find. +// aWindowName: string - Window name of the child window to find. +// aID: integer - Dialog control ID of the child window to find. +// +// ----------------------------------------------------------------------------------------------------------- +type + TEnumChildRec = record + ClassName: string; + WindowName: string; + ControlID: integer; + ChildHandle: HWND; + end; + + PEnumChildRec = ^TEnumChildRec; + + function EnumChildProc(aHandle: HWND; aLParam: LPARAM): boolean; stdcall; + var + data : PEnumChildRec; + passClass: boolean; + passName : boolean; + passID : boolean; + begin + if (aHandle = 0) or (aLParam = 0) then + Exit(False); + + data := PEnumChildRec(aLParam); + if ((data.ClassName = '') and (data.WindowName = '') and (data.ControlID = 0)) then + begin + data^.ChildHandle := aHandle; + Exit(False); + end; + + if (data.ClassName = '') then + passClass := True + else + passClass := TextEquals(GetWindowClassName(aHandle), data^.ClassName); + + if (data.WindowName = '') then + passName := True + else + passName := TextEquals(GetWindowCaption(aHandle), data^.WindowName); + + if (data.ControlID = 0) then + passID := True + else + passID := GetDlgCtrlID(aHandle) = data.ControlID; + + if (passClass and passName and passID) then + begin + data^.ChildHandle := aHandle; + Exit(False); + end + else + begin + data^.ChildHandle := FindChildWindow(aHandle, data^.ClassName, data^.WindowName, data^.ControlID); + if (data^.ChildHandle = 0) then + Result := True + else + Result := False; + end; + end; + +var + EnumChildRec: TEnumChildRec; +begin + Result := 0; + + EnumChildRec.ClassName := aClsName; + EnumChildRec.WindowName := aWndName; + EnumChildRec.ControlID := aID; + EnumChildRec.ChildHandle := 0; + + EnumChildWindows(aParent, @EnumChildProc, LPARAM(@EnumChildRec)); + + if (EnumChildRec.ChildHandle <> 0) then + Result := EnumChildRec.ChildHandle; +end; + +{ Restores a window without window animations (if enabled). } +function RestoreWindowWithoutAnimations(const aWindow: HWND): boolean; +var + ai : TAnimationInfo; + aiTemp: TAnimationInfo; +begin + Result := False; + + FillChar(ai, SizeOf(ai), 0); + ai.cbSize := SizeOf(ai); + if (SystemParametersInfo(SPI_GETANIMATION, SizeOf(ai), @ai, 0)) then + begin + if (ai.iMinAnimate <> 0) then + begin + FillChar(aiTemp, SizeOf(aiTemp), 0); + aiTemp.cbSize := SizeOf(aiTemp); + aiTemp.iMinAnimate := 0; + SystemParametersInfo(SPI_SETANIMATION, SizeOf(aiTemp), @aiTemp, 0); + end; + + Result := ShowWindow(aWindow, SW_RESTORE); + if (ai.iMinAnimate <> 0) then + Result := Result and SystemParametersInfo(SPI_SETANIMATION, SizeOf(ai), @ai, 0); + end; +end; + +{ Gets executable file version info } +function GetFileVersion(const aFileName: string): string; +var + VerInfoSize : DWORD; + VerInfo : Pointer; + VerValueSize: DWORD; + VerValue : PVSFixedFileInfo; + Dummy : DWORD; + s : shortstring; +begin + Result := ''; + VerInfoSize := GetFileVersionInfoSize(PChar(aFileName), Dummy); + if (VerInfoSize = 0) then + Exit; + GetMem(VerInfo, VerInfoSize); + GetFileVersionInfo(PChar(aFileName), 0, VerInfoSize, VerInfo); + VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize); + with VerValue^ do + begin + Str(dwFileVersionMS shr 16, s); + Result := string(s); + Str(dwFileVersionMS and $FFFF, s); + Result := Result + '.' + string(s); + Str(dwFileVersionLS shr 16, s); + Result := Result + '.' + string(s); + Str(dwFileVersionLS and $FFFF, s); + Result := Result + '.' + string(s); + end; + FreeMem(VerInfo, VerInfoSize); +end; + +{ Separates aShortcut into aKey and aModifier parts. } +procedure SeparateShortcut(const aShortcut: cardinal; var aKey, aModifier: Word); +begin + aKey := Word(aShortcut); + aModifier := HiWord(aShortcut); +end; + +{ Checks if aKey on the keyboard is pressed. } +function IsKeyPressed(aKey: Word): boolean; +begin + Result := (GetAsyncKeyState(aKey) and (1 shl 15) <> 0); +end; + +{ Checks if keyboard modifier (MOD_SHIFT, MOD_CTRL, MOD_ALT, MOD_WIN) is pressed. } +function IsModifierPressed(aModifier: Word): boolean; +begin + Result := False; + + case aModifier of + + MOD_SHIFT: + Result := (IsKeyPressed(VK_LSHIFT) or IsKeyPressed(VK_RSHIFT) or IsKeyPressed(VK_SHIFT)); + + MOD_CONTROL: + Result := (IsKeyPressed(VK_LCONTROL) or IsKeyPressed(VK_RCONTROL) or IsKeyPressed(VK_CONTROL)); + + MOD_ALT: + Result := (IsKeyPressed(VK_LMENU) or IsKeyPressed(VK_RMENU) or IsKeyPressed(VK_MENU)); + + MOD_WIN: + Result := (IsKeyPressed(VK_LWIN) or IsKeyPressed(VK_RWIN) or IsKeyPressed(VK_APPS)); + + end; { case } +end; + +{ Returns a text representation of a keyboard key in current system locale. } +function KeyToText(aKey: Word): string; + + function LocalIsExtendedKey(Key: Word): boolean; + begin + Result := ((Key >= VK_BROWSER_BACK) and (Key <= VK_LAUNCH_APP2)) or (aKey in [VK_LWIN, VK_RWIN]); + end; + + function LocalGetExtendedVKName(aKey: Word): string; + begin + case aKey of + + VK_LWIN, VK_RWIN: + Result := 'Win'; + + VK_BROWSER_BACK: + Result := 'Browser Back'; + + VK_BROWSER_FORWARD: + Result := 'Browser Forward'; + + VK_BROWSER_REFRESH: + Result := 'Browser Refresh'; + + VK_BROWSER_STOP: + Result := 'Browser Stop'; + + VK_BROWSER_SEARCH: + Result := 'Browser Search'; + + VK_BROWSER_FAVORITES: + Result := 'Browser Favorites'; + + VK_BROWSER_HOME: + Result := 'Browser Home'; + + VK_VOLUME_MUTE: + Result := 'Volume Mute'; + + VK_VOLUME_DOWN: + Result := 'Volume Down'; + + VK_VOLUME_UP: + Result := 'Volume Up'; + + VK_MEDIA_NEXT_TRACK: + Result := 'Media Next Track'; + + VK_MEDIA_PREV_TRACK: + Result := 'Media Prev Track'; + + VK_MEDIA_STOP: + Result := 'Media Stop'; + + VK_MEDIA_PLAY_PAUSE: + Result := 'Media Play/Pause'; + + VK_LAUNCH_MAIL: + Result := 'Media Launch Mail'; + + VK_LAUNCH_MEDIA_SELECT: + Result := 'Media Sect'; + + VK_LAUNCH_APP1: + Result := 'Media Launch App 1'; + + VK_LAUNCH_APP2: + Result := 'Media Launch App 2'; + + else + Result := ''; + + end; { case } + end; + + function LocalGetVKName(aSpecial: boolean): string; + var + ScanCode: cardinal; + KeyName : array [0 .. 255] of char; + begin + Result := ''; + if (aSpecial) then + ScanCode := (MapVirtualKey(byte(aKey), 0) shl 16) or (1 shl 24) + else + ScanCode := (MapVirtualKey(byte(aKey), 0) shl 16); + + if (ScanCode <> 0) then + if (GetKeyNameText(ScanCode, KeyName, 255) <> 0) then + Result := KeyName; + + if (Length(Result) <= 1) then + if (LocalIsExtendedKey(aKey)) then + Result := LocalGetExtendedVKName(aKey); + end; + +var + KeyName: string; +begin + case byte(aKey) of + $21 .. $28, $2D, $2E: + KeyName := LocalGetVKName(True); + else + KeyName := LocalGetVKName(False); + end; + Result := KeyName; +end; + +{ Returns modifiers in a format for HotKey controls: "[Modifier1 + [Modifier2 + ]"... } +function ModifiersToText(aModifiers: Word): string; +const + SPlus = ' + '; +begin + if (aModifiers and MOD_SHIFT <> 0) then + Result := Result + KeyToText(VK_SHIFT) + SPlus; + if (aModifiers and MOD_CONTROL <> 0) then + Result := Result + KeyToText(VK_CONTROL) + SPlus; + if (aModifiers and MOD_ALT <> 0) then + Result := Result + KeyToText(VK_MENU) + SPlus; + if (aModifiers and MOD_WIN <> 0) then + Result := Result + KeyToText(VK_LWIN) + SPlus; +end; + +{ Translates a keyboard shortcut to text. } +function ShortcutToText(const aKey, aModifiers: Word): string; +begin + if (aKey = 0) and (aModifiers = 0) then + begin + Result := '(none)'; + Exit; + end; + Result := ModifiersToText(aModifiers); + Result := Result + KeyToText(aKey); +end; + +{ Translates a keyboard shortcut to text. } +function ShortcutToText(const aShortcut: cardinal): string; overload; +var + Key : Word; + Modifiers: Word; +begin + SeparateShortcut(aShortcut, Key, Modifiers); + Result := ShortcutToText(Key, Modifiers); +end; + +{ Checks if a shortcut is already registered by some application. } +function IsShortcutReserved(const aModifiers, aKey: Word): boolean; +var + tempAtom: Word; +begin + tempAtom := GlobalAddAtom(PChar('EvilWorks.HotkeyRegistrationTest')); + Result := RegisterHotKey(0, tempAtom, aModifiers, aKey); + if (Result) then + UnregisterHotKey(0, tempAtom); + GlobalDeleteAtom(tempAtom); + Result := (not Result); +end; + +{ Checks if a shortcut is already registered by some application. } +function IsShortcutReserved(const aShortcut: cardinal): boolean; +var + tempKey : Word; + tempModifiers: Word; +begin + SeparateShortcut(aShortcut, tempKey, tempModifiers); + Result := IsShortcutReserved(tempModifiers, tempKey); +end; + +{ } +function NumElementsInSet(var aSet): Byte; +var + Mask: cardinal; +begin + Mask := $80000000; + Result := 0; + while (Mask <> 0) do + begin + if ((cardinal(aSet) and Mask) <> 0) then + Inc(Result); + Mask := Mask shr 1; + end; +end; + +{ } +function RandomRange(const aMin, aMax: integer): integer; +begin + if (aMin > aMax) then + Result := Random(aMin - aMax) + aMax + else + Result := Random(aMax - aMin) + aMin; +end; + +{ } +function RandomBool: boolean; +begin + Result := (Random > 0.5); +end; + +{ } +function HexToText(const aHexStr: string): string; +const + HexChars = [#$30 .. #$39] + [#$41 .. #$46] + [#$61 .. #$66]; + HexNums = [$30 .. $39]; + HexCharsLo = [$41 .. $46]; + HexCharsHi = [$61 .. $66]; +var + InStr : ansistring; + i : integer; + Len : integer; + B : Byte; + OutByte: Byte; +begin + InStr := ansistring(aHexStr); + i := 1; + while (i <= Length(InStr)) do + begin + if (InStr[i] in HexChars = False) then + Delete(InStr, i, 1) + else + Inc(i); + end; + + Len := Length(InStr); + if (Len = 0) then + Exit; + if (Odd(Len)) then + begin + InStr := InStr + '0'; + Inc(Len); + end; + + i := 1; + while (i <= Len) do + begin + B := Byte(InStr[i + 0]); + if (B in HexNums) then + B := B - $30 + else + if (B in HexCharsLo) then + B := B - $41 + $0A + else + if (B in HexCharsHi) then + B := B - $61 + $0A; + OutByte := 16 * B; + + B := Byte(InStr[i + 1]); + if (B in HexNums) then + B := B - $30 + else + if (B in HexCharsLo) then + B := B - $41 + $0A + else + if (B in HexCharsHi) then + B := B - $61 + $0A; + OutByte := OutByte + B; + + Result := Result + Chr(OutByte); + Inc(i, 2); + end; +end; + +{ } +function HexToDec(const aHexStr: string): cardinal; +var + c: cardinal; + B: Byte; +begin + Result := 0; + if (Length(aHexStr) <> 0) then + begin + c := 1; + B := Length(aHexStr) + 1; + repeat + dec(B); + if (aHexStr[B] <= '9') then + Result := (Result + (cardinal(aHexStr[B]) - 48) * c) + else + Result := (Result + (cardinal(aHexStr[B]) - 55) * c); + + c := c * 16; + until (B = 1); + end; +end; + +{ } +function BytesToFriendlyString(Value: Dword): string; +const + OneKB = 1024; + OneMB = OneKB * 1024; + OneGB = OneMB * 1024; +begin + if Value < OneKB then + Result := FormatFloat('#,##0.00 B', Value) + else + if Value < OneMB then + Result := FormatFloat('#,##0.00 KB', Value / OneKB) + else + if Value < OneGB then + Result := FormatFloat('#,##0.00 MB', Value / OneMB) +end; + +{ } +function BitsToFriendlyString(Value: Dword): string; +const + OneKB = 1000; + OneMB = OneKB * 1000; + OneGB = OneMB * 1000; +begin + if Value < OneKB then + Result := FormatFloat('#,##0.00 bps', Value) + else + if Value < OneMB then + Result := FormatFloat('#,##0.00 Kbps', Value / OneKB) + else + if Value < OneGB then + Result := FormatFloat('#,##0.00 Mbps', Value / OneMB) +end; + +{ Returns a full path for this executable or dll. } +function GetSelfFileName: string; +var + buffer: array [0 .. MAX_PATH] of char; +begin + ZeroMemory(@buffer, Length(buffer) * SizeOf(char)); + if (GetModuleFileName(HInstance, buffer, MAX_PATH) > 0) then + Result := string(buffer) + else + Result := ''; +end; + +{ } +function GetSelfFileNameOnly: string; +begin + Result := ExtractFileNameOnly(GetSelfFileName); +end; + +{ } +function GetSelfDir: string; +begin + Result := ExtractFileDir(GetSelfFileName); +end; + +{ } +function GetSelfPath: string; +begin + Result := ExtractFilePath(GetSelfFileName); +end; + +{ } +function GetWindowsDir: string; +var + Buffer: array [0 .. MAX_PATH] of char; +begin + ZeroMemory(@Buffer, MAX_PATH + 2); + if (GetWindowsDirectory(Buffer, MAX_PATH) > 0) then + begin + Result := Buffer; + end; +end; + +{ } +function GetWindowsPath: string; +begin + Result := IncludeTrailingPathDelimiter(GetWindowsDir); +end; + +{ } +function GetSystemDir: string; +var + Buffer: array [0 .. MAX_PATH] of char; +begin + ZeroMemory(@Buffer, MAX_PATH + 2); + if (GetSystemDirectory(Buffer, MAX_PATH) > 0) then + begin + Result := Buffer; + end; +end; + +{ } +function GetSystemPath: string; +begin + Result := IncludeTrailingPathDelimiter(GetSystemDir); +end; + +{ } +function RemoveExtension(const aFileName: string): string; +var + i: integer; +begin + i := Length(aFileName); + while (i >= 1) and (aFileName[i] <> '.') do + dec(i); + if (i > 0) then + Result := TextLeft(aFileName, i - 1) + else + Result := aFileName; +end; + +{ } +function ExtractFileNameOnly(const aFileName: string): string; +begin + Result := RemoveExtension(ExtractFileName(aFileName)); +end; + +{ } +function ExtractFileDirOnly(const aFileName: string): string; +begin + +end; + +{ } +function ExtractLastPathElement(const aFileName: string): string; +var + tokens: TTokens; +begin + Result := ''; + tokens := TextTokenize(aFileName, PathDelim); + Result := tokens[tokens.Count - 1]; +end; + +{ Gets parent directory of a filesystem object (dir, path or file). } +function ExtractParentDir(const aFileName: string): string; +begin + if (TextEnds(aFileName, PathDelim)) then + Result := ExtractFileDir(aFileName); + Result := ExtractFileDir(Result); +end; + +{ Gets parent directory of a filesystem object (dir, path or file). } +function ExtractParentPath(const aFileName: string): string; +begin + Result := IncludeTrailingPathDelimiter(ExtractParentDir(aFileName)); +end; + +{ Expands an environment variable. } +function ExpandEnvironmentVariable(const aString: string): string; +var + Buffer: PChar; + Ret : cardinal; +begin + Buffer := AllocMem(MAX_PATH + 1); + if (TextEnclosed(aString, CPercent, True)) then + Ret := GetEnvironmentVariable(PChar(TextUnEnclose(aString, CPercent, True)), Buffer, MAX_PATH + 1) + else + Ret := GetEnvironmentVariable(PChar(aString), Buffer, MAX_PATH + 1); + if (Ret <> 0) then + Result := Buffer + else + Result := CEmpty; + FreeMem(Buffer, MAX_PATH + 1); +end; + +{ Expands all % enclosed environment variables in the aString. } +function ExpandEnvironmentVariables(const aString: string): string; +var + s: string; + v: string; + i: integer; +begin + s := aString; + i := 0; + while (True) do + begin + v := TextFindEnclosed(s, CPercent, i, False, True); + if (v <> CEmpty) then + s := TextReplace(s, v, ExpandEnvironmentVariable(v), True) + else + Break; + Inc(i); + end; + Result := s; +end; + +{ Runs a console application capturing its output. } +procedure RunConsoleApp(const aTarget, aParams, aRunIn: string; aOutputProc: TOnOutput); +const + READ_BUFFER_SIZE = 1024 * SizeOf(char); +var + secAttribs : TSecurityAttributes; + startupInfo: TStartUpInfo; + processInfo: TProcessInformation; + Buffer : array [0 .. READ_BUFFER_SIZE - 1] of ansichar; + readPipe : THandle; + writePipe : THandle; + bytesRead : Dword; + appRunning : Dword; + cmdLine : string; + msg : TMsg; +begin + { Create Read/Write pipes for child process. } + ZeroMemory(@secAttribs, SizeOf(secAttribs)); + secAttribs.nLength := SizeOf(secAttribs); + secAttribs.lpSecurityDescriptor := nil; + secAttribs.bInheritHandle := True; + if (CreatePipe(readPipe, writePipe, @secAttribs, 0) = False) then + Exit; + + { Create startup info. } + ZeroMemory(@startupInfo, SizeOf(startupInfo)); + startupInfo.cb := SizeOf(startupInfo); + startupInfo.hStdError := writePipe; + startupInfo.hStdOutput := writePipe; + startupInfo.hStdInput := readPipe; + startupInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW; + startupInfo.wShowWindow := SW_HIDE; + + ZeroMemory(@processInfo, SizeOf(processInfo)); + + { Format cmdLine string. } + if (TextEnclosed(aTarget, CDoubleQuote, True)) then + cmdLine := aTarget + else + cmdLine := TextQuote(aTarget); + + if (aParams <> CEmpty) then + cmdLine := TextQuote(CBackSlash + cmdLine + CSpace + aParams) + else + cmdLine := TextQuote(CBackSlash + cmdLine); + + if (CreateProcess(nil, PChar(aTarget + CSpace + aParams), @secAttribs, @secAttribs, True, NORMAL_PRIORITY_CLASS, nil, nil, startupInfo, processInfo)) then + begin + repeat + appRunning := WaitForSingleObject(processInfo.hProcess, 0); + + if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then + begin + TranslateMessage(msg); + DispatchMessage(msg); + end; + + repeat + bytesRead := 0; + PeekNamedPipe(readPipe, nil, 0, nil, @bytesRead, nil); + if (bytesRead > 0) then + begin + ReadFile(readPipe, Buffer[0], READ_BUFFER_SIZE, bytesRead, nil); + if (bytesRead <> 0) then + begin + Buffer[bytesRead] := #0; + + OemToAnsi(Buffer, Buffer); + if (bytesRead <> 0) and (Assigned(aOutputProc)) then + aOutputProc(string(Buffer)); + end; + end; + until (bytesRead = 0); + + SleepEx(1, True); + + until (appRunning <> WAIT_TIMEOUT); + + CloseHandle(processInfo.hProcess); + CloseHandle(processInfo.hThread); + end; + + CloseHandle(readPipe); + CloseHandle(writePipe); +end; + +end. diff --git a/EvilWorks.System.Xml.pas b/EvilWorks.System.Xml.pas new file mode 100644 index 0000000..f3725ab --- /dev/null +++ b/EvilWorks.System.Xml.pas @@ -0,0 +1,1026 @@ +(*============================================================================================================ + + EvilLibrary by Vedran Vuk 2010-2012 + + Name: EvilWorks.Xml + Description: Barebones Xml class. Don't expect it to follow standards. It parses XML, ok. + File last change date: August 11th. 2012 + File version: 0.0.1 + Licence: Free as in beer. + + ===========================================================================================================*) + +unit EvilWorks.System.Xml; + +interface + +uses + System.Classes, + System.SysUtils, + EvilWorks.System.StrUtils; + +const + SAttributeNotFound = 'Attribute "%s" not found.'; + SNodeNotFound = 'Node "%s" not found.'; + SMalformedXml = 'Malformed XML on line %d.'; + SCantHaveTextAndChildren = 'Node cannot have text and child nodes.'; + +type + { Exceptions } + EXml = class(Exception); + EMalformedXml = class(EXml); + EAttributeNotFound = class(EXml); + ENodeNotFound = class(EXml); + + { Forward declarations } + TXmlAttribute = class; + TXmlAttributes = class; + TXmlNode = class; + TXmlNodes = class; + TXml = class; + + { TXmlAttribute } + TXmlAttribute = class(TPersistent) + private + FOwner: TXmlAttributes; + + FName : string; + FValue: string; + procedure SetName(const aValue: string); + procedure SetValue(const aValue: string); + public + constructor Create(aOwner: TXmlAttributes); virtual; + procedure Assign(aSource: TPersistent); override; + + property Owner: TXmlAttributes read FOwner; + + property name: string read FName write SetName; + property Value: string read FValue write SetValue; + end; + + { TXmlAttributes } + TXmlAttributes = class(TPersistent) + private + FOwner: TXmlNode; + + FList: TList; + function GetCount: integer; + function GetByIndex(const aIndex: integer): TXmlAttribute; + function GetByName(const aName: string): TXmlAttribute; + procedure SetByName(const aName: string; const aValue: TXmlAttribute); + procedure SetByIndex(const aIndex: integer; const aValue: TXmlAttribute); + protected + function Add: TXmlAttribute; overload; + public + constructor Create(aOwner: TXmlNode); virtual; + destructor Destroy; override; + procedure Assign(aSource: TPersistent); override; + + property Owner: TXmlNode read FOwner; + + procedure Add(const aName, aValue: string); overload; + procedure Insert(const aName, aValue: string; const aIndex: integer); + procedure Delete(const aName: string); overload; + procedure Delete(const aIndex: integer); overload; + procedure Clear; + procedure Exchange(const aIndexA, aIndexB: integer); + procedure Move(const aFromIdx, aToIdx: integer); + function First: TXmlAttribute; + function Last: TXmlAttribute; + function Find(const aName: string): TXmlAttribute; + function IndexOf(const aName: string): integer; overload; + function IndexOf(aAttribute: TXmlAttribute): integer; overload; + function AttributeExists(const aName: string): boolean; + + property Attributes[const aName: string]: TXmlAttribute read GetByName write SetByName; + property Items[const aIndex: integer]: TXmlAttribute read GetByIndex write SetByIndex; default; + property Count: integer read GetCount; + end; + + { TXmlNode } + TXmlNode = class(TPersistent) + private + FOwner: TXmlNodes; + + FText : string; + FAttributes: TXmlAttributes; + FName : string; + FNodes : TXmlNodes; + procedure SetText(const aValue: string); + procedure SetAttributes(const aValue: TXmlAttributes); + procedure SetName(const aValue: string); + procedure SetNodes(const aValue: TXmlNodes); + public + constructor Create(aOwner: TXmlNodes); virtual; + destructor Destroy; override; + procedure Assign(aSource: TPersistent); override; + + property Owner: TXmlNodes read FOwner; + published + property Attributes: TXmlAttributes read FAttributes write SetAttributes; + property Nodes : TXmlNodes read FNodes write SetNodes; + property name : string read FName write SetName; + property Text : string read FText write SetText; + end; + + { TXmlNodes } + TXmlNodes = class(TPersistent) + private + FOwner: TXmlNode; + + FList: TList; + function GetByIndex(const aIndex: integer): TXmlNode; + function GetByName(const aName: string): TXmlNode; + function GetCount: integer; + procedure SetByIndex(const aIndex: integer; const aValue: TXmlNode); + procedure SetByName(const aName: string; const aValue: TXmlNode); + protected + function Add: TXmlNode; overload; + public + constructor Create(aOwner: TXmlNode); virtual; + destructor Destroy; override; + procedure Assign(aSource: TPersistent); override; + + property Owner: TXmlNode read FOwner; + + function Add(const aName: string; aText: string = CEmpty): TXmlNode; overload; + function Insert(const aName, aText: string; const aIndex: integer): TXmlNode; + procedure Delete(const aName: string); overload; + procedure Delete(const aIndex: integer); overload; + procedure Clear; + procedure Exchange(const aIndexA, aIndexB: integer); + procedure Move(const aFromIdx, aToIdx: integer); + function First: TXmlNode; + function Last: TXmlNode; + function Find(const aName: string): TXmlNode; + function IndexOf(const aName: string): integer; overload; + function IndexOf(aNode: TXmlNode): integer; overload; + function NodeExists(const aName: string): boolean; + + property Nodes[const aName: string]: TXmlNode read GetByName write SetByName; + property Items[const aIndex: integer]: TXmlNode read GetByIndex write SetByIndex; default; + property Count: integer read GetCount; + end; + + { TXmlHeader } + TXmlHeader = class(TPersistent) + private + FAttributes: TXmlAttributes; + procedure SetAttributes(const aValue: TXmlAttributes); + public + constructor Create; virtual; + destructor Destroy; override; + procedure Assign(aSource: TPersistent); override; + + property Attributes: TXmlAttributes read FAttributes write SetAttributes; + end; + + { TXml } + TXml = class(TPersistent) + private + FHeader : TXmlHeader; + FRoot : TXmlNode; + FIndentString: string; + procedure SetRoot(const aValue: TXmlNode); + procedure SetIndentString(const aValue: string); + procedure SetHeader(const aValue: TXmlHeader); + protected + procedure Malformed(const aLine: integer); + procedure Parse(aReader: TStreamReader); + procedure Serialize(aWriter: TStreamWriter); + public + constructor Create; virtual; + destructor Destroy; override; + procedure Assign(aSource: TPersistent); override; + + procedure Clear; + + procedure LoadFromFile(const aFileName: string); + procedure LoadFromStream(aStream: TStream); + procedure SaveToFile(const aFileName: string); + procedure SaveToStream(aStream: TStream); + + property Header: TXmlHeader read FHeader write SetHeader; + property Root: TXmlNode read FRoot write SetRoot; + property IndentString: string read FIndentString write SetIndentString; + end; + +implementation + +{ TXmlAttribute } + +constructor TXmlAttribute.Create(aOwner: TXmlAttributes); +begin + FOwner := aOwner; +end; + +procedure TXmlAttribute.Assign(aSource: TPersistent); +begin + if (aSource is TXmlAttribute) then + begin + name := TXmlAttribute(aSource).name; + Value := TXmlAttribute(aSource).Value; + end; +end; + +procedure TXmlAttribute.SetName(const aValue: string); +begin + if (FName = aValue) then + Exit; + FName := aValue; +end; + +procedure TXmlAttribute.SetValue(const aValue: string); +begin + if (FValue = aValue) then + Exit; + FValue := aValue; +end; + +{ TXmlAttributes } + +constructor TXmlAttributes.Create(aOwner: TXmlNode); +begin + FOwner := aOwner; + + FList := TList.Create; +end; + +destructor TXmlAttributes.Destroy; +begin + Clear; + FList.Free; + inherited; +end; + +procedure TXmlAttributes.Assign(aSource: TPersistent); +var + i: integer; +begin + if (aSource is TXmlAttributes) then + begin + Self.Clear; + for i := 0 to TXmlAttributes(aSource).Count - 1 do + Self.Add.Assign(TXmlAttributes(aSource).Items[i]); + end; +end; + +function TXmlAttributes.Add: TXmlAttribute; +begin + Result := TXmlAttribute.Create(Self); + FList.Add(Result); +end; + +procedure TXmlAttributes.Add(const aName, aValue: string); +begin + Insert(aName, aValue, FList.Count); +end; + +procedure TXmlAttributes.Insert(const aName, aValue: string; const aIndex: integer); +var + attr: TXmlAttribute; +begin + attr := TXmlAttribute.Create(Self); + attr.name := aName; + attr.Value := aValue; + FList.Insert(aIndex, attr); +end; + +procedure TXmlAttributes.Delete(const aName: string); +var + i: integer; +begin + i := IndexOf(aName); + if (i = - 1) then + raise EAttributeNotFound.CreateFmt(SAttributeNotFound, [aName]); + + TXmlAttribute(FList[i]).Free; + FList.Delete(i); +end; + +procedure TXmlAttributes.Delete(const aIndex: integer); +begin + TXmlAttribute(FList[aIndex]).Free; + FList.Delete(aIndex); +end; + +procedure TXmlAttributes.Clear; +var + i: integer; +begin + for i := FList.Count - 1 downto 0 do + begin + TXmlAttribute(FList[i]).Free; + FList.Delete(i); + end; +end; + +procedure TXmlAttributes.Exchange(const aIndexA, aIndexB: integer); +begin + FList.Exchange(aIndexA, aIndexB); +end; + +procedure TXmlAttributes.Move(const aFromIdx, aToIdx: integer); +begin + FList.Move(aFromIdx, aToIdx); +end; + +function TXmlAttributes.Find(const aName: string): TXmlAttribute; +var + i: integer; +begin + Result := nil; + + for i := 0 to FList.Count - 1 do + if (SameText(TXmlAttribute(FList[i]).name, aName)) then + Exit(TXmlAttribute(FList[i])); +end; + +function TXmlAttributes.IndexOf(const aName: string): integer; +var + i: integer; +begin + Result := - 1; + + for i := 0 to FList.Count - 1 do + if (SameText(TXmlAttribute(FList[i]).name, aName)) then + Exit(i); +end; + +function TXmlAttributes.AttributeExists(const aName: string): boolean; +begin + Result := (IndexOf(aName) > - 1); +end; + +function TXmlAttributes.IndexOf(aAttribute: TXmlAttribute): integer; +var + i: integer; +begin + Result := - 1; + + for i := 0 to FList.Count - 1 do + if (TXmlAttribute(FList[i]) = aAttribute) then + Exit(i); +end; + +function TXmlAttributes.First: TXmlAttribute; +begin + if (FList.Count = 0) then + Exit(nil); + + Result := TXmlAttribute(FList[0]); +end; + +function TXmlAttributes.Last: TXmlAttribute; +begin + if (FList.Count = 0) then + Exit(nil); + + Result := TXmlAttribute(FList[FList.Count - 1]); +end; + +function TXmlAttributes.GetCount: integer; +begin + Result := FList.Count; +end; + +function TXmlAttributes.GetByIndex(const aIndex: integer): TXmlAttribute; +begin + Result := TXmlAttribute(FList[aIndex]); +end; + +function TXmlAttributes.GetByName(const aName: string): TXmlAttribute; +begin + Result := Find(aName); +end; + +procedure TXmlAttributes.SetByIndex(const aIndex: integer; const aValue: TXmlAttribute); +begin + TXmlAttribute(FList[aIndex]).Assign(aValue); +end; + +procedure TXmlAttributes.SetByName(const aName: string; const aValue: TXmlAttribute); +var + attr: TXmlAttribute; +begin + attr := Find(aName); + if (attr = nil) then + raise EAttributeNotFound.CreateFmt(SAttributeNotFound, [aName]); + attr.Assign(aValue); +end; + +{ TXmlNode } + +constructor TXmlNode.Create(aOwner: TXmlNodes); +begin + FOwner := aOwner; + + FAttributes := TXmlAttributes.Create(Self); + FNodes := TXmlNodes.Create(Self); +end; + +destructor TXmlNode.Destroy; +begin + FNodes.Free; + FAttributes.Free; + inherited; +end; + +procedure TXmlNode.Assign(aSource: TPersistent); +begin + if (aSource is TXmlNode) then + begin + name := TXmlNode(aSource).name; + Text := TXmlNode(aSource).Text; + Attributes.Assign(TXmlNode(aSource).Attributes); + Nodes.Assign(TXmlNode(aSource).Nodes); + end; +end; + +procedure TXmlNode.SetAttributes(const aValue: TXmlAttributes); +begin + FAttributes.Assign(aValue); +end; + +procedure TXmlNode.SetName(const aValue: string); +begin + if (FName = aValue) then + Exit; + FName := aValue; +end; + +procedure TXmlNode.SetNodes(const aValue: TXmlNodes); +begin + FNodes.Assign(aValue); +end; + +procedure TXmlNode.SetText(const aValue: string); +begin + if (FText = aValue) then + Exit; + FText := aValue; +end; + +{ TXmlNodes } + +constructor TXmlNodes.Create(aOwner: TXmlNode); +begin + FOwner := aOwner; + + FList := TList.Create; +end; + +destructor TXmlNodes.Destroy; +begin + Clear; + FList.Free; + inherited; +end; + +procedure TXmlNodes.Assign(aSource: TPersistent); +var + i: integer; +begin + if (aSource is TXmlNodes) then + begin + Self.Clear; + for i := 0 to TXmlNodes(aSource).Count - 1 do + Self.Add.Assign(TXmlNodes(aSource).Items[i]); + end; +end; + +function TXmlNodes.Add: TXmlNode; +begin + Result := TXmlNode.Create(Self); + FList.Add(Result); +end; + +function TXmlNodes.Add(const aName: string; aText: string): TXmlNode; +begin + Result := Insert(aName, aText, FList.Count); +end; + +function TXmlNodes.Insert(const aName, aText: string; const aIndex: integer): TXmlNode; +begin + Result := TXmlNode.Create(Self); + Result.name := aName; + Result.Text := aText; + FList.Insert(aIndex, Result); +end; + +procedure TXmlNodes.Delete(const aName: string); +var + i: integer; +begin + i := IndexOf(aName); + if (i = - 1) then + raise ENodeNotFound.CreateFmt(SNodeNotFound, [aName]); + + TXmlNode(FList[i]).Free; + FList.Delete(i); +end; + +procedure TXmlNodes.Delete(const aIndex: integer); +begin + TXmlNode(FList[aIndex]).Free; + FList.Delete(aIndex); +end; + +procedure TXmlNodes.Clear; +var + i: integer; +begin + for i := FList.Count - 1 downto 0 do + begin + TXmlNode(FList[i]).Free; + FList.Delete(i); + end; +end; + +procedure TXmlNodes.Exchange(const aIndexA, aIndexB: integer); +begin + FList.Exchange(aIndexA, aIndexB); +end; + +procedure TXmlNodes.Move(const aFromIdx, aToIdx: integer); +begin + FList.Move(aFromIdx, aToIdx); +end; + +function TXmlNodes.Find(const aName: string): TXmlNode; +var + i: integer; +begin + Result := nil; + + for i := 0 to FList.Count - 1 do + if (SameText(TXmlNode(FList[i]).name, aName)) then + Exit(TXmlNode(FList[i])); +end; + +function TXmlNodes.IndexOf(const aName: string): integer; +var + i: integer; +begin + Result := - 1; + + for i := 0 to FList.Count - 1 do + if (SameText(TXmlNode(FList[i]).name, aName)) then + Exit(i); +end; + +function TXmlNodes.IndexOf(aNode: TXmlNode): integer; +var + i: integer; +begin + Result := - 1; + + for i := 0 to FList.Count - 1 do + if (TXmlNode(FList[i]) = aNode) then + Exit(i); +end; + +function TXmlNodes.NodeExists(const aName: string): boolean; +begin + Result := (IndexOf(aName) <> - 1); +end; + +function TXmlNodes.First: TXmlNode; +begin + if (FList.Count = 0) then + Exit(nil); + + Result := TXmlNode(FList[0]); +end; + +function TXmlNodes.Last: TXmlNode; +begin + if (FList.Count = 0) then + Exit(nil); + + Result := TXmlNode(FList[FList.Count - 1]); +end; + +function TXmlNodes.GetCount: integer; +begin + Result := FList.Count; +end; + +function TXmlNodes.GetByIndex(const aIndex: integer): TXmlNode; +begin + Result := TXmlNode(FList[aIndex]); +end; + +function TXmlNodes.GetByName(const aName: string): TXmlNode; +begin + Result := Find(aName); +end; + +procedure TXmlNodes.SetByIndex(const aIndex: integer; const aValue: TXmlNode); +begin + TXmlNode(FList[aIndex]).Assign(aValue); +end; + +procedure TXmlNodes.SetByName(const aName: string; const aValue: TXmlNode); +var + node: TXmlNode; +begin + node := Find(aName); + if (node = nil) then + raise ENodeNotFound.CreateFmt(SNodeNotFound, [aName]); + node.Assign(aValue); +end; + +{ TXmlHeader } + +constructor TXmlHeader.Create; +begin + FAttributes := TXmlAttributes.Create(nil); +end; + +destructor TXmlHeader.Destroy; +begin + FAttributes.Free; + inherited; +end; + +procedure TXmlHeader.Assign(aSource: TPersistent); +begin + if (aSource is TXmlHeader) then + begin + Attributes.Assign(TXmlHeader(aSource).Attributes); + end; +end; + +procedure TXmlHeader.SetAttributes(const aValue: TXmlAttributes); +begin + FAttributes.Assign(aValue); +end; + +{ TXml } + +constructor TXml.Create; +begin + FHeader := TXmlHeader.Create; + FRoot := TXmlNode.Create(nil); + FIndentString := #9; +end; + +destructor TXml.Destroy; +begin + FRoot.Free; + FHeader.Free; + inherited; +end; + +procedure TXml.Assign(aSource: TPersistent); +begin + if (aSource is TXml) then + begin + Header.Assign(TXml(aSource).Header); + Root.Assign(TXml(aSource).Root); + IndentString := TXml(aSource).IndentString; + end; +end; + +procedure TXml.Clear; +begin + Root.Nodes.Clear; + Root.Attributes.Clear; + Root.name := ''; + Root.Text := ''; +end; + +procedure TXml.Malformed(const aLine: integer); +begin + Clear; + raise EMalformedXml.CreateFmt(SMalformedXml, [aLine]); +end; + +procedure TXml.Parse(aReader: TStreamReader); +var + lineIdx: integer; + + procedure ParseAttributes(const aText: string; aAttributes: TXmlAttributes); + var + tokens: TArray; + token : string; + key : string; + Value : string; + begin + // Split into an array of attribute="value" tokens. + tokens := TextSplit(aText, CSpace, CDoubleQuote, [soCSSep, soCSQot, soQuoted]); + for token in tokens do + begin + // Skip Node name. + if (TextPos(token, CEquals, True) = 0) then + Continue; + + key := Trim(TextFetchLeft(token, CEquals, True)); + Value := Trim(TextFetchRight(token, CEquals, True)); + if (key = EmptyStr) then + Malformed(lineIdx); + if (TextEnclosed(Value, CDoubleQuote, True) = False) then + Malformed(lineIdx); + aAttributes.Add(key, TextUnquote(Value)); + end; + end; + +var + lineStr : string; + lineElements: TArray; + lineElement : string; + tempInt : integer; + tempStr : string; + currNode : TXmlNode; + tempNode : TXmlNode; + + headerExpected : boolean; + nodeTextExpected: boolean; + inComment : boolean; + inText : boolean; +begin + Clear; + lineIdx := 0; + currNode := FRoot; + + headerExpected := True; + nodeTextExpected := False; + inComment := False; + inText := False; + + while (aReader.EndOfStream = False) do + begin + lineStr := Trim(aReader.ReadLine); + Inc(lineIdx); + + // Check for multi line comment end, and remove it from lineStr. + if (inComment) then + begin + tempInt := TextPos(lineStr, '-->', True); + if (tempInt <> 0) then + begin + lineStr := TextCopy(lineStr, tempInt + 3, MaxInt); + inComment := False; + if (lineStr = CEmpty) then + Continue; + end + else + Continue; + end; + + // If there are multiple tags/texts/comments on a lineStr, split it. + lineElements := TextSplitMarkup(lineStr); + for lineElement in lineElements do + begin + if (TextEnclosed(lineElement, '<', '>', True)) then + begin + tempStr := TextUnEnclose(lineElement, '<', '>', True); + + // Check if its a header. + if (TextEnclosed(tempStr, '?xml', '?')) then + begin + if (headerExpected = False) then + Malformed(lineIdx); + + if (inText) then + Malformed(lineIdx); + + ParseAttributes(TextUnEnclose(tempStr, '?xml', '?'), FHeader.Attributes); + headerExpected := False; + end + + // Check if its a comment. + else if (TextEnclosed(tempStr, '!--', '--')) then + begin + { Skip, we wont load comments. } + Continue; + end + + // Check if its self ending tag. + else if (TextEnds(tempStr, '/', True)) then + begin + tempNode := currNode.Nodes.Add(TextFetchLeft(tempStr, CSpace, True), CEmpty); + if (tempNode.name = CEmpty) then + Malformed(lineIdx); + if (inText) then + Malformed(lineIdx); + ParseAttributes(TextUnEnclose(tempStr, '', '/', True), tempNode.Attributes); + end + + // Closing tag + else if (TextBegins(tempStr, '/', True)) then + begin + if (currNode <> FRoot) then + currNode := currNode.Owner.Owner; + if (currNode = nil) then + Malformed(lineIdx); + inText := False; + nodeTextExpected := False; + end + + // Should be an opening tag. + else + begin + if (inText) then + Malformed(lineIdx); + + if (TextPos(tempStr, CSpace, True) <> 0) then + begin + if (currNode = FRoot) and (currNode.name = EmptyStr) then + begin + FRoot.name := TextFetchLeft(tempStr, CSpace, True); + if (FRoot.name = EmptyStr) then + Malformed(lineIdx); + ParseAttributes(tempStr, FRoot.Attributes); + end + else + begin + currNode := currNode.Nodes.Add(TextFetchLeft(tempStr, CSpace, True), CEmpty); + if (currNode.name = CEmpty) then + Malformed(lineIdx); + ParseAttributes(tempStr, currNode.Attributes); + end; + end + else + begin + if (currNode = FRoot) and (currNode.name = EmptyStr) then + begin + FRoot.name := tempStr; + if (FRoot.name = EmptyStr) then + Malformed(lineIdx); + end + else + begin + currNode := currNode.Nodes.Add(tempStr, CEmpty); + if (currNode.name = CEmpty) then + Malformed(lineIdx); + end; + end; + + nodeTextExpected := True; + end; + end + else + begin + // Check for start of multi line comment. + if (TextBegins(lineElement, '