From f43e73fdc1af3d59e8df4f05d96b261e1a29cfdb Mon Sep 17 00:00:00 2001 From: Don Date: Fri, 19 Jul 2024 07:35:30 +0100 Subject: [PATCH] Add missing files. --- fpcupdeluxe.lpi | 134 +- fpcupdeluxelegacy.lpi | 16 +- fpcupdeluxereader.lpi | 100 +- fpcupdeluxespecials.lpi | 68 +- fpcupdeluxetrunk.lpi | 44 +- mORMot/CrossPlatform/SynCrossPlatform.inc | 140 + .../CrossPlatform/SynCrossPlatformCrypto.pas | 361 + mORMot/CrossPlatform/SynCrossPlatformJSON.pas | 2174 + mORMot/CrossPlatform/SynCrossPlatformREST.pas | 3808 + .../SynCrossPlatformSpecific.pas | 1218 + .../CrossPlatform/SynCrossPlatformSynLZ.pas | 261 + .../CrossPlatform/SynCrossPlatformTests.pas | 891 + .../CrossPlatform/templates/API.adoc.mustache | 186 + .../templates/CrossPlatform.pas.mustache | 309 + .../templates/Delphi.pas.mustache | 174 + .../FPC-mORMotInterfaces.pas.mustache | 87 + .../FPCServer-mORMotServer.pas.mustache | 157 + .../templates/SmartMobileStudio.pas.mustache | 361 + .../templates/Swagger.json.mustache | 395 + mORMot/SynCommons.pas | 63349 ++++++++++++++++ mORMot/SynCrtSock.pas | 13159 ++++ mORMot/SynFPCLinux.pas | 1201 + mORMot/SynFPCSock.pas | 1296 + mORMot/SynFPCSockLIBC.inc | 154 + mORMot/SynFPCTypInfo.pas | 200 + mORMot/SynWinSock.pas | 1959 + mORMot/Synopse.inc | 740 + public/gitrevision.txt | 2 +- 28 files changed, 92762 insertions(+), 182 deletions(-) create mode 100644 mORMot/CrossPlatform/SynCrossPlatform.inc create mode 100644 mORMot/CrossPlatform/SynCrossPlatformCrypto.pas create mode 100644 mORMot/CrossPlatform/SynCrossPlatformJSON.pas create mode 100644 mORMot/CrossPlatform/SynCrossPlatformREST.pas create mode 100644 mORMot/CrossPlatform/SynCrossPlatformSpecific.pas create mode 100644 mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas create mode 100644 mORMot/CrossPlatform/SynCrossPlatformTests.pas create mode 100644 mORMot/CrossPlatform/templates/API.adoc.mustache create mode 100644 mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache create mode 100644 mORMot/CrossPlatform/templates/Delphi.pas.mustache create mode 100644 mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache create mode 100644 mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache create mode 100644 mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache create mode 100644 mORMot/CrossPlatform/templates/Swagger.json.mustache create mode 100644 mORMot/SynCommons.pas create mode 100644 mORMot/SynCrtSock.pas create mode 100644 mORMot/SynFPCLinux.pas create mode 100644 mORMot/SynFPCSock.pas create mode 100644 mORMot/SynFPCSockLIBC.inc create mode 100644 mORMot/SynFPCTypInfo.pas create mode 100644 mORMot/SynWinSock.pas create mode 100644 mORMot/Synopse.inc diff --git a/fpcupdeluxe.lpi b/fpcupdeluxe.lpi index 4bc8c75e..f382e690 100644 --- a/fpcupdeluxe.lpi +++ b/fpcupdeluxe.lpi @@ -56,7 +56,7 @@ - + @@ -84,9 +84,9 @@ - + - + @@ -129,9 +129,9 @@ - + - + @@ -164,9 +164,9 @@ - + - + @@ -196,8 +196,8 @@ - - + + @@ -231,8 +231,8 @@ - - + + @@ -274,8 +274,8 @@ - - + + @@ -305,8 +305,8 @@ - - + + @@ -336,8 +336,8 @@ - - + + @@ -367,8 +367,8 @@ - - + + @@ -395,8 +395,8 @@ - - + + @@ -425,8 +425,8 @@ - - + + @@ -458,8 +458,8 @@ - - + + @@ -489,8 +489,8 @@ - - + + @@ -520,8 +520,8 @@ - - + + @@ -551,8 +551,8 @@ - - + + @@ -579,8 +579,8 @@ - - + + @@ -614,8 +614,8 @@ - - + + @@ -648,8 +648,8 @@ - - + + @@ -679,8 +679,8 @@ - - + + @@ -707,8 +707,8 @@ - - + + @@ -735,8 +735,8 @@ - - + + @@ -763,8 +763,8 @@ - - + + @@ -791,8 +791,8 @@ - - + + @@ -819,8 +819,8 @@ - - + + @@ -853,8 +853,8 @@ - - + + @@ -881,8 +881,8 @@ - - + + @@ -909,8 +909,8 @@ - - + + @@ -937,8 +937,8 @@ - - + + @@ -965,8 +965,8 @@ - - + + @@ -996,8 +996,8 @@ - - + + @@ -1030,8 +1030,8 @@ - - + + @@ -1064,8 +1064,8 @@ - - + + @@ -1186,8 +1186,8 @@ - - + + diff --git a/fpcupdeluxelegacy.lpi b/fpcupdeluxelegacy.lpi index 79eb7fa6..d7d32074 100644 --- a/fpcupdeluxelegacy.lpi +++ b/fpcupdeluxelegacy.lpi @@ -48,9 +48,9 @@ - + - + - - + + @@ -116,8 +116,8 @@ if TargetOS='openbsd' then - - + + @@ -239,8 +239,8 @@ if TargetOS='openbsd' then - - + + - + - + @@ -94,9 +94,9 @@ - + - + @@ -132,8 +132,8 @@ - - + + @@ -170,8 +170,8 @@ - - + + @@ -208,8 +208,8 @@ - - + + @@ -239,8 +239,8 @@ - - + + @@ -270,8 +270,8 @@ - - + + @@ -303,8 +303,8 @@ - - + + @@ -336,8 +336,8 @@ - - + + @@ -367,8 +367,8 @@ - - + + @@ -401,8 +401,8 @@ - - + + @@ -435,8 +435,8 @@ - - + + @@ -466,8 +466,8 @@ - - + + @@ -501,8 +501,8 @@ - - + + @@ -534,8 +534,8 @@ - - + + @@ -568,8 +568,8 @@ - - + + @@ -599,8 +599,8 @@ - - + + @@ -630,8 +630,8 @@ - - + + @@ -661,8 +661,8 @@ - - + + @@ -692,8 +692,8 @@ - - + + @@ -723,8 +723,8 @@ - - + + @@ -754,8 +754,8 @@ - - + + @@ -788,8 +788,8 @@ - - + + @@ -822,8 +822,8 @@ - - + + @@ -946,8 +946,8 @@ - - + + - + - + - - + + @@ -109,8 +109,8 @@ if TargetOS='openbsd' then - - + + @@ -140,8 +140,8 @@ if TargetOS='openbsd' then - - + + @@ -171,8 +171,8 @@ if TargetOS='openbsd' then - - + + @@ -202,8 +202,8 @@ if TargetOS='openbsd' then - - + + @@ -232,8 +232,8 @@ if TargetOS='openbsd' then - - + + @@ -267,8 +267,8 @@ if TargetOS='openbsd' then - - + + @@ -317,8 +317,8 @@ if TargetOS='openbsd' then - - + + @@ -346,8 +346,8 @@ if TargetOS='openbsd' then - - + + @@ -378,8 +378,8 @@ if TargetOS='openbsd' then - - + + @@ -419,8 +419,8 @@ if TargetOS='openbsd' then - - + + @@ -459,8 +459,8 @@ if TargetOS='openbsd' then - - + + @@ -490,8 +490,8 @@ if TargetOS='openbsd' then - - + + @@ -521,8 +521,8 @@ if TargetOS='openbsd' then - - + + @@ -552,8 +552,8 @@ if TargetOS='openbsd' then - - + + @@ -674,8 +674,8 @@ if TargetOS='openbsd' then - - + + - - + + - - + + @@ -112,8 +112,8 @@ if TargetOS='openbsd' then - - + + @@ -143,8 +143,8 @@ if TargetOS='openbsd' then - - + + @@ -174,8 +174,8 @@ if TargetOS='openbsd' then - - + + @@ -205,8 +205,8 @@ if TargetOS='openbsd' then - - + + @@ -236,8 +236,8 @@ if TargetOS='openbsd' then - - + + - - + + @@ -312,8 +312,8 @@ if TargetOS='openbsd' then - - + + @@ -343,8 +343,8 @@ if TargetOS='openbsd' then - - + + @@ -466,8 +466,8 @@ if TargetOS='openbsd' then - - + + this will change the TInvokeableVariantType.SetProperty() signature + {$define FPC_VARIANTSETVAR} + {$endif} + +{$else} + +{$ifdef DWSSCRIPT} // always defined since SMS 1.1.2 + {$define ISDWS} // e.g. for SmartMobileStudio or Delphi Web Script + {$define ISSMS} // for SmartMobileStudio +{$else} + {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer + {$ifdef NEXTGEN} + {$ZEROBASEDSTRINGS OFF} // we expect to share code among platforms + {$endif NEXTGEN} + {$ifdef UNICODE} + {$ifdef CPUX64} + {$define CPU64} + {$endif} + {$else} + {$define USEOBJECTINSTEADOFRECORD} + {$endif UNICODE} + {$ifdef VER140} + {$define ISDELPHI6} + {$endif} + {$if CompilerVersion >= 18} // Delphi 2006 or newer + {$define HASINLINE} + {$ifend} + {$if CompilerVersion >= 21.0} + {$define ISDELPHI2010} + {$ifend} + {$if CompilerVersion >= 22.0} + {$define ISDELPHIXE} + {$ifend} + {$if CompilerVersion >= 23.0} + {$define ISDELPHIXE2} // e.g. for Vcl.Graphics + {$ifndef MSWINDOWS} + {$define USETMONITOR} + {$endif} + {$ifend} + {$if CompilerVersion >= 25.0} + {$define ISDELPHIXE4} + {$ZEROBASEDSTRINGS OFF} // we expect to share code among platforms + {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints + {$ifend} + {$if CompilerVersion >= 29.0} + {$define ISDELPHIXE8} // e.g. for System.Net.HttpClient + {$ifend} + {$if CompilerVersion >= 32.0} + {$define ISDELPHI102} // e.g. for System.Net.URLClient.ResponseTimeout + {$ifend} + {$else} + {$define ISDELPHI5OROLDER} + {$define USEOBJECTINSTEADOFRECORD} + {$endif CONDITIONALEXPRESSIONS} + {$Q-} // disable overflow checking + {$R-} // disable range checking +{$endif DELPHIWEBSCRIPT} + +{$endif FPC} diff --git a/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas b/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas new file mode 100644 index 00000000..a56faa9f --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas @@ -0,0 +1,361 @@ +/// cryptographic cross-platform units +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformCrypto; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Should compile with Delphi for any platform (including NextGen for mobiles), + with FPC 2.7 or Kylix, and with SmartMobileStudio 2.1.1 + +} + +{$ifdef DWSCRIPT} // always defined since SMS 1.1.2 + {$define ISDWS} // e.g. for SmartMobileStudio or Delphi Web Script + {$define ISSMS} // for SmartMobileStudio +{$else} + {$i SynCrossPlatform.inc} // define e.g. HASINLINE +{$endif} + +interface + +{$ifdef ISDWS} +uses + SmartCL.System; +{$else} +uses + SysUtils, + Classes; +{$endif} + + +type + {$ifdef ISDWS} + hash32 = integer; + {$else} + hash32 = cardinal; + {$endif} + +var + /// table used by crc32() function + // - table content is created from code in initialization section below + {$ifdef ISDWS} + crc32tab: array of hash32; + {$else} + crc32tab: array[byte] of hash32; + {$endif} + +{$ifndef ISDWS} +/// compute the zlib/deflate crc32 hash value on a supplied buffer +function crc32(aCrc32: hash32; const buf: array of byte): hash32; +{$endif} + +/// compute the zlib/deflate crc32 hash value on a supplied ASCII-7 buffer +function crc32ascii(aCrc32: hash32; const buf: string): hash32; + +type + /// internal buffer for SHA256 hashing + TSHA256Buffer = array[0..63] of hash32; + /// internal work buffer for SHA256 hashing + TSHAHash = record + A,B,C,D,E,F,G,H: hash32; + end; + /// class for SHA256 hashing + TSHA256 = class + private + // Working hash + Hash: TSHAHash; + // 64bit msg length + MLen: integer; + // Block buffer + Buffer: TSHA256Buffer; + // Index in buffer + Index: integer; + // used by Update and Finalize + procedure Compress; + public + /// initialize SHA256 context for hashing + constructor Create; +{$ifndef ISDWS} + /// update the SHA256 context with some data + procedure Update(const buf: array of byte); overload; +{$endif} + /// update the SHA256 context with 8 bit ascii data (e.g. UTF-8) + procedure Update(const ascii: string); overload; + /// finalize and compute the resulting SHA256 hash Digest of all data + // affected to Update() method + // - returns the data as Hexadecimal + function Finalize: string; + end; + +{$ifndef ISDWS} +/// compute SHA256 hexa digest of a supplied buffer +function SHA256(const buf: array of byte): string; overload; +{$endif} + +/// compute SHA256 hexa digest of a supplied 8 bit ascii data (e.g. UTF-8) +function SHA256(const buf: string): string; overload; + + +implementation + + +{$ifdef ISDWS} +function shr0(c: hash32): hash32; inline; +begin + {$ifdef ISSMS} // circumvent DWS compiler bug + asm + @result = @c >>> 0; + end; + {$else} + result := c shr 0; + {$endif} +end; +{$else} +type // no-operation for unmanaged Delphi + shr0 = hash32; +{$endif} + +procedure InitCrc32Tab; +var i,n,crc: hash32; +begin + for i := 0 to 255 do begin + crc := i; + for n := 1 to 8 do + if (crc and 1)<>0 then + // $edb88320 from polynomial p=(0,1,2,4,5,7,8,10,11,12,16,22,23,26) + crc := shr0((crc shr 1) xor $edb88320) else + crc := crc shr 1; + {$ifndef ISSMS} + crc32tab[i] := crc; + {$else} + crc32tab.push(crc); + {$endif} + end; +end; + +function crc32ascii(aCrc32: hash32; const buf: string): hash32; +var i: integer; +begin + result := shr0(not aCRC32); + for i := 1 to length(buf) do + result := crc32tab[(result xor ord(buf[i])) and $ff] xor (result shr 8); + result := shr0(not result); +end; + +{$ifndef ISDWS} +function crc32(aCrc32: hash32; const buf: array of byte): hash32; +var i: integer; +begin + result := shr0(not aCRC32); + for i := 0 to length(buf)-1 do + result := crc32tab[(result xor buf[i]) and $ff] xor (result shr 8); + result := shr0(not result); +end; +{$endif ISDWS} + +const + K: TSHA256Buffer = ( + $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); + +procedure TSHA256.Compress; +var W: TSHA256Buffer; + H: TSHAHash; + i: integer; + t1, t2: hash32; +begin + H := Hash; + for i := 0 to 15 do + W[i]:= shr0((Buffer[i*4] shl 24)or(Buffer[i*4+1] shl 16)or + (Buffer[i*4+2] shl 8)or Buffer[i*4+3]); + for i := 16 to 63 do + W[i] := shr0((((W[i-2]shr 17)or(W[i-2]shl 15))xor((W[i-2]shr 19)or(W[i-2]shl 13)) + xor (W[i-2]shr 10))+W[i-7]+(((W[i-15]shr 7)or(W[i-15]shl 25)) + xor ((W[i-15]shr 18)or(W[i-15]shl 14))xor(W[i-15]shr 3))+W[i-16]); + for i := 0 to high(W) do begin + t1 := shr0(H.H+(((H.E shr 6)or(H.E shl 26))xor((H.E shr 11)or(H.E shl 21))xor + ((H.E shr 25)or(H.E shl 7)))+((H.E and H.F)xor(not H.E and H.G))+K[i]+W[i]); + t2 := shr0((((H.A shr 2)or(H.A shl 30))xor((H.A shr 13)or(H.A shl 19))xor + ((H.A shr 22)xor(H.A shl 10)))+((H.A and H.B)xor(H.A and H.C)xor(H.B and H.C))); + H.H := H.G; H.G := H.F; H.F := H.E; H.E := shr0(H.D+t1); + H.D := H.C; H.C := H.B; H.B := H.A; H.A := shr0(t1+t2); + end; + Hash.A := shr0(Hash.A+H.A); + Hash.B := shr0(Hash.B+H.B); + Hash.C := shr0(Hash.C+H.C); + Hash.D := shr0(Hash.D+H.D); + Hash.E := shr0(Hash.E+H.E); + Hash.F := shr0(Hash.F+H.F); + Hash.G := shr0(Hash.G+H.G); + Hash.H := shr0(Hash.H+H.H); +end; + +constructor TSHA256.Create; +begin + Hash.A := $6a09e667; + Hash.B := $bb67ae85; + Hash.C := $3c6ef372; + Hash.D := $a54ff53a; + Hash.E := $510e527f; + Hash.F := $9b05688c; + Hash.G := $1f83d9ab; + Hash.H := $5be0cd19; +end; + +{$ifndef ISDWS} +procedure TSHA256.Update(const buf: array of byte); +var Len, aLen, i: integer; + DataNdx: integer; +begin + Len := length(buf); + DataNdx := 0; + inc(MLen,Len shl 3); + while Len>0 do begin + aLen := 64-Index; + if aLen<=Len then begin + for i := 0 to aLen-1 do + Buffer[Index+i] := buf[DataNdx+i]; + dec(Len,aLen); + inc(DataNdx,aLen); + Compress; + Index:= 0; + end else begin + for i := 0 to Len-1 do + Buffer[Index+i] := buf[DataNdx+i]; + inc(Index,Len); + break; + end; + end; +end; +{$endif ISDWS} + +procedure TSHA256.Update(const ascii: string); +var Len, aLen, i: integer; + DataNdx: integer; +begin + Len := length(ascii); + DataNdx := 1; + inc(MLen,Len shl 3); + while Len>0 do begin + aLen := 64-Index; + if aLen<=Len then begin + for i := 0 to aLen-1 do + Buffer[Index+i] := ord(ascii[DataNdx+i]); + dec(Len,aLen); + inc(DataNdx,aLen); + Compress; + Index:= 0; + end else begin + for i := 0 to Len-1 do + Buffer[Index+i] := ord(ascii[DataNdx+i]); + inc(Index,Len); + break; + end; + end; +end; + +function TSHA256.Finalize: string; +var i: integer; +begin + // Message padding + // 1. append bit '1' after Buffer + Buffer[Index]:= $80; + for i := Index+1 to 63 do + Buffer[i] := 0; + // 2. Compress if more than 448 bits, (no room for 64 bit length) + if Index>=56 then begin + Compress; + for i := 0 to 59 do + Buffer[i] := 0; + end; + // Write 64 bit Buffer length into the last bits of the last block + // (in big endian format) and do a final compress + Buffer[60] := (MLen and $ff000000)shr 24; + Buffer[61] := (MLen and $ff0000)shr 16; + Buffer[62] := (MLen and $ff00)shr 8; + Buffer[63] := MLen and $ff; + Compress; + // Hash -> Digest to big endian format + result := LowerCase(IntToHex(Hash.A,8)+IntToHex(Hash.B,8)+IntToHex(Hash.C,8)+ + IntToHex(Hash.D,8)+IntToHex(Hash.E,8)+IntToHex(Hash.F,8)+IntToHex(Hash.G,8)+ + IntToHex(Hash.H,8)); +end; + +{$ifndef ISDWS} +function SHA256(const buf: array of byte): string; +var SHA: TSHA256; +begin + SHA := TSHA256.Create; + try + SHA.Update(buf); + result := SHA.Finalize; + finally + SHA.Free; + end; +end; +{$endif} + +function SHA256(const buf: string): string; +var SHA: TSHA256; +begin + SHA := TSHA256.Create; + try + SHA.Update(buf); + result := SHA.Finalize; + finally + SHA.Free; + end; +end; + +initialization + InitCrc32Tab; +end. diff --git a/mORMot/CrossPlatform/SynCrossPlatformJSON.pas b/mORMot/CrossPlatform/SynCrossPlatformJSON.pas new file mode 100644 index 00000000..e7835081 --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformJSON.pas @@ -0,0 +1,2174 @@ +/// minimum standand-alone cross-platform JSON process using variants +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformJSON; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Witya + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Should compile with Delphi for any platform (including NextGen for mobiles), + with FPC 2.7 or Kylix, and with SmartMobileStudio 2+ + - FPC prior to 2.7.1 has some issues with working with variants: UTF-8 + encoding is sometimes lost, and TInvokeableVariantType.SetProperty is broken + +} + +{$i SynCrossPlatform.inc} // define e.g. HASINLINE + +interface + +uses + SysUtils, + Classes, +{$ifdef NEXTGEN} + System.Generics.Collections, +{$endif} +{$ifndef NEXTGEN} + Contnrs, +{$endif} + Variants, + TypInfo; + +type + TStringDynArray = array of string; + TVariantDynArray = array of variant; + TIntegerDynArray = array of integer; + + /// this type is used to store BLOB content + TByteDynArray = array of byte; + PByteDynArray = ^TByteDynArray; + + {$ifdef FPC} + NativeInt = PtrInt; + NativeUInt = PtrUInt; + {$else} + {$ifndef ISDELPHI2010} // Delphi 2009 NativeUInt is buggy + NativeInt = integer; + NativeUInt = cardinal; + {$endif} + {$ifndef UNICODE} + RawByteString = AnsiString; + {$endif} + {$endif} + + // this type will store UTF-8 encoded buffer (also on NextGen platform) + {$ifdef NEXTGEN} + TUTF8Buffer = TBytes; + // TObjecTList is not defined in Mobile platforms + TObjectList = TObjectList; + {$else} + TUTF8Buffer = UTF8String; + {$endif} + + /// exception used during standand-alone cross-platform JSON process + EJSONException = class(Exception); + + /// which kind of document the TJSONVariantData contains + TJSONVariantKind = (jvUndefined, jvObject, jvArray); + + PJSONVariantData = ^TJSONVariantData; + + {$A-} + /// stores any JSON object or array as variant + // - this structure is not very optimized for speed or memory use, but is + // simple and strong enough for our client-side purpose + // - it is in fact already faster (and using less memory) than DBXJSON and + // SuperObject / XSuperObject libraries - of course, mORMot's TDocVariant + // is faster, as dwsJSON is in some cases, but those are not cross-platform + {$ifdef USEOBJECTINSTEADOFRECORD} + TJSONVariantData = object + protected + {$else} + TJSONVariantData = record + private + {$endif} + VType: TVarType; + _Align: byte; + VKind: TJSONVariantKind; + VCount: integer; + function GetKind: TJSONVariantKind; + function GetCount: integer; + function GetVarData(const aName: string; var Dest: TVarData): boolean; + function GetValue(const aName: string): variant; + function GetValueCopy(const aName: string): variant; + procedure SetValue(const aName: string; const aValue: variant); + function GetItem(aIndex: integer): variant; + procedure SetItem(aIndex: integer; const aItem: variant); + public + /// names of this jvObject + Names: TStringDynArray; + /// values of this jvObject or jvArray + Values: TVariantDynArray; + /// initialize the low-level memory structure + // - you should call Clear before calling overloaded Init several times + procedure Init; overload; + /// initialize the low-level memory structure with a given JSON content + // - you should call Clear before calling overloaded Init several times + procedure Init(const JSON: string); overload; + /// initialize the low-level memory structure with a given array of variant + // - you should call Clear before calling overloaded Init several times + procedure InitFrom(const aValues: TVariantDynArray); overload; + /// delete all internal stored data + // - basically the same as Finalize(aJsonVariantData) + aJsonVariantData.Init + // - you should call this method before calling overloaded Init several times + procedure Clear; + /// access to a nested TJSONVariantData item + // - returns nil if aName was not found, or not a true TJSONVariantData item + function Data(const aName: string): PJSONVariantData; + {$ifdef HASINLINE}inline;{$endif} + /// access to a nested TJSONVariantData item, creating it if necessary + // - aPath can be specified with any depth, e.g. 'level1.level2.level3' + // - if the item does not exist or is not a true TJSONVariantData, a new + // one will be created, and returned as pointer + function EnsureData(const aPath: string): PJSONVariantData; + /// add a void TJSONVariantData to the jvArray and return a pointer to it + function AddItem: PJSONVariantData; + /// add a value to the jvArray + // - raise a ESJONException if the instance is a jvObject + procedure AddValue(const aValue: variant); + /// add a name/value pair to the jvObject + // - raise a ESJONException if the instance is a jvArray + procedure AddNameValue(const aName: string; const aValue: variant); + /// search for a name in this jvObject + function NameIndex(const aName: string): integer; + /// set a value of this jvObject to a given path + // - aPath can be specified with any depth, e.g. 'level1.level2.level3' + procedure SetPath(const aPath: string; const aValue: variant); + /// fill this document from a JSON array or object + function FromJSON(const JSON: string): boolean; + /// convert this document into JSON array or object + function ToJSON: string; + /// fill the published properties of supplied class from this JSON object + function ToObject(Instance: TObject): boolean; + /// create an instance, and fill its published properties from this JSON object + // - it should contain some "ClassName" properties, i.e. JSON should have + // been created by ObjectToJSON(Instance,true) and the class should have + // been registered with RegisterClassForJSON() + function ToNewObject: TObject; + /// kind of document this TJSONVariantData contains + // - returns jvUndefined if this instance is not a TJSONVariant custom variant + property Kind: TJSONVariantKind read GetKind; + /// number of items in this jvObject or jvArray + // - returns 0 if this instance is not a TJSONVariant custom variant + property Count: integer read GetCount; + /// access by name to a value of this jvObject + // - value is returned as (varVariant or varByRef) for best speed + // - will return UnAssigned if aName is not correct or this is not a jvObject + property Value[const aName: string]: variant read GetValue write SetValue; default; + /// access by name to a value of this jvObject + // - value is returned as a true copy (not varByRef) so this property is + // slower but safer than Value[], if the owning TJsonVariantData disappears + // - will return UnAssigned if aName is not correct or this is not a jvObject + property ValueCopy[const aName: string]: variant read GetValueCopy; + /// access by index to a value of this jvArray + // - will return UnAssigned if aIndex is not correct or this is not a jvArray + property Item[aIndex: integer]: variant read GetItem write SetItem; + end; + {$A+} + + /// low-level class used to register TJSONVariantData as custom type + // - allows late binding to values, e.g. + // ! jsonvar.avalue := jsonvar.avalue+1; + // - due to an issue with FPC implementation, you can only read properties, + // not set them, so you should write: + // ! TJSONVariantData(jsonvar)['avalue'] := jsonvar.avalue+1; + TJSONVariant = class(TInvokeableVariantType) + protected + {$ifndef FPC} + {$ifndef ISDELPHI6} + function FixupIdent(const AText: string): string; override; + {$endif} + {$endif} + public + procedure Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); override; + procedure Clear(var V: TVarData); override; + function GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; override; + {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 + function SetProperty(var V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + {$else} + function SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + {$endif} + procedure Cast(var Dest: TVarData; const Source: TVarData); override; + procedure CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); override; + end; + + /// handle a JSON result table, as returned by mORMot's server + // - handle both expanded and non expanded layout + // - will be used e.g. on client side for variant-based ORM data parsing + TJSONTable = class + protected + fJSON: string; + fFieldNames: TStringDynArray; + fJSONExpanded: boolean; + fJSONIndexFirstValue: integer; + fJSONCurrentIndex: integer; + fRowValues: TVariantDynArray; + function Get(const FieldName: string): variant; + public + /// parse the supplied JSON content + constructor Create(const aJSON: string); + /// case-insensitive search for a field name + function FieldIndex(const FieldName: string): integer; + /// to be called in a loop to iterate through all data rows + // - if returned true, Value[] contains the fields of this row + function Step(SeekFirst: boolean=false): boolean; + /// to be called in a loop to iterate through all data rows + // - if returned true, RowValues contains this row as TJSONVariant + function StepValue(var RowValues: variant; SeekFirst: boolean=false): boolean; + /// after Step() returned true, can be used to retrieve a field value by name + property Value[const FieldName: string]: variant read Get; default; + /// after Step() returned true, can be used to retrieve a field value by index + property RowValues: TVariantDynArray read fRowValues; + /// the recognized field names + property FieldNames: TStringDynArray read fFieldNames; + /// the associated JSON content + property JSON: string read fJSON; + end; + + /// an abstract type used for RTTI type information + TRTTITypeInfo = PPropInfo; + + /// an abstract type used for RTTI property information + TRTTIPropInfo = PPropInfo; + + TRTTIPropInfoDynArray = array of TRTTIPropInfo; + + /// handle a JSON result table, as returned by mORMot's server + // - handle both expanded and non expanded layout + // - this class is able to use RTTI to fill all published properties of + // a TObject + TJSONTableObject = class(TJSONTable) + protected + fTypeInfo: pointer; + fPropInfo: array of TRTTIPropInfo; + procedure FillPropInfo(aTypeInfo: TRTTITypeInfo); virtual; + procedure FillInstance(Instance: TObject); virtual; + function GetPropInfo(aTypeInfo: TRTTITypeInfo; const PropName: string): TRTTIPropInfo; virtual; + public + /// to be called in a loop to iterate through all data rows + // - if returned true, Object published properties will contain this row + function StepObject(Instance: TObject; SeekFirst: boolean=false): boolean; virtual; + end; + + /// used e.g. by TSynTest for each test case + TPublishedMethod = record + Name: string; + Method: TMethod; + end; + /// as filled by GetPublishedMethods() + TPublishedMethodDynArray = array of TPublishedMethod; + + +/// create a TJSONVariant instance from a given JSON content +// - typical usage may be: +//! var doc: variant; +//! json: string; +//! begin +//! doc := JSONVariant('{"test":1234,"name":"Joh\"n\r"}'); +//! assert(doc.test=1234); // access via late binding +//! assert(doc.name='Joh"n'#13); +//! assert(doc.name2=null); // unknown properties returns null +//! json := doc; // to convert a TJSONVariant to JSON, just assign to a string +//! assert(json='{"test":1234,"name":"Joh\"n\r"}'); +//! end; +// - note that FPC does not allow to set values by late-binding +function JSONVariant(const JSON: string): variant; overload; + +/// create a TJSONVariant TJSONVariant array from a supplied array of values +function JSONVariant(const values: TVariantDynArray): variant; overload; + +/// create a TJSONVariant TJSONVariant array from a supplied array of values +function JSONVariantFromConst(const constValues: array of variant): variant; + +/// access to a TJSONVariant instance members +// - e.g. Kind, Count, Names[] or Values[] +// - will raise an exception if the supplied variant is not a TJSONVariant +// - this function is safer than TJSONVariant(JSONVariant) +function JSONVariantData(const JSONVariant: variant): PJSONVariantData; + +/// access to a TJSONVariant instance members +// - e.g. Kind, Count, Names[] or Values[] +// - will return a read-only fake TJSONVariant with Kind=jvUndefined if the +// supplied variant is not a TJSONVariant +// - if ExpectedKind is jvArray of jvObject, it would return a fake TJSONVariant +// with Kind=jvUndefined if the JSONVariant kind does not match - so you can write: +// !var _a: integer; +// ! _arr: PJSONVariantData; +// !... +// ! _arr := JSONVariantDataSafe(_variant,jvArray); +// ! SetLength(result,_arr.Count); +// ! for _a := 0 to _arr.Count-1 do +// ! result[_a] := _arr.Values[_a]; +// in the above code, _arr.Count will be 0 if _variant.Kind<>jvArray +// - this function is safer than TJSONVariant(JSONVariant) +function JSONVariantDataSafe(const JSONVariant: variant; + ExpectedKind: TJSONVariantKind=jvUndefined): PJSONVariantData; + +var + /// the custom variant type definition registered for TJSONVariant + JSONVariantType: TInvokeableVariantType; + + +/// compute the quoted JSON string corresponding to the supplied text +function StringToJSON(const Text: string): string; + +/// compute the JSON representation of a floating-point value +procedure DoubleToJSON(Value: double; var result: string); + +/// compute the ISO-8601 JSON text representation of a date/time value +// - e.g. "YYYY-MM-DD" "Thh:mm:ss" or "YYYY-MM-DDThh:mm:ss" +// - if Date is 0, will return "" +function DateTimeToJSON(Value: TDateTime): string; + +/// compute the JSON representation of a variant value +// - will work for simple types, or TJSONVariant object or array +function ValueToJSON(const Value: variant): string; + +/// compute a variant from its JSON representation +// - will work for simple types, or TJSONVariant object or array +function JSONToValue(const JSON: string): variant; + +/// compute the ISO-8601 JSON text representation of the current date/time value +// - e.g. "2015-06-27T20:59:29" +function NowToIso8601: string; + +/// compute the unquoted ISO-8601 text representation of a date/time value +// - e.g. 'YYYY-MM-DD' 'Thh:mm:ss' or 'YYYY-MM-DDThh:mm:ss' +// - if Date is 0, will return '' +function DateTimeToIso8601(Value: TDateTime): string; + +/// convert unquoted ISO-8601 text representation into a date/time value +// - e.g. 'YYYY-MM-DD' 'Thh:mm:ss' or 'YYYY-MM-DDThh:mm:ss' +function Iso8601ToDateTime(const Value: string): TDateTime; + +/// compute the JSON representation of an object published properties +// - handle only simple types of properties, not nested class instances +// - any TList/TObjectList/TCollection will be serialized as JSON array +function ObjectToJSON(Instance: TObject; StoreClassName: boolean=false): string; + +/// fill an object published properties from the supplied JSON object +// - handle only simple types of properties, not nested class instances +function JSONToObject(Instance: TObject; const JSON: string): boolean; + +/// create a new object and fil its published properties from the supplied +// JSON object, which should include "ClassName":"..." properties +// - JSON should have been created with ObjectToJSON(Instance,true) and +// the class should have been registered with RegisterClassForJSON() +function JSONToNewObject(const JSON: string): pointer; + +/// register the class types to be created from its name +// - used e.g. by JSONToNewObject() or TJSONVariantData.ToNewObject +procedure RegisterClassForJSON(const Classes: array of TClass); + +/// create a class instance from its name +// - the class should have been registered previously via RegisterClassForJSON() +// - if the supplied class name is not found, will return nil +function CreateClassForJSON(const ClassName: string): TObject; + +/// create a list of object published properties from the supplied JSON object +// - handle only simple types of properties, not nested class instances +function JSONToObjectList(ItemClass: TClass; const JSON: string): TObjectList; + +/// return a string corresponding to the type name, as stored in the RTTI +// - e.g. 'TDateTime', 'TByteDynArray', 'TModTime', 'TCreateTime' +function RTTIPropInfoTypeName(PropInfo: TRTTIPropInfo): string; + +/// retrieve the published properties type information about a given class +procedure GetPropsInfo(TypeInfo: TRTTITypeInfo; var PropNames: TStringDynArray; + var PropRTTI: TRTTIPropInfoDynArray); + +/// retrieve the value of a published property as variant +function GetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo; StoreClassName: boolean = False): variant; + +/// set the value of a published property from a variant +procedure SetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo; + const Value: variant); + +/// retrieve all the published methods of a given class, using RTTI +procedure GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodDynArray); + +/// convert an "array of const" parameter value into its string representation +function VarRecToValue(const V: TVarRec; out wasString: boolean): string; + +/// convert the supplied text as "text", as expected by SQL standard +procedure DoubleQuoteStr(var text: string); + +/// decode a Base64-encoded string +// - default withBase64Magic=TRUE will expect the string to start with our +// JSON_BASE64_MAGIC marker +function Base64JSONStringToBytes(const JSONString: string; + var Bytes: TByteDynArray; withBase64Magic: boolean=true): boolean; + +/// Base-64 encode a BLOB into string +// - default withBase64Magic=TRUE will include our JSON_BASE64_MAGIC marker +function BytesToBase64JSONString(const Bytes: TByteDynArray; + withBase64Magic: boolean=true): string; + +const + /// special code to mark Base64 binary content in JSON string + // - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes + // - prior to Delphi 2009, it won't work as expected since U+FFF0 won't be + // able to be converted into U+FFF0 + {$ifdef UNICODE} + JSON_BASE64_MAGIC: word = $fff0; + {$else} + JSON_BASE64_MAGIC: array[0..2] of byte = ($ef,$bf,$b0); + {$endif} + + /// size, in platform chars, of our special code to mark Base64 binary + // content in JSON string + // - equals 1 since Delphi 2009 (UTF-16 encoded), or 3 for older versions + // (UTF-8encoded) of the compiler compiler + JSON_BASE64_MAGIC_LEN = sizeof(JSON_BASE64_MAGIC) div sizeof(char); + +{$ifndef ISSMS} +/// read an UTF-8 (JSON) file into a native string +// - file should be existing, otherwise an exception is raised +function UTF8FileToString(const aFileName: TFileName): string; +{$endif} + +/// this function is faster than str := str+chr ! +procedure AppendChar(var str: string; chr: Char); + {$ifdef HASINLINE}inline;{$endif} + +/// check that two ASCII-7 latin text do match +function IdemPropName(const PropName1,PropName2: string): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// check that two ASCII-7 latin text do match +// - first parameter is expected to be a shortstring low-level buffer - as such, +// this overloaded function would work with NEXTGEN encoded RTTI +function IdemPropName(PropName1: PByteArray; const PropName2: string): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert ASCII-7 latin text, encoded as a shortstring buffer, into a string +// - as such, this function would work with NEXTGEN encoded RTTI +function ShortStringToString(Buffer: PByteArray): string; + +/// check that two ASCII-7 latin text do match +function StartWithPropName(const PropName1,PropName2: string): boolean; + + +implementation + +function IdemPropName(const PropName1,PropName2: string): boolean; +var L,i: integer; +begin + result := false; + L := length(PropName2); + if length(PropName1)<>L then + exit; + for i := 1 to L do + if (ord(PropName1[i]) xor ord(PropName2[i])) and + {$ifdef UNICODE}$ffdf{$else}$df{$endif}<>0 then + exit; + result := true; +end; + +function ShortStringToString(Buffer: PByteArray): string; +{$ifdef UNICODE} +var i: integer; +begin + SetLength(result,Buffer^[0]); + for i := 1 to Buffer^[0] do + result[i] := chr(Buffer^[i]); +end; +{$else} +begin + SetString(result,PAnsiChar(@Buffer^[1]),Buffer^[0]); +end; +{$endif} + +function IdemPropName(PropName1: PByteArray; const PropName2: string): boolean; +var L,i: integer; +begin + result := false; + L := length(PropName2); + if PropName1^[0]<>L then + exit; + for i := 1 to L do + if (PropName1^[i] xor ord(PropName2[i])) and + {$ifdef UNICODE}$ffdf{$else}$df{$endif}<>0 then + exit; + result := true; +end; + +function StartWithPropName(const PropName1,PropName2: string): boolean; +var L,i: integer; +begin + result := false; + L := length(PropName2); + if length(PropName1)0 then + exit; + result := true; +end; + +{$ifndef ISSMS} // there is no file within HTML5 DOM + +{$ifdef FPC} +// assume string is UTF-8 encoded (as with Lazarus/LCL) +// note that when working with variants, FPC 2.7.1 sometimes clear the code page +type UTF8ToString = RawByteString; +{$else} +{$ifndef UNICODE} +function UTF8ToString(const utf8: TUTF8Buffer): string; +begin + result := UTF8ToAnsi(utf8); +end; +{$endif} +{$endif} + +function UTF8FileToString(const aFileName: TFileName): string; +var F: TFileStream; + len: integer; + utf8: TUTF8Buffer; +begin + F := TFileStream.Create(aFileName,fmOpenRead); + try + len := F.Size; + SetLength(utf8,len); + {$ifdef NEXTGEN} + F.Read(utf8[0],len); + result := TEncoding.UTF8.GetString(utf8); + {$else} + F.Read(utf8[1],len); + result := UTF8ToString(utf8); + {$endif} + finally + F.Free; + end; +end; +{$endif} + +function JSONVariant(const JSON: string): variant; +begin + VarClear(result); + TJSONVariantData(result).FromJSON(JSON); +end; + +function JSONVariant(const values: TVariantDynArray): variant; +begin + VarClear(result); + TJSONVariantData(result).Init; + TJSONVariantData(result).VKind := jvArray; + TJSONVariantData(result).VCount := length(values); + TJSONVariantData(result).Values := values; +end; + +function JSONVariantFromConst(const constValues: array of variant): variant; +var i: integer; +begin + VarClear(result); + with TJSONVariantData(result) do begin + Init; + VKind := jvArray; + VCount := length(values); + SetLength(Values,VCount); + for i := 0 to VCount-1 do + Values[i] := constValues[i]; + end; +end; + +function JSONVariantData(const JSONVariant: variant): PJSONVariantData; +begin + with TVarData(JSONVariant) do + if VType=JSONVariantType.VarType then + result := @JSONVariant else + if VType=varByRef or varVariant then + result := JSONVariantData(PVariant(VPointer)^) else + raise EJSONException.CreateFmt('JSONVariantData.Data(%d<>JSONVariant)',[VType]); +end; + +const // will be in code section of the exe, so will be read-only by design + JSONVariantDataFake: TJSONVariantData = (); + +function JSONVariantDataSafe(const JSONVariant: variant; + ExpectedKind: TJSONVariantKind=jvUndefined): PJSONVariantData; +begin + with TVarData(JSONVariant) do + if VType=JSONVariantType.VarType then + if (ExpectedKind=jvUndefined) or + (TJSONVariantData(JSONVariant).VKind=ExpectedKind) then + result := @JSONVariant else + result := @JSONVariantDataFake else + if VType=varByRef or varVariant then + result := JSONVariantDataSafe(PVariant(VPointer)^) else + result := @JSONVariantDataFake; +end; + +procedure AppendChar(var str: string; chr: Char); +{$ifdef ISSMS} // JavaScript immutable strings +begin + str := str+chr +end; +{$else} +var len: Integer; +begin // str := str+chr would have created a temporary string for chr + len := length(str); + SetLength(str,len+1); + PChar(pointer(str))[len] := chr; // SetLength() made str unique +end; +{$endif} + +function StringToJSON(const Text: string): string; +var len,j: integer; + procedure DoEscape; + var i: Integer; + begin + result := '"'+copy(Text,1,j-1); // here FPC 2.7.1 erases UTF-8 encoding + for i := j to len do begin + case Text[i] of + #8: result := result+'\b'; + #9: result := result+'\t'; + #10: result := result+'\n'; + #12: result := result+'\f'; + #13: result := result+'\r'; + '\': result := result+'\\'; + '"': result := result+'\"'; + else + if Text[i]<' ' then + result := result+'\u00'+IntToHex(ord(Text[i]),2) else + AppendChar(result,Text[i]); // will be UTF-8 encoded later + end; + end; + AppendChar(result,'"'); + end; +begin + len := length(Text); + for j := 1 to len do + case Text[j] of + #0..#31,'\','"': begin + DoEscape; + exit; + end; + end; + // if we reached here, no character needs to be escaped in this string + result := '"'+Text+'"'; // here FPC 2.7.1 erases UTF-8 encoding :( +end; + +{$ifdef KYLIX} + {$define NOFORMATSETTINGS} +{$endif} +{$ifdef ISDELPHI6} + {$define NOFORMATSETTINGS} +{$endif} + +{$ifdef NOFORMATSETTINGS} +procedure DoubleToJSON(Value: double; var result: string); +var decsep: Char; +begin // warning: this is NOT thread-safe if you mix settings + decsep := DecimalSeparator; + result := FloatToStr(Value); + DecimalSeparator := decsep; +end; +{$else} +var + SettingsUS: TFormatSettings + {$ifdef FPC} = ( + CurrencyFormat: 1; + NegCurrFormat: 5; + ThousandSeparator: ','; + DecimalSeparator: '.'; + CurrencyDecimals: 2; + DateSeparator: '-'; + TimeSeparator: ':'; + ListSeparator: ','; + CurrencyString: '$'; + ShortDateFormat: 'd/m/y'; + LongDateFormat: 'dd" "mmmm" "yyyy'; + TimeAMString: 'AM'; + TimePMString: 'PM'; + ShortTimeFormat: 'hh:nn'; + LongTimeFormat: 'hh:nn:ss'; + ShortMonthNames: ('Jan','Feb','Mar','Apr','May','Jun', + 'Jul','Aug','Sep','Oct','Nov','Dec'); + LongMonthNames: ('January','February','March','April','May','June', + 'July','August','September','October','November','December'); + ShortDayNames: ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); + LongDayNames: ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'); + TwoDigitYearCenturyWindow: 50;) + {$endif}; +procedure DoubleToJSON(Value: double; var result: string); +begin + result := FloatToStr(Value,SettingsUS); +end; +{$endif} + +function DateTimeToJSON(Value: TDateTime): string; +begin // e.g. "YYYY-MM-DD" "Thh:mm:ss" or "YYYY-MM-DDThh:mm:ss" + result := '"'+DateTimeToIso8601(Value)+'"'; +end; + +function NowToIso8601: string; +begin + result := DateTimeToIso8601(Now); +end; + +function DateTimeToIso8601(Value: TDateTime): string; +begin // e.g. YYYY-MM-DD Thh:mm:ss or YYYY-MM-DDThh:mm:ss + if Value=0 then + result := '' else + if frac(Value)=0 then + result := FormatDateTime('yyyy"-"mm"-"dd',Value) else + if trunc(Value)=0 then + result := FormatDateTime('"T"hh":"nn":"ss',Value) else + result := FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss',Value); +end; + +function Iso8601ToDateTime(const Value: string): TDateTime; +var Y,M,D, HH,MI,SS: cardinal; +begin // YYYY-MM-DD Thh:mm:ss or YYYY-MM-DDThh:mm:ss + // 1234567890 123456789 1234567890123456789 + result := 0; + case Length(Value) of + 9: if (Value[1]='T') and (Value[4]=':') and (Value[7]=':') then begin + HH := ord(Value[2])*10+ord(Value[3])-(48+480); + MI := ord(Value[5])*10+ord(Value[6])-(48+480); + SS := ord(Value[8])*10+ord(Value[9])-(48+480); + if (HH<24) and (MI<60) and (SS<60) then + result := EncodeTime(HH,MI,SS,0); + end; + 10: if (Value[5]=Value[8]) and (ord(Value[8]) in [ord('-'),ord('/')]) then begin + Y := ord(Value[1])*1000+ord(Value[2])*100+ + ord(Value[3])*10+ord(Value[4])-(48+480+4800+48000); + M := ord(Value[6])*10+ord(Value[7])-(48+480); + D := ord(Value[9])*10+ord(Value[10])-(48+480); + if (Y<=9999) and ((M-1)<12) and ((D-1)<31) then + result := EncodeDate(Y,M,D); + end; + 19: if (Value[5]=Value[8]) and (ord(Value[8]) in [ord('-'),ord('/')]) and + (ord(Value[11]) in [ord(' '),ord('T')]) and (Value[14]=':') and (Value[17]=':') then begin + Y := ord(Value[1])*1000+ord(Value[2])*100+ + ord(Value[3])*10+ord(Value[4])-(48+480+4800+48000); + M := ord(Value[6])*10+ord(Value[7])-(48+480); + D := ord(Value[9])*10+ord(Value[10])-(48+480); + HH := ord(Value[12])*10+ord(Value[13])-(48+480); + MI := ord(Value[15])*10+ord(Value[16])-(48+480); + SS := ord(Value[18])*10+ord(Value[19])-(48+480); + if (Y<=9999) and ((M-1)<12) and ((D-1)<31) and + (HH<24) and (MI<60) and (SS<60) then + result := EncodeDate(Y,M,D)+EncodeTime(HH,MI,SS,0); + end; + end; +end; + +function ValueToJSON(const Value: variant): string; +var I64: Int64; +begin + if TVarData(Value).VType=JSONVariantType.VarType then + result := TJSONVariantData(Value).ToJSON else + if (TVarData(Value).VType=varByRef or varVariant) then + result := ValueToJSON(PVariant(TVarData(Value).VPointer)^) else + if TVarData(Value).VType<=varNull then + result := 'null' else + if TVarData(Value).VType=varBoolean then + if TVarData(Value).VBoolean then + result := 'true' else + result := 'false' else + if TVarData(Value).VType=varDate then + result := DateTimeToJSON(TVarData(Value).VDouble) else + if VarIsOrdinal(Value) then begin + I64 := Value; + result := IntToStr(I64); + end else + if VarIsFloat(Value) then + DoubleToJSON(Value,result) else + if VarIsStr(Value) then + result := StringToJSON(Value) else + result := Value; +end; + +function VarRecToValue(const V: TVarRec; out wasString: boolean): string; +// http://smartmobilestudio.com/forums/topic/is-array-of-const-supported-in-sms +begin + wasString := not (V.VType in + [vtBoolean,vtInteger,vtInt64,vtCurrency,vtExtended,vtVariant]); + with V do + case VType of + {$ifndef NEXTGEN} + vtString: result := string(VString^); + vtAnsiString: result := string(AnsiString(VAnsiString)); + vtChar: result := string(VChar); + vtPChar: result := string(VPChar); + vtWideString: result := string(WideString(VWideString)); + {$endif} + {$ifdef UNICODE} + vtUnicodeString: result := string(VUnicodeString); + {$endif} + vtPWideChar: result := string(VPWideChar); + vtWideChar: result := string(VWideChar); + vtBoolean: if VBoolean then result := '1' else result := '0'; + vtInteger: result := IntToStr(VInteger); + vtInt64: result := IntToStr(VInt64^); + {$ifdef FPC} + vtQWord: result := IntToStr(VQWord^); + {$endif} + vtCurrency: DoubleToJSON(VCurrency^,result); + vtExtended: DoubleToJSON(VExtended^,result); + vtObject: result := ObjectToJSON(VObject); + vtVariant: if TVarData(VVariant^).VType<=varNull then + result := 'null' else begin + wasString := VarIsStr(VVariant^); + result := VVariant^; + end; + else result := ''; + end; +end; + +procedure DoubleQuoteStr(var text: string); +var i,j: integer; + tmp: string; +begin + i := pos('"',text); + if i=0 then begin + text := '"'+text+'"'; + exit; + end; + tmp := '"'+copy(text,1,i)+'"'; + for j := i+1 to length(text) do + if text[j]='"' then + tmp := tmp+'""' else + AppendChar(tmp,text[j]); + text := tmp+'"'; +end; + + +{ TJSONParser } + +type + /// the JSON node types, as recognized by TJSONParser + TJSONParserKind = ( + kNone, kNull, kFalse, kTrue, kString, kInteger, kFloat, kObject, kArray); + + /// SAX parser for any JSON content + {$ifdef USEOBJECTINSTEADOFRECORD} + TJSONParser = object + {$else} + TJSONParser = record + {$endif} + JSON: string; + Index: integer; + JSONLength: integer; + procedure Init(const aJSON: string; aIndex: integer); + function GetNextChar: char; {$ifdef HASINLINE}inline;{$endif} + function GetNextNonWhiteChar: char; {$ifdef HASINLINE}inline;{$endif} + function CheckNextNonWhiteChar(aChar: char): boolean; {$ifdef HASINLINE}inline;{$endif} + function GetNextString(out str: string): boolean; overload; + function GetNextString: string; overload; {$ifdef HASINLINE}inline;{$endif} + function GetNextJSON(out Value: variant): TJSONParserKind; + function CheckNextIdent(const ExpectedIdent: string): Boolean; + function GetNextAlphaPropName(out fieldName: string): boolean; + function ParseJSONObject(var Data: TJSONVariantData): boolean; + function ParseJSONArray(var Data: TJSONVariantData): boolean; + procedure AppendNextStringUnEscape(var str: string); + end; + +procedure TJSONParser.Init(const aJSON: string; aIndex: integer); +begin + JSON := aJSON; + JSONLength := length(JSON); + Index := aIndex; +end; + +function TJSONParser.GetNextChar: char; +begin + if Index<=JSONLength then begin + result := JSON[Index]; + inc(Index); + end else + result := #0; +end; + +function TJSONParser.GetNextNonWhiteChar: char; +begin + if Index<=JSONLength then + repeat + if JSON[Index]>' ' then begin + result := JSON[Index]; + inc(Index); + exit; + end; + inc(Index); + until Index>JSONLength; + result := #0; +end; + +function TJSONParser.CheckNextNonWhiteChar(aChar: char): boolean; +begin + if Index<=JSONLength then + repeat + if JSON[Index]>' ' then begin + result := JSON[Index]=aChar; + if result then + inc(Index); + exit; + end; + inc(Index); + until Index>JSONLength; + result := false; +end; + +procedure TJSONParser.AppendNextStringUnEscape(var str: string); +var c: char; + u: string; + unicode,err: integer; +begin + repeat + c := GetNextChar; + case c of + #0: exit; + '"': break; + '\': begin + c := GetNextChar; + case c of + #0: exit; + 'b': AppendChar(str,#08); + 't': AppendChar(str,#09); + 'n': AppendChar(str,#$0a); + 'f': AppendChar(str,#$0c); + 'r': AppendChar(str,#$0d); + 'u': begin + u := Copy(JSON,Index,4); + if length(u)<>4 then + exit; + inc(Index,4); + val('$'+u,unicode,err); + if err<>0 then + exit; + AppendChar(str,char(unicode)); + end; + else AppendChar(str,c); + end; + end; + else AppendChar(str,c); + end; + until false; +end; + +function TJSONParser.GetNextString(out str: string): boolean; +var i: integer; +begin + for i := Index to JSONLength do + case JSON[i] of + '"': begin // end of string without escape -> direct copy + str := copy(JSON,Index,i-Index); + Index := i+1; + result := true; + exit; + end; + '\': begin // need unescaping + str := copy(JSON,Index,i-Index); + Index := i; + AppendNextStringUnEscape(str); + result := true; + exit; + end; + end; + result := false; +end; + +function TJSONParser.GetNextString: string; +begin + if not GetNextString(result) then + result := ''; +end; + +function TJSONParser.GetNextAlphaPropName(out fieldName: string): boolean; +var i: integer; +begin + result := False; + if (Index>=JSONLength) or + not (Ord(JSON[Index]) in [Ord('A')..Ord('Z'),Ord('a')..Ord('z'),Ord('_'),Ord('$')]) then + exit; // first char must be alphabetical + for i := Index+1 to JSONLength do + case Ord(JSON[i]) of + Ord('0')..Ord('9'),Ord('A')..Ord('Z'),Ord('a')..Ord('z'),Ord('_'): + ; // allow MongoDB extended syntax, e.g. {age:{$gt:18}} + Ord(':'),Ord('='): begin // allow both age:18 and age=18 pairs + fieldName := Copy(JSON,Index,i-Index); + Index := i+1; + result := true; + exit; + end; + else exit; + end; +end; + +function TJSONParser.GetNextJSON(out Value: variant): TJSONParserKind; +var str: string; + i64: Int64; + d: double; + start,err: integer; +begin + result := kNone; + case GetNextNonWhiteChar of + 'n': if copy(JSON,Index,3)='ull' then begin + inc(Index,3); + result := kNull; + Value := null; + end; + 'f': if copy(JSON,Index,4)='alse' then begin + inc(Index,4); + result := kFalse; + Value := false; + end; + 't': if copy(JSON,Index,3)='rue' then begin + inc(Index,3); + result := kTrue; + Value := true; + end; + '"': if GetNextString(str) then begin + result := kString; + Value := str; + end; + '{': if ParseJSONObject(TJSONVariantData(Value)) then + result := kObject; + '[': if ParseJSONArray(TJSONVariantData(Value)) then + result := kArray; + '-','0'..'9': begin + start := Index-1; + while true do + case JSON[Index] of + '-','+','0'..'9','.','E','e': inc(Index); + else break; + end; + str := copy(JSON,start,Index-start); + val(str,i64,err); + if err=0 then begin + Value := i64; + result := kInteger; + end else begin + val(str,d,err); + if err<>0 then + exit; + Value := d; + result := kFloat; + end; + end; + end; +end; + +function TJSONParser.CheckNextIdent(const ExpectedIdent: string): Boolean; +begin + result := (GetNextNonWhiteChar='"') and + (CompareText(GetNextString,ExpectedIdent)=0) and + (GetNextNonWhiteChar=':'); +end; + +function TJSONParser.ParseJSONArray(var Data: TJSONVariantData): boolean; +var item: variant; +begin + result := false; + Data.Init; + if not CheckNextNonWhiteChar(']') then // '[]' -> void array + repeat + if GetNextJSON(item)=kNone then + exit; + Data.AddValue(item); + case GetNextNonWhiteChar of + ',': continue; + ']': break; + else exit; + end; + until false; + SetLength(Data.Values,Data.VCount); + Data.VKind := jvArray; + result := true; +end; + +function TJSONParser.ParseJSONObject(var Data: TJSONVariantData): boolean; +var key: string; + val: variant; +begin + result := false; + Data.Init; + if not CheckNextNonWhiteChar('}') then // '{}' -> void object + repeat + if CheckNextNonWhiteChar('"') then begin + if (not GetNextString(key)) or (GetNextNonWhiteChar<>':') then + exit; + end else + if not GetNextAlphaPropName(key) then + exit; + if GetNextJSON(val)=kNone then + exit; // writeln(Copy(JSON,Index-10,30)); + Data.AddNameValue(key,val); + case GetNextNonWhiteChar of + ',': continue; + '}': break; + else exit; + end; + until false; + SetLength(Data.Names,Data.VCount); + SetLength(Data.Values,Data.VCount); + Data.VKind := jvObject; + result := true; +end; + + +function JSONToValue(const JSON: string): variant; +var Parser: TJSONParser; +begin + Parser.Init(JSON,1); + Parser.GetNextJSON(result); +end; + + +{ RTTI-oriented functions } + +const + BASE64: array[0..63] of char = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; +var + BASE64DECODE: array of ShortInt; + +function BytesToBase64JSONString(const Bytes: TByteDynArray; + withBase64Magic: boolean): string; +var i,len,x,c,j: cardinal; + P: PChar; +begin + len := length(Bytes); + if len=0 then begin + result := ''; + exit; + end; + if withBase64Magic then + x := JSON_BASE64_MAGIC_LEN else + x := 0; + SetLength(result,((len+2)div 3)*4+x); + P := pointer(result); + if withBase64Magic then + move(JSON_BASE64_MAGIC,P^,sizeof(JSON_BASE64_MAGIC)); + j := 0; + for i := 1 to len div 3 do begin + c := Bytes[j] shl 16 or Bytes[j+1] shl 8 or Bytes[j+2]; + inc(j,3); + P[x] := BASE64[(c shr 18) and $3f]; + P[x+1] := BASE64[(c shr 12) and $3f]; + P[x+2] := BASE64[(c shr 6) and $3f]; + P[x+3] := BASE64[c and $3f]; + inc(x,4); + end; + case len mod 3 of + 1: begin + c := Bytes[j] shl 4; + P[x] := BASE64[(c shr 6) and $3f]; + P[x+1] := BASE64[c and $3f]; + P[x+2] := '='; + P[x+3] := '='; + inc(x,4); + end; + 2: begin + c := Bytes[j] shl 10 or Bytes[j+1] shl 2; + P[x] := BASE64[(c shr 12) and $3f]; + P[x+1] := BASE64[(c shr 6) and $3f]; + P[x+2] := BASE64[c and $3f]; + P[x+3] := '='; + inc(x,4); + end; + end; + assert(integer(x)=Length(Result)); +end; + +function Base64One(c: Char): integer; + {$ifdef HASINLINE}inline;{$endif} +begin + result := ord(c); + if result>127 then + result := -1 else + result := BASE64DECODE[result]; +end; + +function Base64JSONStringToBytes(const JSONString: string; + var Bytes: TByteDynArray; withBase64Magic: boolean): boolean; +var i,bits,value,x,magiclen,len: cardinal; +begin + result := JSONString=''; + if result then + exit; + if withBase64Magic then + if comparemem(pointer(JSONString),@JSON_BASE64_MAGIC,sizeof(JSON_BASE64_MAGIC)) then + magiclen := JSON_BASE64_MAGIC_LEN else + {$ifndef UNICODE} + if JSONString[1]='?' then // handle UTF-8 decoding error on ANSI Delphi + magiclen := 1 else + {$endif} + exit else + magiclen := 0; // withBase64Magic=false + x := length(JSONString); + len := x-magiclen; + if len and 3<>0 then + exit; + if len=0 then + Bytes := nil else begin + if BASE64DECODE=nil then begin + SetLength(BASE64DECODE,128); + for i := 0 to 127 do + BASE64DECODE[i] := -1; + for i := 0 to high(BASE64) do + BASE64DECODE[ord(BASE64[i])] := i; + end; + len := (len shr 2)*3; + if Base64One(JSONString[x])<0 then begin + dec(len); + if Base64One(JSONString[x-1])<0 then + dec(len); + end; + SetLength(Bytes,len); + bits := 0; + value := 0; + len := 0; + for i := magiclen+1 to Length(JSONString) do begin + x := ord(JSONString[i]); // inlined Base64One(JSONString[i]) + if x>127 then + break; + x := cardinal(BASE64DECODE[x]); + if integer(x)<0 then + break; + value := value*64+x; + bits := bits+6; + if bits>=8 then begin + bits := bits-8; + x := value shr bits; + value := value and ((1 shl bits)-1); + Bytes[len] := x; + inc(len); + end; + end; + end; + result := len=cardinal(length(Bytes)); +end; + +function RTTIPropInfoTypeName(PropInfo: TRTTIPropInfo): string; +begin + result := ShortStringToString(@PropInfo^.PropType^.Name); +end; + +procedure GetPropsInfo(TypeInfo: TRTTITypeInfo; var PropNames: TStringDynArray; + var PropRTTI: TRTTIPropInfoDynArray); +var i,n: integer; + List: PPropList; +begin + n := GetPropList(PTypeInfo(TypeInfo),List); + SetLength(PropNames,n); + SetLength(PropRTTI,n); + for i := 0 to n-1 do begin + PropRTTI[i] := List^[i]; + PropNames[i] := ShortStringToString(@PropRTTI[i]^.Name); + end; + freemem(List); +end; + +function IsDateTime(PropInfo: TRTTIPropInfo): boolean; + {$ifdef HASINLINE}inline;{$endif} +begin + result := PropInfo^.PropType{$ifndef FPC}^{$endif}=TypeInfo(TDateTime); +end; + +{$ifndef FPC} +type + // used to map a TPropInfo.GetProc/SetProc and retrieve its kind on Delphi + PropWrap = packed record + FillBytes: array [0..SizeOf(Pointer)-2] of byte; + /// = $ff for a field address, or =$fe for a virtual method + Kind: byte; + end; +{$endif FPC} + +function IsBlob(PropInfo: TRTTIPropInfo): boolean; + {$ifdef HASINLINE}inline;{$endif} +begin // we only handle plain TByteDynArray properties without getter/setter +{$ifdef FPC} + result := (PropInfo^.PropType=TypeInfo(TByteDynArray)) and + (PropInfo^.PropProcs and 3=ptField); +{$else} + result := (PropInfo^.PropType^=TypeInfo(TByteDynArray)) and + (PropWrap(PropInfo^.GetProc).Kind=$FF); +{$endif} +end; + +function GetTByteDynArrayProp(Instance: TObject; PropInfo: TRTTIPropInfo): PByteDynArray; + {$ifdef HASINLINE}inline;{$endif} +begin + result := Pointer(NativeUInt(Instance)+ + (NativeUInt(PropInfo^.GetProc){$ifndef FPC} and $00FFFFFF{$endif})); +end; + +function GetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo; StoreClassName: boolean): variant; +var obj: TObject; +begin + VarClear(result); + if (PropInfo=nil) or (Instance=nil) then + exit; + case PropInfo^.PropType^.Kind of + tkInt64{$ifdef FPC}, tkQWord{$endif}: + result := GetInt64Prop(Instance,PropInfo); + tkEnumeration, tkInteger, tkSet: + result := GetOrdProp(Instance,PropInfo); + {$ifdef NEXTGEN} + tkUString: + result := GetStrProp(Instance,PropInfo); + {$else} + {$ifdef FPC}tkAString,{$endif}tkLString: + result := GetStrProp(Instance,PropInfo); + tkWString: + result := GetWideStrProp(Instance,PropInfo); + {$ifdef UNICODE} + tkUString: + result := GetUnicodeStrProp(Instance,PropInfo); + {$endif UNICODE} + {$endif NEXTGEN} + tkFloat: + if IsDateTime(PropInfo) then + result := DateTimeToIso8601(GetFloatProp(Instance,PropInfo)) else + result := GetFloatProp(Instance,PropInfo); + tkVariant: + result := GetVariantProp(Instance,PropInfo); + tkClass: begin + obj := TObject(NativeInt(GetOrdProp(Instance,PropInfo))); + if obj=nil then + result := null else + TJSONVariantData(result).Init(ObjectToJSON(obj, StoreClassName)); + end; + tkDynArray: + if IsBlob(PropInfo) then + result := BytesToBase64JSONString(GetTByteDynArrayProp(Instance,PropInfo)^); + end; +end; + +procedure SetInstanceProp(Instance: TObject; PropInfo: TRTTIPropInfo; + const Value: variant); +var blob: PByteDynArray; + obj: TObject; +begin + if (PropInfo<>nil) and (Instance<>nil) then + case PropInfo^.PropType^.Kind of + tkInt64{$ifdef FPC}, tkQWord{$endif}: + if TVarData(Value).VType=varInt64 then + SetInt64Prop(Instance,PropInfo,TVarData(Value).VInt64) else + SetOrdProp(Instance,PropInfo,Value); + tkEnumeration, tkInteger, tkSet: + SetOrdProp(Instance,PropInfo,Value); + {$ifdef NEXTGEN} + tkUString: + if TVarData(Value).VType<=varNull then + SetStrProp(Instance,PropInfo,'') else + SetStrProp(Instance,PropInfo,Value); + {$else} + {$ifdef FPC}tkAString,{$endif} tkLString: + if TVarData(Value).VType<=varNull then + SetStrProp(Instance,PropInfo,'') else + SetStrProp(Instance,PropInfo,Value); + tkWString: + if TVarData(Value).VType<=varNull then + SetWideStrProp(Instance,PropInfo,'') else + SetWideStrProp(Instance,PropInfo,Value); + {$ifdef UNICODE} + tkUString: + if TVarData(Value).VType<=varNull then + SetUnicodeStrProp(Instance,PropInfo,'') else + SetUnicodeStrProp(Instance,PropInfo,Value); + {$endif UNICODE} + {$endif NEXTGEN} + tkFloat: + if IsDateTime(PropInfo) and VarIsStr(Value) then + SetFloatProp(Instance,PropInfo,Iso8601ToDateTime(Value)) else + SetFloatProp(Instance,PropInfo,Value); + tkVariant: + SetVariantProp(Instance,PropInfo,Value); + tkDynArray: + if IsBlob(PropInfo) then begin + blob := GetTByteDynArrayProp(Instance,PropInfo); + if (TVarData(Value).VType<=varNull) or + not Base64JSONStringToBytes(Value,blob^) then + Finalize(blob^); + end; + tkClass: begin + obj := TObject(NativeInt(GetOrdProp(Instance,PropInfo))); + if TVarData(Value).VType>varNull then + if obj=nil then begin + obj := JSONVariantData(Value)^.ToNewObject; + if obj<>nil then + SetOrdProp(Instance,PropInfo,NativeInt(obj)); + end else + JSONVariantData(Value)^.ToObject(obj); + end; + end; +end; + +function JSONToObjectList(ItemClass: TClass; const JSON: string): TObjectList; +var doc: TJSONVariantData; + item: TObject; + i: integer; +begin + doc.Init(JSON); + if (doc.VKind<>jvArray) or (ItemClass=nil) then + result := nil else begin + result := TObjectList.Create; + for i := 0 to doc.Count-1 do begin + item := ItemClass.Create; + if not JSONVariantData(doc.Values[i])^.ToObject(item) then begin + FreeAndNil(result); + exit; + end; + result.Add(item); + end; + end; +end; + +function JSONToObject(Instance: TObject; const JSON: string): boolean; +var doc: TJSONVariantData; +begin + if Instance=nil then + result := false else begin + doc.Init(JSON); + result := doc.ToObject(Instance); + end; +end; + +function JSONToNewObject(const JSON: string): pointer; +var doc: TJSONVariantData; +begin + doc.Init(JSON); + result := doc.ToNewObject; +end; + +var + RegisteredClass: array of record + ClassName: string; + ClassType: TClass; + end; + +function FindClassForJSON(const ClassName: string): integer; +begin + for result := 0 to high(RegisteredClass) do + if IdemPropName(RegisteredClass[result].ClassName,ClassName) then + exit; + result := -1; +end; + +function CreateClassForJSON(const ClassName: string): TObject; +var i: integer; +begin + i := FindClassForJSON(ClassName); + if i<0 then + result := nil else + result := RegisteredClass[i].ClassType.Create; +end; + +procedure RegisterClassForJSON(const Classes: array of TClass); +var c,i: integer; + name: string; +begin + for c := 0 to high(Classes) do begin + name := string(Classes[c].ClassName); + i := FindClassForJSON(name); + if i>=0 then + continue; + i := length(RegisteredClass); + SetLength(RegisteredClass,i+1); + RegisteredClass[i].ClassName := Name; + RegisteredClass[i].ClassType := Classes[c]; + end; +end; + +function ObjectToJSON(Instance: TObject; StoreClassName: boolean): string; +var TypeInfo: PTypeInfo; + PropCount, i: integer; + PropList: PPropList; + PropInfo: PPropInfo; +begin + if Instance=nil then begin + result := 'null'; + exit; + end; + {$ifndef NEXTGEN} + if Instance.InheritsFrom(TList) then begin + if TList(Instance).Count=0 then + result := '[]' else begin + result := '['; + for i := 0 to TList(Instance).Count-1 do + result := result+ObjectToJSON(TObject( + TList(Instance).List{$ifdef FPC}^{$endif}[i]),StoreClassName)+','; + result[length(result)] := ']'; + end; + exit; + end; + {$endif} + if Instance.InheritsFrom(TStrings) then begin + if TStrings(Instance).Count=0 then + result := '[]' else begin + result := '['; + for i := 0 to TStrings(Instance).Count-1 do + result := result+StringToJSON(TStrings(Instance).Strings[i])+','; + result[length(result)] := ']'; + end; + exit; + end; + if Instance.InheritsFrom(TCollection) then begin + if TCollection(Instance).Count=0 then + result := '[]' else begin + result := '['; + for i := 0 to TCollection(Instance).Count-1 do + result := result+ObjectToJSON(TCollection(Instance).Items[i],StoreClassName)+','; + result[length(result)] := ']'; + end; + exit; + end; + TypeInfo := Instance.ClassInfo; + if TypeInfo=nil then begin + result := 'null'; + exit; + end; + PropCount := GetPropList(TypeInfo,PropList); + if PropCount>0 then + try + if StoreClassName then + result := '{"ClassName":"'+string(Instance.ClassName)+'",' else + result := '{'; + for i := 0 to PropCount-1 do begin + PropInfo := PropList^[i]; + result := result+StringToJSON(ShortStringToString(@PropInfo^.Name))+':'+ + ValueToJSON(GetInstanceProp(Instance,PropInfo,StoreClassName))+','; + end; + result[length(result)] := '}'; + finally + FreeMem(PropList); + end else + result := 'null'; +end; + +procedure GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodDynArray); +var n: integer; + procedure AddParentsFirst(C: TClass); + type + TMethodInfo = packed record + {$ifdef FPC} + Name: PShortString; + Addr: Pointer; + {$else} + Len: Word; + Addr: Pointer; + Name: Byte; + {$endif} + end; + var M: ^TMethodInfo; + Method: TMethod; + i,MCount: integer; + begin + if C=nil then + exit; + AddParentsFirst(C.ClassParent); // put children methods afterward + M := PPointer(NativeInt(C)+vmtMethodTable)^; + if M=nil then + exit; + Method.Data := Instance; + MCount := {$ifdef FPC}PCardinal{$else}PWord{$endif}(M)^; + inc({$ifdef FPC}PCardinal{$else}PWord{$endif}(M)); + for i := 1 to MCount do begin + Method.Code := M^.Addr; + if n>=length(Methods) then + SetLength(Methods,n+32); + Methods[n].Name := {$ifdef FPC}M^.Name^{$else}ShortStringToString(@M^.Name){$endif}; + Methods[n].Method := Method; + inc(n); + {$ifdef FPC} + inc(M); + {$else} + inc(PByte(M),M^.Len); + {$endif} + end; + end; +begin + if Instance=nil then + exit; + n := 0; + AddParentsFirst(Instance.ClassType); + SetLength(Methods,n); +end; + + +{ TJSONVariantData } + +procedure TJSONVariantData.Init; +begin + VType := JSONVariantType.VarType; + {$ifdef UNICODE} // makes compiler happy + _Align := 0; + {$endif} + VKind := jvUndefined; + VCount := 0; + pointer(Names) := nil; + pointer(Values) := nil; +end; + +procedure TJSONVariantData.Init(const JSON: string); +begin + Init; + FromJSON(JSON); + if VType=varNull then + VKind := jvObject else + if VType<>JSONVariantType.VarType then + Init; // we expect a true JSON array or object here +end; + +procedure TJSONVariantData.InitFrom(const aValues: TVariantDynArray); +begin + Init; + VKind := jvArray; + Values := aValues; + VCount := Length(aValues); +end; + +procedure TJSONVariantData.Clear; +begin + Names := nil; + Values := nil; + Init; +end; + +procedure TJSONVariantData.AddNameValue(const aName: string; + const aValue: variant); +begin + if VKind=jvUndefined then + VKind := jvObject else + if VKind<>jvObject then + raise EJSONException.CreateFmt('AddNameValue(%s) over array',[aName]); + if VCount=length(Values) then begin + SetLength(Values,VCount+VCount shr 3+32); + SetLength(Names,VCount+VCount shr 3+32); + end; + Values[VCount] := aValue; + Names[VCount] := aName; + inc(VCount); +end; + +procedure TJSONVariantData.AddValue(const aValue: variant); +begin + if VKind=jvUndefined then + VKind := jvArray else + if VKind<>jvArray then + raise EJSONException.Create('AddValue() over object'); + if VCount=length(Values) then + SetLength(Values,VCount+VCount shr 3+32); + Values[VCount] := aValue; + inc(VCount); +end; + +function TJSONVariantData.FromJSON(const JSON: string): boolean; +var Parser: TJSONParser; +begin + Parser.Init(JSON,1); + result := Parser.GetNextJSON(variant(self)) in [kObject,kArray]; +end; + +function TJSONVariantData.Data(const aName: string): PJSONVariantData; +var i: integer; +begin + i := NameIndex(aName); + if (i<0) or (TVarData(Values[i]).VType<>JSONVariantType.VarType) then + result := nil else + result := @Values[i]; +end; + +function TJSONVariantData.GetKind: TJSONVariantKind; +begin + if (@self=nil) or (VType<>JSONVariantType.VarType) then + result := jvUndefined else + result := VKind; +end; + +function TJSONVariantData.GetCount: integer; +begin + if (@self=nil) or (VType<>JSONVariantType.VarType) then + result := 0 else + result := VCount; +end; + +function TJSONVariantData.GetValue(const aName: string): variant; +begin + VarClear(result); + if (@self<>nil) and (VType=JSONVariantType.VarType) and (VKind=jvObject) then + GetVarData(aName,TVarData(result)); +end; + +function TJSONVariantData.GetValueCopy(const aName: string): variant; +var i: cardinal; +begin + VarClear(result); + if (@self<>nil) and (VType=JSONVariantType.VarType) and (VKind=jvObject) then begin + i := cardinal(NameIndex(aName)); + if inil) and (VType=JSONVariantType.VarType) and (VKind=jvArray) then + if cardinal(aIndex)nil) and (VType=JSONVariantType.VarType) and (VKind=jvArray) then + if cardinal(aIndex)nil) and (VType=JSONVariantType.VarType) and (Names<>nil) then + for result := 0 to VCount-1 do + if Names[result]=aName then + exit; + result := -1; +end; + +procedure TJSONVariantData.SetPath(const aPath: string; const aValue: variant); +var i: integer; +begin + for i := length(aPath) downto 1 do + if aPath[i]='.' then begin + EnsureData(copy(aPath,1,i-1))^.SetValue(copy(aPath,i+1,maxInt),aValue); + exit; + end; + SetValue(aPath,aValue); +end; + +function TJSONVariantData.EnsureData(const aPath: string): PJSONVariantData; +var i: integer; + new: TJSONVariantData; +begin // recursive value set + i := Pos('.',aPath); + if i=0 then begin + i := NameIndex(aPath); + if i<0 then begin // not existing: create new + new.Init; + AddNameValue(aPath,variant(new)); + result := @Values[VCount-1]; + end else begin + if TVarData(Values[i]).VType<>JSONVariantType.VarType then begin + VarClear(Values[i]); + TJSONVariantData(Values[i]).Init; // create as TJSONVariantData + end; + result := @Values[i]; + end; + end else + result := EnsureData(copy(aPath,1,i-1))^.EnsureData(copy(aPath,i+1,maxInt)); +end; + +function TJSONVariantData.AddItem: PJSONVariantData; +var new: TJSONVariantData; +begin + new.Init; + AddValue(variant(new)); + result := @Values[VCount-1]; +end; + +procedure TJSONVariantData.SetValue(const aName: string; + const aValue: variant); +var i: integer; +begin + if @self=nil then + raise EJSONException.Create('Unexpected Value[] access'); + if aName='' then + raise EJSONException.Create('Unexpected Value['''']'); + i := NameIndex(aName); + if i<0 then + AddNameValue(aName,aValue) else + Values[i] := aValue; +end; + +function TJSONVariantData.ToJSON: string; +var i: integer; +begin + case VKind of + jvObject: + if VCount=0 then + result := '{}' else begin + result := '{'; + for i := 0 to VCount-1 do + result := result+StringToJSON(Names[i])+':'+ValueToJSON(Values[i])+','; + result[length(result)] := '}'; + end; + jvArray: + if VCount=0 then + result := '[]' else begin + result := '['; + for i := 0 to VCount-1 do + result := result+ValueToJSON(Values[i])+','; + result[length(result)] := ']'; + end; + else result := 'null'; + end; +end; + +function TJSONVariantData.ToNewObject: TObject; +var ndx,i: Integer; +begin + result := nil; + if (Kind<>jvObject) or (Count=0) then + exit; + ndx := NameIndex('ClassName'); + if ndx<0 then + exit; + result := CreateClassForJSON(Values[ndx]); + if result=nil then + exit; // class name has not been registered + for i := 0 to Count-1 do + if i<>ndx then + SetInstanceProp(result,GetPropInfo(result,Names[i]),Values[i]); +end; + +function TJSONVariantData.ToObject(Instance: TObject): boolean; +var i: integer; + aItem: TCollectionItem; +begin + result := false; + if Instance=nil then + exit; + case Kind of + jvObject: + for i := 0 to Count-1 do + SetInstanceProp(Instance, + GetPropInfo(Instance,Names[i]),Values[i]); + jvArray: + if Instance.InheritsFrom(TCollection) then begin + TCollection(Instance).Clear; + for i := 0 to Count-1 do begin + aItem := TCollection(Instance).Add; + if not JSONVariantData(Values[i])^.ToObject(aItem) then + exit; + end; + end else + if Instance.InheritsFrom(TStrings) then + try + TStrings(Instance).BeginUpdate; + TStrings(Instance).Clear; + for i := 0 to Count-1 do + TStrings(Instance).Add(Values[i]); + finally + TStrings(Instance).EndUpdate; + end else + exit; + else + exit; + end; + result := true; +end; + + +{ TJSONVariant } + +procedure TJSONVariant.Cast(var Dest: TVarData; const Source: TVarData); +begin + CastTo(Dest,Source,VarType); +end; + +procedure TJSONVariant.CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); +begin + if Source.VType<>VarType then + RaiseCastError; + variant(Dest) := TJSONVariantData(Source).ToJSON; +end; + +procedure TJSONVariant.Clear(var V: TVarData); +begin + V.VType := varEmpty; + Finalize(TJSONVariantData(V).Names); + Finalize(TJSONVariantData(V).Values); +end; + +procedure TJSONVariant.Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); +begin + if Indirect then + SimplisticCopy(Dest,Source,true) else begin + VarClear(variant(Dest)); + TJSONVariantData(Dest).Init; + TJSONVariantData(Dest) := TJSONVariantData(Source); + end; +end; + +{$ifndef FPC} +{$ifndef ISDELPHI6} +function TJSONVariant.FixupIdent(const AText: string): string; +begin // we expect the names to be case-sensitive + result := AText; +end; +{$endif} +{$endif} + +function TJSONVariant.GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; +begin + if not TJSONVariantData(V).GetVarData(Name,Dest) then + Dest.VType := varNull; + result := true; +end; + +{$ifdef FPC_VARIANTSETVAR} +function TJSONVariant.SetProperty(var V: TVarData; const Name: string; + const Value: TVarData): Boolean; +{$else} +function TJSONVariant.SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; +{$endif} +begin + {$ifdef FPC} + {$ifndef FPC_VARIANTSETVAR} + raise EJSONException.Create('Setting TJSONVariant via late-binding does not'+ + ' work with FPC - see http://mantis.freepascal.org/view.php?id=26773 -'+ + ' use latest SVN or JSONVariantDataSafe(jsonvar)^[''prop''] := ... instead'); + {$endif} + {$endif} + TJSONVariantData(V).SetValue(Name,variant(Value)); + result := true; +end; + + +{ TJSONTable } + +constructor TJSONTable.Create(const aJSON: string); +var f,firstValue: integer; + EndOfField: char; + fieldCount, fieldName, dummy: variant; + Parser: TJSONParser; +begin + Parser.Init(aJSON,1); + fJSON := aJSON; + EndOfField := #0; + if (Parser.GetNextNonWhiteChar='{') and + Parser.CheckNextIdent('fieldCount') and + (Parser.GetNextJSON(fieldCount)=kInteger) and + (Parser.GetNextNonWhiteChar=',') and + Parser.CheckNextIdent('values') and + (Parser.GetNextNonWhiteChar='[') then begin + // non expanded format: {"fieldCount":2,"values":["ID","Int",1,0,2,0,3,...] + SetLength(fFieldNames,integer(fieldCount)); + for f := 0 to high(fFieldNames) do begin + if Parser.GetNextJSON(fieldName)<>kString then + exit; + fFieldNames[f] := fieldName; + EndOfField := Parser.GetNextNonWhiteChar; + if EndOfField<>',' then + if (EndOfField<>']') or (f<>High(FieldNames)) then + exit + end; + if EndOfField=',' then + fJSONIndexFirstValue := Parser.Index; + end else begin + // expanded format: [{"ID":1,"Int":0},{"ID":2,"Int":0},{"ID":3,...] + Parser.Index := 1; + if (Parser.GetNextNonWhiteChar='[') and + (Parser.GetNextNonWhiteChar='{') then begin + firstValue := Parser.Index; + f := 0; + repeat + if (Parser.GetNextJSON(fieldName)<>kString) or + (Parser.GetNextNonWhiteChar<>':') then + exit; + if Parser.GetNextJSON(dummy)=kNone then + exit; + SetLength(fFieldNames,f+1); + fFieldNames[f] := fieldName; + inc(f); + EndOfField := Parser.GetNextNonWhiteChar; + if EndOfField<>',' then + if EndOfField='}' then + break else + exit; + until false; + fJSONIndexFirstValue := firstValue; + fJSONExpanded := true; + end; + end; + SetLength(fRowValues,length(fFieldNames)); +end; + +function TJSONTable.FieldIndex(const FieldName: string): integer; +begin + for result := 0 to high(fFieldNames) do + if CompareText(fFieldNames[result],FieldName)=0 then + exit; + result := -1; +end; + +function TJSONTable.Get(const FieldName: string): variant; +var ndx: integer; +begin + ndx := FieldIndex(FieldName); + if ndx<0 then + result := null else + result := fRowValues[ndx]; +end; + +function TJSONTable.Step(SeekFirst: boolean): boolean; +var f: integer; + EndOfField: char; + Parser: TJSONParser; +begin + result := false; + if SeekFirst or (fJSONCurrentIndex=0) then + fJSONCurrentIndex := fJSONIndexFirstValue; + if fJSONCurrentIndex<=0 then + exit; + Parser.Init(fJSON,fJSONCurrentIndex); + fJSONCurrentIndex := -1; // indicates end of content in case of exit below + EndOfField := #0; + for f := 0 to high(fRowValues) do begin + if fJSONExpanded and not Parser.CheckNextIdent(fFieldNames[f]) then + exit; + if Parser.GetNextJSON(fRowValues[f])=kNone then + exit; + EndOfField := Parser.GetNextNonWhiteChar; + if EndOfField<>',' then + if f<>High(fRowValues) then + exit else + if ((EndOfField=']') and (not fJSONExpanded)) or + ((EndOfField='}') and fJSONExpanded) then + break else + exit; + end; + if fJSONExpanded then begin + if EndOfField<>'}' then + exit; + EndOfField := Parser.GetNextNonWhiteChar; + if (EndOfField=',') and + (Parser.GetNextNonWhiteChar<>'{') then + exit; + end; + if EndOfField=',' then + fJSONCurrentIndex := Parser.Index; // indicates next Step() has data + result := true; +end; + +function TJSONTable.StepValue(var RowValues: variant; SeekFirst: boolean): boolean; +begin + result := Step(SeekFirst); + if not result then + exit; + if TVarData(RowValues).VType<>JSONVariantType.VarType then begin + VarClear(RowValues); + TJSONVariantData(RowValues).Init; + end; + TJSONVariantData(RowValues).VKind := jvObject; + TJSONVariantData(RowValues).VCount := Length(fFieldNames); + TJSONVariantData(RowValues).Names := fFieldNames; + TJSONVariantData(RowValues).Values := fRowValues; +end; + + +{ TJSONTableObject } + +function TJSONTableObject.StepObject(Instance: TObject; SeekFirst: boolean=false): boolean; +begin + if (Instance=nil) then + result := false else + result := Step(SeekFirst); + if result then + FillInstance(Instance); +end; + +procedure TJSONTableObject.FillInstance(Instance: TObject); +var i: integer; +begin + if fTypeInfo<>Instance.ClassInfo then + FillPropInfo(Instance.ClassInfo); + for i := 0 to Length(fPropInfo)-1 do + SetInstanceProp(Instance,fPropInfo[i],fRowValues[i]); +end; + +function TJSONTableObject.GetPropInfo(aTypeInfo: TRTTITypeInfo; + const PropName: string): TRTTIPropInfo; +begin + result := TypInfo.GetPropInfo(PTypeInfo(aTypeInfo),PropName); +end; + +procedure TJSONTableObject.FillPropInfo(aTypeInfo: TRTTITypeInfo); +var i: integer; +begin + fTypeInfo := aTypeInfo; + SetLength(fPropInfo,Length(fFieldNames)); + for i := 0 to length(FieldNames)-1 do + fPropInfo[i] := GetPropInfo(aTypeInfo,fFieldNames[i]); +end; + + +initialization + JSONVariantType := TJSONVariant.Create; + {$ifndef FPC} + {$ifndef NOFORMATSETTINGS} + {$ifdef ISDELPHIXE} + SettingsUS := TFormatSettings.Create('en_US'); + {$else} + GetLocaleFormatSettings($0409,SettingsUS); + {$endif} + {$endif} + {$endif} +end. diff --git a/mORMot/CrossPlatform/SynCrossPlatformREST.pas b/mORMot/CrossPlatform/SynCrossPlatformREST.pas new file mode 100644 index 00000000..5fbfb034 --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformREST.pas @@ -0,0 +1,3808 @@ +/// minimum stand-alone cross-platform REST process for mORMot client +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformREST; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - hanspi + - warleyalex + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + + Should compile with Delphi for any platform (including NextGen for mobiles), + with FPC 2.7 or Kylix, and with SmartMobileStudio 2.1.1 + +} + +{$ifdef DWSCRIPT} // always defined since SMS 1.1.2 + {$define ISDWS} // e.g. for SmartMobileStudio or Delphi Web Script + {$define ISSMS} // for SmartMobileStudio +{$else} + {$i SynCrossPlatform.inc} // define e.g. HASINLINE +{$endif} + +interface + +{$ifdef ISDWS} +uses + SmartCL.System, + System.Types, + ECMA.Json, +{$else} +uses + SysUtils, + Classes, + TypInfo, +{$ifdef ISDELPHI2010} + System.Generics.Collections, +{$endif} +{$ifndef NEXTGEN} + Contnrs, +{$endif} + Variants, + SynCrossPlatformJSON, +{$endif ISDWS} + SynCrossPlatformSpecific, + SynCrossPlatformCrypto; + + +const + /// maximum number of fields in a database Table + MAX_SQLFIELDS = 256; + + /// used as "stored AS_UNIQUE" published property definition in TSQLRecord + AS_UNIQUE = false; + +type + /// alias to share the same string type between client and server + RawUTF8 = string; + + TSQLRest = class; + TSQLRecord = class; + TSQLModel = class; + + TSQLRecordClass = class of TSQLRecord; + TSQLRecordClassDynArray = array of TSQLRecordClass; + + {$ifdef ISDWS} + + // UTILS functions + function window: variant; external 'window' property; + function document: variant; external 'document' property; + + // URI functions + function EncodeURIComponent(str: String): String; external 'encodeURIComponent'; + function DecodeURIComponent(str: String): String; external 'decodeURIComponent'; + function EncodeURI(str: String): String; external 'encodeURI'; + function DecodeURI(str: String): String; external 'decodeURI'; + + // Variant management + function VarIsValidRef(const aRef: Variant): Boolean; + +type + // circumvent limited DWS / SMS syntax + TPersistent = TObject; + TObjectList = array of TObject; + // stored as binary, transmitted as Base64 (VariantToBlob=atob and BlobToVariant=btoa) + TSQLRawBlob = variant; + // TTimeLogBits.Value has a 38-bit precision, so features exact representation + // as JavaScript numbers (stored in a 52-bit mantissa) + TTimeLog = Int53; + TModTime = TTimeLog; + TCreateTime = TTimeLog; + TGUID = string; + TSQLFieldBit = enum (Low = 0, High = MAX_SQLFIELDS-1); + + ERestException = class(EW3Exception); + + /// handle a JSON result table, as returned by mORMot's REST server ORM + // - we define a dedicated class to by-pass SynCrossPlatformJSON unit + TSQLTableJSON = class + protected + fInternalState: cardinal; + fFieldCount, fRowCount, fCurrentRow: integer; + fFieldNames: TStrArray; + fValues: TVariantDynArray; + public + /// parse the supplied JSON content + constructor Create(const aJSON: string); + /// to be called in a loop to iterate through all data rows + // - if returned true, Object published properties will contain this row + function FillOne(Value: TSQLRecord; SeekFirst: boolean=false): boolean; + end; + + {$else} + + /// Exception type raised when working with REST access + ERestException = class(Exception); + + /// alias to share the same blob type between client and server + TSQLRawBlob = TByteDynArray; + + /// fast bit-encoded date and time value + TTimeLog = type Int64; + + /// used to define a field which shall be set at each modification + TModTime = type TTimeLog; + + /// used to define a field which shall be set at record creation + TCreateTime = type TTimeLog; + + /// used to identify the a field in a Table as in TSQLFieldBits + TSQLFieldBit = 0..MAX_SQLFIELDS-1; + + /// handle a JSON result table, as returned by mORMot's REST server ORM + // - this class is expected to work with TSQLRecord instances only + // - it will let any "RowID" JSON key match TSQLRecord.ID property + TSQLTableJSON = class(TJSONTableObject) + protected + fInternalState: cardinal; + /// allow to let "RowID" JSON key match TSQLRecord.ID + function GetPropInfo(aTypeInfo: TRTTITypeInfo; const PropName: string): TRTTIPropInfo; override; + public + /// to be called in a loop to iterate through all data rows + // - if returned true, Object published properties will contain this row + function FillOne(aValue: TSQLRecord; aSeekFirst: boolean=false): boolean; + end; + + {$endif ISDWS} + + /// Exception type raised when working with interface-based service process + EServiceException = class(ERestException); + + /// the available logging events, as handled by our Cross-Platform units + // - defined with the same values in SynCommons.pas + // - sllInfo will log general information events + // - sllDebug will log detailed debugging information + // - sllTrace will log low-level step by step debugging information + // - sllWarning will log unexpected values (not an error) + // - sllError will log errors + // - sllEnter will log every method start + // - sllLeave will log every method exit + // - sllLastError will log the GetLastError OS message + // - sllException will log all exception raised - available since Windows XP + // - sllExceptionOS will log all OS low-level exceptions (EDivByZero, + // ERangeError, EAccessViolation...) + // - sllMemory will log memory statistics + // - sllStackTrace will log caller's stack trace (it's by default part of + // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS, + // sllLastError and sllFail) + // - sllFail was defined for TSynTestsLogged.Failed method, and can be used + // to log some customer-side assertions (may be notifications, not errors) + // - sllSQL is dedicated to trace the SQL statements + // - sllCache should be used to trace the internal caching mechanism + // - sllResult could trace the SQL results, JSON encoded + // - sllDB is dedicated to trace low-level database engine features + // - sllHTTP could be used to trace HTTP process + // - sllClient/sllServer could be used to trace some Client or Server process + // - sllServiceCall/sllServiceReturn to trace some remote service or library + // - sllUserAuth to trace user authentication (e.g. for individual requests) + // - sllCustom* items can be used for any purpose + // - sllNewRun will be written when a process opens a rotated log + // - sllDDDError will log any DDD-related low-level error information + // - sllDDDInfo will log any DDD-related low-level debugging information + TSynLogInfo = ( + sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError, + sllEnter, sllLeave, + sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace, + sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer, + sllServiceCall, sllServiceReturn, sllUserAuth, + sllCustom1, sllCustom2, sllCustom3, sllCustom4, + sllNewRun, sllDDDError, sllDDDInfo); + + /// used to define a set of logging level abilities + // - i.e. a combination of none or several logging event + // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE + // to log all errors and exceptions + TSynLogInfos = set of TSynLogInfo; + + /// callback event used to write some text to a logging system + // - could be a local file (not for SMS apps), or a remote log server + // - the Text is already in the same format than the one generated by TSynLog + TOnSQLRestLog = procedure(const Text: string) of object; + + /// used to store bit set for all available fields in a Table + // - in this unit, field at index [0] indicates TSQLRecord.ID + TSQLFieldBits = set of TSQLFieldBit; + + /// a published property kind + // - does not match mORMot.pas TSQLFieldType: here we recognize only types + // which may expect a special behavior in this unit + TSQLFieldKind = ( + sftUnspecified, sftDateTime, sftTimeLog, sftBlob, sftModTime, sftCreateTime, + sftRecord, sftVariant); + + /// a set of published property Kind + TSQLFieldKinds = set of TSQLFieldKind; + + { Should TID be a string since number is limited to 53-bit in JavaScript? + -> or define and use an explicit Int52 type for SMS? } + /// the TSQLRecord primary key is a 64 bit integer + TID = {$ifndef ISDWS}type{$endif} Int64; + + /// a dynamic array of TSQLRecord primary keys + // - used e.g. for BATCH process + TIDDynArray = array of TID; + + /// store information of one TSQLRecord published property + TSQLModelInfoPropInfo = class + public + /// the name of the published property + // - e.g. 'FirstName' + Name: string; + /// the property field type + Kind: TSQLFieldKind; + {$ifdef ISDWS} + /// index of the published property in the associated Prop[] + FieldIndex: TSQLFieldBit; + {$else} + /// the property type name, as retrieved from RTTI + TypeName: string; + /// RTTI information about the published property + RTTI: TRTTIPropInfo; + /// initialize the instance + constructor CreateFrom(aRTTI: TRTTIPropInfo); + {$endif} + end; + + /// store information of all TSQLRecord published properties + TSQLModelInfoPropInfoDynArray = array of TSQLModelInfoPropInfo; + + /// store information of one TSQLRecord class + TSQLModelInfo = class + public + /// the TSQLRecord class type itself + Table: TSQLRecordClass; + /// the short name of the class + // - i.e. 'People' for TSQLRecordPeople + Name: string; + /// information about every published property + // - first is always the ID field + Prop: TSQLModelInfoPropInfoDynArray; + /// specifies the "simple" fields, i.e. all non BLOB fields + SimpleFields: TSQLFieldBits; + /// specifies the BLOB fields + BlobFields: TSQLFieldBits; + /// specifies all fields, including simple and BLOB fields + AllFields: TSQLFieldBits; + /// specifies the TModTime fields + ModTimeFields: TSQLFieldBits; + /// specifies the TCreateTime fields + CreateTimeFields: TSQLFieldBits; + /// specifies the TModTime and TCreateTime fields + ModAndCreateTimeFields: TSQLFieldBits; + /// specifies the Record fields + RecordFields: TSQLFieldBits; + /// specifies the Variant fields + VariantFields: TSQLFieldBits; + /// contains all published properties kind + HasKind: TSQLFieldKinds; + /// TRUE if has TModTime or TCreateTime fields + HasTimeFields: boolean; + {$ifdef ISSMS} + /// allow fast by-name access to Prop[] + PropCache: variant; + {$else} + /// finalize the memory used + destructor Destroy; override; + {$endif} + /// initialize the class member for the supplied TSQLRecord + constructor CreateFromRTTI(aTable: TSQLRecordClass); + /// FieldNames='' to retrieve simple fields, '*' all fields, or as specified + function FieldNamesToFieldBits(const FieldNames: string; + IncludeModTimeFields: boolean): TSQLFieldBits; + /// return the corresponding field names + function FieldBitsToFieldNames(const FieldBits: TSQLFieldBits): string; + /// set TModTime and TCreateFields + procedure ComputeFieldsBeforeWrite(aClient: TSQLRest; + Value: TSQLRecord; AndCreate: Boolean); + /// compute the 'SELECT ... FROM ...' corresponding to the supplied fields + function SQLSelect(const FieldNames: string): string; + /// save the specified record as JSON for record adding + function ToJSONAdd(Client: TSQLRest; Value: TSQLRecord; ForceID: boolean; + const FieldNames: string): string; + /// save the specified record as JSON for record update + function ToJSONUpdate(Client: TSQLRest; Value: TSQLRecord; + const FieldNames: string; ForceID: boolean): string; + /// save the specified record as JSON + function ToJSON(Value: TSQLRecord; const Fields: TSQLFieldBits): string; overload; + end; + + /// store information of several TSQLRecord class + TSQLModelInfoDynArray = array of TSQLModelInfo; + + /// store the database model + TSQLModel = class + protected + fRoot: string; + fInfo: TSQLModelInfoDynArray; + public + /// initialize the Database Model + // - set the Tables to be associated with this Model, as TSQLRecord classes + // - set the optional Root URI path of this Model - default is 'root' + constructor Create(const Tables: array of TSQLRecordClass; + const aRoot: string {$ifndef ISDWS}='root'{$endif}); + /// register a new Table class to this Model + procedure Add(Table: TSQLRecordClass); + {$ifndef ISSMS} + /// finalize the memory used + destructor Destroy; override; + {$endif} + /// get index of aTable in Tables[], returns -1 if not found + function GetTableIndex(aTable: TSQLRecordClass): integer; overload; + /// get index of aTable in Tables[], returns -1 if not found + function GetTableIndex(const aTableName: string): integer; overload; + /// get index of aTable in Tables[], raise an ERestException if not found + function GetTableIndexExisting(aTable: TSQLRecordClass): integer; + /// get the RTTI information for the specified class or raise an ERestException + function InfoExisting(aTable: TSQLRecordClass): TSQLModelInfo; + /// the RTTI information for each class + property Info: TSQLModelInfoDynArray read fInfo; + /// the Root URI path of this Database Model + property Root: string read fRoot; + end; + + {$ifdef ISSMS} + /// low-level structure used for server-side generated pseudo RTTI + TRTTIPropInfos = class + public + Props: TSQLModelInfoPropInfoDynArray; + PropCache: variant; + /// define the published properties + // - optional PropKinds[] can override default sftUnspecified type + constructor Create(const PropNames: array of string; + const PropKinds: array of TSQLFieldKind); + end; + {$endif} + + /// abstract ORM class to access remote tables + // - in comparison to mORMot.pas TSQLRecord published fields, dynamic arrays + // shall be defined as variant (since SynCrossPlatformJSON do not serialize) + // - inherit from TPersistent to have RTTI for its published properties + // (SmartMobileStudio does not allow {$M+} in the source) + TSQLRecord = class(TPersistent) + protected + fID: TID; + fInternalState: cardinal; + fFill: TSQLTableJSON; + {$ifdef ISSMS} + class function GetRTTI: TRTTIPropInfos; + /// you should override these methods + class function ComputeRTTI: TRTTIPropInfos; virtual; + procedure SetProperty(FieldIndex: integer; const Value: variant); virtual; + function GetProperty(FieldIndex: integer): variant; virtual; + {$endif} + public + /// this constructor initializes the record + constructor Create; overload; virtual; + /// this constructor loads a record from a REST instance from its ID + constructor Create(aClient: TSQLRest; aID: TID; + ForUpdate: boolean=false); overload; + /// this constructor loads a record from a REST instance + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + constructor Create(aClient: TSQLRest; const FieldNames, SQLWhere: string; + const BoundsSQLWhere: array of const); overload; + /// this constructor ask the server for a list of matching records + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + // - then you can also loop through all rows with + // ! while Rec.FillOne do + // ! dosomethingwith(Rec); + constructor CreateAndFillPrepare(aClient: TSQLRest; const FieldNames, + SQLWhere: string; const BoundsSQLWhere: array of const); + /// this constructor will loads a record from its variant representation + // - will call internaly the FromJSON() method + constructor CreateFromVariant(const aValue: variant); + /// finalize the record memory + destructor Destroy; override; + /// fill the specified record from the supplied JSON + function FromJSON(const aJSON: string): boolean; + /// fill the specified record from its variant representation + function FromVariant(const aValue: variant): boolean; + {$ifdef ISSMS} + /// fill the specified record from Names/Values pairs + function FromNamesValues(const Names: TStrArray; const Values: TVariantDynArray; + ValuesStartIndex: integer): boolean; + {$endif} + /// fill all published properties of this object with the next available + // row of data, as returned by CreateAndFillPrepare() constructor + function FillOne: boolean; + /// go to the first data row, as returned by CreateAndFillPrepare(), + // then fill all published properties of this object + // - you can use it e.g. as: + // ! while Rec.FillOne do + // ! dosomethingwith(Rec); + // ! if Rec.FillRewind then + // ! repeat + // ! dosomeotherthingwith(Rec); + // ! until not Rec.FillOne; + function FillRewind: boolean; + /// get the object properties as JSON + // - FieldNames='' to retrieve simple fields, '*' all fields, or as specified + function ToJSON(aModel: TSQLModel; aFieldNames: string=''): string; + /// get the object properties as a TJSONVariant document + function ToVariant: variant; + /// return the class type of this TSQLRecord + function RecordClass: TSQLRecordClass; + {$ifdef HASINLINE}inline;{$endif} + /// contains the TSQLTableJSON instance after CreateAndFillPrepare() + property FillTable: TSQLTableJSON read fFill; + /// internal state counter of the mORMot server at last access time + // - can be used to check if retrieved data may be out of date + property InternalState: cardinal read fInternalState; + published + /// stores the record's primary key + property ID: TID read fID write fID; + end; + + /// table containing the available user access rights for authentication + // - is added here since should be part of the model + // - no wrapper is available to handle AccessRights, since for security + // reasons it is not available remotely from client side + TSQLAuthGroup = class(TSQLRecord) + protected + fIdent: string; + fAccessRights: string; + fSessionTimeOut: integer; + {$ifdef ISSMS} + class function ComputeRTTI: TRTTIPropInfos; override; + procedure SetProperty(FieldIndex: integer; const Value: variant); override; + function GetProperty(FieldIndex: integer): variant; override; + {$endif} + published + /// the access right identifier, ready to be displayed + // - the same identifier can be used only once (this column is marked as + // unique via a "stored AS_UNIQUE" (i.e. "stored false") attribute) + property Ident: string read fIdent write fIdent + {$ifndef ISDWS}stored AS_UNIQUE{$endif}; + /// the number of minutes a session is kept alive + property SessionTimeout: integer read fSessionTimeOut write fSessionTimeOut; + /// a textual representation of a TSQLAccessRights buffer + property AccessRights: string read fAccessRights write fAccessRights; + end; + + /// class of the table containing the available user access rights for authentication + TSQLAuthGroupClass = class of TSQLAuthGroup; + + /// table containing the Users registered for authentication + TSQLAuthUser = class(TSQLRecord) + protected + fLogonName: string; + fPasswordHashHexa: string; + fDisplayName: string; + fData: TSQLRawBlob; + fGroup: TID; + {$ifdef ISSMS} + class function ComputeRTTI: TRTTIPropInfos; override; + procedure SetProperty(FieldIndex: integer; const Value: variant); override; + function GetProperty(FieldIndex: integer): variant; override; + {$endif} + procedure SetPasswordPlain(const Value: string); + public + /// able to set the PasswordHashHexa field from a plain password content + // - in fact, PasswordHashHexa := SHA256('salt'+PasswordPlain) in UTF-8 + property PasswordPlain: string write SetPasswordPlain; + published + /// the User identification Name, as entered at log-in + // - the same identifier can be used only once (this column is marked as + // unique via a "stored AS_UNIQUE" - i.e. "stored false" - attribute), and + // therefore indexed in the database (e.g. hashed in TSQLRestStorageInMemory) + property LogonName: string read fLogonName write fLogonName + {$ifndef ISDWS}stored AS_UNIQUE{$endif}; + /// the User Name, as may be displayed or printed + property DisplayName: string read fDisplayName write fDisplayName; + /// the hexa encoded associated SHA-256 hash of the password + property PasswordHashHexa: string read fPasswordHashHexa write fPasswordHashHexa; + /// the associated access rights of this user in TSQLAuthGroup + // - access rights are managed by group + // - note that 'Group' field name is not allowed by SQLite + property GroupRights: TID read fGroup write fGroup; + /// some custom data, associated to the User + // - Server application may store here custom data + // - its content is not used by the framework but 'may' be used by your + // application + property Data: TSQLRawBlob read fData write fData; + end; + + TSQLRestServerAuthentication = class; + + /// class used for client authentication + TSQLRestServerAuthenticationClass = class of TSQLRestServerAuthentication; + + /// the possible Server-side instance implementation patterns for + // interface-based services + // - each interface-based service will be implemented by a corresponding + // class instance on the server: this parameter is used to define how + // class instances are created and managed + // - on the Client-side, each instance will be handled depending on the + // server side implementation (i.e. with sicClientDriven behavior if necessary) + TServiceInstanceImplementation = ( + sicSingle, sicShared, sicClientDriven, sicPerSession, sicPerUser, sicPerGroup, + sicPerThread); + + TSQLRestClientURI = class; + + /// abstract ancestor to all client-side interface-based services + // - any overriden class will in fact call the server to execute its methods + // - inherited classes are in fact the main entry point for all interface-based + // services, without any interface use: + // ! aCalculator := TServiceCalculator.Create(aClient); + // ! try + // ! aIntegerResult := aCalculator.Add(10,20); + // ! finally + // ! aCalculator.Free; + // ! end; + // - under SmartMobileStudio, calling Free is mandatory only for + // sicClientDriven mode (to release the server-side associated session), + // so e.g. for a sicShared instance, you can safely write: + // ! aIntegerResult := TServiceCalculator.Create(aClient).Add(10,20); + // - as you already noted, server-side interface-based services are in fact + // consummed without any interface in this cross-platform unit! + TServiceClientAbstract = class{$ifndef ISDWS}(TInterfacedObject){$endif} + protected + fClient: TSQLRestClientURI; + fServiceName: string; + fServiceURI: string; + fInstanceImplementation: TServiceInstanceImplementation; + fContractExpected: string; + function GetClient: TSQLRestClientURI; + function GetContractExpected: string; + function GetInstanceImplementation: TServiceInstanceImplementation; + function GetRunningInstance: TServiceClientAbstract; + function GetServiceName: string; + function GetServiceURI: string; + public + /// initialize the fake instance + // - this method will synchronously (i.e. blocking) check the server + // contract according to the one expected by the client + // - overriden constructors will set the parameters expected by the server + constructor Create(aClient: TSQLRestClientURI); virtual; + /// the associated TSQLRestClientURI instance + property Client: TSQLRestClientURI read GetClient; + /// the unmangdled remote service name + property ServiceName: string read GetServiceName; + /// the URI to access to the remote service + property ServiceURI: string read GetServiceURI; + /// how this instance lifetime is expected to be handled + property InstanceImplementation: TServiceInstanceImplementation read GetInstanceImplementation; + /// the published service contract, as expected by both client and server + property ContractExpected: string read GetContractExpected; + end; + + {$ifndef ISDWS} + /// all generated client interfaces will inherit from this abstract parent + IServiceAbstract = interface + ['{06F02DCC-0DD1-4961-A5F4-C11AE375F03B}'] + function GetClient: TSQLRestClientURI; + function GetContractExpected: string; + function GetInstanceImplementation: TServiceInstanceImplementation; + function GetRunningInstance: TServiceClientAbstract; + function GetServiceName: string; + function GetServiceURI: string; + /// the associated TSQLRestClientURI instance + property Client: TSQLRestClientURI read GetClient; + /// the unmangdled remote service name + property ServiceName: string read GetServiceName; + /// the URI to access to the remote service + property ServiceURI: string read GetServiceURI; + /// how this instance lifetime is expected to be handled + property InstanceImplementation: TServiceInstanceImplementation read GetInstanceImplementation; + /// the published service contract, as expected by both client and server + property ContractExpected: string read GetContractExpected; + /// the client class instance currently implementing this interface + property RunningInstance: TServiceClientAbstract read GetRunningInstance; + end; + {$endif} + + /// abstract ancestor to all sicClientDriven interface-based services + // - since server-side life-time is driven by the client, this kind of class + // expects an explicit call to aService.Free (even on SmartMobileStudio) + TServiceClientAbstractClientDriven = class(TServiceClientAbstract) + protected + fClientID: string; + public + /// initialize the fake instance and create the remote per-client session + // - raise an EServiceException if a per-client session was already started + // for the specified TSQLRestClientURI + // - overriden constructors will set the parameters expected by the server + constructor Create(aClient: TSQLRestClientURI); override; + /// this overriden method (called at aService.Free) will notify the server + destructor Destroy; override; + /// the currently running instance ID on the server side + // - only one instance is allowed per TSQLRestClientURI process + property ClientID: string read fClientID; + end; + + /// class type used to identify an interface-based service + // - we do not rely on interfaces here, but simply on abstract classes + TServiceClientAbstractClass = class of TServiceClientAbstract; + + /// class used to determine the protocol of interface-based services + // - see TSQLRestRoutingREST and TSQLRestRoutingJSON_RPC + // for overridden methods - NEVER set this abstract TSQLRestRoutingAbstract + // class on TSQLRest.ServicesRouting property ! + TSQLRestRoutingAbstract = class + public + /// at Client Side, compute URI and BODY according to the routing scheme + // - abstract implementation which is to be overridden + // - as input, "method" should be the method name to be executed for "uri", + // "params" should contain the incoming parameters as JSON array (with []), + // and "clientDriven" ID should contain the optional Client ID value + // - at output, should update the HTTP "uri" corresponding to the proper + // routing, and should return the corresponding HTTP body within "sent" + class procedure ClientSideInvoke(var uri: string; + const method, params, clientDrivenID: string; var sent: string); virtual; abstract; + end; + + /// used to define the protocol of interface-based services + TSQLRestRoutingAbstractClass = class of TSQLRestRoutingAbstract; + + /// default simple REST protocol for interface-based services + // - this is the default protocol used by TSQLRest + TSQLRestRoutingREST = class(TSQLRestRoutingAbstract) + public + /// at Client Side, compute URI and BODY according to RESTful routing scheme + // - e.g. on input uri='root/Calculator', method='Add', params='[1,2]' and + // clientDrivenID='1234' -> on output uri='root/Calculator.Add/1234' and + // sent='[1,2]' + class procedure ClientSideInvoke(var uri: string; + const method, params, clientDrivenID: string; var sent: string); override; + end; + + /// JSON/RPC protocol for interface-based services + // - alternative to the TSQLRestRoutingREST default protocol set by TSQLRest + TSQLRestRoutingJSON_RPC = class(TSQLRestRoutingAbstract) + public + /// at Client Side, compute URI and BODY according to JSON/RPC routing scheme + // - e.g. on input uri='root/Calculator', method='Add', params='[1,2]' and + // clientDrivenID='1234' -> on output uri='root/Calculator' and + // sent={"method":"Add","params":[1,2],"id":1234} + class procedure ClientSideInvoke(var uri: string; + const method, params, clientDrivenID: string; var sent: string); override; + end; + + /// the available options for TSQLRest.BatchStart() process + // - boInsertOrIgnore will create 'INSERT OR IGNORE' statements instead of + // plain 'INSERT' - by now, only direct SQLite3 engine supports it on server + TSQLRestBatchOption = ( + boInsertOrIgnore); + + /// a set of options for TSQLRest.BatchStart() process + TSQLRestBatchOptions = set of TSQLRestBatchOption; + + {$ifdef ISSMS} + /// callback used e.g. by TSQLRestClientURI.Connect() overloaded method + TSQLRestEvent = procedure(Client: TSQLRestClientURI); + + /// callback which should return TRUE on process success, or FALSE on error + TSQLRestEventProcess = function: boolean; + + {$else} + TSQLRestLogClientThread = class; + {$endif ISSMS} + + + /// abstract REST access class + TSQLRest = class + protected + fModel: TSQLModel; + fServerTimeStampOffset: TDateTime; + fBatch: string; + fBatchTable: TSQLRecordClass; + fBatchCount: integer; + fServicesRouting: TSQLRestRoutingAbstractClass; + fInternalState: cardinal; + fOwnModel: boolean; + fLogLevel: TSynLogInfos; + fOnLog: TOnSQLRestLog; + {$ifdef ISSMS} + fLogClient: TSQLRestClientURI; + procedure LogToRemoteServerText(const Text: string); + {$else} + fLogClient: TSQLRestLogClientThread; + fLogFileBuffer: array of byte; + fLogFile: system.text; + procedure LogToFileText(const Text: string); + {$endif} + procedure LogClose; + function GetServerTimeStamp: TTimeLog; + function SetServerTimeStamp(const ServerResponse: string): boolean; + function InternalBatch(Table: TSQLRecordClass; const CMD: string; var Info: TSQLModelInfo): Integer; + function ExecuteAdd(tableIndex: integer; const json: string): TID; virtual; abstract; + function ExecuteUpdate(tableIndex: integer; ID: TID; const json: string): boolean; virtual; abstract; + function ExecuteBatchSend(Table: TSQLRecordClass; const Data: string; + var Results: TIDDynArray): integer; virtual; abstract; + public + /// initialize the class, and associate it to a specified database Model + // - if aOwnModel is TRUE, this class destructor will free aModel instance + constructor Create(aModel: TSQLModel; aOwnModel: boolean=false); virtual; + /// will release the associated Model, if aOwnModel was TRUE at Create() + destructor Destroy; override; + + /// get a member from its ID + // - return true on success, and fill all simple fields + function Retrieve(aID: TID; Value: TSQLRecord; + ForUpdate: boolean=false): boolean; overload; virtual; abstract; + /// get a member from a where clause + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + function Retrieve(const FieldNames, SQLWhere: string; + const BoundsSQLWhere: array of const; Value: TSQLRecord): boolean; overload; + {$ifndef ISSMS} + /// get a blob field content from its record ID and supplied blob field name + // - returns true on success, and the blob binary data + function RetrieveBlob(Table: TSQLRecordClass; aID: TID; + const BlobFieldName: string; out BlobData: TSQLRawBlob): boolean; virtual; abstract; + {$endif} + /// execute directly a SQL statement, expecting a list of results + // - return a result table on success, nil on failure + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + function MultiFieldValues(Table: TSQLRecordClass; const FieldNames, + SQLWhere: string; const BoundsSQLWhere: array of const; + LimitFirstRow: Boolean=false): TSQLTableJSON; overload; + /// execute directly a SQL statement, expecting a list of results + // - return a result table on success, nil on failure + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + function MultiFieldValues(Table: TSQLRecordClass; const FieldNames, + SQLWhere: string): TSQLTableJSON; overload; + /// execute directly a SQL statement, returning a list of TSQLRecord + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + function RetrieveList(Table: TSQLRecordClass; const FieldNames, + SQLWhere: string; const BoundsSQLWhere: array of const): TObjectList; overload; + /// execute directly a SQL statement, returning a list of data rows or nil + function ExecuteList(const SQL: string): TSQLTableJSON; virtual; abstract; + {$ifdef ISDELPHI2010} // Delphi 2009 generics support is buggy :( + /// execute directly a SQL statement, returning a generic list of TSQLRecord + // - you can bind parameters by using ? in the SQLWhere clause + // - use DateTimeToSQL() for date/time database fields + // - FieldNames='' retrieve simple fields, '*' all fields, or as specified + function RetrieveList(const FieldNames, SQLWhere: string; const BoundsSQLWhere: array of const): TObjectList; overload; + {$endif} + + /// create a new member, returning the newly created ID, or 0 on error + // - if SendData is true, content of Value is sent to the server as JSON + // - if ForceID is true, client sends the Value.ID field to use this ID for + // adding the record (instead of a database-generated ID) + // - by default, only simple fields are pushed to the server, but you may + // specify a CSV list of field values to be transmitted - including blobs, + // which will be sent as base-64 encoded JSON + function Add(Value: TSQLRecord; SendData: boolean; ForceID: boolean=false; + FieldNames: string=''): TID; virtual; + /// delete a member + function Delete(Table: TSQLRecordClass; ID: TID): boolean; virtual; abstract; + /// update a member + // - you can let default FieldNames='' to update simple fields, '*' to + // update all fields (including BLOBs), or specify a CSV list of updated fields + function Update(Value: TSQLRecord; FieldNames: string=''): boolean; virtual; + + /// begin a BATCH sequence to speed up huge database change + // - then call BatchAdd(), BatchUpdate() or BatchDelete() methods with the + // proper class or instance of the + // - at BatchSend call, all the sequence transactions will be sent at once + // - at BatchAbort call, all operations will be aborted + // - expect one TSQLRecordClass as parameter, which will be used for the whole + // sequence (in this case, you can't mix classes in the same BATCH sequence) + // - if no TSQLRecordClass is supplied, the BATCH sequence will allow any + // kind of individual record in BatchAdd/BatchUpdate/BatchDelete + // - return TRUE on success, FALSE if aTable is incorrect or a previous BATCH + // sequence was already initiated + // - this method includes a AutomaticTransactionPerRow parameter, which will + // let all BATCH process be executed on the server side within an unique + // transaction grouped by the given number of rows + function BatchStart(aTable: TSQLRecordClass; + AutomaticTransactionPerRow: cardinal=10000; + BatchOptions: TSQLRestBatchOptions=[]): boolean; virtual; + /// create a new member in current BATCH sequence + // - similar to Add(), but in BATCH mode: nothing is sent until BatchSend() + // - returns the corresponding index in the current BATCH sequence, -1 on error + // - you can set FieldNames='' to sent simple fields, '*' to add all fields + // (including BLOBs), or specify a CSV list of added fields + // - this method will always compute and send TCreateTime/TModTime fields + function BatchAdd(Value: TSQLRecord; SendData: boolean; ForceID: boolean=false; + FieldNames: string=''): integer; + /// update a member in current BATCH sequence + // - similar to Update(), but in BATCH mode: nothing is sent until BatchSend() + // - returns the corresponding index in the current BATCH sequence, -1 on error + // - you can set FieldNames='' to sent simple fields, '*' to add all fields + // (including BLOBs), or specify a CSV list of added fields + // - this method will always compute and send any TModTime fields + function BatchUpdate(Value: TSQLRecord; FieldNames: string=''): integer; + /// delete a member in current BATCH sequence + // - similar to Delete(), but in BATCH mode: nothing is sent until BatchSend() + // - returns the corresponding index in the current BATCH sequence, -1 on error + // - deleted record class is the TSQLRecordClass used at BatchStart() + // call: it will fail if no class was specified for this BATCH sequence + function BatchDelete(ID: TID): integer; overload; + /// delete a member in current BATCH sequence + // - similar to Delete(), but in BATCH mode: nothing is sent until BatchSend() + // - returns the corresponding index in the current BATCH sequence, -1 on error + // - with this overloaded method, the deleted record class is specified: + // no class shall have been set at BatchStart() call, or should be the same + function BatchDelete(Table: TSQLRecordClass; ID: TID): integer; overload; + /// delete a member in current BATCH sequence + // - similar to Delete(), but in BATCH mode: nothing is sent until BatchSend() + // - returns the corresponding index in the current BATCH sequence, -1 on error + function BatchDelete(Value: TSQLRecord): integer; overload; + /// retrieve the current number of pending transactions in the BATCH sequence + // - every call to BatchAdd/Update/Delete methods increases this count + function BatchCount: integer; + /// execute a BATCH sequence started by BatchStart() method + // - send all pending BatchAdd/Update/Delete statements to the remote server + // - will return the URI Status value, i.e. 200/HTTP_SUCCESS OK on success + // - a dynamic array of 64 bit integers will be created in Results, + // containing all ROWDID created for each BatchAdd call, or 200 + // (=HTTP_SUCCESS) for all successfull BatchUpdate/BatchDelete, or 0 on error + // - any error during server-side process MUST be checked against Results[] + // (the main URI Status is 200 if about communication success, and won't + // imply that all statements in the BATCH sequence were successfull + function BatchSend(var Results: TIDDynArray): integer; + /// abort a BATCH sequence started by BatchStart() method + // - in short, nothing is sent to the remote server, and sequence is voided + procedure BatchAbort; + + /// call this method to add some information to the log at a specified level + // - the supplied log level will be checked against TSQLRest.LogLevel + // - if Instance is set, it will log the corresponding class name and address + // - will compute the text line in the very same format as TSynLog class + // - use LogToFile() or LogToRemoteServer() to set the OnLog callback + procedure Log(Level: TSynLogInfo; const Text: string; Instance: TObject=nil); overload; + /// call this method to add some information to the log at a specified level + // - overloaded method which will call Format() to render the text + // - here the Fmt layout is e.g. '%s %d %g', as standard Format(), and not + // the same as with SynCommons' FormatUTF8() + // - the supplied log level will be checked against TSQLRest.LogLevel + // - if Instance is set, it will log the corresponding class name and address + // - use LogToFile() or LogToRemoteServer() to set the OnLog callback + procedure Log(Level: TSynLogInfo; const Fmt: string; const Args: array of const; + Instance: TObject=nil); overload; + /// call this method to add some information to the log at a specified level + // - overloaded method which will log the corresponding class name and address + // - the supplied log level will be checked against TSQLRest.LogLevel + // - use LogToFile() or LogToRemoteServer() to set the OnLog callback + procedure Log(Level: TSynLogInfo; Instance: TObject); overload; + /// call this method to add some information to the log for an Exception + // - will log the Exception class name and message, if sllExecption is set + procedure Log(E: Exception); overload; + {$ifdef ISSMS} + /// start the logging process into a remote log server + // - the server could be for instance a LogView tool running in server mode + procedure LogToRemoteServer(LogLevel: TSynLogInfos; + const aServer: string; aPort: integer=8091; aRoot: string='LogService'); + {$else} + /// start the logging process into a file + // - if no directory is specified, will use the current one + // - if no file name is supplied, will compute a new one with the current + // time stamp, in the specified directory + procedure LogToFile(LogLevel: TSynLogInfos; + const aFolderName: TFileName=''; const aFileName: TFileName=''); + /// start the logging process into a remote log server + // - the server could be for instance a LogView tool running in server mode + procedure LogToRemoteServer(LogLevel: TSynLogInfos; + const aServer: string; aPort: integer=8091; const aRoot: string='LogService'); + {$endif} + + /// the associated data model + property Model: TSQLModel read fModel; + /// the set of log events which will be logged by Log() overloaded methods + // - set to [] by default, meaning that log is disabled + property LogLevel: TSynLogInfos read fLogLevel write fLogLevel; + /// the callback to be executed by Log() overloaded methods + // - if none is set, the instance won't log anything + property OnLog: TOnSQLRestLog read fOnLog write fOnLog; + /// the current Date and Time, as retrieved from the server at connection + property ServerTimeStamp: TTimeLog read GetServerTimeStamp; + /// internal state counter of the mORMot server at last access time + // - can be used to check if retrieved data may be out of date + property InternalState: cardinal read fInternalState; + /// the access protocol to be used for interface-based services + // - is set to TSQLRestRoutingREST by default + // - you can set TSQLRestRoutingJSON_RPC if the server expects this protocol + property ServicesRouting: TSQLRestRoutingAbstractClass read fServicesRouting; + end; + + /// REST client access class + TSQLRestClientURI = class(TSQLRest) + protected + fAuthentication: TSQLRestServerAuthentication; + fOnlyJSONRequests: boolean; + fRunningClientDriven: TStringList; + {$ifdef ISSMS} + fAsynchCount: integer; + fAsynchPendingText: array of string; + procedure SetAsynchText(const Text: string); + procedure CallAsynchText; + /// connect to the REST server, and retrieve its time stamp offset + // - under SMS, you SHOULD use this asynchronous method, which won't block + // the browser, e.g. if the network is offline + procedure SetAsynch(var Call: TSQLRestURIParams; onSuccess, onError: TSQLRestEvent; + onBeforeSuccess: TSQLRestEventProcess); + {$endif} + function getURI(aTable: TSQLRecordClass): string; + function getURIID(aTableExistingIndex: integer; aID: TID): string; + function getURICallBack(const aMethodName: string; aTable: TSQLRecordClass; aID: TID): string; + function ExecuteAdd(tableIndex: integer; const json: string): TID; override; + function ExecuteUpdate(tableIndex: integer; ID: TID; const json: string): boolean; override; + function ExecuteBatchSend(Table: TSQLRecordClass; const Data: string; + var Results: TIDDynArray): integer; override; + procedure InternalURI(var Call: TSQLRestURIParams); virtual; abstract; + procedure InternalStateUpdate(const Call: TSQLRestURIParams); + procedure CallRemoteServiceInternal(var Call: TSQLRestURIParams; + aCaller: TServiceClientAbstract; const aMethod, aParams: string); + procedure InternalServiceCheck(const aMethodName: string; + const Call: TSQLRestURIParams); + public + {$ifndef ISSMS} + /// initialize the class, and associate it to a specified database Model + // - if aOwnModel is TRUE, this class destructor will free aModel instance + constructor Create(aModel: TSQLModel; aOwnModel: boolean=false); override; + {$endif} + /// will call SessionClose + destructor Destroy; override; + + {$ifdef ISSMS} + /// connect to the REST server, and retrieve its time stamp offset + // - under SMS, only this asynchronous method is available, which won't + // block the browser, e.g. if the network is offline + // - code sample using two lambda functions may be: + // ! client := TSQLRestClientHTTP.Create(ServerAddress.Text,888,model,false); + // ! client.Connect( + // ! lambda + // ! if client.ServerTimeStamp=0 then + // ! ShowMessage('Impossible to retrieve server time stamp') else + // ! writeln('ServerTimeStamp='+IntToStr(client.ServerTimeStamp)); + // ! if not client.SetUser(TSQLRestServerAuthenticationDefault,LogonName.Text,LogonPassWord.Text) then + // ! ShowMessage('Authentication Error'); + // ! writeln('Safely connected with SessionID='+IntToStr(client.Authentication.SessionID)); + // ! people := TSQLRecordPeople.Create(client,1); // blocking request + // ! assert(people.ID=1); + // ! writeln('Disconnect from server'); + // ! client.Free; + // ! end, + // ! lambda + // ! ShowMessage('Impossible to connect to the server'); + // ! end); + procedure Connect(onSuccess, onError: TSQLRestEvent); + {$else} + /// connect to the REST server, and retrieve its time stamp offset + // - under SMS, you should not use this blocking version, but + // the overloaded asynchronous method + function Connect: boolean; + {$endif ISSMS} + /// method calling the remote Server via a RESTful command + // - calls the InternalURI abstract method + // - this method will sign the url, if authentication is enabled + procedure URI(var Call: TSQLRestURIParams); virtual; + /// get a member from its ID using URI() + function Retrieve(aID: TID; Value: TSQLRecord; + ForUpdate: boolean=false): boolean; overload; override; + {$ifndef ISSMS} + /// get a blob field content from its record ID and supplied blob field name + // - returns true on success, and the blob binary data, as direclty + // retrieved from the server via a dedicated HTTP GET request + function RetrieveBlob(Table: TSQLRecordClass; aID: TID; + const BlobFieldName: string; out BlobData: TSQLRawBlob): boolean; override; + {$endif} + /// execute directly a SQL statement, returning a list of rows or nil + // - we expect reUrlEncodedSQL to be defined in AllowRemoteExecute on + // server side, since we will encode the SQL at URL level, so that all + // HTTP client libraires will accept this layout (e.g. Indy or AJAX) + function ExecuteList(const SQL: string): TSQLTableJSON; override; + /// delete a member + function Delete(Table: TSQLRecordClass; ID: TID): boolean; override; + + /// wrapper to the protected URI method to call a method on the server + // - perform a ModelRoot/[TableName/[ID/]]MethodName RESTful GET request + // - if no Table is expected, set aTable=nil (we do not define nil as + // default parameter, since the SMS compiler is sometimes confused) + procedure CallBackGet(const aMethodName: string; + const aNameValueParameters: array of const; var Call: TSQLRestURIParams; + aTable: TSQLRecordClass; aID: TID=0); + /// decode "result":... content as returned by CallBackGet() + // - if no Table is expected, set aTable=nil (we do not define nil as + // default parameter, since the SMS compiler is sometimes confused) + function CallBackGetResult(const aMethodName: string; + const aNameValueParameters: array of const; + aTable: TSQLRecordClass; aID: TID=0): string; + /// authenticate an User to the current connected Server + // - using TSQLRestServerAuthenticationDefault or TSQLRestServerAuthenticationNone + // - will set Authentication property on success + function SetUser(aAuthenticationClass: TSQLRestServerAuthenticationClass; + const aUserName, aPassword: string; aHashedPassword: Boolean=False): boolean; + /// close the session initiated with SetUser() + // - will reset Authentication property to nil + procedure SessionClose; + + {$ifdef ISSMS} + /// asynchronous execution a specified interface-based service method on the server + // - under SMS, this asynchronous method won't block the browser, e.g. if + // the network is offline + // - you should not call it, but directly TServiceClient* methods + procedure CallRemoteServiceAsynch(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; + onSuccess: procedure(res: array of Variant); onError: TSQLRestEvent; + aReturnsCustomAnswer: boolean=false); + /// synchronous execution a specified interface-based service method on the server + // - under SMS, this synchronous method would block the browser, e.g. if + // the network is offline, or the server is late to answer + // - but synchronous code is somewhat easier to follow than asynchronous + // - you should not call it, but directly TServiceClient* methods + function CallRemoteServiceSynch(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; aReturnsCustomAnswer: boolean=false): TVariantDynArray; + {$else} + /// execute a specified interface-based service method on the server + // - this blocking method would raise an EServiceException on error + // - you should not call it, but directly TServiceClient* methods + procedure CallRemoteService(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; out res: TVariantDynArray; + aReturnsCustomAnswer: boolean=false); + {$endif ISSMS} + /// set this property to TRUE if the server expects only APPLICATION/JSON + // - applies only for AJAX clients (i.e. SmartMobileStudio platform) + // - true will let any remote call be identified as "preflighted requests", + // so will send an OPTIONS method prior to any request: may be twice slower + // - the default is false, as in TSQLHttpServer.OnlyJSONRequests + property OnlyJSONRequests: boolean read fOnlyJSONRequests write fOnlyJSONRequests; + /// if not nil, point to the current authentication session running + property Authentication: TSQLRestServerAuthentication read fAuthentication; + end; + + {$ifndef ISSMS} + TSQLRestClientHTTP = class; + + /// thread used to asynchronously log to a remote client + TSQLRestLogClientThread = class(TThread) + protected + fOwner: TSQLRest; + fOnLog: TOnSQLRestLog; + fClient: TSQLRestClientHTTP; + fLock: TMutex; + fPending: string; + procedure Execute; override; + public + /// initialize the thread + constructor Create(Owner: TSQLRest; + const aServer: string; aPort: integer; const aRoot: string); + /// log one line of text + procedure LogToRemoteServerText(const Text: string); + /// finalize the thread + destructor Destroy; override; + end; + {$endif ISSMS} + + /// abstract class used for client authentication + TSQLRestServerAuthentication = class + protected + fUser: TSQLAuthUser; + fSessionID: cardinal; + fSessionIDHexa8: string; + procedure SetSessionID(Value: Cardinal); + // override this method to return the session key + function ClientComputeSessionKey(Sender: TSQLRestClientURI): string; + virtual; abstract; + function ClientSessionComputeSignature(Sender: TSQLRestClientURI; + const url: string): string; virtual; abstract; + public + /// initialize client authentication instance, i.e. the User associated instance + constructor Create(const aUserName, aPassword: string; + aHashedPassword: Boolean=false); + /// finalize the instance + destructor Destroy; override; + /// read-only access to the logged user information + // - only LogonName and PasswordHashHexa are set here + property User: TSQLAuthUser read fUser; + /// contains the session ID used for the authentication + property SessionID: cardinal read fSessionID; + end; + + /// mORMot secure RESTful authentication scheme + TSQLRestServerAuthenticationDefault = class(TSQLRestServerAuthentication) + protected + fSessionPrivateKey: hash32; + function ClientComputeSessionKey(Sender: TSQLRestClientURI): string; override; + function ClientSessionComputeSignature(Sender: TSQLRestClientURI; + const url: string): string; override; + end; + + /// mORMot weak RESTful authentication scheme + TSQLRestServerAuthenticationNone = class(TSQLRestServerAuthentication) + protected + function ClientComputeSessionKey(Sender: TSQLRestClientURI): string; override; + function ClientSessionComputeSignature(Sender: TSQLRestClientURI; + const url: string): string; override; + end; + + /// REST client via HTTP + // - note that this implementation is not thread-safe yet + TSQLRestClientHTTP = class(TSQLRestClientURI) + protected + fConnection: TAbstractHttpConnection; + fParameters: TSQLRestConnectionParams; + fKeepAlive: Integer; + fCustomHttpHeader: RawUTF8; // e.g. for SetHttpBasicAuthHeaders() + fForceTerminate: Boolean; + procedure InternalURI(var Call: TSQLRestURIParams); override; + public + /// access to a mORMot server via HTTP + constructor Create(const aServer: string; aPort: integer; aModel: TSQLModel; + aOwnModel: boolean=false; aHttps: boolean=false + {$ifndef ISSMS}; const aProxyName: string=''; + const aProxyByPass: string=''; aSendTimeout: Cardinal=30000; + aReceiveTimeout: Cardinal=30000; aConnectionTimeOut: cardinal=30000{$endif}); + reintroduce; virtual; + /// finalize the connection + destructor Destroy; override; + /// force the HTTP headers of any request to contain some HTTP BASIC + // authentication, without creating any remote session + // - here the password should be given as clear content + // - potential use case is to use a mORMot client through a HTTPS proxy + // - then you can use SetUser(TSQLRestServerAuthenticationDefault,...) to + // define any another "mORMot only" authentication + procedure SetHttpBasicAuthHeaders(const aUserName, aPasswordClear: RawUTF8); + + /// the associated connection, if active + property Connection: TAbstractHttpConnection read fConnection; + /// the connection parameters + property Parameters: TSQLRestConnectionParams read fParameters; + {$ifndef ISSMS} + /// the keep-alive timeout, in ms (20000 by default) + property KeepAlive: Integer read fKeepAlive write fKeepAlive; + {$endif ISSMS} + end; + +const + /// \uFFF1 special code to mark ISO-8601 SQLDATE in JSON + // - e.g. '"\uFFF12012-05-04"' pattern + // - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes + // - as generated by DateTimeToSQL/TimeLogToSQL functions, and expected by + // our mORMot server + // - should be used with BoundsSQLWhere parameters, e.g. with FormatBind() + {$ifdef UNICODE} + JSON_SQLDATE_MAGIC = #$fff1; + {$else} + {$ifdef ISSMS} + JSON_SQLDATE_MAGIC = #$fff1; + {$else} + JSON_SQLDATE_MAGIC = #$ef#$bf#$b1; + {$endif} + {$endif} + + var + /// can be set to TSQLRest.LogLevel in order to log all available events + LOG_VERBOSE: TSynLogInfos; + + /// contains the logging levels for which stack trace should be dumped + // - which are mainly exceptions or application errors + LOG_STACKTRACE: TSynLogInfos; + + /// the text equivalency of each logging level, as written in the log content + // - and expected by TSynLog and our LogView tool + LOG_LEVEL_TEXT: array[TSynLogInfo] of string = ( + ' ', ' info ', ' debug ', ' trace ', ' warn ', ' ERROR ', + ' + ', ' - ', + ' OSERR ', ' EXC ', ' EXCOS ', ' mem ', ' stack ', ' fail ', + ' SQL ', ' cache ', ' res ', ' DB ', ' http ', ' clnt ', ' srvr ', + ' call ', ' ret ', ' auth ', + ' cust1 ', ' cust2 ', ' cust3 ', ' cust4 ', ' rotat ', ' dddER ', ' dddIN '); + + +/// true if PropName is either 'ID' or 'RowID' +function IsRowID(const PropName: string): boolean; + {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// can be used to create a statement with inlined parameters +// - use DateTimeToSQL() for date/time database fields +function FormatBind(const SQLWhere: string; + const BoundsSQLWhere: array of const): string; + +/// compute a TTimeLog value from Delphi date/time type +function DateTimeToTTimeLog(Value: TDateTime): TTimeLog; + +/// convert a TTimeLog value into the Delphi date/time type +function TTimeLogToDateTime(Value: TTimeLog): TDateTime; + +/// convert a TTimeLog value into an ISO-8601 encoded date/time text +function TTimeLogToIso8601(Value: TTimeLog): string; + +/// returns a string with 2 digits +// - the supplied value should be in 0..99 range +function ToDigit2(value: integer): string; + +/// returns a string with 4 digits +// - the supplied value should be in 0..9999 range +function ToDigit4(value: integer): string; + +/// convert a date/time to a ISO-8601 string format for SQL '?' inlined parameters +// - if DT=0, returns '' +// - if DT contains only a date, returns the date encoded as '\uFFF1YYYY-MM-DD' +// - if DT contains only a time, returns the time encoded as '\uFFF1Thh:mm:ss' +// - otherwise, returns the ISO-8601 date and time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' +// - to be used e.g. as in: +// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[DateTimeToSQL(Now)]); +// - see TimeLogToSQL() if you are using TTimeLog/TModTime/TCreateTime values +function DateTimeToSQL(DT: TDateTime): string; + +/// convert a TTimeLog value into a ISO-8601 string format for SQL '?' inlined +// parameters +// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e. +// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' +function TimeLogToSQL(const TimeStamp: TTimeLog): string; + +/// convert a base-64 encoded blob into its binary representation +function VariantToBlob(const Value: variant): TSQLRawBlob; + +/// convert a binary blob into its base-64 representation +function BlobToVariant(const Blob: TSQLRawBlob): variant; + +/// convert a string value into a TGUID instance +function VariantToGUID(const value: variant): TGUID; + +/// convert a TGUID instance into a string value +function GUIDToVariant(const GUID: TGUID): variant; + +/// convert a variant value into a THttpBody binary +// - will use a variant of type string as mean of proprietary raw binary storage: +// format is limited to HttpBodyToVariant() conversion +function VariantToHttpBody(const value: variant): THttpBody; + +/// convert a THttpBody binary content into a variant value +// - will use a variant of type string as mean of proprietary raw binary storage: +// you need to use VariantToHttpBody() to get the value back from the variant +function HttpBodyToVariant(const HttpBody: THttpBody): variant; + +/// convert a text or integer enumeration representation into its ordinal value +function VariantToEnum(const Value: variant; const TextValues: array of string): integer; + +/// convert any TSQLRecord class instance into a TJSONVariant type +function ObjectToVariant(value: TSQLRecord): variant; + +/// hash the supplied text values after UTF-8 encoding +// - as expected by the framework server +function SHA256Compute(const Values: array of string): string; + +/// encode a text as defined by RFC 3986 +function UrlEncode(const aValue: string): string; overload; + +/// encode name=value pairs as defined by RFC 3986 +function UrlEncode(const aNameValueParameters: array of const): string; overload; + +/// decode a text as defined by RFC 3986 +function UrlDecode(const aValue: string): string; + +/// retrieve one header from a low-level HTTP response +// - use e.g. location := GetOutHeader(Call,'location'); +function GetOutHeader(const Call: TSQLRestURIParams; const Name: string): string; + +const + /// the first field in TSQLFieldBits is always ID/RowID + ID_SQLFIELD: TSQLFieldBit = TSQLFieldBit(0); + +var + /// contains no field bit set + NO_SQLFIELDBITS: TSQLFieldBits; + + +implementation + +{$ifdef ISDWS} +function VarIsValidRef(const aRef: Variant): Boolean; +begin + asm + @Result = !((@aRef == null) || (@aRef == undefined)); + end; +end; +{$endif} +function IsRowID(const PropName: string): boolean; +begin + result := IdemPropName(PropName,'ID') or + IdemPropName(PropName,'RowID'); +end; + +function FormatBind(const SQLWhere: string; + const BoundsSQLWhere: array of const): string; +var tmpIsString: Boolean; + tmp: string; + i,deb,arg,maxArgs,SQLWhereLen: integer; +{$ifdef ISSMS} + args: variant; // open parameters are not a true array in JavaScript +begin + asm + @args=@BoundsSQLWhere; + end; + maxArgs := args.length-1; +{$else} +begin + maxArgs := high(BoundsSQLWhere); +{$endif} + result := ''; + arg := 0; + deb := 1; + i := 1; // we need i after then main loop -> do not use for i := 1 to ... + SQLWhereLen := length(SQLWhere); + while i<=SQLWhereLen do + if SQLWhere[i]='?' then begin + result := result+copy(SQLWhere,deb,i-deb)+':('; + if arg>maxArgs then + tmp := 'null' else begin + tmp := VarRecToValue( + {$ifdef ISSMS}args{$else}BoundsSQLWhere{$endif}[arg],tmpIsString); + if tmpIsString then + DoubleQuoteStr(tmp); + inc(arg); + end; + result := result+tmp+'):'; + inc(i); + deb := i; + end else + inc(i); + result := result+copy(SQLWhere,deb,i-deb); +end; + +function DateTimeToTTimeLog(Value: TDateTime): TTimeLog; +var HH,MM,SS,MS,Y,M,D: word; + {$ifndef ISSMS} + V: Int64; + {$endif} +begin + DecodeTime(Value,HH,MM,SS,MS); + DecodeDate(Value,Y,M,D); + {$ifdef ISSMS} // JavaScript truncates to 32 bit binary + result := SS+MM*$40+(HH+D*$20+M*$400+Y*$4000-$420)*$1000; + {$else} + V := HH+D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10); + result := SS+MM shl 6+V shl 12; + {$endif} +end; + +function TTimeLogToDateTime(Value: TTimeLog): TDateTime; +var Y: cardinal; + Time: TDateTime; +begin + {$ifdef ISSMS} // JavaScript truncates to 32 bit binary + Y := (Value div $4000000) and 4095; + {$else} + Y := (Value shr (6+6+5+5+4)) and 4095; + {$endif} + if (Y=0) or not TryEncodeDate(Y,1+(Value shr (6+6+5+5)) and 15, + 1+(Value shr (6+6+5)) and 31{$ifdef ISSMS},DateTimeZone.UTC{$endif},result) then + result := 0; + if (Value and (1 shl (6+6+5)-1)<>0) and + TryEncodeTime((Value shr (6+6)) and 31, + (Value shr 6) and 63,Value and 63, 0, Time) then + result := result+Time; +end; + +function TTimeLogToIso8601(Value: TTimeLog): string; +begin + result := DateTimeToIso8601(TTimeLogToDateTime(Value)); +end; + +function DateTimeToSQL(DT: TDateTime): string; +begin + result := JSON_SQLDATE_MAGIC+DateTimeToIso8601(DT); +end; + +function TimeLogToSQL(const TimeStamp: TTimeLog): string; +begin + result := JSON_SQLDATE_MAGIC+TTimeLogToIso8601(TimeStamp); +end; + +function ToDigit2(value: integer): string; +begin + if value<=0 then + result := '00' else + if value>99 then + result := '99' else + result := chr(48+value div 10)+chr(48+value mod 10); +end; + +function ToDigit4(value: integer): string; +begin + if value<=0 then + result := '0000' else + if value>9999 then + result := '9999' else + result := ToDigit2(value div 100)+ToDigit2(value mod 100); +end; + +function UrlEncode(const aValue: string): string; overload; +{$ifdef ISSMS} inline; +begin // see http://www.w3schools.com/jsref/jsref_encodeuricomponent.asp + result := encodeURIComponent(aValue); +end; +{$else} +const + HexChars: array[0..15] of string = ( + '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); +var i,c: integer; + utf8: TUTF8Buffer; +begin + result := ''; + {$ifdef NEXTGEN} + utf8 := TEncoding.UTF8.GetBytes(aValue); + for i := 0 to high(utf8) do begin + {$else} + utf8 := UTF8Encode(aValue); + for i := 1 to length(utf8) do begin + {$endif} + c := ord(utf8[i]); + case c of + ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'), + ord('_'),ord('-'),ord('.'),ord('~'): + AppendChar(result,char(c)); + ord(' '): AppendChar(result,'+'); + else result := result+'%'+HexChars[c shr 4]+HexChars[c and $F]; + end; // see rfc3986 2.3. Unreserved Characters + end; +end; +{$endif} + +function UrlEncode(const aNameValueParameters: array of const): string; overload; +var n,a: integer; + name,value: string; + {$ifdef ISSMS} + temp: variant; + {$else} + wasString: Boolean; + i: integer; + {$endif} +begin + result := ''; +{$ifdef ISSMS} // open parameters are not a true array in JavaScript + asm + @temp=@aNameValueParameters; + end; + n := temp.length; + if n>1 then begin + for a := 0 to (n-1)shr 1 do begin + name := temp[a*2]; + value := temp[a*2+1]; +{$else} + n := high(aNameValueParameters); + if n>0 then begin + for a := 0 to n div 2 do begin + name := VarRecToValue(aNameValueParameters[a*2],wasString); + for i := 1 to length(name) do + if not (ord(name[i]) in [ord('a')..ord('z'),ord('A')..ord('Z')]) then + raise ERestException.CreateFmt( + 'UrlEncode() expect alphabetic names, not "%s"',[name]); + value := VarRecToValue(aNameValueParameters[a*2+1],wasString); +{$endif} + result := result+'&'+name+'='+UrlEncode(value); + end; + end; + if result<>'' then + result[1] := '?'; +end; + +function HexDecode(a,b: char): integer; +var ai,bi: integer; +begin + ai := Pos(upcase(a),'0123456789ABCDEF')-1; + bi := Pos(upcase(b),'0123456789ABCDEF')-1; + if (ai<0) or (bi<0) then + result := ord('?') else + result := ai shl 4+bi; +end; + +function UrlDecode(const aValue: string): string; +{$ifdef ISSMS} +begin + result := decodeURIComponent(aValue); +end; +{$else} +var i,c,n,len: integer; + utf8: TUTF8Buffer; +begin + i := 1; + len := length(aValue); + n := 0; + SetLength(utf8,len); + while i<=length(aValue) do begin + {$ifndef NEXTGEN} // TUTF8Buffer = UTF8String is [1-based] + inc(n); + {$endif} + c := ord(aValue[i]); + case c of + ord('+'): + utf8[n] := AnsiChar(' '); + ord('%'): begin + if i+2<=len then + utf8[n] := AnsiChar(HexDecode(aValue[i+1],aValue[i+2])) else + utf8[n] := AnsiChar('?'); + inc(i,2); + end; + else if c>127 then + utf8[n] := AnsiChar('?') else + utf8[n] := AnsiChar(c); + end; + inc(i); + {$ifdef NEXTGEN} // TUTF8Buffer = TBytes is [0-based] + inc(n); + {$endif} + end; + SetLength(utf8,n); + {$ifdef NEXTGEN} + result := TEncoding.UTF8.GetString(utf8); + {$else} + {$ifdef UNICODE} + result := UTF8ToString(utf8); + {$else} + result := Utf8Decode(utf8); + {$endif} + {$endif} +end; +{$endif ISSMS} + + +{ TSQLRecord } + +{$ifdef ISSMS} + +constructor TRTTIPropInfos.Create(const PropNames: array of string; + const PropKinds: array of TSQLFieldKind); +var name: string; + p: integer; + prop: TSQLModelInfoPropInfo; +begin + prop := new TSQLModelInfoPropInfo; + prop.Name := 'RowID'; // first Field is RowID + Props.Add(prop); + for name in PropNames do begin + prop := new TSQLModelInfoPropInfo; + prop.Name := name; + Props.Add(prop); + end; + PropCache := new JObject; + for p := 0 to high(Props) do begin + prop := Props[p]; + prop.FieldIndex := TSQLFieldBit(p); + if (p>0) and (p<=length(PropKinds)) then + prop.Kind := PropKinds[p-1] else + prop.Kind := sftUnspecified; + PropCache[uppercase(prop.Name)] := prop; + end; +end; + +function Find(PropCache: variant; Name: string; var Info: TSQLModelInfoPropInfo): boolean; inline; +begin + Name := UpperCase(Name); + if Name='ID' then + Name := 'ROWID'; + var nfo: TSQLModelInfoPropInfo; + asm + @nfo=@PropCache[@Name]; + end; + result := VarIsValidRef(nfo); + Info := nfo; +end; + +var + RTTI_Cache: variant = new JObject; + +{$HINTS OFF} +class function TSQLRecord.GetRTTI: TRTTIPropInfos; +begin // use RTTI_Cache as global dictionary of all TSQLRecord's RTTI + var res = RTTI_Cache[ClassName]; + if VarIsValidRef(res) then asm + @result=@res; + end else begin + result := ComputeRTTI; + RTTI_Cache[ClassName] := result; + end; +end; +{$HINTS ON} + +class function TSQLRecord.ComputeRTTI: TRTTIPropInfos; +begin + result := TRTTIPropInfos.Create([],[]); +end; + +procedure TSQLRecord.SetProperty(FieldIndex: integer; const Value: variant); +begin + case FieldIndex of + 0: fID := Value; + end; +end; + +function TSQLRecord.GetProperty(FieldIndex: integer): variant; +begin + case FieldIndex of + 0: result := fID; + end; +end; + +{$endif ISSMS} + +constructor TSQLRecord.Create; +begin + // do nothing by now: inherited classes may set some properties +end; + +constructor TSQLRecord.Create(aClient: TSQLRest; aID: TID; + ForUpdate: boolean=false); +begin + Create; + if aClient<>nil then + aClient.Retrieve(aID,self,ForUpdate); +end; + +constructor TSQLRecord.Create(aClient: TSQLRest; + const FieldNames, SQLWhere: string; const BoundsSQLWhere: array of const); +begin + Create; + if aClient<>nil then + aClient.Retrieve(FieldNames,SQLWhere,BoundsSQLWhere,self); +end; + +constructor TSQLRecord.CreateAndFillPrepare(aClient: TSQLRest; + const FieldNames, SQLWhere: string; + const BoundsSQLWhere: array of const); +begin + Create; + fFill := aClient.MultiFieldValues(RecordClass,FieldNames,SQLWhere,BoundsSQLWhere); +end; + +destructor TSQLRecord.Destroy; +begin + fFill.Free; // may help even with SMS (marking objects as Garbage Collect) + inherited; +end; + +function TSQLRecord.RecordClass: TSQLRecordClass; +begin + if self=nil then + result := nil else + result := TSQLRecordClass(ClassType); +end; + +function TSQLRecord.FillOne: boolean; +begin + if (self=nil) or (fFill=nil) then + result := false else + result := fFill.FillOne(self); +end; + +function TSQLRecord.FillRewind: boolean; +begin + if (self=nil) or (fFill=nil) then + result := false else + result := fFill.FillOne(self,true); +end; + +{$ifdef ISSMS} + +function TSQLRecord.FromNamesValues(const Names: TStrArray; + const Values: TVariantDynArray; ValuesStartIndex: integer): boolean; +var i: integer; + info: TSQLModelInfoPropInfo; + rtti: TRTTIPropInfos; +begin + result := false; + if ValuesStartIndex+length(Names)>length(Values) then + exit; + rtti := GetRTTI; + for i := 0 to high(Names) do + if Find(rtti.PropCache,Names[i],info) then + SetProperty(info.FieldIndex,Values[i+ValuesStartIndex]) else + exit; + result := true; +end; + +{$endif} + +function TSQLRecord.FromJSON(const aJSON: string): boolean; +var doc: TJSONVariantData; + table: TSQLTableJSON; + {$ifndef ISSMS} + i: Integer; + {$endif} +begin + if (self=nil) or (aJSON='') then + result := false else + if StartWithPropName(aJSON,'{"fieldCount":') then begin + table := TSQLTableJSON.Create(aJSON); // non expanded format + try + result := table.FillOne(self); + finally + table.Free; + end; + end else begin // expanded format + {$ifdef ISSMS} + doc := TJSONVariantData.Create(aJSON); + result := FromNamesValues(doc.Names,doc.Values,0); + {$else} + doc.Init(aJSON); + for i := 0 to doc.Count-1 do + if IsRowID(doc.Names[i]) then + doc.Names[i] := 'ID'; + result := doc.ToObject(self); + {$endif} + end; +end; + +constructor TSQLRecord.CreateFromVariant(const aValue: variant); +begin + Create; + FromVariant(aValue); +end; + +function TSQLRecord.FromVariant(const aValue: variant): boolean; +begin + result := FromJSON(ValueToJSON(aValue)); +end; + +function TSQLRecord.ToJSON(aModel: TSQLModel; aFieldNames: string=''): String; +var nfo: TSQLModelInfo; +begin + if self=nil then + result := 'null' else begin + nfo := aModel.InfoExisting(RecordClass); + result := nfo.ToJSON(self,nfo.FieldNamesToFieldBits(aFieldNames,false)); + end; +end; + +function TSQLRecord.ToVariant: variant; +begin + if self=nil then + result := null else begin + {$ifdef ISSMS} + result := new JObject; + var rtti := GetRTTI; + for var f := 0 to high(rtti.Props) do + result[rtti.Props[f].Name] := GetProperty(f); + {$else} + result := JSONVariant(ObjectToJSON(self)); + {$endif} + end; +end; + + +{ TSQLTableJSON } + +{$ifdef ISDWS} // circumvent weird DWS / SMS syntax + +constructor TSQLTableJSON.Create(const aJSON: string); +begin + var dat = JSON.Parse(aJSON); + case VariantType(dat) of + jvObject: begin + // non expanded format: {"fieldCount":2,"values":["ID","Int",1,0,2,0,3,...] + fFieldCount := dat.fieldCount; + var values := dat.values; + if VariantType(values)<>jvArray then + exit; + asm + @fValues=@values; + end; + var n = fValues.Count; + if (n0) then + exit; + for var i := 0 to fFieldCount-1 do + fFieldNames.Add(string(fValues[i])); + fRowCount := (n div fFieldCount)-1; + end; + jvArray: begin + // expanded format: [{"ID":1,"Int":0},{"ID":2,"Int":0},{"ID":3,...] + asm + @fValues=@dat; + end; + fRowCount := fValues.Count; + end; + end; + if fRowCount>0 then + fCurrentRow := 1; +end; + +function TSQLTableJSON.FillOne(Value: TSQLRecord; SeekFirst: boolean=false): boolean; +begin + result := false; + if (Value=nil) or (fRowCount=0) then + exit; + if SeekFirst then + fCurrentRow := 1 else + if fCurrentRow>fRowCount then + exit; + if fFieldNames.Count>0 then begin + // non expanded format + result := Value.FromNamesValues(fFieldNames,fValues,fCurrentRow*fFieldCount); + end else begin + // expanded format + var doc := TJSONVariantData.CreateFrom(fValues[fCurrentRow-1]); + result := Value.FromNamesValues(doc.Names,doc.Values,0); + end; + inc(fCurrentRow); + if result then + Value.fInternalState := fInternalState; +end; + +{$else} + +function TSQLTableJSON.FillOne(aValue: TSQLRecord; aSeekFirst: boolean): boolean; +begin + result := StepObject(aValue,aSeekFirst); + if result then + aValue.fInternalState := fInternalState; +end; + +function TSQLTableJSON.GetPropInfo(aTypeInfo: TRTTITypeInfo; + const PropName: string): TRTTIPropInfo; +begin + result := inherited GetPropInfo(aTypeInfo,PropName); + if (result=nil) and IdemPropName(PropName,'RowID') then + result := inherited GetPropInfo(aTypeInfo,'ID'); +end; + + +{ TSQLModelInfoPropInfo } + +constructor TSQLModelInfoPropInfo.CreateFrom(aRTTI: TRTTIPropInfo); +begin + RTTI := aRTTI; + TypeName := RTTIPropInfoTypeName(RTTI); + case RTTI^.PropType^.Kind of + tkRecord: Kind := sftRecord; + tkVariant: Kind := sftVariant; + else + if TypeName='TByteDynArray' then + Kind := sftBlob else + if TypeName='TDateTime' then + Kind := sftDateTime else + if TypeName='TCreateTime' then + Kind := sftCreateTime else + if TypeName='TModTime' then + Kind := sftModTime; + end; +end; + +{$endif ISDWS} + + +{ TSQLModelInfo } + +procedure TSQLModelInfo.ComputeFieldsBeforeWrite(aClient: TSQLRest; + Value: TSQLRecord; AndCreate: Boolean); +var f: TSQLFieldBit; + fields: TSQLFieldBits; + TimeStamp: Int64; +begin + if (Value=nil) or not HasTimeFields then + exit; + if AndCreate then + fields := ModAndCreateTimeFields else + fields := ModTimeFields; + TimeStamp := aClient.ServerTimeStamp; + for f := 0 to length(Prop)-1 do + if f in fields then + {$ifdef ISSMS} + Value.SetProperty(ord(f),TimeStamp); + {$else} + SetInstanceProp(Value,Prop[f].RTTI,TimeStamp); + {$endif} +end; + +function GetDisplayNameFromClass(C: TClass): string; +begin + if C=nil then + result := '' else begin + result := C.ClassName; + if IdemPropName(copy(result,1,4),'TSQL') then + if IdemPropName(copy(result,5,6),'Record') then + delete(result,1,10) else + delete(result,1,4) else + if result[1]='T' then + delete(result,1,1); + end; +end; + +constructor TSQLModelInfo.CreateFromRTTI(aTable: TSQLRecordClass); +var f: TSQLFieldBit; + Kind: TSQLFieldKind; +{$ifdef ISDWS} + rtti: TRTTIPropInfos; +{$else} + List: TRTTIPropInfoDynArray; + Names: TStringDynArray; +{$endif} +begin + Table := aTable; + Name := GetDisplayNameFromClass(Table); + {$ifdef ISDWS} + rtti := aTable.GetRTTI; + Prop := rtti.Props; + PropCache := rtti.PropCache; + {$else} + GetPropsInfo(Table.ClassInfo,Names,List); + SetLength(Prop,length(List)); + for f := 0 to high(List) do begin + Prop[f] := TSQLModelInfoPropInfo.CreateFrom(List[f]); + if f=0 then + Prop[f].Name := 'RowID' else + Prop[f].Name := Names[f]; + end; + {$endif} + for f := 0 to TSQLFieldBit(high(Prop)) do begin + include(AllFields,f); + Kind := Prop[ord(f)].Kind; + include(HasKind,Kind); + if Kind=sftBlob then + Include(BlobFields,f) else + Include(SimpleFields,f); + case Kind of + sftModTime: begin + include(ModTimeFields,f); + include(ModAndCreateTimeFields,f); + HasTimeFields := true; + end; + sftCreateTime: begin + include(CreateTimeFields,f); + include(ModAndCreateTimeFields,f); + HasTimeFields := true; + end; + sftRecord: + include(RecordFields,f); + sftVariant: + include(VariantFields,f); + end; + end; +end; + +{$ifndef ISSMS} + +destructor TSQLModelInfo.Destroy; +var i: integer; +begin + inherited; + for i := 0 to Length(Prop)-1 do + Prop[i].Free; +end; + +{$endif} + +function TSQLModelInfo.FieldBitsToFieldNames( + const FieldBits: TSQLFieldBits): string; +var f: TSQLFieldBit; +begin + result := ''; + for f := 0 to length(Prop)-1 do + if f in FieldBits then + result := result+Prop[ord(f)].Name+','; + if result<>'' then + SetLength(result,length(result)-1); +end; + +function TSQLModelInfo.FieldNamesToFieldBits(const FieldNames: string; + IncludeModTimeFields: boolean): TSQLFieldBits; +var i: integer; + f: TSQLFieldBit; + field: string; +begin + if FieldNames='' then + result := SimpleFields else + if FieldNames='*' then + result := AllFields else begin + result := NO_SQLFIELDBITS; + i := 1; + while GetNextCSV(FieldNames,i,field,',',true) do begin + {$ifdef ISSMS} + var Info: TSQLModelInfoPropInfo; + if Find(PropCache,field,info) then + include(result,info.FieldIndex); + {$else} + if IsRowID(field) then + Include(result,ID_SQLFIELD) else + for f := 1 to length(Prop)-1 do + if IdemPropName(field,Prop[ord(f)].Name) then begin + include(result,f); + break; + end; + {$endif} + end; + {$ifdef ISSMS} + if IncludeModTimeFields and (sftModTime in HasKind) then + for f := 1 to length(Prop)-1 do + if f in ModTimeFields then + include(result,f); + {$else} + if IncludeModTimeFields then + result := result+ModTimeFields; + {$endif} + end; +end; + +function TSQLModelInfo.SQLSelect(const FieldNames: string): string; +begin + result := 'select '+FieldBitsToFieldNames(FieldNamesToFieldBits( + FieldNames,false))+' from '+Name; +end; + +function TSQLModelInfo.ToJSON(Value: TSQLRecord; const Fields: TSQLFieldBits): string; +var f: TSQLFieldBit; +begin +{$ifdef ISSMS} + if Value=nil then + exit('null'); + var doc: variant := new JObject; + for f := 0 to length(Prop)-1 do + if f in Fields then + doc[Prop[ord(f)].Name] := Value.GetProperty(f); + result := JSON.Stringify(doc); // rely on JavaScript serialization +{$else} + result := '{'; + for f := 0 to length(Prop)-1 do + if f in Fields then + result := result+'"'+Prop[ord(f)].Name+'":'+ + ValueToJSON(GetInstanceProp(Value,Prop[f].RTTI))+','; + if result='{' then + result := 'null' else + result[Length(Result)] := '}'; +{$endif} +end; + +function TSQLModelInfo.ToJSONAdd(Client: TSQLRest; + Value: TSQLRecord; ForceID: boolean; const FieldNames: string): string; +var Fields: TSQLFieldBits; +begin + ComputeFieldsBeforeWrite(Client,Value,true); + fields := FieldNamesToFieldBits(FieldNames,true); + if not ForceID then + exclude(fields,ID_SQLFIELD); + result := ToJSON(Value,fields); +end; + +function TSQLModelInfo.ToJSONUpdate(Client: TSQLRest; Value: TSQLRecord; + const FieldNames: string; ForceID: boolean): string; +var Fields: TSQLFieldBits; +begin + fields := FieldNamesToFieldBits(FieldNames,true); + if ForceID then + include(fields,ID_SQLFIELD) else + exclude(fields,ID_SQLFIELD); + ComputeFieldsBeforeWrite(Client,Value,false); + result := ToJSON(Value,fields); +end; + + +{ TSQLModel } + +procedure TSQLModel.Add(Table: TSQLRecordClass); +var n,i: integer; + nfo: TSQLModelInfo; +begin + n := length(fInfo); + for i := 0 to n-1 do + if fInfo[i].Table=Table then + raise ERESTException.CreateFmt('%s registered twice',[Table.ClassName]); + nfo := TSQLModelInfo.CreateFromRTTI(Table); + {$ifdef ISSMS} + fInfo.Add(nfo); + {$else} + SetLength(fInfo,n+1); + fInfo[n] := nfo; + {$endif} +end; + +constructor TSQLModel.Create(const Tables: array of TSQLRecordClass; + const aRoot: string); +var t: integer; +begin + {$ifdef ISSMS} + for t := 0 to high(Tables) do + fInfo.Add(TSQLModelInfo.CreateFromRTTI(Tables[t])); + {$else} + SetLength(fInfo,length(Tables)); + for t := 0 to high(fInfo) do + fInfo[t] := TSQLModelInfo.CreateFromRTTI(Tables[t]); + {$endif} + if aRoot<>'' then + if aRoot[length(aRoot)]='/' then + fRoot := copy(aRoot,1,Length(aRoot)-1) else + fRoot := aRoot; +end; + +function TSQLModel.GetTableIndex(aTable: TSQLRecordClass): integer; +begin + if self<>nil then + for result := 0 to High(fInfo) do + if fInfo[result].Table=aTable then + exit; + result := -1; +end; + +{$ifndef ISSMS} + +destructor TSQLModel.Destroy; +var i: integer; +begin + inherited; + for i := 0 to high(fInfo) do + fInfo[i].Free; +end; + +{$endif} + +function TSQLModel.InfoExisting(aTable: TSQLRecordClass): TSQLModelInfo; +begin + result := Info[GetTableIndexExisting(aTable)]; +end; + +function TSQLModel.GetTableIndex(const aTableName: string): integer; +begin + if self<>nil then + for result := 0 to High(fInfo) do + if IdemPropName(fInfo[result].Name,aTableName) then + exit; + result := -1; +end; + +function TSQLModel.GetTableIndexExisting(aTable: TSQLRecordClass): integer; +begin + if self=nil then + result := -1 else + result := GetTableIndex(aTable); + if result<0 then + raise ERestException.CreateFmt('%s should be part of the Model', + [aTable.ClassName]); +end; + +{ TSQLRest } + +constructor TSQLRest.Create(aModel: TSQLModel; aOwnModel: boolean); +begin + inherited Create; + fModel := aModel; + fOwnModel := aOwnModel; + fServicesRouting := TSQLRestRoutingREST; +end; + +destructor TSQLRest.Destroy; +begin + Log(sllInfo,'Destroy',self); + inherited; + if fOwnModel then + fModel.Free; + LogClose; +end; + +function TSQLRest.MultiFieldValues(Table: TSQLRecordClass; + const FieldNames, SQLWhere: string; const BoundsSQLWhere: array of const; + LimitFirstRow: Boolean): TSQLTableJSON; +var where: string; +begin + where := FormatBind(SQLWhere,BoundsSQLWhere); + if LimitFirstRow then + where := where+' limit 1'; + result := MultiFieldValues(Table,FieldNames,where); +end; + +function TSQLRest.GetServerTimeStamp: TTimeLog; +begin + if fServerTimeStampOffset=0 then + result := 0 else + result := DateTimeToTTimeLog(Now+fServerTimeStampOffset); +end; + +function TSQLRest.SetServerTimeStamp(const ServerResponse: string): boolean; +var TimeStamp: Int64; +begin + if not TryStrToInt64(ServerResponse,TimeStamp) then + result := false else begin + fServerTimeStampOffset := TTimeLogToDateTime(TimeStamp)-Now; + if fServerTimeStampOffset=0 then + fServerTimeStampOffset := 0.000001; // ensure <> 0 (indicates error) + result := true; + end; +end; + +function TSQLRest.MultiFieldValues(Table: TSQLRecordClass; + const FieldNames, SQLWhere: string): TSQLTableJSON; +var sql: string; +begin + sql := Model.InfoExisting(Table).SQLSelect(FieldNames); + if SQLWhere<>'' then + sql := sql+' where '+SQLWhere; + result := ExecuteList(sql); +end; + +function TSQLRest.Retrieve(const FieldNames,SQLWhere: string; + const BoundsSQLWhere: array of const; Value: TSQLRecord): boolean; +var table: TSQLTableJSON; +begin + table := MultiFieldValues(Value.RecordClass,FieldNames, + SQLWhere,BoundsSQLWhere,true); + if table=nil then + result := false else + try + result := table.FillOne(Value); + finally + table.Free; + end; +end; + +function TSQLRest.RetrieveList(Table: TSQLRecordClass; const FieldNames, + SQLWhere: string; const BoundsSQLWhere: array of const): TObjectList; +var rows: TSQLTableJSON; + rec: TSQLRecord; +begin + {$ifndef ISSMS} // result is already created as "array of TObject" + result := TObjectList.Create; + {$endif} + rows := MultiFieldValues(Table,FieldNames,SQLWhere,BoundsSQLWhere); + if rows<>nil then + try + repeat + rec := Table.Create; + if not rows.FillOne(rec) then begin + rec.Free; + break; + end; + result.Add(rec); + until false; + finally + rows.Free; + end; +end; + +{$ifdef ISDELPHI2010} +function TSQLRest.RetrieveList(const FieldNames, SQLWhere: string; + const BoundsSQLWhere: array of const): TObjectList; +var rows: TSQLTableJSON; + rec: TSQLRecord; +begin + result := TObjectList.Create; // TObjectList will free each T instance + rows := MultiFieldValues(TSQLRecordClass(T),FieldNames,SQLWhere,BoundsSQLWhere); + if rows<>nil then + try + repeat + rec := TSQLRecordClass(T).Create; + if not rows.FillOne(rec) then begin + rec.Free; + break; + end; + result.Add(rec); + until false; + finally + rows.Free; + end; +end; +{$endif} + +function TSQLRest.Add(Value: TSQLRecord; SendData, ForceID: boolean; + FieldNames: string): TID; +var tableIndex: Integer; + json: string; +begin + tableIndex := Model.GetTableIndexExisting(Value.RecordClass); + if SendData then + json := Model.Info[tableIndex].ToJSONAdd(self,Value,ForceID,FieldNames); + result := ExecuteAdd(tableIndex,json); + if result>0 then + Value.fInternalState := InternalState; +end; + +function TSQLRest.Update(Value: TSQLRecord; FieldNames: string): boolean; +var tableIndex: Integer; + json: string; +begin + if (Value=nil) or (Value.ID<=0) then begin + result := false; + exit; + end; + tableIndex := Model.GetTableIndexExisting(Value.RecordClass); + json := Model.Info[tableIndex].ToJSONUpdate(self,Value,FieldNames,false); + result := ExecuteUpdate(tableIndex,Value.ID,json); + if result then + Value.fInternalState := InternalState; +end; + +function TSQLRest.BatchStart(aTable: TSQLRecordClass; + AutomaticTransactionPerRow: cardinal; BatchOptions: TSQLRestBatchOptions): boolean; +begin + if (fBatchCount<>0) or (fBatch<>'') or (AutomaticTransactionPerRow<=0) then begin + result := false; // already opened BATCH sequence + exit; + end; + if aTable<>nil then // sent as '{"Table":["cmd",values,...]}' + fBatch := '{"'+Model.InfoExisting(aTable).Name+'":'; + fBatch := Format('%s["automaticTransactionPerRow",%d,"options",%d,', + [fBatch,AutomaticTransactionPerRow,byte(BatchOptions)]); + fBatchTable := aTable; + result := true; +end; + +function TSQLRest.InternalBatch(Table: TSQLRecordClass; const CMD: string; + var Info: TSQLModelInfo): Integer; +begin + result := -1; + if (self=nil) or (Table=nil) or (fBatch='') then + exit; // invalid parameters, or not opened BATCH sequence + Info := Model.InfoExisting(Table); + if fBatchTable<>nil then + if fBatchTable<>Table then + exit else + fBatch := fBatch+CMD+'",' else + fBatch := fBatch+CMD+'@'+Info.Name+'",'; + result := fBatchCount; + inc(fBatchCount); +end; + +function TSQLRest.BatchAdd(Value: TSQLRecord; SendData: boolean; ForceID: boolean; + FieldNames: string): integer; +var info: TSQLModelInfo; +begin + result := InternalBatch(Value.RecordClass,'"POST',info); + if result>=0 then + if not SendData then + fBatch := fBatch+'{},' else + fBatch := fBatch+info.ToJSONAdd(self,Value,ForceID,FieldNames)+','; +end; + +function TSQLRest.BatchUpdate(Value: TSQLRecord; FieldNames: string): integer; +var info: TSQLModelInfo; +begin + if (Value=nil) or (Value.ID<=0) then + result := -1 else begin + result := InternalBatch(Value.RecordClass,'"PUT',info); + if result>=0 then + fBatch := fBatch+info.ToJSONUpdate(self,Value,FieldNames,true)+','; + end; +end; + +function TSQLRest.BatchDelete(Table: TSQLRecordClass; ID: TID): integer; +var info: TSQLModelInfo; +begin + if ID<=0 then + result := -1 else begin + result := InternalBatch(Table,'"DELETE',info); + if result>=0 then + fBatch := fBatch+IntToStr(ID)+','; + end; +end; + +function TSQLRest.BatchDelete(ID: TID): integer; +begin + result := BatchDelete(fBatchTable,ID); +end; + +function TSQLRest.BatchDelete(Value: TSQLRecord): integer; +begin + result := BatchDelete(Value.RecordClass,Value.ID); +end; + +function TSQLRest.BatchCount: integer; +begin + if self=nil then + result := 0 else + result := fBatchCount; +end; + +function TSQLRest.BatchSend(var Results: TIDDynArray): integer; +begin + if (self=nil) or (fBatch='') then + result := HTTP_BADREQUEST else + try + if BatchCount>0 then begin + fBatch[length(fBatch)] := ']'; + if fBatchTable<>nil then + fBatch := fBatch+'}'; + result := ExecuteBatchSend(fBatchTable,fBatch,Results); + end else + result := HTTP_SUCCESS; // nothing to send + finally + BatchAbort; + end; +end; + +procedure TSQLRest.BatchAbort; +begin + if self=nil then + exit; + fBatchCount := 0; + fBatchTable := nil; + fBatch := ''; +end; + +procedure TSQLRest.Log(Level: TSynLogInfo; const Text: string; Instance: TObject); +procedure DoLog; +var line: string; + Value: TDateTime; + HH,MM,SS,MS,Y,M,D: word; + {$ifndef ISSMS} + i: integer; + {$endif} +begin + // compute the line as expected by TSynLog / LogView + Value := Now; + DecodeTime(Value,HH,MM,SS,MS); + DecodeDate(Value,Y,M,D); + line := ToDigit4(Y)+ToDigit2(M)+ToDigit2(D)+' '+ToDigit2(HH)+ToDigit2(MM)+ + ToDigit2(SS)+ToDigit2(MS shr 4)+LOG_LEVEL_TEXT[Level]; + if Assigned(Instance) then + line := line+Instance.ClassName+ + {$ifdef ISSMS}' ';{$else}'('+IntToHex( + {$ifdef CPU64}Int64(Instance),16{$else}cardinal(Instance),8{$endif})+') '; + {$endif} + line := line+Text; + // ensure no CR/LF in the output row + {$ifdef ISSMS} + line := line.Replace(#10,' ').Replace(#13,' '); + {$else} + for i := 1 to length(line) do + if ord(line[i])<32 then + line[i] := ' '; + {$endif} + // line output + fOnLog(line); +end; +begin + if Assigned(self) and Assigned(fOnLog) and (Level in fLogLevel) then + DoLog; +end; + +procedure TSQLRest.Log(Level: TSynLogInfo; const Fmt: string; const Args: array of const; + Instance: TObject); +begin + if Assigned(self) and Assigned(fOnLog) and (Level in fLogLevel) then + Log(Level,Format(Fmt,Args),Instance); +end; + +procedure TSQLRest.Log(Level: TSynLogInfo; Instance: TObject); +begin + if Assigned(self) and Assigned(fOnLog) and (Level in fLogLevel) then + Log(Level,'',Instance); +end; + +procedure TSQLRest.Log(E: Exception); +begin + if Assigned(self) and Assigned(fOnLog) and (sllException in fLogLevel) then begin + {$ifdef ISSMS} + var msg: string; + asm @msg = new Error().stack; end; + Log(sllException,'%s raised with message "%s" %s',[E.ClassName,E.Message,msg]); + {$else} + Log(sllException,'%s raised with message "%s"',[E.ClassName,E.Message]); + {$endif} + end; +end; + +{$ifdef ISSMS} + +procedure TSQLRest.LogToRemoteServer(LogLevel: TSynLogInfos; + const aServer: string; aPort: integer; aRoot: string); +var Call: TSQLRestURIParams; + userAgent: string; +begin + LogClose; + fLogClient := TSQLRestClientHTTP.Create(aServer,aPort,TSQLModel.Create([],aRoot),true); + fLogClient.CallBackGet('TimeStamp',[],Call,nil); // synchronous connection + if Call.OutStatus=HTTP_SUCCESS then begin + fLogLevel := LogLevel; + OnLog := LogToRemoteServerText; + asm @userAgent = navigator.userAgent; end; + Log(sllClient,'Remote Cross-Platform Client Connected from AJAX app '+userAgent); + end else + LogClose; +end; + +procedure TSQLRest.LogToRemoteServerText(const Text: string); +begin + if fLogClient<>nil then + fLogClient.SetAsynchText(Text); +end; + +{$else} + +constructor TSQLRestLogClientThread.Create(Owner: TSQLRest; + const aServer: string; aPort: integer; const aRoot: string); +begin + fLock := TMutex.Create; + fOwner := Owner; + fClient := TSQLRestClientHTTP.Create(aServer,aPort, + TSQLModel.Create([],aRoot),true,false,'','',10000,10000,500); + fOwner.OnLog := {$ifdef FPC}@{$endif}LogToRemoteServerText; + inherited Create(false); +end; + +destructor TSQLRestLogClientThread.Destroy; +begin + if fOwner.fLogClient=Self then begin + fOwner.fLogClient := nil; + fOwner.fOnlog := nil; + end; + fClient.fForceTerminate := true; + inherited Destroy; + fClient.Free; + fLock.Free; +end; + +procedure TSQLRestLogClientThread.LogToRemoteServerText(const Text: string); +begin + if self=nil then + exit; // avoid GPF + fLock.Enter; + if fPending='' then + fPending := Text else + fPending := fPending+#13#10+Text; + fLock.Leave; +end; + +procedure TSQLRestLogClientThread.Execute; +var exeName, data: string; + Call: TSQLRestURIParams; +begin + if not fClient.Connect then + exit; + fOwner.OnLog := {$ifdef FPC}@{$endif}LogToRemoteServerText; + exeName := paramstr(0); + if exeName='' then + exeName := 'non Windows platform'; + fOwner.Log(sllClient,'Remote Cross-Platform Client %s Connected from %s', + [ClassName,exeName]); + while not Terminated do begin + sleep(10); + if Terminated then + break; + fLock.Enter; + data := fPending; + fPending := ''; + fLock.Leave; + if data='' then + continue; + Call.Init(fClient.getURICallBack('RemoteLog',nil,0),'PUT',data); + fClient.URI(Call); + end; +end; + +procedure TSQLRest.LogToRemoteServer(LogLevel: TSynLogInfos; + const aServer: string; aPort: integer; const aRoot: string); +begin + LogClose; + fLogLevel := LogLevel; + fLogClient := TSQLRestLogClientThread.Create(self,aServer,aPort,aRoot); +end; + +procedure TSQLRest.LogToFile(LogLevel: TSynLogInfos; const aFolderName,aFileName: TFileName); +var FN: TFileName; +begin + LogClose; + if aFolderName<>'' then + FN := IncludeTrailingPathDelimiter(aFolderName); + if aFileName<>'' then + if ExtractFileExt(aFileName)='' then + FN := FN+aFileName+'.log' else + FN := FN+aFileName else + FN := FN+FormatDateTime('yyyymmddhhnnss',Now)+'.log'; + try + AssignFile(fLogFile,FN); + SetLength(fLogFileBuffer,4096); + system.SetTextBuf(fLogFile,fLogFileBuffer[0],4096); + Rewrite(fLogFile); + Writeln(fLogFile,paramstr(0),' 0.0.0.0 (',DateTimeToIso8601(Date),')'); + Writeln(fLogFile,'Host=Unknown User=Unknown CPU=Unknown OS=0.0=0.0.0 Wow64=0 Freq=1'); + Writeln(fLogFile,'TSQLRest 1.18 CrossPlatform ',NowToIso8601,#13#10); + fLogLevel := LogLevel; + OnLog := {$ifdef FPC}@{$endif}LogToFileText; + except + on E: Exception do + Finalize(fLogFileBuffer); + end; +end; + +procedure TSQLRest.LogToFileText(const Text: string); +begin + if fLogFileBuffer<>nil then + writeln(fLogFile,Text); +end; + +{$endif ISSMS} + +procedure TSQLRest.LogClose; +begin + fLogLevel := []; + fOnLog := nil; + {$ifdef ISSMS} + if fLogClient<>nil then begin + fLogClient.CallAsynchText; // send NOW any pending log + fLogClient.Free; + fLogClient := nil; + end; + {$else} + if fLogFileBuffer<>nil then + try + system.Close(fLogFile); + finally + Finalize(fLogFileBuffer); + end; + FreeAndNil(fLogClient); + {$endif} +end; + + +{ TSQLRestClientURI } + +const + LOGLEVELDB: array[boolean] of TSynLogInfo = (sllError,sllDB); + +function TSQLRestClientURI.getURI(aTable: TSQLRecordClass): string; +begin + result := Model.Root; + if (aTable<>nil) and (aTable<>TSQLRecord) then // SMS converts nil->TSQLRecord + result := result+'/'+Model.InfoExisting(aTable).Name; +end; + +function TSQLRestClientURI.getURICallBack(const aMethodName: string; + aTable: TSQLRecordClass; aID: TID): string; +begin + result := getURI(aTable); + if aID>0 then + result := result+'/'+IntToStr(aID); + result := result+'/'+aMethodName; +end; + +function TSQLRestClientURI.getURIID(aTableExistingIndex: integer; aID: TID): string; +begin + result := Model.Root+'/'+Model.Info[aTableExistingIndex].Name; + if aID>0 then + result := result+'/'+IntToStr(aID); +end; + +function TSQLRestClientURI.ExecuteList(const SQL: string): TSQLTableJSON; +var Call: TSQLRestURIParams; + json: string; +begin + result := nil; + if self=nil then + exit; + Log(sllSQL,SQL); + // strict HTTP does not allow any body content -> encode SQL at URL + // so we expect reUrlEncodedSQL to be defined in AllowRemoteExecute + Call.Init(Model.Root+UrlEncode(['sql',sql]),'GET',''); + URI(Call); + if Call.OutStatus=HTTP_SUCCESS then begin + json := Call.OutBodyUtf8; + result := TSQLTableJSON.Create(json); + result.fInternalState := fInternalState; + end else + Log(sllError,'ExecuteList failed'); +end; + +function TSQLRestClientURI.Retrieve(aID: TID; Value: TSQLRecord; + ForUpdate: boolean): boolean; +var tableIndex: Integer; + Call: TSQLRestURIParams; + json: string; +begin + tableIndex := Model.GetTableIndexExisting(Value.RecordClass); + Call.Url := getURIID(tableIndex,aID); + if ForUpdate then + Call.Verb := 'LOCK' else + Call.Verb := 'GET'; + URI(Call); + result := Call.OutStatus=HTTP_SUCCESS; + if result then begin + json := Call.OutBodyUtf8; + Value.FromJSON(json); + Value.fInternalState := fInternalState; + end; + Log(LOGLEVELDB[result],'%s.Retrieve(ID=%d) %s',[Model.Info[tableIndex].Name,aID,json]); +end; + +{$ifndef ISSMS} +function TSQLRestClientURI.RetrieveBlob(Table: TSQLRecordClass; aID: TID; + const BlobFieldName: string; out BlobData: TSQLRawBlob): boolean; +var tableIndex: Integer; + Call: TSQLRestURIParams; +begin + tableIndex := Model.GetTableIndexExisting(Table); + Call.Init(getURIID(tableIndex,aID)+'/'+BlobFieldName,'GET',''); + URI(Call); + result := Call.OutStatus=HTTP_SUCCESS; + if result then + BlobData := TSQLRawBlob(Call.OutBody); + Log(LOGLEVELDB[result],'%s.RetrieveBlob(ID=%d,"%s") len=%d', + [Model.Info[tableIndex].Name,aID,BlobFieldName,length(BlobData)]); +end; +{$endif} + +function FindHeader(const Headers, Name: string): string; +{$ifdef ISSMS} // dedicated function using faster JavaScript library +var search,nameValue: string; + searchLen: integer; +begin + if Headers='' then + exit ''; + search := UpperCase(Name); + searchLen := Length(search); + for nameValue in Headers.Split(#13#10) do + if uppercase(copy(nameValue,1,searchLen))=search then + exit copy(nameValue,searchLen+1,length(nameValue)); +end; +{$else} +var i: integer; + line: string; +begin + result := ''; + i := 1; + while GetNextCSV(Headers,i,line,#10) do + if StartWithPropName(line,Name) then begin + delete(line,1,length(Name)); + result := trim(line); // will work if EOL is CRLF or LF only + exit; + end; +end; +{$endif} + +function GetOutHeader(const Call: TSQLRestURIParams; const Name: string): string; +begin +{$ifdef ISSMS_XHRISBUGGY} // retrieval from Call.XHR is buggy on some browers :( + // see https://synopse.info/forum/viewtopic.php?pid=11730#p11730 + if VarIsValidRef(Call.XHR) then + result := Call.XHR.getResponseHeader(Name); +{$else} + result := FindHeader(Call.OutHead,Name+': '); +{$endif} +end; + +procedure TSQLRestClientURI.InternalStateUpdate(const Call: TSQLRestURIParams); +var receivedState: cardinal; +begin + if Call.OutHead='' then + exit; // nothing to update from (e.g. asynchronous call) + receivedState := StrToIntDef(GetOutHeader(Call,'Server-InternalState'),0); + if receivedState>fInternalState then + fInternalState := receivedState; + if sllTrace in fLogLevel then + Log(sllTrace,'%s %s status=%d state=%d in=%d out=%d', + [Call.Verb,Call.UrlWithoutSignature,Call.OutStatus,fInternalState, + length(Call.InBody),length(Call.OutBody)]); +end; + +procedure TSQLRestClientURI.URI(var Call: TSQLRestURIParams); +var sign: string; +begin + Call.OutStatus := HTTP_UNAVAILABLE; + if self=nil then + exit; + Call.UrlWithoutSignature := Call.Url; + if (fAuthentication<>nil) and (fAuthentication.SessionID<>0) then begin + if Pos('?',Call.Url)=0 then + sign := '?session_signature=' else + sign := '&session_signature='; + Call.Url := Call.Url+sign+ + fAuthentication.ClientSessionComputeSignature(self,Call.Url); + end; + InternalURI(Call); + InternalStateUpdate(Call); +end; + +procedure TSQLRestClientURI.InternalServiceCheck(const aMethodName: string; + const Call: TSQLRestURIParams); +begin + {$ifdef ISSMS} + if Assigned(Call.OnSuccess) then + exit; // asynchronous call do not have a result yet + {$endif} + if Call.OutStatus<>HTTP_SUCCESS then + Log(sllError,'Service %s returned %s',[aMethodName,Call.OutBodyUtf8]) else + Log(sllServiceReturn,'%s success',[aMethodName]); +end; + +procedure TSQLRestClientURI.CallBackGet(const aMethodName: string; + const aNameValueParameters: array of const; var Call: TSQLRestURIParams; + aTable: TSQLRecordClass; aID: TID); +begin + Log(sllServiceCall,'Method-based service %s',[aMethodName]); + Call.Url := getURICallBack(aMethodName,aTable,aID)+UrlEncode(aNameValueParameters); + Call.Verb := 'GET'; + URI(Call); + InternalServiceCheck(aMethodName,Call); +end; + +function TSQLRestClientURI.ExecuteBatchSend(Table: TSQLRecordClass; const Data: string; + var Results: TIDDynArray): integer; +var {$ifdef ISSMS} + doc: variant; + {$else} + doc: TJSONVariantData; + jsonres: string; + {$endif} + Call: TSQLRestURIParams; + start: TDateTime; + i: integer; +begin + start := Now; + Log(sllServiceCall,'BATCH with %d rows',[fBatchCount]); + Call.Init(getURICallBack('Batch',Table,0),'POST',Data); + URI(Call); + result := Call.OutStatus; + if result<>HTTP_SUCCESS then begin + Log(sllError,'BATCH error'); + exit; // transmission or internal server error + end; + Log(sllServiceReturn,'BATCH success in %s',[FormatDateTime('nn:ss:zzz',Now-start)]); + {$ifdef ISSMS} + Results.Clear; + if Call.OutBody='["OK"]' then begin + for i := 0 to fBatchCount-1 do + Results.Add(HTTP_SUCCESS); + end else begin + doc := JSON.Parse(Call.OutBody); + if (VariantType(doc)=jvArray) and (doc.length=fBatchCount) then + for i := 0 to fBatchCount-1 do + Results.Add(integer(doc[i])); + end; + {$else} + SetLength(Results,fBatchCount); + HttpBodyToText(Call.OutBody,jsonres); + if jsonres='["OK"]' then begin + for i := 0 to fBatchCount-1 do + Results[i] := HTTP_SUCCESS; + end else begin + doc.Init(jsonres); + if (doc.Kind=jvArray) and (doc.Count=fBatchCount) then + for i := 0 to fBatchCount-1 do + Results[i] := {$ifdef FPC}Int64{$endif}(doc.Values[i]); + end; + {$endif} +end; + +/// marshall {result:...,id:...} and {result:...} body answers +function CallGetResult(const aCall: TSQLRestURIParams; var outID: TID): variant; +{$ifndef ISSMS} +var doc: TJSONVariantData; + jsonres: string; + tmpID:variant; +{$endif} +begin + VarClear(result); + outID := 0; + if aCall.OutStatus<>HTTP_SUCCESS then + exit; + {$ifdef ISSMS} + var doc := JSON.Parse(aCall.OutBody); + if VarIsValidRef(doc.result) then + result := doc.result; + if VarIsValidRef(doc.id) then + outID := doc.id; + {$else} + HttpBodyToText(aCall.OutBody,jsonres); + doc.Init(jsonres); + result := doc.ValueCopy['result']; // Value[] -> varByRef + tmpID:=doc.Value['id']; + outID := Int64(tmpID); + {$endif} +end; + +function TSQLRestClientURI.CallBackGetResult(const aMethodName: string; + const aNameValueParameters: array of const; aTable: TSQLRecordClass; aID: TID): string; +var Call: TSQLRestURIParams; + dummyID: TID; +begin + CallBackGet(aMethodName,aNameValueParameters,Call,aTable,aID); + result := CallGetResult(Call,dummyID); +end; + +procedure TSQLRestClientURI.CallRemoteServiceInternal(var Call: TSQLRestURIParams; + aCaller: TServiceClientAbstract; const aMethod, aParams: string); +var url, clientDrivenID, sent, methName: string; +begin + methName:= aCaller.fServiceURI+'.'+aMethod; + Log(sllServiceCall,'Interface-based service '+methName); + url := Model.Root+'/'+aCaller.fServiceURI; + if aCaller.fInstanceImplementation=sicClientDriven then + clientDrivenID := (aCaller as TServiceClientAbstractClientDriven).ClientID; + ServicesRouting.ClientSideInvoke(url,aMethod,aParams,clientDrivenID,sent); + Call.Init(url,'POST',sent); + URI(Call); // asynchronous or synchronous call + InternalServiceCheck(methName,Call); // will log only for synchronous call +end; + +{ Some definitions copied from mORMot.pas unit } + +type + TServiceInternalMethod = (imFree, imContract, imSignature); + +const + SERVICE_PSEUDO_METHOD: array[TServiceInternalMethod] of string = ( + '_free_','_contract_','_signature_'); + +{$ifdef ISSMS} + +procedure TSQLRestClientURI.SetAsynch(var Call: TSQLRestURIParams; + onSuccess, onError: TSQLRestEvent; onBeforeSuccess: TSQLRestEventProcess); +begin + if not Assigned(onSuccess) then + raise ERestException.Create('SetAsynch expects onSuccess'); + inc(fAsynchCount); + Call.OnSuccess := + lambda + if Call.XHR.readyState=rrsDone then begin + InternalStateUpdate(Call); + if not assigned(onBeforeSuccess) then + onSuccess(self) else + if onBeforeSuccess then + onSuccess(self) else + if assigned(onError) then + onError(self); + if fAsynchCount>0 then + dec(fAsynchCount); + if fAsynchCount=0 then + CallAsynchText; // send any pending asynchronous task + end; + end; + Call.OnError := + lambda + if Assigned(onError) then + onError(Self); + if fAsynchCount>0 then + dec(fAsynchCount); + if fAsynchCount=0 then + CallAsynchText; // send any pending asynchronous task, even on error + end; +end; + +procedure TSQLRestClientURI.SetAsynchText(const Text: string); +begin + fAsynchPendingText.Add(Text); + if fAsynchCount=0 then + CallAsynchText; // send it now if no pending asynchronous task +end; + +procedure TSQLRestClientURI.CallAsynchText; +var Call: TSQLRestURIParams; +begin + if length(fAsynchPendingText)=0 then + exit; // nothing to send + Call.Init(getURICallBack('RemoteLog',nil,0),'PUT', + fAsynchPendingText.Join(#13#10)); // all rows sent at once + fAsynchPendingText.Clear; + SetAsynch(Call,lambda end,nil,nil); // asynchronous call without error check + URI(Call); +end; + +procedure TSQLRestClientURI.Connect(onSuccess, onError: TSQLRestEvent); +var Call: TSQLRestURIParams; +begin + SetAsynch(Call,onSuccess,onError, + lambda + result := (Call.OutStatus=HTTP_SUCCESS) and SetServerTimeStamp(Call.OutBody); + end); + CallBackGet('TimeStamp',[],Call,nil); // asynchronous call +end; + +procedure TSQLRestClientURI.CallRemoteServiceASynch(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; + onSuccess: procedure(res: array of Variant); onError: TSQLRestEvent; + aReturnsCustomAnswer: boolean); +var Call: TSQLRestURIParams; +begin + // ForceServiceResultAsJSONObject not implemented yet + SetAsynch(Call, + lambda + if not assigned(onSuccess) then + exit; // no result to handle + if aReturnsCustomAnswer then begin + if Call.OutStatus=HTTP_SUCCESS then begin + var result: TVariantDynArray; + result.Add(Call.OutBody); + onSuccess(result); + end else + if Assigned(onError) then + onError(self); + exit; + end; + var outID: TID; + var result := CallGetResult(Call,outID); // from {result:...,id:...} + if VarIsValidRef(result) then begin + if (aCaller.fInstanceImplementation=sicClientDriven) and (outID<>0) then + (aCaller as TServiceClientAbstractClientDriven).fClientID := IntToStr(outID); + if aExpectedOutputParamsCount=0 then + onSuccess([]) else begin + var res := TJSONVariantData.CreateFrom(result); + if (res.Kind=jvArray) and (res.Count=aExpectedOutputParamsCount) then + onSuccess(res.Values) else + if Assigned(onError) then + onError(self); + end; + end else + if Assigned(onError) then + onError(self); + end, + onError, + lambda + result := (Call.OutStatus=HTTP_SUCCESS) and (Call.OutBody<>''); + end); + CallRemoteServiceInternal(Call,aCaller,aMethodName,JSON.Stringify(variant(aInputParams))); +end; + +function TSQLRestClientURI.CallRemoteServiceSynch(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; aReturnsCustomAnswer: boolean): TVariantDynArray; +var Call: TSQLRestURIParams; + outResult: variant; + outID: TID; +procedure RaiseError; +begin + raise EServiceException.CreateFmt('Error calling %s.%s - returned status %d', + [aCaller.fServiceName,aMethodName,Call.OutStatus]); +end; +begin + // ForceServiceResultAsJSONObject not implemented yet + CallRemoteServiceInternal(Call,aCaller,aMethodName,JSON.Stringify(variant(aInputParams))); + if aReturnsCustomAnswer then begin + if Call.OutStatus<>HTTP_SUCCESS then + RaiseError; + result.Add(Call.OutBody); + exit; + end; + outResult := CallGetResult(Call,outID); // from {result:...,id:...} + if not VarIsValidRef(outResult) then + RaiseError; + if (aCaller.fInstanceImplementation=sicClientDriven) and (outID<>0) then + (aCaller as TServiceClientAbstractClientDriven).fClientID := IntToStr(outID); + if aExpectedOutputParamsCount=0 then + exit; // returns default [] + var res := TJSONVariantData.CreateFrom(outResult); + if (res.Kind=jvArray) and (res.Count=aExpectedOutputParamsCount) then + result := res.Values else + raise EServiceException.CreateFmt('Error calling %s.%s - '+ + 'received %d parameters (expected %d)', + [aCaller.fServiceName,aMethodName,res.Count,aExpectedOutputParamsCount]); +end; + +{$else} + +function TSQLRestClientURI.Connect: boolean; +var Call: TSQLRestURIParams; +begin + Log(sllInfo,'Connect',self); + CallBackGet('TimeStamp',[],Call,nil); + result := Call.OutStatus=HTTP_SUCCESS; + if not result then + exit; + result := SetServerTimeStamp(Call.OutBodyUtf8); +end; + +procedure TSQLRestClientURI.CallRemoteService(aCaller: TServiceClientAbstract; + const aMethodName: string; aExpectedOutputParamsCount: integer; + const aInputParams: array of variant; out res: TVariantDynArray; + aReturnsCustomAnswer: boolean); +var Call: TSQLRestURIParams; + params: TJSONVariantData; + result: variant; + bodyerror: string; + arr: PJSONVariantData; + i: integer; + outID: TID; +begin + params.Init; + for i := 0 to high(aInputParams) do + params.AddValue(aInputParams[i]); + CallRemoteServiceInternal(Call,aCaller,aMethodName,params.ToJSON); + if Call.OutStatus<>HTTP_SUCCESS then begin + HttpBodyToText(Call.OutBody,bodyerror); + raise EServiceException.CreateFmt('Error calling %s.%s - returned status %d'#13#10'%s', + [aCaller.fServiceName,aMethodName,Call.OutStatus,bodyerror]); + end; + if aReturnsCustomAnswer then begin + SetLength(res,1); + res[0] := HttpBodyToVariant(Call.OutBody); + exit; + end; + result := CallGetResult(Call,outID); + if (aCaller.fInstanceImplementation=sicClientDriven) and (outID<>0) then + (aCaller as TServiceClientAbstractClientDriven).fClientID := IntToStr(outID); + if aExpectedOutputParamsCount=0 then + exit; + arr := JSONVariantDataSafe(result,jvArray); // Count=0 if not jvArray + if arr^.Count<>aExpectedOutputParamsCount then + raise EServiceException.CreateFmt('Error calling %s.%s - '+ + 'received %d parameters (expected %d)', + [aCaller.fServiceName,aMethodName,arr^.Count,aExpectedOutputParamsCount]); + res := arr^.Values; +end; + +{$endif ISSMS} + +function TSQLRestClientURI.ExecuteAdd(tableIndex: integer; + const json: string): TID; +var Call: TSQLRestURIParams; + location: string; + i: integer; +begin + result := 0; + Call.Init(getURIID(tableIndex,0),'POST',json); + URI(Call); + if Call.OutStatus<>HTTP_CREATED then begin + Log(sllError,'Error creating %s with %s',[Model.Info[tableIndex].Name,json]); + exit; + end; + location := GetOutHeader(Call,'location'); + for i := length(location) downto 1 do + if not (ord(location[i]) in [ord('0')..ord('9')]) then begin + result := StrToInt64Def(Copy(location,i+1,length(location)),0); + break; // 'Location: root/People/11012' e.g. + end; + Log(sllDB,'%s.ID=%d created from %s',[Model.Info[tableIndex].Name,result,json]); +end; + +function TSQLRestClientURI.Delete(Table: TSQLRecordClass; + ID: TID): boolean; +var Call: TSQLRestURIParams; + tableIndex: integer; +begin + result := false; + if ID<=0 then + exit; + tableIndex := Model.GetTableIndexExisting(Table); + Call.Init(getURIID(tableIndex,ID),'DELETE',''); + URI(Call); + if Call.OutStatus=HTTP_SUCCESS then + result := true; + Log(LOGLEVELDB[result],'Delete %s.ID=%d',[Model.Info[tableIndex].Name,ID]); +end; + +function TSQLRestClientURI.ExecuteUpdate(tableIndex: integer; ID: TID; + const json: string): boolean; +var Call: TSQLRestURIParams; +begin + Call.Init(getURIID(tableIndex,ID),'PUT',json); + URI(Call); + result := Call.OutStatus=HTTP_SUCCESS; + Log(LOGLEVELDB[result],'Update %s.ID=%d with %s',[Model.Info[tableIndex].Name,ID,json]); +end; + +function TSQLRestClientURI.SetUser(aAuthenticationClass: TSQLRestServerAuthenticationClass; + const aUserName, aPassword: string; aHashedPassword: Boolean): boolean; +var aKey, aSessionID: string; + i: integer; +begin + result := false; + if fAuthentication<>nil then + SessionClose; + if aAuthenticationClass=nil then + exit; + fAuthentication := aAuthenticationClass.Create(aUserName,aPassword,aHashedPassword); + try + aKey := fAuthentication.ClientComputeSessionKey(self); + i := 1; + GetNextCSV(aKey,i,aSessionID,'+'); + if TryStrToInt(aSessionID,i) and (i>0) then begin + fAuthentication.SetSessionID(i); + Log(sllUserAuth,'Session %d created for "%s" with %s', + [i,aUserName,fAuthentication.ClassName]); + result := true; + end else begin + fAuthentication.Free; + fAuthentication := nil; + end; + except + fAuthentication.Free; + fAuthentication := nil; + end; + if fAuthentication=nil then + Log(sllError,'Session not created for "%s"',[aUserName]); +end; + +procedure TSQLRestClientURI.SessionClose; +var Call: TSQLRestURIParams; +begin + if (self<>nil) and (fAuthentication<>nil) then + try // notify Server to end of session + CallBackGet('Auth',['UserName',fAuthentication.User.LogonName, + 'Session',fAuthentication.SessionID],Call,nil); + finally + fAuthentication.Free; + fAuthentication := nil; + end; +end; + +{$ifndef ISSMS} +constructor TSQLRestClientURI.Create(aModel: TSQLModel; aOwnModel: boolean); +begin + fRunningClientDriven := TStringList.Create; + inherited Create(aModel,aOwnModel); +end; +{$endif} + +destructor TSQLRestClientURI.Destroy; +begin + {$ifndef ISSMS} + fRunningClientDriven.Free; + {$endif} + SessionClose; + inherited Destroy; +end; + +{ TSQLRestClientHTTP } + +constructor TSQLRestClientHTTP.Create(const aServer: string; + aPort: integer; aModel: TSQLModel; aOwnModel, aHttps: boolean + {$ifndef ISSMS}; const aProxyName, aProxyByPass: string; + aSendTimeout, aReceiveTimeout, aConnectionTimeOut: Cardinal{$endif}); +begin + inherited Create(aModel,aOwnModel); + fParameters.Server := aServer; + fParameters.Port := aPort; + fParameters.Https := aHttps; + {$ifndef ISSMS} + fParameters.ProxyName := aProxyName; + fParameters.ProxyByPass := aProxyByPass; + fParameters.ConnectionTimeOut := aConnectionTimeOut; + fParameters.SendTimeout := aSendTimeout; + fParameters.ReceiveTimeout := aReceiveTimeout; + {$endif} + fKeepAlive := 20000; +end; + +destructor TSQLRestClientHTTP.Destroy; +begin + inherited; + fAuthentication.Free; + fConnection.Free; +end; + +procedure TSQLRestClientHTTP.InternalURI(var Call: TSQLRestURIParams); +var inType: string; + retry: integer; +begin + inType := FindHeader(Call.InHead,'content-type: '); + if inType='' then begin + if OnlyJSONRequests then + inType := JSON_CONTENT_TYPE else + inType := 'text/plain'; // avoid slow CORS preflighted requests + Call.InHead := trim(Call.InHead+#13#10'content-type: '+inType); + end; + if fCustomHttpHeader<>'' then + Call.InHead := trim(Call.InHead+fCustomHttpHeader); + for retry := 0 to 1 do begin + if fConnection=nil then + try + fConnection := HttpConnectionClass.Create(fParameters); + // TODO: handle SynLZ compression and SHA/AES encryption? + except + on E: Exception do begin + Log(E); + fConnection.Free; + fConnection := nil; + end; + end; + if fConnection=nil then begin + Call.OutStatus := HTTP_NOTIMPLEMENTED; + break; + end; + try + fConnection.URI(Call,inType,fKeepAlive); + break; // do not retry on transmission success, or asynchronous request + except + on E: Exception do begin + Log(E); + fConnection.Free; + fConnection := nil; + Call.OutStatus := HTTP_NOTIMPLEMENTED; + if fForceTerminate then + break; + end; // will retry once (e.g. if connection broken) + end; + end; +end; + +procedure TSQLRestClientHTTP.SetHttpBasicAuthHeaders(const aUserName, aPasswordClear: RawUTF8); +var base64: RawUTF8; +begin + base64 := aUsername+':'+aPasswordClear; + {$ifdef ISSMS} + base64 := window.btoa(base64); + {$else} + base64 := BytesToBase64JSONString(TByteDynArray(TextToHttpBody(base64)),false); + {$endif} + fCustomHttpHeader := #13#10'Authorization: Basic '+base64; +end; + + +{ TSQLAuthUser } + +{$ifdef ISSMS} // manual RTTI for SMS + +class function TSQLAuthUser.ComputeRTTI: TRTTIPropInfos; +begin + result := TRTTIPropInfos.Create( + ['Data','Group','LogonName','DisplayName','PasswordHashHexa'], + [sftBlob]); +end; + +procedure TSQLAuthUser.SetProperty(FieldIndex: integer; const Value: variant); +begin + case FieldIndex of + 0: fID := Value; + 1: fData := Value; + 2: fGroup := Value; + 3: fLogonName := Value; + 4: fDisplayName := Value; + 5: fPasswordHashHexa := Value; + end; +end; + +function TSQLAuthUser.GetProperty(FieldIndex: integer): variant; +begin + case FieldIndex of + 0: result := fID; + 1: result := fData; + 2: result := fGroup; + 3: result := fLogonName; + 4: result := fDisplayName; + 5: result := fPasswordHashHexa; + end; +end; + +{$endif} + +function SHA256Compute(const Values: array of string): string; +var buf: THttpBody; + a: integer; + sha: TSHA256; +begin + sha := TSHA256.Create; + try + for a := 0 to high(Values) do begin + buf := TextToHttpBody(Values[a]); + sha.Update(buf); + end; + result := sha.Finalize; + finally + sha.Free; + end; +end; + +procedure TSQLAuthUser.SetPasswordPlain(const Value: string); +begin + PasswordHashHexa := SHA256Compute(['salt',Value]); +end; + + +{ TSQLRestServerAuthentication } + +constructor TSQLRestServerAuthentication.Create(const aUserName, aPassword: string; + aHashedPassword: Boolean); +begin + fUser := TSQLAuthUser.Create; + fUser.LogonName := aUserName; + if aHashedPassword then + fUser.PasswordHashHexa := aPassword else + fUser.PasswordPlain := aPassword; +end; + +destructor TSQLRestServerAuthentication.Destroy; +begin + fUser.Free; + inherited; +end; + +procedure TSQLRestServerAuthentication.SetSessionID(Value: Cardinal); +begin + fSessionID := Value; + fSessionIDHexa8 := LowerCase(IntToHex(Value,8)); +end; + +{ TSQLRestServerAuthenticationDefault } + +function TSQLRestServerAuthenticationDefault.ClientComputeSessionKey( + Sender: TSQLRestClientURI): string; +var aServerNonce, aClientNonce, aPassHash: string; +begin + if fUser.LogonName='' then + exit; + aServerNonce := Sender.CallBackGetResult('Auth',['UserName',User.LogonName],nil); + if aServerNonce='' then + exit; + aClientNonce := SHA256Compute([Copy(NowToIso8601,1,16)]); + aPassHash := Sha256Compute([Sender.Model.Root,aServerNonce,aClientNonce, + User.LogonName,User.PasswordHashHexa]); + result := Sender.CallBackGetResult('Auth',['UserName',User.LogonName, + 'Password',aPassHash,'ClientNonce',aClientNonce],nil); + fSessionPrivateKey := crc32ascii(crc32ascii(0,result),fUser.fPasswordHashHexa); +end; + +function TSQLRestServerAuthenticationDefault.ClientSessionComputeSignature( + Sender: TSQLRestClientURI; const url: string): string; +var nonce: string; +begin + nonce := LowerCase(IntToHex(trunc(Now*(24*60*60)),8)); + result := fSessionIDHexa8+nonce+LowerCase(IntToHex( + crc32ascii(crc32ascii(fSessionPrivateKey,nonce),url),8)); +end; + +{ TSQLRestServerAuthenticationNone } + +function TSQLRestServerAuthenticationNone.ClientComputeSessionKey( + Sender: TSQLRestClientURI): string; +begin + result := Sender.CallBackGetResult('Auth',['UserName',User.LogonName],nil); +end; + +function TSQLRestServerAuthenticationNone.ClientSessionComputeSignature( + Sender: TSQLRestClientURI; const url: string): string; +begin + result := fSessionIDHexa8; +end; + +{$ifdef ISSMS} + +{ TSQLAuthGroup } // manual RTTI for SMS + +class function TSQLAuthGroup.ComputeRTTI: TRTTIPropInfos; +begin + result := TRTTIPropInfos.Create( + ['Ident','SessionTimeOut','AccessRights'],[]); +end; + +procedure TSQLAuthGroup.SetProperty(FieldIndex: integer; const Value: variant); +begin + case FieldIndex of + 0: fID := Value; + 1: fIdent := Value; + 2: fSessionTimeOut := Value; + 3: fAccessRights := Value; + end; +end; + +function TSQLAuthGroup.GetProperty(FieldIndex: integer): variant; +begin + case FieldIndex of + 0: result := fID; + 1: result := fIdent; + 2: result := fSessionTimeOut; + 3: result := fAccessRights; + end; +end; + + +function VariantToBlob(const Value: variant): TSQLRawBlob; +begin + if TVariant.IsString(Value) then begin + var s: string := Value; + if s='' then + result := null else + result := BrowserAPI.Window.atob(s); + end else + result := null; +end; + +function BlobToVariant(const Blob: TSQLRawBlob): variant; +begin + if TVariant.IsString(Blob) then + result := BrowserAPI.Window.btoa(Blob) else + result := null; +end; + +function VariantToGUID(const value: variant): TGUID; inline; +begin + result := value; // no-op since TGUID=string +end; + +function GUIDToVariant(const GUID: TGUID): variant; inline; +begin + result := GUID; // no-op since TGUID=string +end; + +function VariantToHttpBody(const value: variant): THttpBody; +begin + result := value; // no-op since THttpBody=string +end; + +function HttpBodyToVariant(const HttpBody: THttpBody): variant; +begin + result := HttpBody; // no-op since THttpBody=string +end; + +{$else} + +{$ifdef FPC} // original VarIsStr() does not handle varByRef as expected :( +function VarIsStr(const Value: variant): boolean; inline; +begin + result := Variants.VarIsStr(PVariant(FindVarData(Value))^); +end; +{$endif} + +function VariantToBlob(const Value: variant): TSQLRawBlob; +begin + if VarIsStr(Value) then // avoid conversion error from null to string + Base64JSONStringToBytes(Value,result) else + Finalize(result); +end; + +function BlobToVariant(const Blob: TSQLRawBlob): variant; +begin + if Blob=nil then + result := null else + result := BytesToBase64JSONString(Blob); +end; + +function VariantToGUID(const value: variant): TGUID; +var S: string; +begin + FillChar(result,SizeOf(result),0); + if not VarIsStr(value) then + exit; + S := string(Value); + if S<>'' then + try + result := SysUtils.StringToGUID('{'+s+'}'); + except + ; // ignore any conversion error and return void TGUID + end; +end; + +function GUIDToVariant(const GUID: TGUID): variant; +begin + try + result := Copy(SysUtils.GUIDToString(GUID),2,36); + except + result := ''; // should not happen + end; +end; + +const + varHttpBody = {$ifdef UNICODE}varUString{$else}varString{$endif}; + +function VariantToHttpBody(const value: variant): THttpBody; +var P: PCardinal; + Len: cardinal; +begin + result := nil; + with TVarData(value) do begin + if (VType<>varHttpBody) or (VAny=nil) then + exit; + P := VAny; + {$ifdef UNICODE} + Len := P^; + if Len>=cardinal(length(UnicodeString(VAny))*2) then + exit; // input does not come from HttpBodyToVariant() -> avoid GPF + inc(P); + {$else} + Len := length(RawByteString(VAny)); + {$endif} + SetLength(result,Len); + move(P^,pointer(result)^,len); + end; +end; + +function HttpBodyToVariant(const HttpBody: THttpBody): variant; +var P: PCardinal; + Len: cardinal; +begin + VarClear(result); + Len := length(HttpBody); + if Len>0 then + with TVarData(result) do begin + VType := varHttpBody; + VAny := nil; + {$ifdef UNICODE} + SetLength(UnicodeString(VAny),Len shr 1+2); + P := VAny; + P^ := Len; + inc(P); + {$else} + SetLength(RawByteString(VAny),Len); + P := VAny; + {$endif} + move(pointer(HttpBody)^,P^,Len); + end; +end; + +{$endif ISSMS} + +function VariantToEnum(const Value: variant; const TextValues: array of string): integer; +{$ifdef ISSMS} +begin + if TVariant.IsNumber(Value) then + result := Value else begin + result := TextValues.IndexOf(string(Value)); + if result>=0 then + exit; +{$else} +var str: string; +begin + if VarIsOrdinal(Value) then + result := Value else begin + str := Value; + if str<>'' then + for result := 0 to high(TextValues) do + if str=TextValues[result] then + exit; +{$endif} + result := 0; // return first item by default + end; +end; + +function ObjectToVariant(value: TSQLRecord): variant; +begin + result := value.ToVariant; +end; + + +{ TServiceClientAbstract } + +constructor TServiceClientAbstract.Create(aClient: TSQLRestClientURI); +var Call: TSQLRestURIParams; // manual synchronous call + dummyID: TID; + result: variant; + contract: string; +begin + if (fServiceName='') or (fServiceURI='') then + raise EServiceException.CreateFmt( + 'Overriden %s.Create should have set properties',[ClassName]); + if aClient=nil then + raise EServiceException.CreateFmt('%s.Create(nil)',[ClassName]); + fClient := aClient; + fClient.CallRemoteServiceInternal(Call,self,SERVICE_PSEUDO_METHOD[imContract],'[]'); + result := CallGetResult(Call,dummyID); + {$ifdef ISSMS} + if VariantType(result)=jvArray then + contract := result[0] else + contract := result.contract; // if ResultAsJSONObject=true + {$else} + with JSONVariantDataSafe(result,jvArray)^ do // Count=0 if not jvArray + if Count=1 then + contract := Values[0] else + contract := Value['contract']; // if ResultAsJSONObject=true + {$endif} + if contract<>fContractExpected then + raise EServiceException.CreateFmt('Invalid contract "%s" for %s: expected "%s"', + [contract,ClassName,fContractExpected]); +end; + +function TServiceClientAbstract.GetClient: TSQLRestClientURI; +begin + result := fClient; +end; + +function TServiceClientAbstract.GetContractExpected: string; +begin + result := fContractExpected; +end; + +function TServiceClientAbstract.GetInstanceImplementation: TServiceInstanceImplementation; +begin + result := fInstanceImplementation; +end; + +function TServiceClientAbstract.GetRunningInstance: TServiceClientAbstract; +begin + result := self; +end; + +function TServiceClientAbstract.GetServiceName: string; +begin + result := fServiceName; +end; + +function TServiceClientAbstract.GetServiceURI: string; +begin + result := fServiceURI; +end; + + +{ TServiceClientAbstractClientDriven } + +constructor TServiceClientAbstractClientDriven.Create(aClient: TSQLRestClientURI); +begin + if fInstanceImplementation<>sicClientDriven then + raise EServiceException.CreateFmt( + 'Overriden %s.Create should have set sicClientDriven',[ClassName]); + if aClient.fRunningClientDriven.IndexOf(fServiceName)>=0 then + raise EServiceException.CreateFmt('Only ONE instance of %s is allowed at once', + [ClassName]); + inherited Create(aClient); // will synchronously check the contract from server + aClient.fRunningClientDriven.Add(fServiceName); // mark as opened +end; + +destructor TServiceClientAbstractClientDriven.Destroy; +var ndx: integer; + {$ifndef ISSMS} + res: TVariantDynArray; + {$endif} +begin + if fClient<>nil then + try + if fClientID<>'' then + {$ifdef ISSMS} + fClient.CallRemoteServiceAsynch(self,SERVICE_PSEUDO_METHOD[imFree],0,[],nil,nil); + {$else} + try // synchronous blocking call + fClient.CallRemoteService(self,SERVICE_PSEUDO_METHOD[imFree],0,[],res); + except + ; // ignore, since the connection may be broken (will timeout on server) + end; + {$endif} + finally + ndx := fClient.fRunningClientDriven.IndexOf(ServiceName); + if ndx>=0 then + fClient.fRunningClientDriven.Delete(ndx); // mark as closed + end; + inherited; +end; + +{ TSQLRestRoutingREST } + +class procedure TSQLRestRoutingREST.ClientSideInvoke(var uri: String; + const method: String; const params: String; const clientDrivenID: String; + var sent: String); +begin + if clientDrivenID<>'' then + uri := uri+'.'+method+'/'+clientDrivenID else + uri := uri+'.'+method; + sent := params; // we may also encode them within the URI +end; + +{ TSQLRestRoutingJSON_RPC } + +class procedure TSQLRestRoutingJSON_RPC.ClientSideInvoke(var uri: String; + const method: String; const params: String; const clientDrivenID: String; + var sent: String); +begin + sent := '{"method":"'+method+'","params":'+params; + if clientDrivenID='' then + sent := sent+'}' else + sent := sent+',"id":'+clientDrivenID+'}'; +end; + +/// SmartMobileStudio does not like constant sets with the Delphi syntax +var nfo: TSynLogInfo; +initialization + include(LOG_STACKTRACE,sllLastError); + include(LOG_STACKTRACE,sllError); + include(LOG_STACKTRACE,sllException); + include(LOG_STACKTRACE,sllExceptionOS); + for nfo := succ(sllNone) to high(nfo) do + include(LOG_VERBOSE,nfo); +end. diff --git a/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas b/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas new file mode 100644 index 00000000..01955e56 --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas @@ -0,0 +1,1218 @@ +/// system-specific cross-platform units +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformSpecific; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - danielkuettner + - Stefan (itSDS) + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + + Each operating system will have its own API calls in this single unit + Should compile with Delphi for any platform (including NextGen for mobiles), + with FPC 2.7 or Kylix, and with SmartMobileStudio 2.2 + +} + +{$ifdef DWSCRIPT} // always defined since SMS 1.1.2 + {$define ISDWS} // e.g. for SmartMobileStudio or Delphi Web Script + {$define ISSMS} // for SmartMobileStudio + {$define HASINLINE} +{$else} // Delphi or FPC: select a single USE* conditional + {$I SynCrossPlatform.inc} // define e.g. HASINLINE + {$ifdef MSWINDOWS} + {$ifdef FPC} + {$define USESYNCRT} // sounds to be the best choice under Windows + {.$define USEFCL} // for debugging the FCL within Lazarus + {$else} + {$define USESYNCRT} // sounds to be the best choice under Windows + {.$define USEINDY} // for debugging Indy within Delphi + {.$define USEHTTPCLIENT} // for debugging XE8+ HttpClient within Delphi + {$endif} + {$define USECRITICALSECTION} + {$else} + {$ifdef FPC} + {$define USEFCL} + {$define USECRITICALSECTION} + {$else} + {$ifdef ISDELPHIXE8} // use new XE8+ System.Net.HttpClient + {$ifdef ANDROID} + {$define USEHTTPCLIENT} + {.$define USEINDY} // for debugging Indy within Android + {$else} + {$define USEINDY} // HttpClient has still issues with https under iOS + {$endif ANDROID} + {$else} + {$define USEINDY} + {$endif ISDELPHIXE8} + {$endif FPC} + {$endif MSWINDOWS} +{$endif} + +interface + +{$ifdef ISDWS} +uses + SmartCL.System, + System.Types, + ECMA.Date, + ECMA.Json; +{$else} +uses + {$ifdef MSWINDOWS} + Windows, + {$else} + {$endif} + SysUtils, + Classes; +{$endif} + +type + {$ifdef ISDWS} + JDateHelper = helper for JDate + private + function GetAsDateTime : TDateTime; + function GetAsLocalDateTime : TDateTime; + procedure SetAsDateTime(dt : TDateTime); + procedure SetAsLocalDateTime(dt : TDateTime); + public + property AsDateTime : TDateTime read GetAsDateTime write SetAsDateTime; + property AsLocalDateTime : TDateTime read GetAsLocalDateTime write SetAsLocalDateTime; + end; + // HTTP body may not match the string type, and could be binary + THttpBody = string; + + // define some Delphi types not supported natively by DWS/SMS + char = string; + byte = integer; + word = integer; + cardinal = integer; + // warning: JavaScript truncates integer to its mantissa resolution + sign! + Int53 = integer; + Int64 = integer; + currency = float; + TPersistent = TObject; + TObjectList = array of TObject; + TStringList = array of string; + TVariantDynArray = array of variant; + TIntegerDynArray = array of integer; + + // as defined in SmartCL.Inet and expected by XMLHttpRequest + THttpRequestReadyState = (rrsUnsent = 0, + rrsOpened = 1, + rrsHeadersReceived = 2, + rrsLoading = 3, + rrsDone = 4); + {$else} + + /// will store input and output HTTP body content + // - HTTP body may not match the string type, and could be binary + // - this kind of variable is compatible with NextGen version of the compiler + THttpBody = array of byte; + + /// cross-platform thread safe locking + // - will use TMonitor on the newest Delphi platforms + TMutex = class + {$ifdef USECRITICALSECTION} + protected + fLock: TRTLCriticalSection; + public + constructor Create; + destructor Destroy; override; + {$endif} + public + procedure Enter; + procedure Leave; + end; + + {$ifdef NEXTGEN} + /// see TUTF8Buffer = TBytes in SynCrossPlatformJSON + AnsiChar = byte; + {$endif NEXTGEN} + + {$endif ISDWS} + + /// used to store the request of a REST call + {$ifdef USEOBJECTINSTEADOFRECORD} + TSQLRestURIParams = object + {$else} + TSQLRestURIParams = record + {$endif} + /// input parameter containing the caller URI + Url: string; + /// caller URI, without any appended signature + UrlWithoutSignature: string; + /// input parameter containing the caller method + Verb: string; + /// input parameter containing the caller message headers + InHead: string; + /// input parameter containing the caller message body + InBody: THttpBody; + /// output parameter to be set to the response message header + OutHead: string; + /// output parameter to be set to the response message body + OutBody: THttpBody; + /// output parameter to be set to the HTTP status integer code + OutStatus: cardinal; + {$ifdef ISDWS} + /// the associated TXMLHttpRequest instance + XHR: THandle; + /// callback events for asynchronous call + // - will be affected to the corresponding XHR events + OnSuccess: TProcedureRef; + OnError: TProcedureRef; + {$endif} + /// set the caller content + procedure Init(const aUrl,aVerb,aUTF8Body: string); + /// get the response message body as UTF-8 + function OutBodyUtf8: string; + end; + + /// the connection parameters, as stored and used by TAbstractHttpConnection + TSQLRestConnectionParams = record + /// the server name or IP address + Server: string; + /// the server port + Port: integer; + /// if the connection should be HTTPS + Https: boolean; + {$ifndef ISSMS} + /// the optional proxy name to be used + ProxyName: string; + /// the optional proxy password to be used + ProxyByPass: string; + /// the connection timeout, in ms + ConnectionTimeOut: integer; + /// the timeout when sending data, in ms + SendTimeout: cardinal; + /// the timeout when receiving data, in ms + ReceiveTimeout: cardinal + {$endif} + end; + + /// abstract class for HTTP client connection + TAbstractHttpConnection = class + protected + fParameters: TSQLRestConnectionParams; + fURL: string; + fOpaqueConnection: TObject; + public + /// this is the main entry point for all HTTP clients + // - connect to http://aServer:aPort or https://aServer:aPort + // - optional aProxyName may contain the name of the proxy server to use, + // and aProxyByPass an optional semicolon delimited list of host names or + // IP addresses, or both, that should not be routed through the proxy + constructor Create(const aParameters: TSQLRestConnectionParams); virtual; + /// perform the request + // - this is the main entry point of this class + // - inherited classes should override this abstract method + procedure URI(var Call: TSQLRestURIParams; const InDataType: string; + KeepAlive: integer); virtual; abstract; + + /// the remote server full URI + // - e.g. 'http://myserver:888/' + property Server: string read fURL; + /// the connection parameters + property Parameters: TSQLRestConnectionParams read fParameters; + /// opaque access to the effective connection class instance + // - which may be a TFPHttpClient, a TIdHTTP or a TWinHttpAPI + property ActualConnection: TObject read fOpaqueConnection; + end; + + /// define the inherited class for HTTP client connection + TAbstractHttpConnectionClass = class of TAbstractHttpConnection; + + +const + /// MIME content type used for JSON communication + JSON_CONTENT_TYPE = 'application/json; charset=UTF-8'; + + /// HTTP Status Code for "Continue" + HTTP_CONTINUE = 100; + /// HTTP Status Code for "Switching Protocols" + HTTP_SWITCHINGPROTOCOLS = 101; + /// HTTP Status Code for "Success" + HTTP_SUCCESS = 200; + /// HTTP Status Code for "Created" + HTTP_CREATED = 201; + /// HTTP Status Code for "Accepted" + HTTP_ACCEPTED = 202; + /// HTTP Status Code for "Non-Authoritative Information" + HTTP_NONAUTHORIZEDINFO = 203; + /// HTTP Status Code for "No Content" + HTTP_NOCONTENT = 204; + /// HTTP Status Code for "Partial Content" + HTTP_PARTIALCONTENT = 206; + /// HTTP Status Code for "Multiple Choices" + HTTP_MULTIPLECHOICES = 300; + /// HTTP Status Code for "Moved Permanently" + HTTP_MOVEDPERMANENTLY = 301; + /// HTTP Status Code for "Found" + HTTP_FOUND = 302; + /// HTTP Status Code for "See Other" + HTTP_SEEOTHER = 303; + /// HTTP Status Code for "Not Modified" + HTTP_NOTMODIFIED = 304; + /// HTTP Status Code for "Use Proxy" + HTTP_USEPROXY = 305; + /// HTTP Status Code for "Temporary Redirect" + HTTP_TEMPORARYREDIRECT = 307; + /// HTTP Status Code for "Bad Request" + HTTP_BADREQUEST = 400; + /// HTTP Status Code for "Unauthorized" + HTTP_UNAUTHORIZED = 401; + /// HTTP Status Code for "Forbidden" + HTTP_FORBIDDEN = 403; + /// HTTP Status Code for "Not Found" + HTTP_NOTFOUND = 404; + // HTTP Status Code for "Method Not Allowed" + HTTP_NOTALLOWED = 405; + // HTTP Status Code for "Not Acceptable" + HTTP_NOTACCEPTABLE = 406; + // HTTP Status Code for "Proxy Authentication Required" + HTTP_PROXYAUTHREQUIRED = 407; + /// HTTP Status Code for "Request Time-out" + HTTP_TIMEOUT = 408; + /// HTTP Status Code for "Internal Server Error" + HTTP_SERVERERROR = 500; + /// HTTP Status Code for "Not Implemented" + HTTP_NOTIMPLEMENTED = 501; + /// HTTP Status Code for "Bad Gateway" + HTTP_BADGATEWAY = 502; + /// HTTP Status Code for "Service Unavailable" + HTTP_UNAVAILABLE = 503; + /// HTTP Status Code for "Gateway Timeout" + HTTP_GATEWAYTIMEOUT = 504; + /// HTTP Status Code for "HTTP Version Not Supported" + HTTP_HTTPVERSIONNONSUPPORTED = 505; + + +/// gives access to the class type to implement a HTTP connection +// - will use WinHTTP API (from our SynCrtSock) under Windows +// - will use Indy for Delphi on other platforms +// - will use fcl-web (fphttpclient) with FreePascal +function HttpConnectionClass: TAbstractHttpConnectionClass; + + +/// convert a text into UTF-8 binary buffer +function TextToHttpBody(const Text: string): THttpBody; + +/// convert a UTF-8 binary buffer into texts +procedure HttpBodyToText(const Body: THttpBody; var Text: string); + +/// will return the next CSV value from the supplied text +function GetNextCSV(const str: string; var index: Integer; var res: string; + Sep: char=','; resultTrim: boolean=false): boolean; + +{$ifdef ISDWS} +// some definitions implemented in SynCrossPlatformJSON.pas for Delphi+FPC + +procedure DoubleQuoteStr(var text: string); +function IdemPropName(const PropName1,PropName2: string): boolean; +function StartWithPropName(const PropName1,PropName2: string): boolean; +function VarRecToValue(const VarRec: variant; var tmpIsString: boolean): string; +procedure DecodeTime(Value: TDateTime; var HH,MM,SS,MS: word); +procedure DecodeDate(Value: TDateTime; var Y,M,D: word); +function TryEncodeDate(Y,M,D: integer; UTC: DateTimeZone; var Value: TDateTime): boolean; +function TryEncodeTime(HH,MM,SS,MS: integer; var Value: TDateTIme): boolean; +function NowToIso8601: string; +function DateTimeToIso8601(Value: TDateTime): string; +function Iso8601ToDateTime(const Value: string): TDateTime; +function TryStrToInt(const S: string; var Value: integer): Boolean; +function TryStrToInt64(const S: string; var Value: Int64): Boolean; +function StrToInt64Def(const S: string; const def: Int64): Int64; +function UpCase(ch: Char): Char; inline; + +type + /// which kind of document the TJSONVariantData contains + TJSONVariantKind = (jvUndefined, jvObject, jvArray); + + /// stores any JSON object or array as variant + TJSONVariantData = class + public + Kind: TJSONVariantKind; + Names: TStrArray; + Values: TVariantDynArray; + /// initialize the low-level memory structure with a given JSON content + constructor Create(const aJSON: string); + /// initialize the low-level memory structure with a given object + constructor CreateFrom(const document: variant); + /// number of items in this jvObject or jvArray + property Count: integer read (Values.Count); + end; + +/// guess the type of a supplied variant +function VariantType(const Value: variant): TJSONVariantKind; + +/// faster than chr(c) when you are sure that c<=$ffff +function DirectChr(c: Integer): string; external 'String.fromCharCode'; + +/// compute the JSON representation of a variant value +// - match function signature as defined in SynCrossPlatformJSON +function ValueToJSON(Value: variant): string; external 'JSON.stringify'; + +/// compute a variant from its JSON representation +// - match function signature as defined in SynCrossPlatformJSON +function JSONToValue(JSON: string): variant; external 'JSON.parse'; + +{$endif} + + +implementation + +{$ifdef USEFCL} +uses + fphttpclient; +{$endif} + +{$ifdef USEINDY} +uses + IdHTTP, IdCoderMIME, + {$ifdef MACOS} + {$ifdef CPUARM} + IdSSLOpenSSLHeaders_Static, // for iOS ARM + {$else} + IdSSLOpenSSLHeaders, // for OSX and iOS x86 + {$endif} + {$endif} + IdSSLOpenSSL; + // for SSL support with iOS and Android client, please follow instructions at + // http://blog.marcocantu.com/blog/using_ssl_delphi_ios.html and you may + // download the *.a files from http://indy.fulgan.com/SSL/OpenSSLStaticLibs.7z + // see also https://synopse.info/forum/viewtopic.php?id=2325 +{$endif} + +{$ifdef USESYNCRT} +uses + SynCrtSock; +{$endif} + +{$ifdef USEHTTPCLIENT} +uses + System.Net.UrlClient, + System.Net.HttpClient; +{$endif} + +{$ifdef ISDWS} +function JDateHelper.GetAsDateTime : TDateTime; +begin + Result := Self.getTime / 864e5 + 25569; +end; + +procedure JDateHelper.SetAsDateTime(dt : TDateTime); +begin + Self.setTime(round((dt - 25569) * 864e5)); +end; + +function JDateHelper.GetAsLocalDateTime: TDateTime; +begin + Result := (Self.getTime - 60000 * Self.getTimezoneOffset) / 864e5 + 25569; +end; + +procedure JDateHelper.SetAsLocalDateTime(dt: TDateTime); +begin + Self.setTime(round((dt - 25569) * 864e5) + 60000 * Self.getTimezoneOffset); +end; +{$endif} + +function TextToHttpBody(const Text: string): THttpBody; +{$ifdef ISSMS} +begin + // http://ecmanaut.blogspot.fr/2006/07/encoding-decoding-utf8-in-javascript.html + asm + @result=unescape(encodeURIComponent(@Text)); + end; +end; +{$else} +{$ifdef NEXTGEN} +begin + result := THttpBody(TEncoding.UTF8.GetBytes(Text)); +end; +{$else} +var utf8: UTF8String; + n: integer; +begin + utf8 := UTF8Encode(Text); + n := length(utf8); + SetLength(result,n); + move(pointer(utf8)^,pointer(result)^,n); +end; +{$endif} +{$endif} + +function GetNextCSV(const str: string; var index: Integer; var res: string; + Sep: char=','; resultTrim: boolean=false): boolean; +var i,j,L: integer; +begin + L := length(str); + if index<=L then begin + i := index; + while i<=L do + if str[i]=Sep then + break else + inc(i); + j := index; + index := i+1; + if resultTrim then begin + while (jj) and (ord(str[i-1])<=32) do dec(i); + end; + res := copy(str,j,i-j); + result := true; + end else + result := false; +end; + +procedure HttpBodyToText(const Body: THttpBody; var Text: string); +{$ifdef ISSMS} +begin + asm + @Text=decodeURIComponent(escape(@Body)); + end; +end; +{$else} +{$ifdef NEXTGEN} +begin + Text := TEncoding.UTF8.GetString(TBytes(Body)); +end; +{$else} +var utf8: UTF8String; + L: integer; +begin + L := length(Body); + SetLength(utf8,L); + move(pointer(Body)^,pointer(utf8)^,L); + {$ifdef UNICODE} + Text := UTF8ToString(utf8); + {$else} + Text := UTF8Decode(utf8); + {$endif} +end; +{$endif} +{$endif} + + +{ TAbstractHttpConnection } + +const + INTERNET_DEFAULT_HTTP_PORT = 80; + INTERNET_DEFAULT_HTTPS_PORT = 443; + +constructor TAbstractHttpConnection.Create( + const aParameters: TSQLRestConnectionParams); +begin + inherited Create; + fParameters := aParameters; + if fParameters.Port=0 then + if fParameters.Https then + fParameters.Port := INTERNET_DEFAULT_HTTPS_PORT else + fParameters.Port := INTERNET_DEFAULT_HTTP_PORT; + if fParameters.Https then + fURL := 'https://' else + fURL := 'http://'; + fURL := fURL+fParameters.Server+':'+IntToStr(fParameters.Port)+'/'; +end; + + +{$ifdef USEFCL} + +type + TFclHttpConnectionClass = class(TAbstractHttpConnection) + protected + fConnection: TFPHttpClient; + public + constructor Create(const aParameters: TSQLRestConnectionParams); override; + procedure URI(var Call: TSQLRestURIParams; const InDataType: string; KeepAlive: integer); override; + destructor Destroy; override; + end; + +{ TFclHttpConnectionClass } + +constructor TFclHttpConnectionClass.Create( + const aParameters: TSQLRestConnectionParams); +begin + inherited Create(aParameters); + fConnection := TFPHttpClient.Create(nil); + fOpaqueConnection := fConnection; +end; + +procedure TFclHttpConnectionClass.URI(var Call: TSQLRestURIParams; + const InDataType: string; KeepAlive: integer); +var InStr,OutStr: TBytesStream; +begin + InStr := TBytesStream.Create(Call.InBody); + OutStr := TBytesStream.Create; + try + fConnection.RequestHeaders.Text := Call.InHead; + fConnection.RequestBody := InStr; + fConnection.HTTPMethod(Call.Verb,fURL+Call.Url,OutStr,[]); + Call.OutStatus := fConnection.ResponseStatusCode; + Call.OutHead := fConnection.ResponseHeaders.Text; + Call.OutBody := OutStr.Bytes; + SetLength(Call.OutBody,OutStr.Position); + finally + OutStr.Free; + InStr.Free; + end; +end; + +destructor TFclHttpConnectionClass.Destroy; +begin + fConnection.Free; + inherited Destroy; +end; + +function HttpConnectionClass: TAbstractHttpConnectionClass; +begin + result := TFclHttpConnectionClass; +end; + +{$endif} + +{$ifdef USEINDY} + +type + TIndyHttpConnectionClass = class(TAbstractHttpConnection) + protected + fConnection: TIdHTTP; + fIOHandler: TIdSSLIOHandlerSocketOpenSSL; // here due to NextGen ARC model + fLock : TMutex; + public + constructor Create(const aParameters: TSQLRestConnectionParams); override; + procedure URI(var Call: TSQLRestURIParams; const InDataType: string; + KeepAlive: integer); override; + destructor Destroy; override; + end; + +{ TIndyHttpConnectionClass } + +constructor TIndyHttpConnectionClass.Create( + const aParameters: TSQLRestConnectionParams); +begin + inherited; + fLock := TMutex.Create; + fConnection := TIdHTTP.Create(nil); + fOpaqueConnection := fConnection; + fConnection.UseNagle := False; + fConnection.HTTPOptions := fConnection.HTTPOptions+[hoKeepOrigProtocol]; + fConnection.ConnectTimeout := fParameters.ConnectionTimeOut; + fConnection.ReadTimeout := fParameters.ReceiveTimeout; + if fParameters.Https then begin + fIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil); + fConnection.IOHandler := fIOHandler; + end; + if fParameters.ProxyName<>'' then + fConnection.ProxyParams.ProxyServer := fParameters.ProxyName; +end; + +destructor TIndyHttpConnectionClass.Destroy; +begin + fConnection.Free; + fIOHandler.Free; + fLock.Free; + inherited; +end; + +procedure TIndyHttpConnectionClass.URI(var Call: TSQLRestURIParams; + const InDataType: string; KeepAlive: integer); +var InStr, OutStr: TStream; + OutLen,i: integer; + Auth: string; +begin + fLock.Enter; + try + InStr := TMemoryStream.Create; + OutStr := TMemoryStream.Create; + try + fConnection.Request.RawHeaders.Text := Call.InHead; + Auth := fConnection.Request.RawHeaders.Values['Authorization']; + if (Auth<>'') and SameText(Copy(Auth,1,6),'Basic ') then begin + // see https://synopse.info/forum/viewtopic.php?pid=11761#p11761 + with TIdDecoderMIME.Create do + try + Auth := DecodeString(copy(Auth,7,maxInt)); + finally + Free; + end; + i := Pos(':',Auth); + if i>0 then begin + fConnection.Request.BasicAuthentication := true; + fConnection.Request.Username := copy(Auth,1,i-1); + fConnection.Request.Password := Copy(Auth,i+1,maxInt); + end; + end; + if Call.InBody<>nil then begin + InStr.Write(Call.InBody[0],length(Call.InBody)); + InStr.Seek(0,soBeginning); + fConnection.Request.Source := InStr; + end; + if Call.Verb='GET' then // allow 404 as valid Call.OutStatus + fConnection.Get(fURL+Call.Url,OutStr,[HTTP_SUCCESS,HTTP_NOTFOUND]) else + if Call.Verb='POST' then + fConnection.Post(fURL+Call.Url,InStr,OutStr) else + if Call.Verb='PUT' then + fConnection.Put(fURL+Call.Url,InStr) else + if Call.Verb='DELETE' then + fConnection.Delete(fURL+Call.Url) else + raise Exception.CreateFmt('Indy does not know method %s',[Call.Verb]); + Call.OutStatus := fConnection.Response.ResponseCode; + Call.OutHead := fConnection.Response.RawHeaders.Text; + OutLen := OutStr.Size; + if OutLen>0 then begin + SetLength(Call.OutBody,OutLen); + OutStr.Seek(0,soBeginning); + OutStr.Read(Call.OutBody[0],OutLen); + end; + finally + OutStr.Free; + InStr.Free; + end; + finally + fLock.Leave; + end; +end; + +function HttpConnectionClass: TAbstractHttpConnectionClass; +begin + result := TIndyHttpConnectionClass; +end; +{$endif} + +{$ifdef USEHTTPCLIENT} +type + THttpClientHttpConnectionClass = class(TAbstractHttpConnection) + protected + fConnection: THttpClient; + procedure DoValidateServerCertificate(const Sender: TObject; + const ARequest: TURLRequest; const Certificate: TCertificate; var Accepted: Boolean); + public + constructor Create(const aParameters: TSQLRestConnectionParams); override; + procedure URI(var Call: TSQLRestURIParams; const InDataType: string; KeepAlive: integer); override; + destructor Destroy; override; + end; + +{ TFclHttpConnectionClass } + +constructor THttpClientHttpConnectionClass.Create(const aParameters: TSQLRestConnectionParams); +begin + inherited Create(aParameters); + fConnection := THttpClient.Create; + {$ifdef ISDELPHI102} // this basic settings are available only since Berlin! + fConnection.ConnectionTimeout := aParameters.ConnectionTimeOut; + fConnection.ResponseTimeout := aParameters.ReceiveTimeout; + {$endif} + fConnection.OnValidateServerCertificate := DoValidateServerCertificate; + fOpaqueConnection := fConnection; +end; + +function NetHeadersToText(const AHeaders: TNetHeaders): string; +var i: integer; +begin + result := ''; + for i := 0 to High(AHeaders) do + with AHeaders[i] do + result := result+Name+': '+Value+#13#10; +end; + +procedure THttpClientHttpConnectionClass.URI(var Call: TSQLRestURIParams; const InDataType: string; KeepAlive: integer); +var + InStr, OutStr: TStream; + OutLen: integer; + LResponse : IHTTPResponse; +begin + InStr := TMemoryStream.Create; + OutStr := TMemoryStream.Create; + try + if Call.InBody<>nil then begin + InStr.Write(Call.InBody[0],length(Call.InBody)); + InStr.Seek(0,soBeginning); + end; + LResponse := nil; + if Call.Verb='GET' then // allow 404 as valid Call.OutStatus + LResponse := fConnection.Get(fURL+Call.Url,OutStr) + else if Call.Verb='POST' then + LResponse := fConnection.Post(fURL+Call.Url,InStr,OutStr) + else if Call.Verb='PUT' then + LResponse := fConnection.Put(fURL+Call.Url,InStr) + else if Call.Verb='DELETE' then + LResponse := fConnection.Delete(fURL+Call.Url) + else + raise Exception.CreateFmt('Indy does not know method %s',[Call.Verb]); + if LResponse <> nil then begin + Call.OutStatus := LResponse.StatusCode; + Call.OutHead := NetHeadersToText(LResponse.Headers); + OutLen := OutStr.Size; + if OutLen>0 then begin + SetLength(Call.OutBody,OutLen); + OutStr.Seek(0,soBeginning); + OutStr.Read(Call.OutBody[0],OutLen); + end; + end; + finally + OutStr.Free; + InStr.Free; + end; +end; + +destructor THttpClientHttpConnectionClass.Destroy; +begin + fConnection.Free; + inherited Destroy; +end; + +procedure THttpClientHttpConnectionClass.DoValidateServerCertificate(const Sender: TObject; + const ARequest: TURLRequest; const Certificate: TCertificate; var Accepted: Boolean); +begin + Accepted := True; +end; + +function HttpConnectionClass: TAbstractHttpConnectionClass; +begin + result := THttpClientHttpConnectionClass; +end; + +{$endif} + +{$ifdef USESYNCRT} +type + TWinHttpConnectionClass = class(TAbstractHttpConnection) + protected + fConnection: TWinHttpAPI; + fLock: TRTLCriticalSection; + public + constructor Create(const aParameters: TSQLRestConnectionParams); override; + procedure URI(var Call: TSQLRestURIParams; const InDataType: string; + KeepAlive: integer); override; + destructor Destroy; override; + end; + +{ TWinHttpConnectionClass } + +constructor TWinHttpConnectionClass.Create( + const aParameters: TSQLRestConnectionParams); +begin + inherited; + InitializeCriticalSection(fLock); + fConnection := TWinHTTP.Create(SockString(fParameters.Server), + SockString(IntToStr(fParameters.Port)),fParameters.Https, + SockString(fParameters.ProxyName),SockString(fParameters.ProxyByPass), + fParameters.ConnectionTimeOut,fParameters.SendTimeout,fParameters.ReceiveTimeout); + fOpaqueConnection := fConnection; + fConnection.IgnoreSSLCertificateErrors := true; // do not be paranoid here +end; + +destructor TWinHttpConnectionClass.Destroy; +begin + fConnection.Free; + DeleteCriticalSection(fLock); + inherited; +end; + +procedure TWinHttpConnectionClass.URI(var Call: TSQLRestURIParams; + const InDataType: string; KeepAlive: integer); +var inb,outb,outh: SockString; + n: integer; +begin + EnterCriticalSection(fLock); + try + SetString(inb,PAnsiChar(Call.InBody),length(Call.InBody)); + Call.OutStatus := fConnection.Request(SockString(Call.Url), + SockString(Call.Verb),KeepAlive,SockString(Call.InHead), + inb,SockString(InDataType),outh,outb); + Call.OutHead := string(outh); + n := length(outb); + SetLength(Call.OutBody,n); + Move(pointer(outb)^,pointer(Call.OutBody)^,n); + finally + LeaveCriticalSection(fLock); + end; +end; + +function HttpConnectionClass: TAbstractHttpConnectionClass; +begin + result := TWinHttpConnectionClass; +end; + +{$endif} + + +{$ifdef ISDWS} // some definitions usually made in SynCrossPlatformJSON.pas + +procedure DoubleQuoteStr(var text: string); +var i,j: integer; + tmp: string; +begin + i := pos('"',text); + if i=0 then begin + text := '"'+text+'"'; + exit; + end; + tmp := '"'+copy(text,1,i)+'"'; + for j := i+1 to length(text) do + if text[j]='"' then + tmp := tmp+'""' else + tmp := tmp+text[j]; + text := tmp+'"'; +end; + +function IdemPropName(const PropName1,PropName2: string): boolean; +begin + result := uppercase(PropName1)=uppercase(PropName2); +end; + +function StartWithPropName(const PropName1,PropName2: string): boolean; +var L: integer; +begin + L := length(PropName2); + if length(PropName1)'' then begin + var i = 1; + var line: string; + while GetNextCSV(Call.InHead,i,line,#10) do begin + var l := pos(':',line ); + if l=0 then + continue; + var head := trim(copy(line,1,l-1)); + var value := trim(copy(line,l+1,length(line))); + if (head<>'') and (value<>'') then + Call.XHR.setRequestHeader(head,value); + end; + end; + if Call.InBody='' then + Call.XHR.send(null) else + Call.XHR.send(Call.InBody); + if not Assigned(Call.OnSuccess) then begin // synchronous call + Call.OutStatus := Call.XHR.status; + Call.OutHead := Call.XHR.getAllResponseHeaders(); + Call.OutBody := Call.XHR.responseText; + end; +end; + + +function HttpConnectionClass: TAbstractHttpConnectionClass; +begin + result := TSMSHttpConnectionClass; +end; + +{$endif ISDWS} + + +{ TSQLRestURIParams } + +procedure TSQLRestURIParams.Init(const aUrl,aVerb,aUTF8Body: string); +begin + Url := aUrl; + Verb := aVerb; + if aUTF8Body='' then + exit; + {$ifdef ISSMS} + InBody := aUTF8Body; + {$else} + InBody := TextToHttpBody(aUTF8Body); + {$endif} +end; + +function TSQLRestURIParams.OutBodyUtf8: String; +begin + {$ifdef ISSMS} + result := OutBody; // XMLHttpRequest did convert UTF-8 into DomString + {$else} + HttpBodyToText(OutBody,result); + {$endif} +end; + + +{$ifndef ISDWS} + +{ TMutex } + +{$ifdef USETMONITOR} + +procedure TMutex.Enter; +begin + TMonitor.Enter(self); +end; + +procedure TMutex.Leave; +begin + TMonitor.Exit(self); +end; + +{$else} + +constructor TMutex.Create; +begin + {$ifdef FPC} + InitCriticalSection(fLock); + {$else} + InitializeCriticalSection(fLock); + {$endif} +end; + +destructor TMutex.Destroy; +begin + {$ifdef FPC} + DoneCriticalSection(fLock); + {$else} + DeleteCriticalSection(fLock); + {$endif} +end; + +procedure TMutex.Enter; +begin + EnterCriticalSection(fLock); +end; + +procedure TMutex.Leave; +begin + LeaveCriticalSection(fLock); +end; + +{$endif} + +{$endif ISDWS} + +initialization +{$ifdef USEINDY} + // see http://www.monien.net/delphi-xe5-ssl-https-on-different-platforms-with-tidhttp-and-trestclient + {$ifdef MACOS} // for OSX, iOS ARM and iOS x86 + {$ifndef CPUARM} + IdOpenSSLSetLibPath('/usr/lib/'); // for OSX and iOS x86 + {$endif} + {$endif} +{$endif USEINDY} +end. diff --git a/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas b/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas new file mode 100644 index 00000000..9570c4b3 --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas @@ -0,0 +1,261 @@ +/// SynLZ compression cross-platform unit +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformSynLZ; + +interface + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + + Compatible with the main SynLZ.pas unit + Should compile with Delphi for any platform (including NextGen for mobiles), + with FPC 2.7 or Kylix - but not yet with SmartMobileStudio 2.1.1 + +} + +/// get maximum possible (worse) compressed size for out_p +function SynLZcomplen(in_len: cardinal): cardinal; + +/// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) +function SynLZdecomplen(in_p: pointer): cardinal; + +/// 1st compression algorithm uses hashing with a 32bits control word +function SynLZcomp(src: pointer; size: cardinal; dst: pointer): cardinal; + +/// 1st compression algorithm uses hashing with a 32bits control word +// - this is the fastest pure pascal implementation +function SynLZdecomp(src: pointer; size: cardinal; dst: pointer): cardinal; + + +implementation + +function SynLZcomplen(in_len: cardinal): cardinal; +begin + result := in_len+in_len shr 3+16; // worse case +end; + +function SynLZdecomplen(in_p: pointer): cardinal; +begin + result := PWord(in_p)^; + inc(PWord(in_p)); + if result and $8000<>0 then + result := (result and $7fff) or (cardinal(PWord(in_p)^) shl 15); +end; + +type +{$ifdef FPC} + PBytes = PAnsiChar; +{$else} + PtrUInt = {$ifdef UNICODE} NativeUInt {$else} cardinal {$endif}; + TBytes = array[0..maxInt-1] of byte; + PBytes = ^TBytes; +{$endif FPC} + +function SynLZcomp(src: pointer; size: cardinal; dst: pointer): cardinal; +var dst_beg, // initial dst value + src_end, // real last byte available in src + src_endmatch, // last byte to try for hashing + o: PtrUInt; + CWbit: cardinal; + CWpoint: PCardinal; + v, h, cached, t, tmax: PtrUInt; + offset: array[0..4095] of PtrUInt; + cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64) +begin + dst_beg := PtrUInt(dst); + // 1. store in_len + if size>=$8000 then begin // size in 32KB..2GB -> stored as integer + PWord(dst)^ := $8000 or (size and $7fff); + PWord(PtrUInt(dst)+2)^ := size shr 15; + inc(PCardinal(dst)); + end else begin + PWord(dst)^ := size ; // size<32768 -> stored as word + if size=0 then begin + result := 2; + exit; + end; + inc(PWord(dst)); + end; + // 2. compress + src_end := PtrUInt(src)+size; + src_endmatch := src_end-(6+5); + CWbit := 1; + CWpoint := pointer(dst); + PCardinal(dst)^ := 0; + inc(PByte(dst),sizeof(CWpoint^)); + fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 + // 1. main loop to search using hash[] + if PtrUInt(src)<=src_endmatch then + repeat + v := PCardinal(src)^; + h := ((v shr 12) xor v) and 4095; + o := offset[h]; + offset[h] := PtrUInt(src); + cached := v xor cache[h]; // o=nil if cache[h] is uninitialized + cache[h] := v; + if (cached and $00ffffff=0) and (o<>0) and (PtrUInt(src)-o>2) then begin + CWpoint^ := CWpoint^ or CWbit; + inc(PWord(src)); + inc(o,2); + t := 1; + tmax := src_end-PtrUInt(src)-1; + if tmax>=(255+16) then + tmax := (255+16); + while (PBytes(o)[t]=PBytes(src)[t]) and (t0 + if t<=15 then begin // mark 2 to 17 bytes -> size=1..15 + PWord(dst)^ := cardinal(t or h); + inc(PWord(dst)); + end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t + dec(t,16); + PWord(dst)^ := h; // size=0 + PByte(PtrUInt(dst)+2)^ := t; + inc(PByte(dst),3); + end; + end else begin + PByte(dst)^ := PByte(src)^; + inc(PByte(src)); + inc(PByte(dst)); + end; + inc(CWbit,CWBit); + if CWbit=0 then begin + CWpoint := pointer(dst); + PCardinal(dst)^ := 0; + inc(PCardinal(dst)); + inc(CWbit); + end; + if PtrUInt(src)<=src_endmatch then continue else break; + until false; + // 2. store remaining bytes + if PtrUInt(src)0 then begin + result := (result and $7fff) or (cardinal(PWord(src)^) shl 15); + inc(PWord(src)); + end; + // 2. decompress + last_hashed := PtrUInt(dst)-1; +nextCW: + CW := PCardinal(src)^; + inc(PCardinal(src)); + CWbit := 1; + if PtrUInt(src)=src_end then break; + if last_hashed0 then + continue else + goto nextCW; + end else begin + h := PWord(src)^; + inc(PWord(src)); + t := (h and 15)+2; + h := h shr 4; + if t=2 then begin + t := PByte(src)^+(16+2); + inc(PByte(src)); + end; + o := offset[h]; + if PtrUInt(dst)-o0 then + continue else + goto nextCW; + end; + until false; +end; + +end. diff --git a/mORMot/CrossPlatform/SynCrossPlatformTests.pas b/mORMot/CrossPlatform/SynCrossPlatformTests.pas new file mode 100644 index 00000000..978ed839 --- /dev/null +++ b/mORMot/CrossPlatform/SynCrossPlatformTests.pas @@ -0,0 +1,891 @@ +/// regression tests for mORMot's cross-platform units +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrossPlatformTests; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Should compile with Delphi for any platform, or with FPC or Kylix + +} + +{$i SynCrossPlatform.inc} // define e.g. HASINLINE + +interface + +uses + SysUtils, + Classes, + Variants, + TypInfo, +{$ifdef ISDELPHI2010} + System.Generics.Collections, +{$endif} +{$ifndef NEXTGEN} + Contnrs, +{$endif} + mORMotClient, // as generated by mORMotWrappers.pas ! + SynCrossPlatformJSON, + SynCrossPlatformCrypto, + SynCrossPlatformSpecific, + SynCrossPlatformRest; + + +type + /// the prototype of an individual test + // - to be used with TSynTest descendants + TSynTestEvent = procedure of object; + +{$M+} { we need the RTTI for the published methods of this object class } + /// generic class for performing simple tests + // - purpose of this ancestor is to have RTTI for its published methods, + // which will contain the tests + TSynTest = class + protected + fFailureMsg: string; + fCurrentTest: Integer; + public + /// the test case name + Ident: string; + /// the registered tests, i.e. all published methods of this class + Tests: TPublishedMethodDynArray; + /// how many Check() call did pass + Passed: cardinal; + /// how many Check() call did failed + Failed: cardinal; + /// create the test instance + // - this constructor will add all published methods to the internal + // test list, accessible via the Count/TestName/TestMethod properties + constructor Create(const aIdent: string=''); + /// run all tests + procedure Run(LogToConsole: boolean); + /// validate a test + procedure Check(test: Boolean; const Msg: string=''); overload; + published + end; + + /// regression tests of our CrossPlatform units + TSynCrossPlatformTests = class(TSynTest) + published + procedure Iso8601DateTime; + procedure Base64Encoding; + procedure JSON; + procedure Model; + procedure Cryptography; + end; + + /// regression tests of our CrossPlatform units + TSynCrossPlatformClient = class(TSynTest) + protected + fAuthentication: TSQLRestServerAuthenticationClass; + fClient: TSQLRestClientHTTP; + public + constructor Create(aAuthentication: TSQLRestServerAuthenticationClass); reintroduce; + destructor Destroy; override; + published + procedure Connection; + procedure ORM; + procedure ORMBatch; + procedure Services; + procedure CleanUp; + end; +{$M-} + + +implementation + +type + TSQLRecordPeopleSimple = class(TSQLRecord) + private + fData: TSQLRawBlob; + fFirstName: RawUTF8; + fLastName: RawUTF8; + fYearOfBirth: integer; + fYearOfDeath: word; + published + property FirstName: RawUTF8 read fFirstName write fFirstName; + property LastName: RawUTF8 read fLastName write fLastName; + property Data: TSQLRawBlob read fData write fData; + property YearOfBirth: integer read fYearOfBirth write fYearOfBirth; + property YearOfDeath: word read fYearOfDeath write fYearOfDeath; + end; + + TMainNested = class(TCollectionItem) + private + fNumber: double; + fIdent: RawUTF8; + published + property Ident: RawUTF8 read fIdent write fIdent; + property Number: double read fNumber write fNumber; + end; + + TMain = class(TPersistent) + private + fName: RawUTF8; + fNested: TCollection; + fList: TStringList; + public + constructor Create; + destructor Destroy; override; + published + property Name: RawUTF8 read fName write fName; + property Nested: TCollection read fNested; + property List: TStringList read fList; + end; + + +{ TSynTest } + +procedure TSynTest.Check(test: Boolean; const Msg: string=''); +begin + if test then + inc(Passed) else begin + inc(Failed); + if Msg<>'' then + fFailureMsg := fFailureMsg+'['+Msg+'] '; + end; +end; + +constructor TSynTest.Create(const aIdent: string); +begin + Ident := aIdent; + GetPublishedMethods(self,Tests); +end; + +procedure TSynTest.Run(LogToConsole: boolean); +var i: integer; + BeforePassed,BeforeFailed: cardinal; + startclass, startmethod: TDateTime; + datetime: string; + LogFile: text; + procedure Log(const Fmt: string; const Args: array of const); + var msg: string; + begin + msg := format(Fmt,Args); + if LogToConsole then + writeln(msg) else + writeln(LogFile,msg); + if not LogToConsole then + Flush(LogFile); + end; +begin + startclass := Now; + datetime := DateTimeToIso8601(startclass); + if not LogToConsole then begin + assign(LogFile,ExtractFilePath(ParamStr(0))+ + FormatDateTime('yyyy mm dd hh nn ss',startclass)+'.txt'); + rewrite(LogFile); + end; + Log(#13#10' %s'#13#10'%s',[Ident,StringOfChar('-',length(Ident)+2)]); + for i := 0 to high(Tests) do begin + Log(#13#10' %d. Running "%s"',[i+1,Tests[i].Name]); + startmethod := Now; + BeforePassed := Passed; + BeforeFailed := Failed; + try + fCurrentTest := i; + TSynTestEvent(Tests[i].Method)(); + except + on E: Exception do + Check(False,format('Exception %s raised with message "%s"',[E.ClassName,E.Message])); + end; + if Failed<>BeforeFailed then + Log(' !!! %d test(s) failed / %d %s',[Failed-BeforeFailed, + Failed-BeforeFailed+Passed-BeforePassed,fFailureMsg]) else + Log(' %d tests passed in %s',[Passed-BeforePassed, + FormatDateTime('nn:ss:zzz',Now-startmethod)]); + fFailureMsg := ''; + end; + Log(#13#10' Tests failed: %d / %d'#13#10' Time elapsed: %s'#13#10#13#10' %s', + [Failed,Failed+Passed,FormatDateTime('nn:ss:zzz',Now-startclass),datetime]); + if not LogToConsole then + close(LogFile); +end; + + +{ TSynCrossPlatformTests } + +procedure TSynCrossPlatformTests.Base64Encoding; +var b,c: TByteDynArray; + i: integer; +begin + check(b=nil); + for i := 0 to 100 do begin + SetLength(b,i); + if i>0 then + b[i-1] := i; + check(Base64JSONStringToBytes(BytesToBase64JSONString(b),c)); + check(length(c)=i); + check(CompareMem(Pointer(b),pointer(c),i)); + end; +end; + +procedure TSynCrossPlatformTests.Cryptography; +var c: array of byte; + s: string; +begin + SetLength(c,5); + c[4] := $96; + Check(crc32(0,c)=$DF4EC16C,'crc32'); + Check(crc32ascii(0,'abcdefghijklmnop')=$943AC093); + SetLength(c,3); + c[0] := ord('a'); + c[1] := ord('b'); + c[2] := ord('c'); + s := SHA256(c); + check(s='ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad'); + check(SHA256('abc')=s); +end; + +procedure TSynCrossPlatformTests.Iso8601DateTime; +procedure Test(D: TDateTime); +var s: string; +procedure One(D: TDateTime); +var E: TDateTime; + V: TTimeLog; +begin + s := DateTimeToIso8601(D); + E := Iso8601ToDateTime(s); + Check(Abs(D-E)<(1/SecsPerDay)); // we allow 1 sec error + Check(DateTimeToJSON(D)='"'+s+'"'); + V := DateTimeToTTimeLog(D); + E := TTimeLogToDateTime(V); + Check(Abs(D-E)<(1/SecsPerDay)); + Check(UrlDecode(UrlEncode(s))=s); +end; +begin + One(D); + Check(length(s)=19); + One(Trunc(D)); + Check(length(s)=10); + One(Frac(D)); + Check(length(s)=9); +end; +var D: TDateTime; + i: integer; + s: string; + T: TTimeLog; +begin + s := '2014-06-28T11:50:22'; + D := Iso8601ToDateTime(s); + Check(Abs(D-41818.49331)<(1/SecsPerDay)); + Check(DateTimeToIso8601(D)=s); + T := DateTimeToTTimeLog(D); + Check(T=135181810838); + D := Now/20+Random*20; // some starting random date/time + for i := 1 to 2000 do begin + Test(D); + D := D+Random*57; // go further a little bit: change date/time + end; +end; + +procedure TSynCrossPlatformTests.JSON; +var doc: variant; + js,json2,inlined: string; + i: integer; + obj1,obj2: TMain; + item: TMainNested; +begin + doc := JSONVariant('{"test":1234,"name":"Joh\"n\r","zero":0.0}'); + check(doc.test=1234); + check(doc.name='Joh"n'#13); + check(doc.name2=null); + check(doc.zero=0); + js := doc; + check(js='{"test":1234,"name":"Joh\"n\r","zero":0}'); + {$ifdef FPC} + TJSONVariantData(doc)['name2'] := 3.1415926; + TJSONVariantData(doc)['name'] := 'John'; + {$else} + doc.name2 := 3.1415926; + doc.name := 'John'; + {$endif} + js := doc; + check(js='{"test":1234,"name":"John","zero":0,"name2":3.1415926}'); + doc := JSONVariant('[{ID:1,"Username":"xx","FirstName":"System",Active:-1}]'); + check(TJSONVariantData(doc).Kind=jvArray); + check(TJSONVariantData(doc).Count=1); + check(TJSONVariantData(doc).Values[0].ID=1); + check(TJSONVariantData(doc).Values[0].Username='xx'); + check(TJSONVariantData(doc).Values[0].Active=-1); + check(IsRowID('id')); + check(IsRowID('iD')); + check(IsRowID('rowid')); + check(IsRowID('RowID')); + check(not IsRowID('iz')); + check(not IsRowID('i2')); + check(not IsRowID('rawid')); + check(not IsRowID('')); + check(FormatBind('',[])=''); + for i := 1 to 1000 do begin + js := IntToStr(i); + inlined := ':('+js+'):'; + check(FormatBind(js,[])=js); + check(FormatBind(js,[i])=js); + check(FormatBind('?',[i])=inlined); + check(FormatBind('a?a',[i])='a'+inlined+'a'); + check(FormatBind('a?',[i])='a'+inlined); + check(FormatBind('?a',[i])=inlined+'a'); + check(FormatBind('ab?',[i])='ab'+inlined); + check(FormatBind('?ab',[i])=inlined+'ab'); + check(FormatBind('ab?ab',[i])='ab'+inlined+'ab'); + check(FormatBind('abc?abc',[i])='abc'+inlined+'abc'); + check(FormatBind('abc?abc',[i,1])='abc'+inlined+'abc'); + check(FormatBind(js+'?',[i])=js+inlined); + check(FormatBind('?'+js,[i])=inlined+js); + check(FormatBind('ab?ab',[js])='ab:("'+js+'"):ab'); + check(FormatBind('ab?ab',[variant(js)])='ab:("'+js+'"):ab'); + check(FormatBind('ab?ab',[variant(i)])='ab'+inlined+'ab'); + check(FormatBind('ab?ab?',[variant(i)])='ab'+inlined+'ab:(null):'); + check(FormatBind('ab?ab??cd',[i,i,js])='ab'+inlined+'ab'+inlined+ + ':("'+js+'"):cd'); + end; + RegisterClassForJSON([TMainNested]); // for JSONToNewObject() + obj1 := TMain.Create; + obj2 := TMain.Create; + try + for i := 1 to 100 do begin + obj1.Name := IntToStr(i); + item := obj1.Nested.Add as TMainNested; + item.Ident := obj1.Name; + item.Number := i/2; + check(obj1.Nested.Count=i); + obj1.list.Add(obj1.Name); + js := ObjectToJSON(obj1); + check(js<>''); + if i=1 then + check(js='{"Name":"1","Nested":[{"Ident":"1","Number":0.5}],"List":["1"]}'); + JSONToObject(obj2,js); + check(obj2.Nested.Count=i); + json2 := ObjectToJSON(obj2); + check(json2=js); + js := ObjectToJSON(item,true); + item := TMainNested(JSONToNewObject(js)); + check(item<>nil); + json2 := ObjectToJSON(item,true); + check(json2=js); + item.Free; + end; + finally + obj2.Free; + obj1.Free; + end; + js := 'one,two,3'; + i := 1; + check(GetNextCSV(js,i,json2)); + check(json2='one'); + check(GetNextCSV(js,i,json2)); + check(json2='two'); + check(GetNextCSV(js,i,json2)); + check(json2='3'); + check(not GetNextCSV(js,i,json2)); + check(not GetNextCSV(js,i,json2)); + js := 'one'; + i := 1; + check(GetNextCSV(js,i,json2)); + check(json2='one'); + check(not GetNextCSV(js,i,json2)); + js := ''; + i := 1; + check(not GetNextCSV(js,i,json2)); + doc := JsonVariant('{}'); + js := doc; + check(js='{}'); +end; + +procedure TSynCrossPlatformTests.Model; +var mdel: TSQLModel; + people: TSQLRecordPeopleSimple; + i: integer; + js: string; + fields: TSQLFieldBits; +begin + mdel := TSQLModel.Create([TSQLRecordPeopleSimple],'test/'); + Check(mdel.Root='test'); + Check(length(mdel.Info)=1); + Check(mdel.Info[0].Table=TSQLRecordPeopleSimple); + Check(mdel.Info[0].Name='PeopleSimple'); + Check(length(mdel.Info[0].Prop)=6); + people := TSQLRecordPeopleSimple.Create; + try + for i := 1 to 1000 do begin + people.ID := i; + people.FirstName := IntToStr(i); + people.LastName := people.FirstName+people.FirstName; + people.YearOfBirth := i+500; + people.YearOfDeath := people.YearOfBirth+40; + js := ObjectToJSON(people); + check(js=Format('{"ID":%d,"FirstName":"%d","LastName":"%d%d",'+ + '"Data":"","YearOfBirth":%d,"YearOfDeath":%d}',[i,i,i,i,i+500,i+540])); + end; + finally + people.Free; + end; + Check(PInteger(@mdel.Info[0].SimpleFields)^=$37); + Check(PInteger(@mdel.Info[0].BlobFields)^=8); + fields := mdel.Info[0].FieldNamesToFieldBits('',false); + Check(PInteger(@fields)^=$37); + fields := mdel.Info[0].FieldNamesToFieldBits('*',false); + Check(PInteger(@fields)^=PInteger(@mdel.Info[0].AllFields)^); + fields := mdel.Info[0].FieldNamesToFieldBits('id,firstname',false); + Check(PInteger(@fields)^=3); + fields := mdel.Info[0].FieldNamesToFieldBits('RowID , firstname ',false); + Check(PInteger(@fields)^=3); + Check(mdel.Info[0].FieldBitsToFieldNames(fields)='RowID,FirstName'); + fields := mdel.Info[0].FieldNamesToFieldBits('firstname,id,toto',false); + Check(PInteger(@fields)^=3); + Check(mdel.Info[0].FieldBitsToFieldNames(fields)='RowID,FirstName'); + mdel.Free; +end; + + +{ TMain } + +constructor TMain.Create; +begin + inherited; + fNested := TCollection.Create(TMainNested); + fList := TStringList.Create; +end; + +destructor TMain.Destroy; +begin + fList.Free; + fNested.Free; + inherited; +end; + +{ TSynCrossPlatformClient } + +constructor TSynCrossPlatformClient.Create( + aAuthentication: TSQLRestServerAuthenticationClass); +begin + inherited Create; + fAuthentication := aAuthentication; +end; + +destructor TSynCrossPlatformClient.Destroy; +begin + CleanUp; + inherited; +end; + +procedure TSynCrossPlatformClient.CleanUp; +begin + FreeAndNil(fClient); + check(fClient=nil); +end; + +procedure TSynCrossPlatformClient.Connection; +var doremotelog: boolean; + dofilelog: boolean; +begin + doremotelog := false; + dofilelog := false; + if fAuthentication=TSQLRestServerAuthenticationDefault then begin + fClient := GetClient('localhost','User','synopse'); + if dofilelog then + fClient.LogToFile(LOG_VERBOSE); + if doremotelog then + fClient.LogToRemoteServer(LOG_VERBOSE,'localhost'); + end else begin + fClient := TSQLRestClientHTTP.Create('localhost',SERVER_PORT,GetModel,true); + if dofilelog then + fClient.LogToFile(LOG_VERBOSE); + if doremotelog then + fClient.LogToRemoteServer(LOG_VERBOSE,'localhost'); + check(fClient.Connect); + check(fClient.ServerTimeStamp<>0); + if fAuthentication<>nil then + fClient.SetUser(fAuthentication,'User','synopse'); + end; +end; + +procedure TSynCrossPlatformClient.ORM; + procedure TestPeople(people: TSQLRecordPeople; var id: integer); + begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=id); + Check(people.FirstName=''); + Check(people.LastName=''); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(people.Sexe=sFemale); + end; +var people: TSQLRecordPeople; + Call: TSQLRestURIParams; + i,id: integer; + list: TObjectList; + {$ifdef ISDELPHI2010} + peoples: TObjectList; + {$endif ISDELPHI2010} +begin + fClient.CallBackGet('DropTable',[],Call,TSQLRecordPeople); + Check(fClient.InternalState>0); + Check(Call.OutStatus=HTTP_SUCCESS); + people := TSQLRecordPeople.Create; + try + Check(people.InternalState=0); + for i := 1 to 200 do begin + people.FirstName := 'First'+IntToStr(i); + people.LastName := 'Last'+IntToStr(i); + people.YearOfBirth := i+1800; + people.YearOfDeath := i+1825; + people.Sexe := TPeopleSexe(i and 1); + Check(fClient.Add(people,true)=i); + Check(people.InternalState=fClient.InternalState); + end; + finally + people.Free; + end; + people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'','',[]); + try + Check(people.InternalState=0); + id := 0; + while people.FillOne do begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=id); + Check(people.FirstName='First'+IntToStr(id)); + Check(people.LastName='Last'+IntToStr(id)); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(ord(people.Sexe)=id and 1); + end; + Check(id=200); + finally + people.Free; + end; + people := TSQLRecordPeople.CreateAndFillPrepare(fClient, + 'YearOFBIRTH,Yearofdeath,id','',[]); + try + Check(people.InternalState=0); + id := 0; + while people.FillOne do + TestPeople(people,id); + Check(id=200); + finally + people.Free; + end; + list := fClient.RetrieveList(TSQLRecordPeople,'YearOFBIRTH,Yearofdeath,id','',[]); + try + id := 0; + for i := 0 to list.Count-1 do + TestPeople(TSQLRecordPeople(list[i]),id); + Check(id=200); + finally + list.Free; + end; + {$ifdef ISDELPHI2010} + peoples := fClient.RetrieveList('YearOFBIRTH,yearofdeath,id','',[]); + try + id := 0; + for i := 0 to peoples.Count-1 do + TestPeople(peoples[i],id); + Check(id=200); + finally + peoples.Free; + end; + {$endif ISDELPHI2010} + people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'', + 'yearofbirth=?',[1900]); + try + Check(people.InternalState=0); + id := 0; + while people.FillOne do begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=100); + Check(people.FirstName='First100'); + Check(people.LastName='Last100'); + Check(people.YearOfBirth=1900); + Check(people.YearOfDeath=1925); + end; + Check(id=1); + finally + people.Free; + end; + for i := 1 to 200 do + if i and 15=0 then + fClient.Delete(TSQLRecordPeople,i) else + if i mod 82=0 then begin + people := TSQLRecordPeople.Create; + try + id := i+1; + people.ID := i; + people.FirstName := 'First'+IntToStr(id); + people.LastName := 'Last'+IntToStr(id); + people.YearOfBirth := id+1800; + people.YearOfDeath := id+1825; + Check(people.InternalState=0); + Check(fClient.Update(people,'YEarOFBIRTH,YEarOfDeath')); + Check(people.InternalState=fClient.InternalState); + finally + people.Free; + end; + end; + for i := 1 to 200 do begin + people := TSQLRecordPeople.Create(fClient,i); + try + if i and 15=0 then + Check(people.ID=0) else begin + Check(people.InternalState=fClient.InternalState); + if i mod 82=0 then + id := i+1 else + id := i; + Check(people.ID=i); + Check(people.FirstName='First'+IntToStr(i)); + Check(people.LastName='Last'+IntToStr(i)); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(ord(people.Sexe)=i and 1); + end; + finally + people.Free; + end; + end; +end; + +procedure TSynCrossPlatformClient.ORMBatch; +var people: TSQLRecordPeople; + Call: TSQLRestURIParams; + res: TIDDynArray; + {$ifndef ISDWS} + blob: TSQLRawBlob; + {$endif} + i,id: integer; +begin + fClient.CallBackGet('DropTable',[],Call,TSQLRecordPeople); + Check(fClient.InternalState>0); + Check(Call.OutStatus=HTTP_SUCCESS); + fClient.BatchStart(TSQLRecordPeople); + people := TSQLRecordPeople.Create; + try + for i := 1 to 200 do begin + Check(people.InternalState=0); + people.FirstName := 'First'+IntToStr(i); + people.LastName := 'Last'+IntToStr(i); + people.YearOfBirth := i+1800; + people.YearOfDeath := i+1825; + people.Sexe := TPeopleSexe(i and 1); + fClient.BatchAdd(people,true); + end; + finally + people.Free; + end; + Check(fClient.BatchSend(res)=HTTP_SUCCESS); + Check(length(res)=200); + for i := 1 to length(res) do + Check(res[i-1]=i); + people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'','',[]); + try + Check(people.InternalState=0); + id := 0; + while people.FillOne do begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=id); + Check(people.FirstName='First'+IntToStr(id)); + Check(people.LastName='Last'+IntToStr(id)); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(ord(people.Sexe)=id and 1); + end; + Check(id=200); + finally + people.Free; + end; + people := TSQLRecordPeople.CreateAndFillPrepare(fClient, + 'YearOFBIRTH,Yearofdeath,id','',[]); + try + id := 0; + Check(people.InternalState=0); + while people.FillOne do begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=id); + Check(people.FirstName=''); + Check(people.LastName=''); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(people.Sexe=sFemale); + end; + Check(id=200); + finally + people.Free; + end; + people := TSQLRecordPeople.CreateAndFillPrepare(fClient,'', + 'yearofbirth=?',[1900]); + try + Check(people.InternalState=0); + id := 0; + while people.FillOne do begin + Check(people.InternalState=fClient.InternalState); + inc(id); + Check(people.ID=100); + Check(people.FirstName='First100'); + Check(people.LastName='Last100'); + Check(people.YearOfBirth=1900); + Check(people.YearOfDeath=1925); + end; + Check(id=1); + finally + people.Free; + end; + fClient.BatchStart(nil); + for i := 1 to 200 do + if i and 15=0 then + fClient.BatchDelete(TSQLRecordPeople,i) else + if i mod 82=0 then begin + people := TSQLRecordPeople.Create; + try + id := i+1; + people.ID := i; + people.FirstName := 'First'+IntToStr(id); + people.LastName := 'Last'+IntToStr(id); + people.YearOfBirth := id+1800; + people.YearOfDeath := id+1825; + Check(fClient.BatchUpdate(people,'YEarOFBIRTH,YEarOfDeath')>=0); + Check(people.InternalState=0); + finally + people.Free; + end; + end; + Check(fClient.BatchSend(res)=HTTP_SUCCESS); + Check(length(res)=14); + for i := 1 to 14 do + Check(res[i-1]=HTTP_SUCCESS); + for i := 1 to 200 do begin + people := TSQLRecordPeople.Create(fClient,i); + try + if i and 15=0 then + Check(people.ID=0) else begin + Check(people.InternalState=fClient.InternalState); + if i mod 82=0 then + id := i+1 else + id := i; + Check(people.ID=i); + Check(people.FirstName='First'+IntToStr(i)); + Check(people.LastName='Last'+IntToStr(i)); + Check(people.YearOfBirth=id+1800); + Check(people.YearOfDeath=id+1825); + Check(ord(people.Sexe)=i and 1); + end; + finally + people.Free; + end; + end; + {$ifndef ISDWS} + exit; // Add(..,'Data') below is buggy, but RetrieveBlob() seems fine + people := TSQLRecordPeople.Create; + try + people.FirstName := 'With'; + people.LastName := 'Blob'; + SetLength(blob,2); + blob[0] := 1; + blob[1] := 2; + people.Data := blob; + id := fClient.Add(people,true,false,'FirstName,LastName,Data'); + Check(id=201); + Check(people.InternalState=fClient.InternalState); + blob := nil; + finally + people.Free; + end; + people := TSQLRecordPeople.Create(fClient,id); + try + Check(people.FirstName='With'); + Check(people.LastName='Blob'); + Check(people.Data=nil); + Check(not fClient.RetrieveBlob(TSQLRecordPeople,id,'wrongfieldname',blob)); + Check(blob=nil); + Check(fClient.RetrieveBlob(TSQLRecordPeople,id,'data',blob)); + Check(blob<>nil); + finally + people.Free; + end; + {$endif} +end; + +procedure TSynCrossPlatformClient.Services; +var calc: ICalculator; + i,j: integer; + sex: TPeopleSexe; + name: string; + rec: TTestCustomJSONArraySimpleArray; +const SEX_TEXT: array[0..1] of RawUTF8 = ('Miss','Mister'); +begin + calc := TServiceCalculator.Create(fClient); + check(calc.InstanceImplementation=sicShared); + check(calc.ServiceName='Calculator'); + for i := 1 to 200 do + check(calc.Add(i,i+1)=i*2+1); + for i := 1 to 200 do begin + sex := TPeopleSexe(i and 1); + name := 'Smith'; + calc.ToText(i,'$',sex,name); + check(sex=sFemale); + check(name=format('$ %d for %s Smith',[i,SEX_TEXT[i and 1]])); + end; + Fillchar(rec,SizeOf(rec),0); + for i := 1 to 100 do begin + name := calc.RecordToText(rec); + if i=1 then + check(name='{"F":"","G":[],"H":{"H1":0,"H2":"","H3":{"H3a":false,"H3b":null}},"I":"","J":[]}'); + check(length(Rec.F)=i); + for j := 1 to length(Rec.F) do + check(Rec.F[j]='!'); + check(length(Rec.G)=i); + for j := 0 to high(Rec.G) do + check(Rec.G[j]=IntToStr(j+1)); + check(Rec.H.H1=i); + check(length(Rec.J)=i-1); + for j := 0 to high(Rec.J) do begin + Check(Rec.J[j].J1=j); + Check(Rec.J[j].J2.D2=j); + Check(Rec.J[j].J3=TRecordEnum(j mod (ord(high(TRecordEnum))+1))); + end; + end; +end; + +end. diff --git a/mORMot/CrossPlatform/templates/API.adoc.mustache b/mORMot/CrossPlatform/templates/API.adoc.mustache new file mode 100644 index 00000000..7cf78566 --- /dev/null +++ b/mORMot/CrossPlatform/templates/API.adoc.mustache @@ -0,0 +1,186 @@ +== API Documentation + +NOTE: API Documentation {{exeVersion}} retrieved {{#protocol}}from {{protocol}}://{{host}}/{{uri}} {{/protocol}}at {{time}}. + +This documentation has been generated by {{exeInfo}}, running mORMot {{mORMotVersion}}. + +WARNING: Any manual modification of this file may be lost after regeneration. + +=== Services + +This server does publish the following RESTful services: + +{{#soa.services}} +* <<{{uri}}>>. +{{/soa.services}} + +It will also use some <>{{#withArrays}}, <>{{/withArrays}}{{#withEnumerates}}, <>{{/withEnumerates}}{{#withsets}}, <>{{/withsets}} type definitions, which will be transmitted as JSON objects, arrays or integers. The expected MIME transmission type, at HTTP level, is `application/json; charset=UTF-8`. Communication protocol may be either `http://` or `https://`, depending on the server configuration. + +The following documentation will detail each service, and the input/output JSON content, as expected by each command. + + +{{#soa.services}} +=== {{uri}} + +[.lead] +{{serviceDescription}} + +This `{{uri}}` service does publish the following methods (aka commands): + +{{#methods}} +* <<{{methodName}}>>. +{{/methods}} +{{>. +{{/isArray}} +{{#isRecord}}* <<{{typePascal}}>>. +{{/isRecord}} +{{#isEnum}}* <<{{typePascal}}>>. +{{/isEnum}}{{/typePascal}}{{/typeList}} + +{{#methods}} +==== {{methodName}} + +[.lead] +{{methodDescription}} + +.URI (alternatives) + POST {{protocol}}://servername:port/{{root}}/{{uri}}.{{methodName}} + POST {{protocol}}://servername:port/{{root}}/{{uri}}/{{methodName}} + +.Input Body +---- +{{#hasInParams}} +{ +{{#args}} +{{#dirInput}} + {{jsonQuote argName}}: {{typePascal}}{{commaInSingle}} +{{/dirInput}} +{{/args}} +} +{{/hasInParams}} +{{^hasInParams}} +No input expected. +{{/hasInParams}} +---- + +.Output Body +---- +{{#hasOutParams}} +{ +{{#args}} +{{#dirOutput}} + {{jsonQuote argName}}: {{typePascal}}{{#commaOutResult}},{{/commaOutResult}} +{{/dirOutput}} +{{/args}} +} +{{/hasOutParams}} +{{^hasOutParams}} +No output expected. +{{/hasOutParams}} +---- + +See also: + +{{#args}} +{{>typeList}} +{{/args}} +* Other <<{{uri}}>> Services. + +{{/methods}} + +{{/soa.services}} + +{{#withRecords}} +=== Objects + +The following objects are used during data transmission: +{{writerec}}{{nestedIdentation}} }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}}{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}} }{{/nestedRecordArray}}{{^-last}},{{/-last}} +{{/fields}}{{/writerec}} + +{{#records}} +==== {{name}} + +[.lead] +{{recordDescription}} + +.Definition +---- +{{>writerec}} +} +---- +See also: + +{{#fields}} +{{>typeList}} +{{/fields}} +* Other <>. +{{#withArrays}} +* Other <>. +{{/withArrays}} +{{#withEnumerates}} +* Other <>. +{{/withEnumerates}} +{{#withsets}} +* Other <>. +{{/withsets}} + +{{/records}} + +{{/withRecords}} +{{#withArrays}} +=== Arrays + +The following arrays are used during data transmission: + +{{#arrays}} +==== {{name}} + +This is a JSON array of <<{{typeSource}}>>. + +{{/arrays}} + +{{/withArrays}} +{{#withEnumerates}} + +=== Enumerations + +When transmitted within other <>, <> or <> content, enumerations are represented by their `integer` JSON value. Any other value will be ignored. + +The following enumerations have been defined: + +{{#enumerates}} +==== {{name}} + +[.lead] +{{enumDescription}} + +{{#values}} + {{-index0}} = {{EnumTrim .}} +{{/values}} + +{{/enumerates}} +{{/withEnumerates}} + +{{#withsets}} + +=== Sets + +When transmitted within other <>, <> or <> content, sets are represented by their `integer` JSON value, matching binary bit storage. The `integer` values below may be added, to compute the set of individual flags - a value of `0` meaning a void set. + +The following sets have been defined: + +{{#sets}} +==== {{name}} + +[.lead] +{{setDescription}} + +{{#values}} + {{PowerOfTwo -index0}} = {{EnumTrim .}} +{{/values}} + +{{/sets}} + +{{/withsets}} diff --git a/mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache b/mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache new file mode 100644 index 00000000..0040695d --- /dev/null +++ b/mORMot/CrossPlatform/templates/CrossPlatform.pas.mustache @@ -0,0 +1,309 @@ +/// remote access to a mORMot server using SynCrossPlatform* units +{{#uri}} +// - retrieved from {{protocol}}://{{host}}/{{uri}} +// at {{time}} using "{{templateName}}" template +{{/uri}} +{{^uri}} +// - generated at {{time}} +{{/uri}} +unit {{fileName}}; + +{ + WARNING: + This unit has been generated by a mORMot {{mORMotVersion}} server. + Any manual modification of this file may be lost after regeneration. + + Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez + Synopse Informatique - http://synopse.info + + This unit is released under a MPL/GPL/LGPL tri-license, + and therefore may be freely included in any application. + + This unit would work on Delphi 6 and later, under all supported platforms + (including MacOSX, and NextGen iPhone/iPad), and the Free Pascal Compiler. +} + +interface + +uses + SynCrossPlatformJSON, + SynCrossPlatformSpecific, + SynCrossPlatformREST; + +{{! recursive partials used to write records type definition}} +{{writerec}}{{nestedIdentation}} end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}} end;{{/nestedRecordArray}} +{{/fields}}{{/writerec}} +{{#withEnumerates}} +type // define some enumeration types, used below +{{#enumerates}} + {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/enumerates}} + +{{/withEnumerates}} +{{#withSets}} +type // define some set types, used below +{{#sets}} + {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/sets}} + +{{/withSets}} +{{#withRecords}} +type // define some record types, used as properties below +{{#records}} + {{name}} = {{>writerec}} end; + +{{/records}} +{{/withRecords}} +{{#withArrays}} +type // define some dynamic array types, used as properties below +{{#arrays}} + {{name}} = array of {{typeSource}}; +{{/arrays}} + +{{/withArrays}} +{{method}} +{{/methods}} + end; + + /// implements I{{interfaceURI}} {{#uri}}from {{protocol}}://{{host}}/{{root}}/{{uri}}{{/uri}} + // - this service will run in sic{{instanceCreationName}} mode + TService{{interfaceURI}} = class(TServiceClientAbstract{{#isClientDriven}}ClientDriven{{/isClientDriven}},I{{interfaceURI}}) + public + constructor Create(aClient: TSQLRestClientURI); override; +{{#methods}} + {{verb}} {{>method}} +{{/methods}} + end; + +{{/soa.services}} +const + /// the server port{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}} + SERVER_PORT = {{port}}; + /// the server model root name{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}} + SERVER_ROOT = '{{root}}'; + + +/// return the database Model corresponding to this server +function GetModel(const aRoot: string=SERVER_ROOT): TSQLModel; + +/// create a TSQLRestClientHTTP instance and connect to the server +// - it will use by default port {{port}} over root '{{root}}'{{#host}}, corresponding +// to {{protocol}}://{{host}}/{{root}}{{/host}} +{{#authClass}} +// - secure connection will be established via {{.}} +// with the supplied credentials - on connection or authentication error, +// this function will raise a corresponding exception +{{/authClass}} +function GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string; + aServerPort: integer=SERVER_PORT; const aServerRoot: string=SERVER_ROOT; + aHttps: boolean={{#https}}true{{/https}}{{^https}}false{{/https}}): TSQLRestClientHTTP; + +{{#withHelpers}} +// publish some low-level helpers for variant conversion +// - used internally: you should not need those functions in your end-user code +{{#enumerates}} +function Variant2{{name}}(const _variant: variant): {{name}}; +{{/enumerates}} +{{#records}} +function Variant2{{name}}(_variant: variant): {{name}}; +function {{name}}2Variant(const _record: {{name}}): variant; +{{/records}} +{{#arrays}} +function Variant2{{name}}(const _variant: variant): {{name}}; +function {{name}}2Variant(const _array: {{name}}): variant; +{{/arrays}} + +{{/withHelpers}} + +implementation + +{$HINTS OFF} // for H2164 hints of unused variables + +{{#withEnumerates}} + +{ Some helpers for enumerates types } + +{{#enumerates}} +function Variant2{{name}}(const _variant: variant): {{name}}; +begin + result := {{name}}(VariantToEnum(_variant,[{{#values}}'{{.}}'{{^-last}},{{/-last}}{{/values}}])); +end; + +{{/enumerates}} +{{/withEnumerates}} +{{#withRecords}} +{{setrec}}{{/nestedRecord}}{{#fromVariant}} result.{{fullPropName}} := {{fromVariant}}(_variant.{{fullPropName}}); +{{/fromVariant}}{{#nestedSimpleArray}} _arr := JSONVariantDataSafe(_variant.{{fullPropName}},jvArray); + SetLength(result.{{fullPropName}},_arr^.Count); + for _a := 0 to high(result.{{fullPropName}}) do + result.{{fullPropName}}[_a] := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}_arr^.Values[_a]{{#fromVariant}}){{/fromVariant}}; +{{/nestedSimpleArray}}{{#nestedRecordArray}} _arr := JSONVariantDataSafe(_variant.{{fullPropName}},jvArray); + SetLength(result.{{fullPropName}},_arr^.Count); + for _a := 0 to high(result.{{fullPropName}}) do + with result.{{fullPropName}}[_a] do begin +{{#fields}} + {{propName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}_arr^.Values[_a].{{propName}}{{#fromVariant}}){{/fromVariant}}; +{{/fields}} + end; +{{/nestedRecordArray}}{{/fields}}{{/setrec}} +{{getrec}}{{/nestedRecord}}{{#toVariant}} res.SetPath('{{fullPropName}}',{{toVariant}}(_record.{{fullPropName}})); +{{/toVariant}}{{#nestedSimpleArray}} with res.EnsureData('{{fullPropName}}')^ do + for i := 0 to high(_record.{{fullPropName}}) do + AddValue({{#toVariant}}{{toVariant}}({{/toVariant}}_record.{{fullPropName}}[i]{{#toVariant}}){{/toVariant}}); +{{/nestedSimpleArray}}{{#nestedRecordArray}} with res.EnsureData('{{fullPropName}}')^ do + for i := 0 to high(_record.{{fullPropName}}) do + with AddItem^, _record.{{fullPropName}}[i] do begin +{{#fields}} + AddNameValue('{{propName}}',{{#toVariant}}{{toVariant}}({{/toVariant}}{{propName}}{{#toVariant}}){{/toVariant}}); +{{/fields}} + end; +{{/nestedRecordArray}}{{/fields}}{{/getrec}}{ Some helpers for record types } +{{#records}} + +function Variant2{{name}}(_variant: variant): {{name}}; +var _a: integer; + _arr: PJSONVariantData; +begin +{{>setrec}} +end; + +function {{name}}2Variant(const _record: {{name}}): variant; +var i: integer; + res: TJSONVariantData; +begin + res.Init; +{{>getrec}} + result := variant(res); +end; +{{/records}} + +{{/withRecords}} +{{#withArrays}} + +{ Some helpers for dynamic array types } + +{{#arrays}} +function Variant2{{name}}(const _variant: variant): {{name}}; +var i: integer; + arr: PJSONVariantData; +begin + arr := JSONVariantDataSafe(_variant,jvArray); + SetLength(result,arr^.Count); + for i := 0 to arr^.Count-1 do + result[i] := {{#fromVariant}}{{fromVariant}}{{/fromVariant}}(arr^.Values[i]); +end; + +function {{name}}2Variant(const _array: {{name}}): variant; +var i: integer; + res: TJSONVariantData; +begin + res.Init; + for i := 0 to high(_array) do + res.AddValue({{#toVariant}}{{toVariant}}{{/toVariant}}(_array[i])); + result := variant(res); +end; + +{{/arrays}} +{{/withArrays}} + +{$HINTS ON} // for H2164 hints of unused variables + +function GetModel(const aRoot: string): TSQLModel; +begin + result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],aRoot); +end; + +function GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string; + aServerPort: integer; const aServerRoot: string; aHttps: boolean): TSQLRestClientHTTP; +begin + result := TSQLRestClientHTTP.Create(aServerAddress,aServerPort, + GetModel(aServerRoot),true,aHttps); // aOwnModel=true + try + if (not result.Connect) or (result.ServerTimeStamp=0) then + raise ERestException.CreateFmt('Impossible to connect to %s:%d server', + [aServerAddress,aServerPort]); +{{#authClass}} + if not result.SetUser({{.}},aUserName,aPassword) then + raise ERestException.CreateFmt('%s:%d server rejected "%s" credentials', + [aServerAddress,aServerPort,aUserName]); +{{/authClass}} + except + result.Free; + raise; + end; +end; + +{{#soa.services}} + +{ TService{{interfaceURI}} } + +constructor TService{{interfaceURI}}.Create(aClient: TSQLRestClientURI); +begin + fServiceName := '{{interfaceURI}}'; + fServiceURI := '{{uri}}'; + fInstanceImplementation := sic{{instanceCreationName}}; + fContractExpected := '{{contractExpected}}'; + inherited Create(aClient); +end; + +{{#methods}} +{{verb}} TService{{interfaceURI}}.{{>method}} +var res: TVariantDynArray; +begin + fClient.CallRemoteService(self,'{{methodName}}',{{ArgsOutputCount}}, // raise EServiceException on error + [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}],res{{#resultIsServiceCustomAnswer}},true{{/resultIsServiceCustomAnswer}}); +{{#args}}{{#dirOutput}}{{#isObject}} {{argName}}.Free; // avoid memory leak +{{/isObject}} {{argName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}}; +{{/dirOutput}}{{/args}}end; + +{{/methods}} +{{/soa.services}} + +end. \ No newline at end of file diff --git a/mORMot/CrossPlatform/templates/Delphi.pas.mustache b/mORMot/CrossPlatform/templates/Delphi.pas.mustache new file mode 100644 index 00000000..5c6dab1b --- /dev/null +++ b/mORMot/CrossPlatform/templates/Delphi.pas.mustache @@ -0,0 +1,174 @@ +/// remote access to a mORMot server using mORMot units +{{#uri}} +// - retrieved from http://{{host}}/{{uri}} +// at {{time}} using "{{templateName}}" template +{{/uri}} +{{^uri}} +// - generated at {{time}} +{{/uri}} +unit {{fileName}}; + +{ + WARNING: + This unit has been generated by a mORMot {{mORMotVersion}} server. + Any manual modification of this file may be lost after regeneration. + + Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez + Synopse Informatique - http://synopse.info + + This unit is released under a MPL/GPL/LGPL tri-license, + and therefore may be freely included in any application. + + This unit would work on Delphi 6 and later, under Win32 and Win64 platforms, + and with FPC 2.7/trunk revision, under Win32 and Linux32. +} + +interface + +uses + SynCommons, + mORMot; +{{! recursive partials used to write records type definition}} +{{writerec}}{{nestedIdentation}} end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}} end;{{/nestedRecordArray}} +{{/fields}}{{/writerec}} +{{textrec}} }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}}{{/nestedSimpleArray}}{{#nestedRecordArray}}[ {{>textrec}} ]{{/nestedRecordArray}} {{/fields}}{{/textrec}} +{{#withEnumerates}} +type // define some enumeration types, used below +{{#enumerates}} + {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/enumerates}} + +{{/withEnumerates}} +{{#withSets}} +type // define some set types, used below +{{#sets}} + {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/sets}} + +{{/withSets}} +{{#withRecords}} +type // define some record types, used as properties below +{{#records}} + {{name}} = {{>writerec}} end; + +{{/records}} +{{/withRecords}} +{{#withArrays}} +type // define some dynamic array types, used as properties below +{{#arrays}} + {{name}} = array of {{typeSource}}; +{{/arrays}} + +{{/withArrays}} +{{method}} +{{/methods}} + end; + + {{/soa.services}} + +/// return the database Model corresponding to this server +function GetModel: TSQLModel; + +const + /// the server port{{#uri}}, corresponding to http://{{host}}{{/uri}} + SERVER_PORT = {{port}}; + + +{{#soa.enabled}} +/// define the interface-based services to be consummed by the client +// - will define the following interfaces: +{{#soa.services}} +// ! I{{interfaceURI}} sic{{instanceCreationName}} {{GUID}} +{{/soa.services}} +procedure RegisterServices(Client: TSQLRestClientURI); +{{/soa.enabled}} + + +implementation + +{{#orm}} +{{#hasRecords}} +{ {{className}} } + +class procedure {{className}}.InternalRegisterCustomProperties( + Props: TSQLRecordProperties); +begin +{{#fields}} +{{#isrecord}} + Props.RegisterCustomPropertyFromRTTI(Self,TypeInfo({{typeDelphi}}), + '{{name}}',@{{className}}(nil).f{{name}}); +{{/isrecord}} +{{/fields}} +end; + +{{/hasRecords}} +{{/orm}} + +function GetModel: TSQLModel; +begin + result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],'{{root}}'); +end; + +{{#soa.enabled}} +procedure RegisterServices(Client: TSQLRestClientURI); +begin +{{#soa.services}} + Client.ServiceRegister(TypeInfo(I{{interfaceURI}}),sic{{instanceCreationName}}); +{{/soa.services}} +end; +{{/soa.enabled}} + +{{#withRecords}} +const // text-based types definition for records and dynamic arrays +{{#records}} + __{{name}} = '{{>textrec}}'; +{{/records}} + +initialization +{{#enumerates}} + TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( + TypeInfo({{name}})); +{{/enumerates}} +{{#records}} + TTextWriter.RegisterCustomJSONSerializerFromText( + TypeInfo({{name}}),__{{name}}); +{{/records}} +{{/withRecords}} +end. \ No newline at end of file diff --git a/mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache b/mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache new file mode 100644 index 00000000..a5f5576f --- /dev/null +++ b/mORMot/CrossPlatform/templates/FPC-mORMotInterfaces.pas.mustache @@ -0,0 +1,87 @@ +/// SOA interface methods definition to circumvent FPC missing RTTI +{{#uri}} +// - retrieved from http://{{host}}/{{uri}} +// at {{time}} using "{{templateName}}" template +{{/uri}} +{{^uri}} +// - generated at {{time}} +{{/uri}} +unit {{fileName}}; + +{ + WARNING: + This unit has been generated by a mORMot {{mORMotVersion}} server. + Any manual modification of this file may be lost after regeneration. + + Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez + Synopse Informatique - http://synopse.info + + This unit is released under a MPL/GPL/LGPL tri-license, + and therefore may be freely included in any application. + + This unit is intended to work on older FPC compilers, which lack of RTTI + for interfaces - see http://bugs.freepascal.org/view.php?id=26774 + + USAGE: + + Add this {{fileName}} unit to your uses clause, so that the following + interfaces would be defined as expected by mORMot under FPC: + +{{#soa.services}} + - {{interfaceName}} +{{/soa.services}} + +} + +interface + +{$I Synopse.inc} // needed for setting HASINTERFACERTTI and proper FPC modes + +uses + SysUtils, + Classes, + SynCommons, + SynLog, + mORMot{{#units}}, + {{.}}{{/units}}; + + +implementation + +{{#soa.enabled}} +{$ifndef HASINTERFACERTTI} // circumvent old FPC bug of missing RTTI + +{ TInterfaceFactoryDefinition } + +type + /// define and manage missing interface RTTI for the following interfaces: +{{#soa.services}} + // - {{interfaceName}} +{{/soa.services}} + TInterfaceFactoryDefinition = class(TInterfaceFactoryGenerated) + protected + procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override; + end; + +procedure TInterfaceFactoryDefinition.AddMethodsFromTypeInfo(aInterface: PTypeInfo); +begin +{{#soa.services}} + if aInterface=TypeInfo({{interfaceName}}) then begin +{{#methods}} + AddMethod('{{methodName}}',[ +{{#args}} ord(smd{{dirName}}),'{{argName}}',TypeInfo({{typeSource}}){{#isArgLast}}]);{{/isArgLast}}{{^isArgLast}}, +{{/isArgLast}}{{/args}} {{^args}}]);{{/args}} +{{/methods}} + exit; + end; +{{/soa.services}} +end; + +initialization +{{#soa.services}} + TInterfaceFactoryDefinition.RegisterInterface(TypeInfo({{interfaceName}})); +{{/soa.services}} + +{$endif HASINTERFACERTTI} +{{/soa.enabled}} +end. diff --git a/mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache b/mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache new file mode 100644 index 00000000..220a3640 --- /dev/null +++ b/mORMot/CrossPlatform/templates/FPCServer-mORMotServer.pas.mustache @@ -0,0 +1,157 @@ +/// {{#units}}{{.}} {{/units}}generated types for a FPC mORMot server +{{#uri}} +// - retrieved from http://{{host}}/{{uri}} +// at {{time}} using "{{templateName}}" template +{{/uri}} +{{^uri}} +// - generated at {{time}} +{{/uri}} +unit {{fileName}}; + +(* + WARNING: + This unit has been generated by a mORMot {{mORMotVersion}} server. + Any manual modification of this file may be lost after regeneration. + + Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez + Synopse Informatique - http://synopse.info + + This unit is released under a MPL/GPL/LGPL tri-license, + and therefore may be freely included in any application. + + This unit is intended to work on older FPC compilers, which lack of RTTI + for interfaces and records. As a result, you would be able to compile + your server executable for hosting in Linux. + + It will also include RTTI for records for versions prior to Delphi 2010. + + USAGE: + + 1. Compile your code using latest versions of Delphi (which supports + record definition as published properties since XE5) + + 2. Enumerations, sets, dynamic arrays and records type definitions + would be shared from the original Delphi units + + 3. Add a reference to this {{fileName}} unit to your uses clause, so that + missing RTTI would be available for the following types: +{{#records}} + - {{name}} record +{{/records}} +{{#soa.services}} + - I{{interfaceURI}} interface +{{/soa.services}} +{{#ORMWithRecords}} + + 4. Ensure there is a reference to {$I Synopse.inc} at the beginning of the following units: +{{#units}} + - {{.}}.pas +{{/units}} + + 5. Modify the following type definitions to include the information + about record published properties: +{{#orm}} +{{#hasRecords}} + + {{className}} = class({{classParent}}) // in {{unitName}}.pas + ... + public + {$ifndef PUBLISHRECORD} // defined in Synopse.inc + class procedure InternalRegisterCustomProperties(Props: TSQLRecordProperties); override; + {$endif} + ... + +{$ifndef PUBLISHRECORD} +class procedure {{className}}.InternalRegisterCustomProperties(Props: TSQLRecordProperties); +begin +{{#fields}} +{{#isrecord}} + Props.RegisterCustomPropertyFromRTTI(Self,TypeInfo({{typeDelphi}}), + '{{name}}',@{{className}}(nil).f{{name}}); +{{/isrecord}} +{{/fields}} +end; +{$endif} +{{/hasRecords}} +{{/orm}} +{{/ORMWithRecords}} +*) + +interface + +{$I Synopse.inc} // needed for setting HASINTERFACERTTI and proper FPC modes + +uses + SysUtils, + Classes, + SynCommons, + mORMot, + mORMotDDD{{#units}}, + {{.}}{{/units}}; + + +implementation + +{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug +{{#soa.enabled}} + +{ TInterfaceFactoryDefinition } + +type + /// define and manage missing interface RTTI for defined interfaces + TInterfaceFactoryDefinition = class(TInterfaceFactoryGenerated) + protected + /// will declare the following types to the interface factory: +{{#soa.services}} + // - I{{interfaceURI}} +{{/soa.services}} + procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo); override; + end; + +procedure TInterfaceFactoryDefinition.AddMethodsFromTypeInfo(aInterface: PTypeInfo); +begin +{{#soa.services}} + if aInterface=TypeInfo(I{{interfaceURI}}) then begin +{{#methods}} + AddMethod('{{methodName}}',[ +{{#args}} ord(smd{{dirName}}),'{{argName}}',TypeInfo({{typeSource}}){{#isArgLast}}]);{{/isArgLast}}{{^isArgLast}}, +{{/isArgLast}}{{/args}} +{{/methods}} + exit; + end; +{{/soa.services}} +end; + +{$endif HASINTERFACERTTI} +{{/soa.enabled}} +{{#withRecords}} +{{textrec}} }{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typeDelphi}}{{/nestedSimpleArray}}{{#nestedRecordArray}}[ {{>textrec}} ]{{/nestedRecordArray}} {{/fields}}{{/textrec}} + +{$ifndef ISDELPHI2010} + +const // text-based types definition for records and dynamic arrays +{{#records}} + __{{name}} = '{{>textrec}}'; +{{/records}} + +{{/withRecords}} +initialization +{{#enumerates}} + TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( + TypeInfo({{name}})); +{{/enumerates}} +{{#records}} + TTextWriter.RegisterCustomJSONSerializerFromText( + TypeInfo({{name}}),__{{name}}); +{{/records}} +{{#soa.enabled}} +{$ifndef HASINTERFACERTTI} // circumvent a old FPC bug +{{#soa.services}} + TInterfaceFactoryDefinition.RegisterInterface( + TypeInfo(I{{interfaceURI}})); +{{/soa.services}} +{$endif HASINTERFACERTTI} +{{/soa.enabled}} + +{$endif ISDELPHI2010} +end. \ No newline at end of file diff --git a/mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache b/mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache new file mode 100644 index 00000000..5d3706d1 --- /dev/null +++ b/mORMot/CrossPlatform/templates/SmartMobileStudio.pas.mustache @@ -0,0 +1,361 @@ +/// remote access to a mORMot server using SmartMobileStudio +{{#uri}} +// - retrieved from {{protocol}}://{{host}}/{{uri}} +// at {{time}} using "{{templateName}}" template +{{/uri}} +{{^uri}} +// - generated at {{time}} +{{/uri}} +unit {{fileName}}; + +{ + WARNING: + This unit has been generated by a mORMot {{mORMotVersion}} server. + Any manual modification of this file may be lost after regeneration. + + Synopse mORMot framework. Copyright (C) {{year}} Arnaud Bouchez + Synopse Informatique - http://synopse.info + + This unit is released under a MPL/GPL/LGPL tri-license, + and therefore may be freely included in any application. + + This unit would work on Smart Mobile Studio 2.1.1 and later. +} + +interface + +uses + SmartCL.System, + System.Types, + SynCrossPlatformSpecific, + SynCrossPlatformREST; + +{{! recursive partials used to write records type definition}} +{{writerec}}{{nestedIdentation}} end;{{/nestedRecord}}{{#nestedSimpleArray}}array of {{typePascal}};{{/nestedSimpleArray}}{{#nestedRecordArray}}array of {{>writerec}}{{nestedIdentation}} end;{{/nestedRecordArray}} +{{/fields}}{{/writerec}} +{{#withEnumerates}} +type // define some enumeration types, used below +{{#enumerates}} + {{name}} = ({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/enumerates}} + +{{/withEnumerates}} +{{#withSets}} +type // define some set types, used below +{{#sets}} + {{name}} = set of({{#values}}{{.}}{{^-last}}, {{/-last}}{{/values}}); +{{/sets}} + +{{/withSets}} +{{#withRecords}} +type // define some record types, used as properties below +{{#records}} + {{name}} = {{>writerec}} end; + +{{/records}} +{{/withRecords}} +{{#withArrays}} +type // define some dynamic array types, used as properties below +{{#arrays}} + {{name}} = array of {{typeSource}}; +{{/arrays}} + +{{/withArrays}} +type{{methodAsynch}} + {{verb}} {{>methodSynch}} +{{/methods}} + end; + +{{/soa.services}} + +const + /// the server port{{#uri}}, corresponding to {{protocol}}://{{host}}{{/uri}} + SERVER_PORT = {{port}}; + /// the server model root name{{#uri}}, corresponding to {{protocol}}://{{host}}/{{root}}{{/uri}} + SERVER_ROOT = '{{root}}'; + + +/// return the database Model corresponding to this server +function GetModel(aRoot: string=SERVER_ROOT): TSQLModel; + +/// create a TSQLRestClientHTTP instance and connect to the server +// - it will use by default port {{port}} over root '{{root}}'{{#host}}, corresponding +// to {{protocol}}://{{host}}/{{root}}{{/host}} +{{#authClass}} +// - secure connection will be established via {{.}} +// with the supplied credentials +{{/authClass}} +// - request will be asynchronous, and trigger onSuccess or onError event +procedure GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string; + onSuccess, onError: TSQLRestEvent; + aServerPort: integer=SERVER_PORT; aServerRoot: string=SERVER_ROOT; + aHttps: boolean={{#https}}true{{/https}}{{^https}}false{{/https}}); + +{{#withHelpers}} +// publish some low-level helpers for variant conversion +// - used internally: you should not need those functions in your end-user code +{{#enumerates}} +function Variant2{{name}}(const _variant: variant): {{name}}; +function {{name}}ToText(const value: {{name}}): string; +{{/enumerates}} +{{#records}} +function Variant2{{name}}(const Value: variant): {{name}}; +function {{name}}2Variant(const Value: {{name}}): variant; +{{/records}} +{{#arrays}} +function Variant2{{name}}(const _variant: variant): {{name}}; +function {{name}}2Variant(const _array: {{name}}): variant; +{{/arrays}} + +{{/withHelpers}} + +implementation +{{setrec}}{{/nestedRecord}}{{#fromVariant}} result.{{fullPropName}} := {{fromVariant}}(Value.{{fullPropName}}); +{{/fromVariant}}{{#nestedSimpleArray}} if VariantType(Value.{{fullPropName}})=jvArray then + for var i := 0 to integer(Value.{{fullPropName}}.length)-1 do + result.{{fullPropName}}.Add({{typePascal}}(Value.{{fullPropName}}[i])); +{{/nestedSimpleArray}}{{#nestedRecordArray}} if VariantType(Value.{{fullPropName}})=jvArray then begin + var tmp: {{name}}; + tmp.{{propName}}.SetLength(1); + for var n := 0 to integer(Value.{{fullPropName}}.length)-1 do begin + var source := Value.{{fullPropName}}[n]; + var dest := tmp.{{propName}}[0]; +{{#fields}} + dest.{{propName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}source.{{propName}}{{#fromVariant}}){{/fromVariant}}; +{{/fields}} + result.{{fullPropName}}.Add(dest); + end; + end; +{{/nestedRecordArray}}{{/fields}}{{/setrec}} +{{getrec}}{{/nestedRecord}}{{#toVariant}} result.{{fullPropName}} := {{toVariant}}(Value.{{fullPropName}}); +{{/toVariant}}{{#nestedSimpleArray}} result.{{fullPropName}} := variant(Value.{{fullPropName}}); +{{/nestedSimpleArray}}{{#nestedRecordArray}} result.{{fullPropName}} := TVariant.CreateArray; + for var source in Value.{{fullPropName}} do begin + var dest: variant := new JObject; +{{#fields}} + dest.{{propName}} := {{#toVariant}}{{toVariant}}({{/toVariant}}source.{{propName}}{{#toVariant}}){{/toVariant}}; +{{/fields}} + result.{{fullPropName}}.push(dest); + end; +{{/nestedRecordArray}}{{/fields}}{{/getrec}} +{{#withEnumerates}} +{ Some helpers for enumerates types } + +{$HINTS OFF} // for begin asm return ... end; end below + +// those functions will use the existing generated string array constant +// defined by the SMS compiler for each enumeration + +{{#enumerates}} +function Variant2{{name}}(const _variant: variant): {{name}}; +begin + asm return @VariantToEnum(@_variant,@{{name}}); end; +end; + +function {{name}}ToText(const value: {{name}}): string; +begin + asm return @{{name}}[@value]; end; +end; + +{{/enumerates}} +{$HINTS ON} + +{{/withEnumerates}} +{{#withRecords}} +{ Some helpers for record types: + due to potential obfuscation of generated JavaScript, we can't assume + that the JSON used for transmission would match record fields naming } +{{#records}} + +function Variant2{{name}}(const Value: variant): {{name}}; +begin +{{>setrec}} +end; + +function {{name}}2Variant(const Value: {{name}}): variant; +begin + result := new JObject; +{{>getrec}} +end; +{{/records}} + +{{/withRecords}} +{{#withArrays}} + +{ Some helpers for dynamic array types } + +{{#arrays}} +function Variant2{{name}}(const _variant: variant): {{name}}; +var tmp: {{typeSource}}; +begin + if VariantType(_variant)=jvArray then + for var i := 0 to integer(_variant.Length)-1 do begin + tmp := {{#fromVariant}}{{fromVariant}}{{/fromVariant}}(_variant[i]); + result.Add(tmp); + end; +end; + +function {{name}}2Variant(const _array: {{name}}): variant; +var i: integer; +begin + result := TVariant.CreateArray; + for i := 0 to high(_array) do + result.push({{#toVariant}}{{toVariant}}{{/toVariant}}(_array[i])); +end; + +{{/arrays}} +{{/withArrays}} +{{#orm}} + +{{^isInMormotPas}} + +{ {{className}} } + +class function {{className}}.ComputeRTTI: TRTTIPropInfos; +begin + result := TRTTIPropInfos.Create( + [{{#fields}}'{{name}}'{{comma}}{{/fields}}], + [{{#fields}}{{typekindname}}{{comma}}{{/fields}}]); +end; + +procedure {{className}}.SetProperty(FieldIndex: integer; const Value: variant); +begin + case FieldIndex of + 0: fID := Value; + {{#fields}} + {{index}}: f{{name}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}Value{{#fromVariant}}){{/fromVariant}}; + {{/fields}} + end; +end; + +function {{className}}.GetProperty(FieldIndex: integer): variant; +begin + case FieldIndex of + 0: result := fID; + {{#fields}} + {{index}}: result := {{#toVariant}}{{toVariant}}({{/toVariant}}f{{name}}{{#toVariant}}){{/toVariant}}; + {{/fields}} + end; +end; + +{{/isInMormotPas}} +{{/orm}} + +function GetModel(aRoot: string): TSQLModel; +begin + result := TSQLModel.Create([{{#orm}}{{className}}{{comma}}{{/orm}}],aRoot); +end; + +procedure GetClient(const aServerAddress{{#authClass}}, aUserName,aPassword{{/authClass}}: string; + onSuccess, onError: TSQLRestEvent; aServerPort: integer; aServerRoot: string; + aHttps: boolean); +begin + var client := TSQLRestClientHTTP.Create(aServerAddress,aServerPort, + GetModel(aServerRoot),true,aHttps); // aOwnModel=true + client.Connect( + lambda + try + if client.ServerTimeStamp=0 then begin + if Assigned(onError) then + onError(client); + exit; + end; +{{#authClass}} + if not client.SetUser({{.}},aUserName,aPassword) then begin + if Assigned(onError) then + onError(client); + exit; + end; +{{/authClass}} + if Assigned(onSuccess) then + onSuccess(client); + except + if Assigned(onError) then + onError(client); + end; + end, + onError); +end; + +{{#soa.services}} + +{ TService{{interfaceURI}} } + +constructor TService{{interfaceURI}}.Create(aClient: TSQLRestClientURI); +begin + fServiceName := '{{interfaceURI}}'; + fServiceURI := '{{uri}}'; + fInstanceImplementation := sic{{instanceCreationName}}; + fContractExpected := '{{contractExpected}}'; + inherited Create(aClient); +end; + + +{{#methods}} +procedure TService{{interfaceURI}}.{{>methodAsynch}} +begin + fClient.CallRemoteServiceAsynch(self,'{{methodName}}',{{ArgsOutputCount}}, + [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}], + lambda (res: array of Variant) + onSuccess({{#args}}{{#dirOutput}}{{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}}{{#commaOutResult}},{{/commaOutResult}}{{/dirOutput}}{{/args}}); + end, onError{{#resultIsServiceCustomAnswer}}, true{{/resultIsServiceCustomAnswer}}); +end; + +{{verb}} TService{{interfaceURI}}.{{>methodSynch}} +begin + var res := fClient.CallRemoteServiceSynch(self,'{{methodName}}',{{ArgsOutputCount}}, + [{{#args}}{{#dirInput}}{{#toVariant}}{{toVariant}}({{argName}}){{/toVariant}}{{^toVariant}}{{argName}}{{/toVariant}}{{commaInSingle}}{{/dirInput}}{{/args}}]{{#resultIsServiceCustomAnswer}},true{{/resultIsServiceCustomAnswer}}); +{{#args}}{{#dirOutput}} {{argName}} := {{#fromVariant}}{{fromVariant}}({{/fromVariant}}res[{{indexOutResult}}{{#fromVariant}}){{/fromVariant}}; +{{/dirOutput}}{{/args}}end; + + +{{/methods}} +{{/soa.services}} + +end. \ No newline at end of file diff --git a/mORMot/CrossPlatform/templates/Swagger.json.mustache b/mORMot/CrossPlatform/templates/Swagger.json.mustache new file mode 100644 index 00000000..97b809b3 --- /dev/null +++ b/mORMot/CrossPlatform/templates/Swagger.json.mustache @@ -0,0 +1,395 @@ +{{! recursive partial used to expand type definition + HACK: Objects, Enums, Records and Arrays, which are used by reference + and defined outside the main units have to be handled explicitly. + All internal types have their Swagger-Typ defined. }} +{{write-type}}}{{/nestedSimpleArray}}{{/typeSwagger}}{{/write-type}} + +{ + "swagger": "2.0", + "info": { + "description": "Generated by {{exeInfo}} using mORMot {{mORMotVersion}} at {{time}}", + "title": "{{root}} API{{#exeVersion}} {{.}}{{/exeVersion}}", + "version": "{{exeVersion}}" + }, + "host": "{{host}}", + "basePath": "/{{root}}", + "tags": [ + {{#orm}} + { + "name": "{{tableName}}", + "description": "ORM endpoint for {{root}}/{{tableName}} record" + }{{^-last}},{{/-last}} + {{/orm}} + {{#soa}}{{#hasorm}},{{/hasorm}} + {{#services}} + { + "name": "{{uri}}", + "description": {{#serviceDescription}}{{jsonQuote serviceDescription}}{{/serviceDescription}}{{^serviceDescription}}"SOA endpoint for {{root}}/{{uri}} service"{{/serviceDescription}} + }{{^-last}},{{/-last}} + {{/services}} + {{/soa}} + ], + + "definitions": { + {{#orm}} + "{{tableName}}": { + "type": "object", + "description": "ORM {{tableName}} record definition", + "properties": { + "ID":{"type":"integer","format":"int64"}{{#fields}},"{{name}}":{{typeSwagger}}{{/fields}} + } + }, + {{/orm}} + {{#records}} + "{{name}}": { + "type": "object", + "description": "SOA {{name}} object DTO definition", + "properties": { + {{#fields}} + "{{propName}}": {{>write-type}}{{^-last}},{{/-last}} + {{/fields}} + } + }, + + {{/records}} + {{#arrays}} + "{{name}}": { + "type": "array", + "summary": "SOA {{name}} array DTO definition", + "items": {{>write-type}} + }, + {{/arrays}} + {{#enumerates}} + "{{name}}": { + "type": "string", + "description": "SOA {{name}} enumeration DTO definition", + "enum": [ + {{#values}} + "{{.}}"{{^-last}},{{/-last}} + {{/values}} + ], + "required": true + }, + + {{/enumerates}} + "__error": { + "type": "object", + "description": "Generic error information", + "properties": { + "errorCode": {"type":"integer"},"errorText":{"type":"string"} } + } + }, + "paths": { + {{#orm}} + + "/{{tableName}}":{ + "get": { + "tags": [ + "{{tableName}}" + ], + "summary": "query ORM fields values on {{tableName}}", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [{ + "name": "select", + "in": "query", + "description": "define returned fields of {{tableName}} query, set * to return all fields", + "required": true, + "type":"string" + },{ + "name": "where", + "in": "query", + "description": "SELECT-like where condition for {{tableName}} query", + "required": false, + "type":"string" + },{ + "name": "sort", + "in": "query", + "description": "order fields for {{tableName}} query", + "required": false, + "type":"string" + }], + "responses": { + "200": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + } + }, + "/{{tableName}}/":{ + "get": { + "tags": [ + "{{tableName}}" + ], + "summary": "retrieve all {{tableName}} ORM ids", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [], + "responses": { + "200": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + } + , "post": { + "tags": [ + "{{tableName}}" + ], + "summary": "creates a new {{tableName}} ORM record", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [{ + "name": "body", + "in": "body", + "description": "new {{tableName}} JSON object content", + "schema": { + "$ref": "#/definitions/{{tableName}}" + }, + "required": true + }], + "responses": { + "201": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not writable or not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + } + }, + "/{{tableName}}/{id}":{ + "get": { + "tags": [ + "{{tableName}}" + ], + "summary": "retrieve a {{tableName}} ORM record by id", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [{ + "name": "id", + "in": "path", + "description": "id to query {{tableName}}", + "required": true, + "type": "integer", + "format":"int64" + }], + "responses": { + "200": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + }, "put": { + "tags": [ + "{{tableName}}" + ], + "summary": "change a {{tableName}} ORM record by id", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [{ + "name": "id", + "in": "path", + "description": "id to update {{tableName}}", + "required": true, + "type": "integer", + "format":"int64" + },{ + "name": "body", + "in": "body", + "schema": { + "$ref": "#/definitions/{{tableName}}" + }, + "description": "modified {{tableName}} JSON object content (partial fields accepted)", + "required": true + }], + "responses": { + "200": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not writable or not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + },"delete": { + "tags": [ + "{{tableName}}" + ], + "summary": "remove a {{tableName}} ORM record by id", + "description": "", + "produces": [ + "application/json" + ], + "parameters": [{ + "name": "id", + "in": "path", + "description": "id to delete {{tableName}}", + "required": true, + "type": "integer", + "format":"int64" + }], + "responses": { + "200": { + "description": "successful operation", + "schema": { + "$ref": "#/definitions/{{tableName}}" + } + }, + "403": { + "description": "{{tableName}} not writable or not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "404": { + "description": "{{tableName}} not found" + }, + "405": { + "description": "Unauthorized access to {{tableName}}" + } + } + } + }{{^-last}},{{/-last}} + + {{/orm}} + {{#soa}}{{#hasorm}},{{/hasorm}}{{#services}} + {{#methods}} + "/{{uri}}/{{methodName}}": { + "post": { + "description": {{jsonQuote methodDescription}}, + "tags": [ + "{{uri}}" + ], + "parameters": [{ + "in": "body", + "name": "body", + "schema": { + "type": "object", + "properties": { {{#args}}{{#dirInput}} + "{{argName}}": {{>write-type}}{{commaInSingle}}{{/dirInput}}{{/args}} + } + } + }], + "responses": { + "200": { + "description": "{{uri}}.{{methodName}} executed - check returned content for any application-level error{{^resultAsJSONObjectWithoutResult}}\r\n **Warning: Swagger doesn't support untyped arrays, so isn't able to correctly define the response - please use rather *ResultAsJSONObjectWithoutResult* for a public API**{{/resultAsJSONObjectWithoutResult}}", + "schema": { + "type": "object", + "properties": { + {{#resultAsJSONObjectWithoutResult}} + {{#args}} {{#dirOutput}} + "{{argName}}": {{>write-type}}{{#commaOutResult}},{{/commaOutResult}} + {{/dirOutput}}{{/args}} + {{/resultAsJSONObjectWithoutResult}} + {{^resultAsJSONObjectWithoutResult}} + "result": { + "type": "array", + "items": {"type":"string"} + } + {{/resultAsJSONObjectWithoutResult}} + } + } + }, + "401": { + "description": "{{uri}}.{{methodName}} execution not allowed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "403": { + "description": "{{uri}}.{{methodName}} not properly accessed", + "schema": { + "$ref": "#/definitions/__error" + } + }, + "406": { + "description": "{{uri}}.{{methodName}} execution failed - probably due to unexpected input", + "schema": { + "$ref": "#/definitions/__error" + } + } + } + } + }{{^-last}},{{/-last}} + {{/methods}}{{^-last}},{{/-last}} + + {{/services}}{{/soa}} + } +} diff --git a/mORMot/SynCommons.pas b/mORMot/SynCommons.pas new file mode 100644 index 00000000..c9a303e8 --- /dev/null +++ b/mORMot/SynCommons.pas @@ -0,0 +1,63349 @@ +/// common functions used by most Synopse projects +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCommons; + +(* + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Alan Chate + - Aleksandr (sha) + - Alfred Glaenzer (alf) + - ASiwon + - Chaa + - BigStar + - Eugene Ilyin + - f-vicente + - itSDS + - Johan Bontes + - kevinday + - Kevin Chen + - Maciej Izak (hnb) + - Marius Maximus (mariuszekpl) + - mazinsw + - mingda + - PBa + - RalfS + - Sanyin + - Pavel Mashlyakovskii (mpv) + - Wloochacz + - zed + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + +*) + + +{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER + +interface + +uses +{$ifdef MSWINDOWS} + Windows, + Messages, +{$else MSWINDOWS} + {$ifdef KYLIX3} + Types, + LibC, + SynKylix, + {$endif KYLIX3} + {$ifdef FPC} + BaseUnix, + {$endif FPC} +{$endif MSWINDOWS} + Classes, +{$ifndef LVCL} + SyncObjs, // for TEvent and TCriticalSection + Contnrs, // for TObjectList + {$ifdef HASINLINE} + Types, + {$endif HASINLINE} +{$endif LVCL} +{$ifndef NOVARIANTS} + Variants, +{$endif NOVARIANTS} + SynLZ, // needed for TSynMapFile .mab format + SysUtils; + + +const + /// the corresponding version of the freeware Synopse framework + // - includes a commit increasing number (generated by SourceCodeRep tool) + // - a similar constant shall be defined in SynCrtSock.pas + SYNOPSE_FRAMEWORK_VERSION = {$I SynopseCommit.inc}; + + /// a text including the version and the main active conditional options + // - usefull for low-level debugging purpose + SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION + {$ifdef FPC} + {$ifdef FPC_X64MM}+' x64MM'{$ifdef FPCMM_BOOST}+'b'{$endif} + {$ifdef FPCMM_SERVER}+'s'{$endif}{$else} + {$ifdef FPC_FASTMM4}+' FMM4'{$else} + {$ifdef FPC_SYNTBB}+' TBB'{$else} + {$ifdef FPC_SYNJEMALLOC}+' JM'{$else} + {$ifdef FPC_SYNCMEM}+' CM'{$else} + {$ifdef FPC_CMEM}+' cM'{$endif}{$endif}{$endif}{$endif}{$endif}{$endif} + {$else} + {$ifdef LVCL}+' LVCL'{$else} + {$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif} + {$ifdef FullDebugMode}+' FDM'{$endif} + {$endif FPC} + {$ifdef DOPATCHTRTL}+' PRTL'{$endif}; + + +{ ************ common types used for compatibility between compilers and CPU } + +const + /// internal Code Page for UTF-16 Unicode encoding + // - used e.g. for Delphi 2009+ UnicodeString=String type + CP_UTF16 = 1200; + + /// fake code page used to recognize TSQLRawBlob + // - as returned e.g. by TTypeInfo.AnsiStringCodePage from mORMot.pas + CP_SQLRAWBLOB = 65534; + + /// internal Code Page for RawByteString undefined string + CP_RAWBYTESTRING = 65535; + + /// US English Windows Code Page, i.e. WinAnsi standard character encoding + CODEPAGE_US = 1252; + + /// Latin-1 ISO/IEC 8859-1 Code Page + CODEPAGE_LATIN1 = 819; + +{$ifndef MSWINDOWS} + /// internal Code Page for UTF-8 Unicode encoding + CP_UTF8 = 65001; +var + /// contains the curent system code page (default WinAnsi) + GetACP: integer = CODEPAGE_US; +{$endif} + +{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi } + +type + PBoolean = ^Boolean; + +{$else FPC} + +type + {$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009) + PtrInt = NativeInt; + PtrUInt = NativeUInt; + {$else} + /// a CPU-dependent signed integer type cast of a pointer / register + // - used for 64-bit compatibility, native under Free Pascal Compiler + PtrInt = integer; + /// a CPU-dependent unsigned integer type cast of a pointer / register + // - used for 64-bit compatibility, native under Free Pascal Compiler + PtrUInt = cardinal; + {$endif} + /// a CPU-dependent unsigned integer type cast of a pointer of pointer + // - used for 64-bit compatibility, native under Free Pascal Compiler + PPtrUInt = ^PtrUInt; + /// a CPU-dependent signed integer type cast of a pointer of pointer + // - used for 64-bit compatibility, native under Free Pascal Compiler + PPtrInt = ^PtrInt; + + /// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC + // - and UInt64 is buggy as hell under Delphi 2007 when inlining functions: + // older compilers will fallback to signed Int64 values + // - anyway, consider using SortDynArrayQWord() to compare QWord values + // in a safe and efficient way, under a CPUX86 + // - you may use UInt64 explicitly in your computation (like in SynEcc.pas), + // if you are sure that Delphi 6-2007 compiler handles your code as expected, + // but mORMot code will expect to use QWord for its internal process + // (e.g. ORM/SOA serialization) + {$ifdef UNICODE} + QWord = UInt64; + {$else} + QWord = {$ifndef DELPHI5OROLDER}type{$endif} Int64; + {$endif} + /// points to an unsigned Int64 + PQWord = ^QWord; + + {$ifndef ISDELPHIXE2} + /// used to store the handle of a system Thread + TThreadID = cardinal; + {$endif} + +{$endif FPC} + +{$ifdef DELPHI6OROLDER} + +// some definitions not available prior to Delphi 7 +type + UInt64 = Int64; + +{$endif} + +{$ifdef DELPHI5OROLDER} + // Delphi 5 doesn't have those basic types defined :( +const + varShortInt = $0010; + varInt64 = $0014; { vt_i8 } + soBeginning = soFromBeginning; + soCurrent = soFromCurrent; + reInvalidPtr = 2; + PathDelim = '\'; + sLineBreak = #13#10; + +type + PPointer = ^Pointer; + PPAnsiChar = ^PAnsiChar; + PInteger = ^Integer; + PCardinal = ^Cardinal; + PByte = ^Byte; + PWord = ^Word; + PBoolean = ^Boolean; + PDouble = ^Double; + PComp = ^Comp; + THandle = LongWord; + PVarData = ^TVarData; + TVarData = packed record + // mostly used for varNull, varInt64, varDouble, varString and varAny + VType: word; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); // DOUBLE + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: HRESULT); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varByte: (VByte: Byte); + varInt64: (VInt64: Int64); // INTEGER + varString: (VString: Pointer); // TEXT + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); ); + end; +{$else} +{$ifndef FPC} +type + // redefined here to not use the wrong definitions from Windows.pas + PWord = System.PWord; + PSingle = System.PSingle; +{$endif FPC} +{$endif DELPHI5OROLDER} + +type + /// RawUnicode is an Unicode String stored in an AnsiString + // - faster than WideString, which are allocated in Global heap (for COM) + // - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending + // - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1) + // for WideChar count (that's why the definition of this type since Delphi 2009 + // is AnsiString(1200) and not UnicodeString) + // - pointer(RawUnicode) is compatible with Win32 'Wide' API call + // - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead + // - all conversion to/from AnsiString or RawUTF8 must be explicit: the + // compiler is not able to make valid implicit conversion on CP_UTF16 + {$ifdef HASCODEPAGE} + RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString + {$else} + RawUnicode = type AnsiString; + {$endif} + + /// RawUTF8 is an UTF-8 String stored in an AnsiString + // - use this type instead of System.UTF8String, which behavior changed + // between Delphi 2009 compiler and previous versions: our implementation + // is consistent and compatible with all versions of Delphi compiler + // - mimic Delphi 2009 UTF8String, without the charset conversion overhead + // - all conversion to/from AnsiString or RawUnicode must be explicit + {$ifdef HASCODEPAGE} + RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string + {$else} + RawUTF8 = type AnsiString; + {$endif} + + /// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252) + // - use this type instead of System.String, which behavior changed + // between Delphi 2009 compiler and previous versions: our implementation + // is consistent and compatible with all versions of Delphi compiler + // - all conversion to/from RawUTF8 or RawUnicode must be explicit + {$ifdef HASCODEPAGE} + WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage + {$else} + WinAnsiString = type AnsiString; + {$endif} + + {$ifdef HASCODEPAGE} + {$ifdef FPC} + // missing declaration + PRawByteString = ^RawByteString; + {$endif} + {$else} + /// define RawByteString, as it does exist in Delphi 2009+ + // - to be used for byte storage into an AnsiString + // - use this type if you don't want the Delphi compiler not to do any + // code page conversions when you assign a typed AnsiString to a RawByteString, + // i.e. a RawUTF8 or a WinAnsiString + RawByteString = type AnsiString; + /// pointer to a RawByteString + PRawByteString = ^RawByteString; + {$endif} + + /// RawJSON will indicate that this variable content would stay in raw JSON + // - i.e. won't be serialized into values + // - could be any JSON content: number, string, object or array + // - e.g. interface-based service will use it for efficient and AJAX-ready + // transmission of TSQLTableJSON result + RawJSON = type RawUTF8; + + /// SynUnicode is the fastest available Unicode native string type, depending + // on the compiler used + // - this type is native to the compiler, so you can use Length() Copy() and + // such functions with it (this is not possible with RawUnicodeString type) + // - before Delphi 2009+, it uses slow OLE compatible WideString + // (with our Enhanced RTL, WideString allocation can be made faster by using + // an internal caching mechanism of allocation buffers - WideString allocation + // has been made much faster since Windows Vista/Seven) + // - starting with Delphi 2009, it uses fastest UnicodeString type, which + // allow Copy On Write, Reference Counting and fast heap memory allocation + {$ifdef HASVARUSTRING} + SynUnicode = UnicodeString; + {$else} + SynUnicode = WideString; + {$endif HASVARUSTRING} + + PRawUnicode = ^RawUnicode; + PRawJSON = ^RawJSON; + PRawUTF8 = ^RawUTF8; + PWinAnsiString = ^WinAnsiString; + PWinAnsiChar = type PAnsiChar; + PSynUnicode = ^SynUnicode; + + /// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar + // - PAnsiChar is used only for Win-Ansi encoded text + // - the Synopse mORMot framework uses mostly this PUTF8Char type, + // because all data is internaly stored and expected to be UTF-8 encoded + PUTF8Char = type PAnsiChar; + PPUTF8Char = ^PUTF8Char; + + /// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result + TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char; + PPUtf8CharArray = ^TPUtf8CharArray; + + /// a dynamic array of PUTF8Char pointers + TPUTF8CharDynArray = array of PUTF8Char; + + /// a dynamic array of UTF-8 encoded strings + TRawUTF8DynArray = array of RawUTF8; + PRawUTF8DynArray = ^TRawUTF8DynArray; + TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray; + + /// a dynamic array of TVarRec, i.e. could match an "array of const" parameter + TTVarRecDynArray = array of TVarRec; + + {$ifndef NOVARIANTS} + /// a TVarData values array + // - is not called TVarDataArray to avoid confusion with the corresponding + // type already defined in Variants.pas, and used for custom late-binding + TVarDataStaticArray = array[0..MaxInt div SizeOf(TVarData)-1] of TVarData; + PVarDataStaticArray = ^TVarDataStaticArray; + TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant; + PVariantArray = ^TVariantArray; + TVariantDynArray = array of variant; + PPVariant = ^PVariant; + {$endif} + + PIntegerDynArray = ^TIntegerDynArray; + TIntegerDynArray = array of integer; + TIntegerDynArrayDynArray = array of TIntegerDynArray; + PCardinalDynArray = ^TCardinalDynArray; + TCardinalDynArray = array of cardinal; + PSingleDynArray = ^TSingleDynArray; + TSingleDynArray = array of Single; + PInt64DynArray = ^TInt64DynArray; + TInt64DynArray = array of Int64; + PQwordDynArray = ^TQwordDynArray; + TQwordDynArray = array of Qword; + TPtrUIntDynArray = array of PtrUInt; + PDoubleDynArray = ^TDoubleDynArray; + TDoubleDynArray = array of double; + PCurrencyDynArray = ^TCurrencyDynArray; + TCurrencyDynArray = array of Currency; + TWordDynArray = array of word; + PWordDynArray = ^TWordDynArray; + TByteDynArray = array of byte; + PByteDynArray = ^TByteDynArray; + {$ifndef ISDELPHI2007ANDUP} + TBytes = array of byte; + {$endif} + TObjectDynArray = array of TObject; + PObjectDynArray = ^TObjectDynArray; + TPersistentDynArray = array of TPersistent; + PPersistentDynArray = ^TPersistentDynArray; + TPointerDynArray = array of pointer; + PPointerDynArray = ^TPointerDynArray; + TPPointerDynArray = array of PPointer; + PPPointerDynArray = ^TPPointerDynArray; + TMethodDynArray = array of TMethod; + PMethodDynArray = ^TMethodDynArray; + TObjectListDynArray = array of TObjectList; + PObjectListDynArray = ^TObjectListDynArray; + TFileNameDynArray = array of TFileName; + PFileNameDynArray = ^TFileNameDynArray; + TBooleanDynArray = array of boolean; + PBooleanDynArray = ^TBooleanDynArray; + TClassDynArray = array of TClass; + TWinAnsiDynArray = array of WinAnsiString; + PWinAnsiDynArray = ^TWinAnsiDynArray; + TRawByteStringDynArray = array of RawByteString; + TStringDynArray = array of string; + PStringDynArray = ^TStringDynArray; + PShortStringDynArray = array of PShortString; + PPShortStringArray = ^PShortStringArray; + TShortStringDynArray = array of ShortString; + TDateTimeDynArray = array of TDateTime; + PDateTimeDynArray = ^TDateTimeDynArray; + {$ifndef FPC_OR_UNICODE} + TDate = type TDateTime; + TTime = type TDateTime; + {$endif FPC_OR_UNICODE} + TDateDynArray = array of TDate; + PDateDynArray = ^TDateDynArray; + TTimeDynArray = array of TTime; + PTimeDynArray = ^TTimeDynArray; + TWideStringDynArray = array of WideString; + PWideStringDynArray = ^TWideStringDynArray; + TSynUnicodeDynArray = array of SynUnicode; + PSynUnicodeDynArray = ^TSynUnicodeDynArray; + TGUIDDynArray = array of TGUID; + + PObject = ^TObject; + PClass = ^TClass; + PByteArray = ^TByteArray; + TByteArray = array[0..MaxInt-1] of Byte; // redefine here with {$R-} + PBooleanArray = ^TBooleanArray; + TBooleanArray = array[0..MaxInt-1] of Boolean; + TWordArray = array[0..MaxInt div SizeOf(word)-1] of word; + PWordArray = ^TWordArray; + TIntegerArray = array[0..MaxInt div SizeOf(integer)-1] of integer; + PIntegerArray = ^TIntegerArray; + PIntegerArrayDynArray = array of PIntegerArray; + TPIntegerArray = array[0..MaxInt div SizeOf(PIntegerArray)-1] of PInteger; + PPIntegerArray = ^TPIntegerArray; + TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal; + PCardinalArray = ^TCardinalArray; + TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64; + PInt64Array = ^TInt64Array; + TQWordArray = array[0..MaxInt div SizeOf(QWord)-1] of QWord; + PQWordArray = ^TQWordArray; + TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt; + PPtrUIntArray = ^TPtrUIntArray; + TSmallIntArray = array[0..MaxInt div SizeOf(SmallInt)-1] of SmallInt; + PSmallIntArray = ^TSmallIntArray; + TSingleArray = array[0..MaxInt div SizeOf(Single)-1] of Single; + PSingleArray = ^TSingleArray; + TDoubleArray = array[0..MaxInt div SizeOf(Double)-1] of Double; + PDoubleArray = ^TDoubleArray; + TDateTimeArray = array[0..MaxInt div SizeOf(TDateTime)-1] of TDateTime; + PDateTimeArray = ^TDateTimeArray; + TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar; + PPAnsiCharArray = ^TPAnsiCharArray; + TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8; + PRawUTF8Array = ^TRawUTF8Array; + TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString; + PRawByteStringArray = ^TRawByteStringArray; + PShortStringArray = array[0..MaxInt div SizeOf(pointer)-1] of PShortString; + PointerArray = array [0..MaxInt div SizeOf(Pointer)-1] of Pointer; + PPointerArray = ^PointerArray; + TObjectArray = array [0..MaxInt div SizeOf(TObject)-1] of TObject; + PObjectArray = ^TObjectArray; + TPtrIntArray = array[0..MaxInt div SizeOf(PtrInt)-1] of PtrInt; + PPtrIntArray = ^TPtrIntArray; + PInt64Rec = ^Int64Rec; + PPShortString = ^PShortString; + + {$ifndef DELPHI5OROLDER} + PIInterface = ^IInterface; + TInterfaceDynArray = array of IInterface; + PInterfaceDynArray = ^TInterfaceDynArray; + {$endif} + + {$ifndef LVCL} + TCollectionClass = class of TCollection; + TCollectionItemClass = class of TCollectionItem; + {$endif} + + /// class-reference type (metaclass) of a TStream + TStreamClass = class of TStream; + + /// class-reference type (metaclass) of a TInterfacedObject + TInterfacedObjectClass = class of TInterfacedObject; + + +{ ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** } + +// some constants used for UTF-8 conversion, including surrogates +const + UTF16_HISURROGATE_MIN = $d800; + UTF16_HISURROGATE_MAX = $dbff; + UTF16_LOSURROGATE_MIN = $dc00; + UTF16_LOSURROGATE_MAX = $dfff; + UTF8_EXTRABYTES: array[$80..$ff] of byte = ( + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0); + UTF8_EXTRA: array[0..6] of record + offset, minimum: cardinal; + end = ( // http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks + (offset: $00000000; minimum: $00010000), + (offset: $00003080; minimum: $00000080), + (offset: $000e2080; minimum: $00000800), + (offset: $03c82080; minimum: $00010000), + (offset: $fa082080; minimum: $00200000), + (offset: $82082080; minimum: $04000000), + (offset: $00000000; minimum: $04000000)); + UTF8_EXTRA_SURROGATE = 3; + UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc); + +type + /// kind of adding in a TTextWriter + TTextWriterKind = (twNone, twJSONEscape, twOnSameLine); + + /// an abstract class to handle Ansi to/from Unicode translation + // - implementations of this class will handle efficiently all Code Pages + // - this default implementation will use the Operating System APIs + // - you should not create your own class instance by yourself, but should + // better retrieve an instance using TSynAnsiConvert.Engine(), which will + // initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance on need + TSynAnsiConvert = class + protected + fCodePage: cardinal; + fAnsiCharShift: byte; + {$ifdef KYLIX3} + fIConvCodeName: RawUTF8; + {$endif} + procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; + DestTextWriter: TObject; Escape: TTextWriterKind); virtual; + public + /// initialize the internal conversion engine + constructor Create(aCodePage: cardinal); reintroduce; virtual; + /// returns the engine corresponding to a given code page + // - a global list of TSynAnsiConvert instances is handled by the unit - + // therefore, caller should not release the returned instance + // - will return nil in case of unhandled code page + // - is aCodePage is 0, will return CurrentAnsiConvert value + class function Engine(aCodePage: cardinal): TSynAnsiConvert; + /// direct conversion of a PAnsiChar buffer into an Unicode buffer + // - Dest^ buffer must be reserved with at least SourceChars*2 bytes + // - this default implementation will use the Operating System APIs + // - will append a trailing #0 to the returned PWideChar, unless + // NoTrailingZero is set + function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; overload; virtual; + /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - will append a trailing #0 to the returned PUTF8Char, unless + // NoTrailingZero is set + // - this default implementation will use the Operating System APIs + function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; overload; virtual; + /// convert any Ansi Text into an UTF-16 Unicode String + // - returns a value using our RawUnicode kind of string + function AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; overload; + /// convert any Ansi buffer into an Unicode String + // - returns a value using our RawUnicode kind of string + function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; overload; virtual; + /// convert any Ansi buffer into an Unicode String + // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString + function AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; overload; + /// convert any Ansi buffer into an Unicode String + // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString + function AnsiToUnicodeString(const Source: RawByteString): SynUnicode; overload; + /// convert any Ansi Text into an UTF-8 encoded String + // - internaly calls AnsiBufferToUTF8 virtual method + function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; virtual; + /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string + // - will call AnsiBufferToUnicode() overloaded virtual method + function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; overload; virtual; + /// direct conversion of an Unicode buffer into a PAnsiChar buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - this default implementation will rely on the Operating System for + // all non ASCII-7 chars + function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; overload; virtual; + /// direct conversion of an Unicode buffer into an Ansi Text + function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; overload; virtual; + /// convert any Unicode-encoded String into Ansi Text + // - internaly calls UnicodeBufferToAnsi virtual method + function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; + /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer + // - Dest^ buffer must be reserved with at least SourceChars bytes + // - no trailing #0 is appended to the buffer + function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; overload; virtual; + /// convert any UTF-8 encoded buffer into Ansi Text + // - internaly calls UTF8BufferToAnsi virtual method + function UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + /// convert any UTF-8 encoded buffer into Ansi Text + // - internaly calls UTF8BufferToAnsi virtual method + procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; + var result: RawByteString); overload; virtual; + /// convert any UTF-8 encoded String into Ansi Text + // - internaly calls UTF8BufferToAnsi virtual method + function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; virtual; + /// direct conversion of a UTF-8 encoded string into a WinAnsi buffer + // - will truncate the destination string to DestSize bytes (including the + // trailing #0), with a maximum handled size of 2048 bytes + // - returns the number of bytes stored in Dest^ (i.e. the position of #0) + function Utf8ToAnsiBuffer(const S: RawUTF8; Dest: PAnsiChar; DestSize: integer): integer; + /// convert any Ansi Text (providing a From converted) into Ansi Text + function AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; overload; + /// convert any Ansi buffer (providing a From converted) into Ansi Text + function AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; overload; + /// corresponding code page + property CodePage: Cardinal read fCodePage; + end; + + /// a class to handle Ansi to/from Unicode translation of fixed width encoding + // (i.e. non MBCS) + // - this class will handle efficiently all Code Page availables without MBCS + // encoding - like WinAnsi (1252) or Russian (1251) + // - it will use internal fast look-up tables for such encodings + // - this class could take some time to generate, and will consume more than + // 64 KB of memory: you should not create your own class instance by yourself, + // but should better retrieve an instance using TSynAnsiConvert.Engine(), which + // will initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance + // on need + // - this class has some additional methods (e.g. IsValid*) which take + // advantage of the internal lookup tables to provide some fast process + TSynAnsiFixedWidth = class(TSynAnsiConvert) + protected + fAnsiToWide: TWordDynArray; + fWideToAnsi: TByteDynArray; + procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; + DestTextWriter: TObject; Escape: TTextWriterKind); override; + public + /// initialize the internal conversion engine + constructor Create(aCodePage: cardinal); override; + /// direct conversion of a PAnsiChar buffer into an Unicode buffer + // - Dest^ buffer must be reserved with at least SourceChars*2 bytes + // - will append a trailing #0 to the returned PWideChar, unless + // NoTrailingZero is set + function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; + /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - will append a trailing #0 to the returned PUTF8Char, unless + // NoTrailingZero is set + function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; + /// convert any Ansi buffer into an Unicode String + // - returns a value using our RawUnicode kind of string + function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; + /// direct conversion of an Unicode buffer into a PAnsiChar buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - this overridden version will use internal lookup tables for fast process + function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; + /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer + // - Dest^ buffer must be reserved with at least SourceChars bytes + // - no trailing #0 is appended to the buffer + function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; override; + /// conversion of a wide char into the corresponding Ansi character + // - return -1 for an unknown WideChar in the current code page + function WideCharToAnsiChar(wc: cardinal): integer; + /// return TRUE if the supplied unicode buffer only contains characters of + // the corresponding Ansi code page + // - i.e. if the text can be displayed using this code page + function IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; overload; + /// return TRUE if the supplied unicode buffer only contains characters of + // the corresponding Ansi code page + // - i.e. if the text can be displayed using this code page + function IsValidAnsi(WideText: PWideChar): boolean; overload; + /// return TRUE if the supplied UTF-8 buffer only contains characters of + // the corresponding Ansi code page + // - i.e. if the text can be displayed using this code page + function IsValidAnsiU(UTF8Text: PUTF8Char): boolean; + /// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters + // of the corresponding Ansi code page + // - i.e. if the text can be displayed with only 8 bit unicode characters + // (e.g. no "tm" or such) within this code page + function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; + /// direct access to the Ansi-To-Unicode lookup table + // - use this array like AnsiToWide: array[byte] of word + property AnsiToWide: TWordDynArray read fAnsiToWide; + /// direct access to the Unicode-To-Ansi lookup table + // - use this array like WideToAnsi: array[word] of byte + // - any unhandled WideChar will return ord('?') + property WideToAnsi: TByteDynArray read fWideToAnsi; + end; + + /// a class to handle UTF-8 to/from Unicode translation + // - match the TSynAnsiConvert signature, for code page CP_UTF8 + // - this class is mostly a non-operation for conversion to/from UTF-8 + TSynAnsiUTF8 = class(TSynAnsiConvert) + private + function UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; + protected + procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; + DestTextWriter: TObject; Escape: TTextWriterKind); override; + public + /// initialize the internal conversion engine + constructor Create(aCodePage: cardinal); override; + /// direct conversion of a PAnsiChar UTF-8 buffer into an Unicode buffer + // - Dest^ buffer must be reserved with at least SourceChars*2 bytes + // - will append a trailing #0 to the returned PWideChar, unless + // NoTrailingZero is set + function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; + /// direct conversion of a PAnsiChar UTF-8 buffer into a UTF-8 encoded buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - will append a trailing #0 to the returned PUTF8Char, unless + // NoTrailingZero is set + function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; + /// convert any UTF-8 Ansi buffer into an Unicode String + // - returns a value using our RawUnicode kind of string + function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; + /// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; + /// direct conversion of an Unicode buffer into an Ansi Text + function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; override; + /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer + // - Dest^ buffer must be reserved with at least SourceChars bytes + // - no trailing #0 is appended to the buffer + function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; override; + /// convert any UTF-8 encoded buffer into Ansi Text + procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; + var result: RawByteString); override; + /// convert any UTF-8 encoded String into Ansi Text + // - directly assign the input as result, since no conversion is needed + function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override; + /// convert any Ansi Text into an UTF-8 encoded String + // - directly assign the input as result, since no conversion is needed + function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; override; + /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string + function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; override; + end; + + /// a class to handle UTF-16 to/from Unicode translation + // - match the TSynAnsiConvert signature, for code page CP_UTF16 + // - even if UTF-16 is not an Ansi format, code page CP_UTF16 may have been + // used to store UTF-16 encoded binary content + // - this class is mostly a non-operation for conversion to/from Unicode + TSynAnsiUTF16 = class(TSynAnsiConvert) + public + /// initialize the internal conversion engine + constructor Create(aCodePage: cardinal); override; + /// direct conversion of a PAnsiChar UTF-16 buffer into an Unicode buffer + // - Dest^ buffer must be reserved with at least SourceChars*2 bytes + // - will append a trailing #0 to the returned PWideChar, unless + // NoTrailingZero is set + function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; + /// direct conversion of a PAnsiChar UTF-16 buffer into a UTF-8 encoded buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + // - will append a trailing #0 to the returned PUTF8Char, unless + // NoTrailingZero is set + function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; + /// convert any UTF-16 Ansi buffer into an Unicode String + // - returns a value using our RawUnicode kind of string + function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; + /// direct conversion of an Unicode buffer into a PAnsiChar UTF-16 buffer + // - Dest^ buffer must be reserved with at least SourceChars*3 bytes + function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; + /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-16 buffer + // - Dest^ buffer must be reserved with at least SourceChars bytes + // - no trailing #0 is appended to the buffer + function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; override; + end; + + + /// implements a stack-based storage of some (UTF-8 or binary) text + // - avoid temporary memory allocation via the heap for up to 4KB of data + // - could be used e.g. to make a temporary copy when JSON is parsed in-place + // - call one of the Init() overloaded methods, then Done to release its memory + // - all Init() methods will allocate 16 more bytes, for a trailing #0 and + // to ensure our fast JSON parsing won't trigger any GPF (since it may read + // up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function + {$ifdef USERECORDWITHMETHODS}TSynTempBuffer = record + {$else}TSynTempBuffer = object{$endif} + public + /// the text/binary length, in bytes, excluding the trailing #0 + len: PtrInt; + /// where the text/binary is available (and any Source has been copied) + // - equals nil if len=0 + buf: pointer; + /// initialize a temporary copy of the content supplied as RawByteString + // - will also allocate and copy the ending #0 (even for binary) + procedure Init(const Source: RawByteString); overload; + /// initialize a temporary copy of the supplied text buffer, ending with #0 + function Init(Source: PUTF8Char): PUTF8Char; overload; + /// initialize a temporary copy of the supplied text buffer + procedure Init(Source: pointer; SourceLen: PtrInt); overload; + /// initialize a new temporary buffer of a given number of bytes + function Init(SourceLen: PtrInt): pointer; overload; + /// initialize a temporary buffer with the length of the internal stack + function InitOnStack: pointer; + /// initialize the buffer returning the internal buffer size (4095 bytes) + // - could be used e.g. for an API call, first trying with plain temp.Init + // and using temp.buf and temp.len safely in the call, only calling + // temp.Init(expectedsize) if the API returned an error about an insufficient + // buffer space + function Init: integer; overload; {$ifdef HASINLINE}inline;{$endif} + /// initialize a new temporary buffer of a given number of random bytes + // - will fill the buffer via FillRandom() calls + // - forcegsl is true by default, since Lecuyer's generator has no HW bug + function InitRandom(RandomLen: integer; forcegsl: boolean=true): pointer; + /// initialize a new temporary buffer filled with 32-bit integer increasing values + function InitIncreasing(Count: PtrInt; Start: PtrInt=0): PIntegerArray; + /// initialize a new temporary buffer of a given number of zero bytes + function InitZero(ZeroLen: PtrInt): pointer; + /// finalize the temporary storage + procedure Done; overload; {$ifdef HASINLINE}inline;{$endif} + /// finalize the temporary storage, and create a RawUTF8 string from it + procedure Done(EndBuf: pointer; var Dest: RawUTF8); overload; + private + // default 4KB buffer allocated on stack - after the len/buf main fields + tmp: array[0..4095] of AnsiChar; + end; + + /// function prototype to be used for hashing of an element + // - it must return a cardinal hash, with as less collision as possible + // - TDynArrayHashed.Init will use crc32c() if no custom function is supplied, + // which will run either as software or SSE4.2 hardware, with good colision + // for most used kind of data + THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; + +var + /// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252) + // - this instance is global and instantied during the whole program life time + // - it will be created from hard-coded values, and not using the system API, + // since it appeared that some systems (e.g. in Russia) did tweak the registry + // so that 1252 code page maps 1251 code page + WinAnsiConvert: TSynAnsiFixedWidth; + + /// global TSynAnsiConvert instance to handle current system encoding + // - this is the encoding as used by the AnsiString Delphi, so will be used + // before Delphi 2009 to speed-up VCL string handling (especially for UTF-8) + // - this instance is global and instantied during the whole program life time + CurrentAnsiConvert: TSynAnsiConvert; + + /// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8) + // - this instance is global and instantied during the whole program life time + UTF8AnsiConvert: TSynAnsiUTF8; + +/// check if a codepage should be handled by a TSynAnsiFixedWidth page +function IsFixedWidthCodePage(aCodePage: cardinal): boolean; + {$ifdef HASINLINE}inline;{$endif} + +const + /// HTTP header name for the content type, as defined in the corresponding RFC + HEADER_CONTENT_TYPE = 'Content-Type: '; + + /// HTTP header name for the content type, in upper case + // - as defined in the corresponding RFC + // - could be used e.g. with IdemPChar() to retrieve the Content-Type value + HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: '; + + /// HTTP header name for the client IP, in upper case + // - as defined in our HTTP server classes + // - could be used e.g. with IdemPChar() to retrieve the remote IP address + HEADER_REMOTEIP_UPPER = 'REMOTEIP: '; + + /// HTTP header name for the authorization token, in upper case + // - could be used e.g. with IdemPChar() to retrieve a JWT value + // - will detect header computed e.g. by SynCrtSock.AuthorizationBearer() + HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER '; + + /// MIME content type used for JSON communication (as used by the Microsoft + // WCF framework and the YUI framework) + JSON_CONTENT_TYPE = 'application/json; charset=UTF-8'; + + /// HTTP header for MIME content type used for plain JSON + JSON_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+JSON_CONTENT_TYPE; + + /// MIME content type used for plain JSON, in upper case + // - could be used e.g. with IdemPChar() to retrieve the Content-Type value + JSON_CONTENT_TYPE_UPPER = 'APPLICATION/JSON'; + + /// HTTP header for MIME content type used for plain JSON, in upper case + // - could be used e.g. with IdemPChar() to retrieve the Content-Type value + JSON_CONTENT_TYPE_HEADER_UPPER = HEADER_CONTENT_TYPE_UPPER+JSON_CONTENT_TYPE_UPPER; + + /// MIME content type used for plain UTF-8 text + TEXT_CONTENT_TYPE = 'text/plain; charset=UTF-8'; + + /// HTTP header for MIME content type used for plain UTF-8 text + TEXT_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+TEXT_CONTENT_TYPE; + + /// MIME content type used for UTF-8 encoded HTML + HTML_CONTENT_TYPE = 'text/html; charset=UTF-8'; + + /// HTTP header for MIME content type used for UTF-8 encoded HTML + HTML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+HTML_CONTENT_TYPE; + + /// MIME content type used for UTF-8 encoded XML + XML_CONTENT_TYPE = 'text/xml; charset=UTF-8'; + + /// HTTP header for MIME content type used for UTF-8 encoded XML + XML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+XML_CONTENT_TYPE; + + /// MIME content type used for raw binary data + BINARY_CONTENT_TYPE = 'application/octet-stream'; + + /// MIME content type used for raw binary data, in upper case + BINARY_CONTENT_TYPE_UPPER = 'APPLICATION/OCTET-STREAM'; + + /// HTTP header for MIME content type used for raw binary data + BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE; + + /// MIME content type used for a JPEG picture + JPEG_CONTENT_TYPE = 'image/jpeg'; + +var + /// MIME content type used for JSON communication + // - i.e. 'application/json; charset=UTF-8' + // - this global will be initialized with JSON_CONTENT_TYPE constant, to + // avoid a memory allocation each time it is assigned to a variable + JSON_CONTENT_TYPE_VAR: RawUTF8; + + /// HTTP header for MIME content type used for plain JSON + // - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant, + // to avoid a memory allocation each time it is assigned to a variable + JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8; + + /// can be used to avoid a memory allocation for res := 'null' + NULL_STR_VAR: RawUTF8; + +/// compute the new capacity when expanding an array of items +// - handle tiny, small, medium, large and huge sizes properly to reduce +// memory usage and maximize performance +function NextGrow(capacity: integer): integer; + +/// equivalence to SetString(s,nil,len) function +// - faster especially under FPC +procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); + {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// equivalence to SetString(s,nil,len) function with a specific code page +// - faster especially under FPC +procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); + {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// initialize a RawByteString, ensuring returned "aligned" pointer is 16-bytes aligned +// - to be used e.g. for proper SSE process +procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; + out aligned: pointer); + +/// equivalence to @UTF8[1] expression to ensure a RawUTF8 variable is unique +// - will ensure that the string refcount is 1, and return a pointer to the text +// - under FPC, @UTF8[1] does not call UniqueString() as it does with Delphi +// - if UTF8 is a constant (refcount=-1), will create a temporary copy in heap +function UniqueRawUTF8(var UTF8: RawUTF8): pointer; + {$ifdef HASINLINE}inline;{$endif} + +/// will fast replace all #0 chars as ~ +// - could be used after UniqueRawUTF8() on a in-placed modified JSON buffer, +// in which all values have been ended with #0 +// - you can optionally specify a maximum size, in bytes (this won't reallocate +// the string, but just add a #0 at some point in the UTF8 buffer) +// - could allow logging of parsed input e.g. after an exception +procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer=maxInt); + +/// conversion of a wide char into a WinAnsi (CodePage 1252) char +// - return '?' for an unknown WideChar in code page 1252 +function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; + {$ifdef HASINLINE}inline;{$endif} + +/// conversion of a wide char into a WinAnsi (CodePage 1252) char index +// - return -1 for an unknown WideChar in code page 1252 +function WideCharToWinAnsi(wc: cardinal): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied buffer only contains 7-bits Ansi characters +function IsAnsiCompatible(PC: PAnsiChar): boolean; overload; + +/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters +function IsAnsiCompatibleW(PW: PWideChar): boolean; overload; + +/// return TRUE if the supplied buffer only contains 7-bits Ansi characters +function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied text only contains 7-bits Ansi characters +function IsAnsiCompatible(const Text: RawByteString): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters +function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload; + +/// return TRUE if the supplied unicode buffer only contains WinAnsi characters +// - i.e. if the text can be displayed using ANSI_CHARSET +function IsWinAnsi(WideText: PWideChar): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied unicode buffer only contains WinAnsi characters +// - i.e. if the text can be displayed using ANSI_CHARSET +function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters +// - i.e. if the text can be displayed using ANSI_CHARSET +function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters +// - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode +// characters (e.g. no "tm" or such) +function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// UTF-8 encode one UTF-16 character into Dest +// - return the number of bytes written into Dest (i.e. 1,2 or 3) +// - this method does NOT handle UTF-16 surrogate pairs +function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// UTF-8 encode one UTF-16 encoded UCS4 character into Dest +// - return the number of bytes written into Dest (i.e. from 1 up to 6) +// - Source will contain the next UTF-16 character +// - this method DOES handle UTF-16 surrogate pairs +function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; + +/// UTF-8 encode one UCS4 character into Dest +// - return the number of bytes written into Dest (i.e. from 1 up to 6) +// - this method DOES handle UTF-16 surrogate pairs +function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; + +/// direct conversion of an AnsiString with an unknown code page into an +// UTF-8 encoded String +// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 +// - newer UNICODE versions of Delphi will retrieve the code page from string +procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload; + +/// direct conversion of an AnsiString with an unknown code page into an +// UTF-8 encoded String +// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 +// - newer UNICODE versions of Delphi will retrieve the code page from string +function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String +// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), +// and use a fixed pre-calculated array for individual chars conversion +function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String +// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), +// and use a fixed pre-calculated array for individual chars conversion +function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer +// - Dest^ buffer must be reserved with at least SourceChars*3 +// - call internally WinAnsiConvert fast conversion class +function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a WinAnsi shortstring into a UTF-8 text +// - call internally WinAnsiConvert fast conversion class +function ShortStringToUTF8(const source: ShortString): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String +// - very fast, by using a fixed pre-calculated array for individual chars conversion +function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; + +/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer +// - very fast, by using a fixed pre-calculated array for individual chars conversion +// - text will be truncated if necessary to avoid buffer overflow in Dest[] +procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a UTF-8 encoded string into a WinAnsi String +function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String +function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String +procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer +function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer +procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); + +/// direct conversion of an ANSI-7 shortstring into an AnsiString +// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 +function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of an ANSI-7 shortstring into an AnsiString +// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 +procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer +// - faster than System.UTF8ToUnicode +// - sourceBytes can by 0, therefore length is computed from zero terminated source +// - enough place must be available in dest buffer (guess is sourceBytes*3+2) +// - a WideChar(#0) is added at the end (if something is written) unless +// NoTrailingZero is TRUE +// - returns the BYTE count written in dest, excluding the ending WideChar(#0) +function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0; + NoTrailingZero: boolean=false): PtrInt; overload; + +/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer +// - faster than System.UTF8ToUnicode +// - this overloaded function expect a MaxDestChars parameter +// - sourceBytes can not be 0 for this function +// - enough place must be available in dest buffer (guess is sourceBytes*3+2) +// - a WideChar(#0) is added at the end (if something is written) unless +// NoTrailingZero is TRUE +// - returns the BYTE COUNT (not WideChar count) written in dest, excluding the +// ending WideChar(#0) +function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; + MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean=false): PtrInt; overload; + +/// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^ +// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates +// - faster than System.UTF8ToUnicode with dest=nil +function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; + +/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #1..#31 +// control characters +// - supplied input is a pointer to a #0 ended text buffer +function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; overload; + +/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #0..#31 +// control characters +// - supplied input is a RawUTF8 variable +function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; overload; + +/// will truncate the supplied UTF-8 value if its length exceeds the specified +// UTF-16 Unicode characters count +// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates +// - returns FALSE if text was not truncated, TRUE otherwise +function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUtf16: integer): boolean; + +/// will truncate the supplied UTF-8 value if its length exceeds the specified +// bytes count +// - this function will ensure that the returned content will contain only valid +// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence +// - returns FALSE if text was not truncated, TRUE otherwise +function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; + +/// compute the truncated length of the supplied UTF-8 value if it exceeds the +// specified bytes count +// - this function will ensure that the returned content will contain only valid +// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence +// - returns maxUTF8 if text was not truncated, or the number of fitting bytes +function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; overload; + +/// compute the truncated length of the supplied UTF-8 value if it exceeds the +// specified bytes count +// - this function will ensure that the returned content will contain only valid +// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence +// - returns maxUTF8 if text was not truncated, or the number of fitting bytes +function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; overload; + +/// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line +// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates +// - end the parsing at first #13 or #10 character +function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; + +/// convert a UTF-8 encoded buffer into a RawUnicode string +// - if L is 0, L is computed from zero terminated P buffer +// - RawUnicode is ended by a WideChar(#0) +// - faster than System.Utf8Decode() which uses slow widestrings +function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; overload; + +/// convert a UTF-8 string into a RawUnicode string +function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a UTF-8 string into a RawUnicode string +// - this version doesn't resize the length of the result RawUnicode +// and is therefore useful before a Win32 Unicode API call (with nCount=-1) +// - if DestLen is not nil, the resulting length (in bytes) will be stored within +function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): RawUnicode; overload; + +/// convert a UTF-8 string into a RawUnicode string +// - returns the resulting length (in bytes) will be stored within Dest +function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; overload; + +type + /// option set for RawUnicodeToUtf8() conversion + TCharConversionFlags = set of ( + ccfNoTrailingZero, ccfReplacementCharacterForUnmatchedSurrogate); + +/// convert a RawUnicode PWideChar into a UTF-8 string +procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; + var result: RawUTF8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload; + +/// convert a RawUnicode PWideChar into a UTF-8 string +function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; + Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a RawUnicode UTF-16 PWideChar into a UTF-8 buffer +// - replace system.UnicodeToUtf8 implementation, which is rather slow +// since Delphi 2009+ +// - append a trailing #0 to the ending PUTF8Char, unless ccfNoTrailingZero is set +// - if ccfReplacementCharacterForUnmatchedSurrogate is set, this function will identify +// unmatched surrogate pairs and replace them with EF BF BD / FFFD Unicode +// Replacement character - see https://en.wikipedia.org/wiki/Specials_(Unicode_block) +function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; + Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; overload; + +/// convert a RawUnicode PWideChar into a UTF-8 string +// - this version doesn't resize the resulting RawUTF8 string, but return +// the new resulting RawUTF8 byte count into UTF8Length +function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; + out UTF8Length: integer): RawUTF8; overload; + +/// convert a RawUnicode string into a UTF-8 string +function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload; + +/// convert a SynUnicode string into a UTF-8 string +function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8; + +/// convert a WideString into a UTF-8 string +function WideStringToUTF8(const aText: WideString): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer +procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer); + {$ifdef HASINLINE}inline;{$endif} + +/// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string +function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a RawUnicode string into a WinAnsi (code page 1252) string +function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a WideString into a WinAnsi (code page 1252) string +function WideStringToWinAnsi(const Wide: WideString): WinAnsiString; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string +procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer); + +/// convert any Raw Unicode encoded String into a generic SynUnicode Text +function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any Raw Unicode encoded String into a generic SynUnicode Text +function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an Unicode buffer into a WinAnsi (code page 1252) string +procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString); + +/// convert an Unicode buffer into a generic VCL string +function UnicodeBufferToString(source: PWideChar): string; + +{$ifdef HASVARUSTRING} + +/// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string +function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline; + +// this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment +// but is faster, since it uses no Win32 API call +function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline; + +/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string +// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), +// but is faster, since use no Win32 API call +procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload; + +/// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string +function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; inline; + +/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string +// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), +// but is faster, since use no Win32 API call +function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline; + +/// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string +// - this function is faster than default RTL, since use no Win32 API call +function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; overload; + +/// convert a Win-Ansi string into a Delphi 2009+ Unicode string +// - this function is faster than default RTL, since use no Win32 API call +function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload; + +{$endif HASVARUSTRING} + +/// convert any generic VCL Text into an UTF-8 encoded String +// - in the VCL context, it's prefered to use TLanguageFile.StringToUTF8() +// method from mORMoti18n, which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function StringToUTF8(const Text: string): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any generic VCL Text buffer into an UTF-8 encoded String +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any generic VCL Text into an UTF-8 encoded String +// - this overloaded function use a faster by-reference parameter for the result +procedure StringToUTF8(const Text: string; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any generic VCL Text into an UTF-8 encoded String +function ToUTF8(const Text: string): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any UTF-8 encoded shortstring Text into an UTF-8 encoded String +// - expects the supplied content to be already ASCII-7 or UTF-8 encoded, e.g. +// a RTTI type or property name: it won't work with Ansi-encoded strings +function ToUTF8(const Ansi7Text: ShortString): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a TGUID into UTF-8 encoded text +// - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) +// - if you need the embracing { }, use GUIDToRawUTF8() function instead +function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; overload; + +{$ifndef NOVARIANTS} + +type + /// function prototype used internally for variant comparison + // - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue + TVariantCompare = function(const V1,V2: variant): PtrInt; + +/// TVariantCompare-compatible case-sensitive comparison function +// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=false) +function VariantCompare(const V1,V2: variant): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// TVariantCompare-compatible case-insensitive comparison function +// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=true) +function VariantCompareI(const V1,V2: variant): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any Variant into UTF-8 encoded String +// - use VariantSaveJSON() instead if you need a conversion to JSON with +// custom parameters +// - note: null will be returned as 'null' +function VariantToUTF8(const V: Variant): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any Variant into UTF-8 encoded String +// - use VariantSaveJSON() instead if you need a conversion to JSON with +// custom parameters +// - note: null will be returned as 'null' +function ToUTF8(const V: Variant): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any Variant into UTF-8 encoded String +// - use VariantSaveJSON() instead if you need a conversion to JSON with +// custom parameters +// - wasString is set if the V value was a text +// - empty and null variants will be stored as 'null' text - as expected by JSON +// - custom variant types (e.g. TDocVariant) will be stored as JSON +procedure VariantToUTF8(const V: Variant; var result: RawUTF8; + var wasString: boolean); overload; + +/// convert any Variant into UTF-8 encoded String +// - use VariantSaveJSON() instead if you need a conversion to JSON with +// custom parameters +// - returns TRUE if the V value was a text, FALSE if was not (e.g. a number) +// - empty and null variants will be stored as 'null' text - as expected by JSON +// - custom variant types (e.g. TDocVariant) will be stored as JSON +function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; overload; + +/// convert any date/time Variant into a TDateTime value +// - would handle varDate kind of variant, or use a string conversion and +// ISO-8601 parsing if possible +function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; + +/// fast conversion from hexa chars, supplied as a variant string, into a binary buffer +function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; + +/// fast conversion of a binary buffer into hexa chars, as a variant string +function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// fast comparison of a Variant and UTF-8 encoded String (or number) +// - slightly faster than plain V=Str, which computes a temporary variant +// - here Str='' equals unassigned, null or false +// - if CaseSensitive is false, will use IdemPropNameU() for comparison +function VariantEquals(const V: Variant; const Str: RawUTF8; + CaseSensitive: boolean=true): boolean; overload; + +/// convert any Variant into a VCL string type +// - expects any varString value to be stored as a RawUTF8 +// - prior to Delphi 2009, use VariantToString(aVariant) instead of +// string(aVariant) to safely retrieve a string=AnsiString value from a variant +// generated by our framework units - otherwise, you may loose encoded characters +// - for Unicode versions of Delphi, there won't be any potential data loss, +// but this version may be slightly faster than a string(aVariant) +function VariantToString(const V: Variant): string; + +/// convert any Variant into a value encoded as with :(..:) inlined parameters +// in FormatUTF8(Format,Args,Params) +procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); + +/// convert any Variant into another Variant storing an RawUTF8 of the value +// - e.g. VariantToVariantUTF8('toto')='toto' and VariantToVariantUTF8(12)='12' +function VariantToVariantUTF8(const V: Variant): variant; + +/// faster alternative to Finalize(aVariantDynArray) +// - this function will take account and optimize the release of a dynamic +// array of custom variant types values +// - for instance, an array of TDocVariant will be optimized for speed +procedure VariantDynArrayClear(var Value: TVariantDynArray); + {$ifdef HASINLINE}inline;{$endif} + +/// crc32c-based hash of a variant value +// - complex string types will make up to 255 uppercase characters conversion +// if CaseInsensitive is true +// - you can specify your own hashing function if crc32c is not what you expect +function VariantHash(const value: variant; CaseInsensitive: boolean; + Hasher: THasher=nil): cardinal; + +{$endif NOVARIANTS} + +{ note: those VariantToInteger*() functions are expected to be there } + +/// convert any numerical Variant into a 32-bit integer +// - it will expect true numerical Variant and won't convert any string nor +// floating-pointer Variant, which will return FALSE and won't change the +// Value variable content +function VariantToInteger(const V: Variant; var Value: integer): boolean; + +/// convert any numerical Variant into a 64-bit integer +// - it will expect true numerical Variant and won't convert any string nor +// floating-pointer Variant, which will return FALSE and won't change the +// Value variable content +function VariantToInt64(const V: Variant; var Value: Int64): boolean; + +/// convert any numerical Variant into a 64-bit integer +// - it will expect true numerical Variant and won't convert any string nor +// floating-pointer Variant, which will return the supplied DefaultValue +function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; + +/// convert any numerical Variant into a floating point value +function VariantToDouble(const V: Variant; var Value: double): boolean; + +/// convert any numerical Variant into a floating point value +function VariantToDoubleDef(const V: Variant; const default: double=0): double; + +/// convert any numerical Variant into a fixed decimals floating point value +function VariantToCurrency(const V: Variant; var Value: currency): boolean; + +/// convert any numerical Variant into a boolean value +// - text content will return true after case-insensitive 'true' comparison +function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; + +/// convert any numerical Variant into an integer +// - it will expect true numerical Variant and won't convert any string nor +// floating-pointer Variant, which will return the supplied DefaultValue +function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload; + +/// convert any generic VCL Text buffer into an UTF-8 encoded buffer +// - Dest must be able to receive at least SourceChars*3 bytes +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; overload; + +/// convert any generic VCL 0-terminated Text buffer into an UTF-8 string +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; + +/// convert any generic VCL Text into a Raw Unicode encoded String +// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, +// which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function StringToRawUnicode(const S: string): RawUnicode; overload; + +/// convert any generic VCL Text into a SynUnicode encoded String +// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, +// which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function StringToSynUnicode(const S: string): SynUnicode; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any generic VCL Text into a SynUnicode encoded String +// - overloaded to avoid a copy to a temporary result string of a function +procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any generic VCL Text into a Raw Unicode encoded String +// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, +// which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload; + +/// convert any Raw Unicode encoded string into a generic VCL Text +// - uses StrLenW() and not length(U) to handle case when was used as buffer +function RawUnicodeToString(const U: RawUnicode): string; overload; + +/// convert any Raw Unicode encoded buffer into a generic VCL Text +function RawUnicodeToString(P: PWideChar; L: integer): string; overload; + +/// convert any Raw Unicode encoded buffer into a generic VCL Text +procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload; + +/// convert any SynUnicode encoded string into a generic VCL Text +function SynUnicodeToString(const U: SynUnicode): string; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any UTF-8 encoded String into a generic VCL Text +// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, +// which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function UTF8ToString(const Text: RawUTF8): string; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any UTF-8 encoded buffer into a generic VCL Text +// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, +// which will handle full i18n of your application +// - it will work as is with Delphi 2009+ (direct unicode conversion) +// - under older version of Delphi (no unicode), it will use the +// current RTL codepage, as with WideString conversion (but without slow +// WideString usage) +function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload; + {$ifdef UNICODE}inline;{$endif} + +/// convert any UTF-8 encoded buffer into a generic VCL Text +procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload; + +/// convert any UTF-8 encoded String into a generic WideString Text +function UTF8ToWideString(const Text: RawUTF8): WideString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any UTF-8 encoded String into a generic WideString Text +procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any UTF-8 encoded String into a generic WideString Text +procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); overload; + +/// convert any UTF-8 encoded String into a generic SynUnicode Text +function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload; + +/// convert any UTF-8 encoded String into a generic SynUnicode Text +procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload; + +/// convert any UTF-8 encoded buffer into a generic SynUnicode Text +procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); overload; + +/// convert any Ansi 7 bit encoded String into a generic VCL Text +// - the Text content must contain only 7 bit pure ASCII characters +function Ansi7ToString(const Text: RawByteString): string; overload; + {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// convert any Ansi 7 bit encoded String into a generic VCL Text +// - the Text content must contain only 7 bit pure ASCII characters +function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert any Ansi 7 bit encoded String into a generic VCL Text +// - the Text content must contain only 7 bit pure ASCII characters +procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); overload; + +/// convert any generic VCL Text into Ansi 7 bit encoded String +// - the Text content must contain only 7 bit pure ASCII characters +function StringToAnsi7(const Text: string): RawByteString; + +/// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String +function StringToWinAnsi(const Text: string): WinAnsiString; + {$ifdef UNICODE}inline;{$endif} + +/// fast Format() function replacement, optimized for RawUTF8 +// - only supported token is %, which will be written in the resulting string +// according to each Args[] supplied items - so you will never get any exception +// as with the SysUtils.Format() when a specifier is incorrect +// - resulting string has no length limit and uses fast concatenation +// - there is no escape char, so to output a '%' character, you need to use '%' +// as place-holder, and specify '%' as value in the Args array +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - any supplied TObject instance will be written as their class name +function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; overload; + +/// fast Format() function replacement, optimized for RawUTF8 +// - overloaded function, which avoid a temporary RawUTF8 instance on stack +procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; + out result: RawUTF8); overload; + +/// fast Format() function replacement, tuned for direct memory buffer write +// - use the same single token % (and implementation) than FormatUTF8() +// - returns the number of UTF-8 bytes appended to Dest^ +function FormatBuffer(const Format: RawUTF8; const Args: array of const; + Dest: pointer; DestLen: PtrInt): PtrInt; + +/// fast Format() function replacement, for UTF-8 content stored in shortstring +// - use the same single token % (and implementation) than FormatUTF8() +// - shortstring allows fast stack allocation, so is perfect for small content +// - truncate result if the text size exceeds 255 bytes +procedure FormatShort(const Format: RawUTF8; const Args: array of const; + var result: shortstring); + +/// fast Format() function replacement, for UTF-8 content stored in shortstring +function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; + +/// fast Format() function replacement, tuned for small content +// - use the same single token % (and implementation) than FormatUTF8() +procedure FormatString(const Format: RawUTF8; const Args: array of const; + out result: string); overload; + +/// fast Format() function replacement, tuned for small content +// - use the same single token % (and implementation) than FormatUTF8() +function FormatString(const Format: RawUTF8; const Args: array of const): string; overload; + {$ifdef FPC}inline;{$endif} + +type + /// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16 + // - such result type would avoid a string allocation on heap, so are highly + // recommended e.g. when logging small pieces of information + TShort16 = string[16]; + PShort16 = ^TShort16; + +/// fast Format() function replacement, for UTF-8 content stored in TShort16 +// - truncate result if the text size exceeds 16 bytes +procedure FormatShort16(const Format: RawUTF8; const Args: array of const; + var result: TShort16); + +/// fast Format() function replacement, handling % and ? parameters +// - will include Args[] for every % in Format +// - will inline Params[] for every ? in Format, handling special "inlined" +// parameters, as exected by mORMot.pas unit, i.e. :(1234): for numerical +// values, and :('quoted '' string'): for textual values +// - if optional JSONFormat parameter is TRUE, ? parameters will be written +// as JSON quoted strings, without :(...): tokens, e.g. "quoted "" string" +// - resulting string has no length limit and uses fast concatenation +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - any supplied TObject instance will be written as their class name +function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; + JSONFormat: boolean=false): RawUTF8; overload; + +/// read and store text into values[] according to fmt specifiers +// - %d as PInteger, %D as PInt64, %u as PCardinal, %U as PQWord, %f as PDouble, +// %F as PCurrency, %x as 8 hexa chars to PInteger, %X as 16 hexa chars to PInt64, +// %s as PShortString (UTF-8 encoded), %S as PRawUTF8, %L as PRawUTF8 (getting +// all text until the end of the line) +// - optionally, specifiers and any whitespace separated identifiers may be +// extracted and stored into the ident[] array, e.g. '%dFirstInt %s %DOneInt64' +// will store ['dFirstInt','s','DOneInt64'] into ident +function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; + ident: PRawUTF8DynArray=nil): integer; overload; + +/// read text from P/PLen and store it into values[] according to fmt specifiers +function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; + const values: array of pointer; ident: PRawUTF8DynArray): integer; overload; + +/// convert an open array (const Args: array of const) argument to an UTF-8 +// encoded text +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - any supplied TObject instance will be written as their class name +procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; + wasString: PBoolean=nil); + +type + /// a memory structure which avoids a temporary RawUTF8 allocation + // - used by VarRecToTempUTF8() and FormatUTF8()/FormatShort() + TTempUTF8 = record + Len: PtrInt; + Text: PUTF8Char; + TempRawUTF8: pointer; + Temp: array[0..23] of AnsiChar; + end; + PTempUTF8 = ^TTempUTF8; + +/// convert an open array (const Args: array of const) argument to an UTF-8 +// encoded text, using a specified temporary buffer +// - this function would allocate a RawUTF8 in TempRawUTF8 only if needed, +// but use the supplied Res.Temp[] buffer for numbers to text conversion - +// caller should ensure to make RawUTF8(TempRawUTF8) := '' on the entry +// - it would return the number of UTF-8 bytes, i.e. Res.Len +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - any supplied TObject instance will be written as their class name +function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; + +/// convert an open array (const Args: array of const) argument to an UTF-8 +// encoded text, returning FALSE if the argument was not a string value +function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an open array (const Args: array of const) argument to an Int64 +// - returns TRUE and set Value if the supplied argument is a vtInteger, vtInt64 +// or vtBoolean +// - returns FALSE if the argument is not an integer +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; + +/// convert an open array (const Args: array of const) argument to a floating +// point value +// - returns TRUE and set Value if the supplied argument is a number (e.g. +// vtInteger, vtInt64, vtCurrency or vtExtended) +// - returns FALSE if the argument is not a number +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +function VarRecToDouble(const V: TVarRec; out value: double): boolean; + +/// convert an open array (const Args: array of const) argument to a value +// encoded as with :(...): inlined parameters in FormatUTF8(Format,Args,Params) +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - any supplied TObject instance will be written as their class name +procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); + +/// get an open array (const Args: array of const) character argument +// - only handle varChar and varWideChar kind of arguments +function VarRecAsChar(const V: TVarRec): integer; + {$ifdef HASINLINE}inline;{$endif} + +type + /// function prototype used internally for UTF-8 buffer comparison + // - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery + TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt; + +/// convert the endianness of a given unsigned 32-bit integer into BigEndian +function bswap32(a: cardinal): cardinal; + {$ifdef FPC}{$ifndef CPUINTEL}inline;{$endif}{$endif} + +/// convert the endianness of a given unsigned 64-bit integer into BigEndian +function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; + {$ifdef FPC}{$ifndef CPUINTEL}inline;{$endif}{$endif} + +/// convert the endianness of an array of unsigned 64-bit integer into BigEndian +// - n is required to be > 0 +// - warning: on x86, a should be <> b +procedure bswap64array(a,b: PQWordArray; n: PtrInt); + +/// fast concatenation of several AnsiStrings +function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; + +/// creates a TBytes from a RawByteString memory buffer +procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); + +/// creates a RawByteString memory buffer from a TBytes content +procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); + {$ifdef HASINLINE}inline;{$endif} + +/// creates a RawByteString memory buffer from an embedded resource +// - returns '' if the resource is not found +// - warning: resources size may be rounded up to alignment +// - you can specify a library (dll) resource instance handle, if needed +procedure ResourceToRawByteString(const ResName: string; ResType: PChar; + out buf: RawByteString; Instance: THandle=0); + +/// creates a RawByteString memory buffer from an SynLZ-compressed embedded resource +// - returns '' if the resource is not found +// - this method would use SynLZDecompress() after ResourceToRawByteString(), +// with a ResType=PChar(10) (i.e. RC_DATA) +// - you can specify a library (dll) resource instance handle, if needed +procedure ResourceSynLZToRawByteString(const ResName: string; + out buf: RawByteString; Instance: THandle=0); + +{$ifndef ENHANCEDRTL} { is our Enhanced Runtime (or LVCL) library not installed? } + +/// fast dedicated RawUTF8 version of Trim() +// - implemented using x86 asm, if possible +// - this Trim() is seldom used, but this RawUTF8 specific version is needed +// e.g. by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString +// - in the middle of VCL code, consider using TrimU() which won't have name +// collision ambiguity as with SysUtils' homonymous function +function Trim(const S: RawUTF8): RawUTF8; + +/// fast dedicated RawUTF8 version of Trim() +// - could be used if overloaded Trim() from SysUtils.pas is ambiguous +function TrimU(const S: RawUTF8): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +{$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL } + +{$endif ENHANCEDRTL} + +/// our fast version of CompareMem() with optimized asm for x86 and tune pascal +function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; + +{$ifdef HASINLINE} +function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; inline; +{$else} +/// a CompareMem()-like function designed for small and fixed-sized content +// - here, Length is expected to be a constant value - typically from sizeof() - +// so that inlining has better performance than calling the CompareMem() function +var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): Boolean = CompareMem; +{$endif HASINLINE} + +/// a CompareMem()-like function designed for small (a few bytes) content +function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; {$ifdef HASINLINE}inline;{$endif} + +/// convert some ASCII-7 text into binary, using Emile Baudot code +// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; +// charset, following a custom static-huffman-like encoding with 5-bit masks +// - any upper case char will be converted into lowercase during encoding +// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored +// - resulting binary will consume 5 (or 10) bits per character +// - reverse of the BaudotToAscii() function +// - the "baud" symbol rate measurement comes from Emile's name ;) +function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; overload; + +/// convert some ASCII-7 text into binary, using Emile Baudot code +// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; +// charset, following a custom static-huffman-like encoding with 5-bit masks +// - any upper case char will be converted into lowercase during encoding +// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored +// - resulting binary will consume 5 (or 10) bits per character +// - reverse of the BaudotToAscii() function +// - the "baud" symbol rate measurement comes from Emile's name ;) +function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload; + +/// convert some Baudot code binary, into ASCII-7 text +// - reverse of the AsciiToBaudot() function +// - any uppercase character would be decoded as lowercase - and some characters +// may have disapeared +// - the "baud" symbol rate measurement comes from Emile's name ;) +function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; overload; + +/// convert some Baudot code binary, into ASCII-7 text +// - reverse of the AsciiToBaudot() function +// - any uppercase character would be decoded as lowercase - and some characters +// may have disapeared +// - the "baud" symbol rate measurement comes from Emile's name ;) +function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload; + +{$ifdef UNICODE} +/// our fast RawUTF8 version of Pos(), for Unicode only compiler +// - this Pos() is seldom used, but this RawUTF8 specific version is needed +// by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString +// - just a wrapper around PosEx(substr,str,1) +function Pos(const substr, str: RawUTF8): Integer; overload; inline; +{$endif UNICODE} + +/// use our fast RawUTF8 version of IntToStr() +// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 +// - only useful if our Enhanced Runtime (or LVCL) library is not installed +function Int64ToUtf8(Value: Int64): RawUTF8; overload; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// fast RawUTF8 version of IntToStr(), with proper QWord conversion +procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); + +/// use our fast RawUTF8 version of IntToStr() +// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 +// - only useful if our Enhanced Runtime (or LVCL) library is not installed +function Int32ToUtf8(Value: PtrInt): RawUTF8; overload; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// use our fast RawUTF8 version of IntToStr() +// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 +// - result as var parameter saves a local assignment and a try..finally +procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// use our fast RawUTF8 version of IntToStr() +// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 +// - result as var parameter saves a local assignment and a try..finally +procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// use our fast RawUTF8 version of IntToStr() +function ToUTF8(Value: PtrInt): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +{$ifndef CPU64} +/// use our fast RawUTF8 version of IntToStr() +function ToUTF8(Value: Int64): RawUTF8; overload; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} +{$endif} + +/// optimized conversion of a cardinal into RawUTF8 +function UInt32ToUtf8(Value: PtrUInt): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// optimized conversion of a cardinal into RawUTF8 +procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// faster version than default SysUtils.IntToStr implementation +function IntToString(Value: integer): string; overload; + +/// faster version than default SysUtils.IntToStr implementation +function IntToString(Value: cardinal): string; overload; + +/// faster version than default SysUtils.IntToStr implementation +function IntToString(Value: Int64): string; overload; + +/// convert a floating-point value to its numerical text equivalency +function DoubleToString(Value: Double): string; + +/// convert a currency value from its Int64 binary representation into +// its numerical text equivalency +// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) +function Curr64ToString(Value: Int64): string; + +type + /// used to store a set of 8-bit encoded characters + TSynAnsicharSet = set of AnsiChar; + /// used to store a set of 8-bit unsigned integers + TSynByteSet = set of Byte; + +/// check all character within text are spaces or control chars +// - i.e. a faster alternative to trim(text)='' +function IsVoid(const text: RawUTF8): boolean; + +/// returns the supplied text content, without any control char +// - a control char has an ASCII code #0 .. #32, i.e. text[]<=' ' +// - you can specify a custom char set to be excluded, if needed +function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[#0..' ']): RawUTF8; + +var + /// best possible precision when rendering a "single" kind of float + // - can be used as parameter for ExtendedToShort/ExtendedToStr + // - is defined as a var, so that you may be able to override the default + // settings, for the whole process + SINGLE_PRECISION: integer = 8; + /// best possible precision when rendering a "double" kind of float + // - can be used as parameter for ExtendedToShort/ExtendedToStr + // - is defined as a var, so that you may be able to override the default + // settings, for the whole process + DOUBLE_PRECISION: integer = 15; + /// best possible precision when rendering a "extended" kind of float + // - can be used as parameter for ExtendedToShort/ExtendedToStr + // - is defined as a var, so that you may be able to override the default + // settings, for the whole process + EXTENDED_PRECISION: integer = 18; + +const + /// a typical error allowed when working with double floating-point values + // - 1E-12 is too small, and triggers sometimes some unexpected errors; + // FPC RTL uses 1E-4 so we are paranoid enough + DOUBLE_SAME = 1E-11; + +type + {$ifdef TSYNEXTENDED80} + /// the floating-point type to be used for best precision and speed + // - will allow to fallback to double e.g. on x64 and ARM CPUs + TSynExtended = extended; + {$else} + /// ARM/Delphi 64-bit does not support 80bit extended -> double is enough + TSynExtended = double; + {$endif TSYNEXTENDED80} + + /// the non-number values potentially stored in an IEEE floating point + TFloatNan = (fnNumber, fnNan, fnInf, fnNegInf); + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + /// will actually change anything only on FPC ARM/Aarch64 plaforms + unaligned = Double; + {$endif} + + +const + /// the JavaScript-like values of non-number IEEE constants + // - as recognized by FloatToShortNan, and used by TTextWriter.Add() + // when serializing such single/double/extended floating-point values + JSON_NAN: array[TFloatNan] of string[11] = ( + '0', '"NaN"', '"Infinity"', '"-Infinity"'); + +type + /// small structure used as convenient result to Div100() procedure + TDiv100Rec = packed record + /// contains V div 100 after Div100(V) + D: cardinal; + /// contains V mod 100 after Div100(V) + M: cardinal; + end; + +/// simple wrapper to efficiently compute both division and modulo per 100 +// - compute result.D = Y div 100 and result.M = Y mod 100 +// - under FPC, will use fast multiplication by reciprocal so can be inlined +// - under Delphi, we use our own optimized asm version (which can't be inlined) +procedure Div100(Y: cardinal; var res: TDiv100Rec); + {$ifdef FPC} inline; {$endif} + +/// compare to floating point values, with IEEE 754 double precision +// - use this function instead of raw = operator +// - the precision is calculated from the A and B value range +// - faster equivalent than SameValue() in Math unit +// - if you know the precision range of A and B, it's faster to check abs(A-B)QWord(B) is wrong on older versions of Delphi, so you +// should better use this function or SortDynArrayQWord() to properly compare +// two QWord values over CPUX86 +function CompareQWord(A, B: QWord): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// compute the sum of values, using a running compensation for lost low-order bits +// - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution, +// so will eventually result in an incorrect number +// - Kahan algorithm keeps track of the accumulated error in integer operations, +// to achieve a precision of more than 100 bits +// - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm +procedure KahanSum(const Data: double; var Sum, Carry: double); + {$ifdef HASINLINE}inline;{$endif} + +/// convert a floating-point value to its numerical text equivalency +// - on Delphi Win32, calls FloatToText() in ffGeneral mode; on FPC uses str() +// - DOUBLE_PRECISION will redirect to DoubleToShort() and its faster Fabian +// Loitsch's Grisu algorithm if available +// - returns the count of chars stored into S, i.e. length(S) +function ExtendedToShort(var S: ShortString; Value: TSynExtended; Precision: integer): integer; + +/// convert a floating-point value to its numerical text equivalency without +// scientification notation +// - DOUBLE_PRECISION will redirect to DoubleToShortNoExp() and its faster Fabian +// Loitsch's Grisu algorithm if available - or calls str(Value:0:precision,S) +// - returns the count of chars stored into S, i.e. length(S) +function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; + Precision: integer): integer; + +/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number +// - as returned by ExtendedToShort/DoubleToShort textual conversion +// - such values do appear as IEEE floating points, but are not defined in JSON +function FloatToShortNan(const s: shortstring): TFloatNan; + {$ifdef HASINLINE}inline;{$endif} + +/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number +// - as returned e.g. by ExtendedToStr/DoubleToStr textual conversion +// - such values do appear as IEEE floating points, but are not defined in JSON +function FloatToStrNan(const s: RawUTF8): TFloatNan; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a floating-point value to its numerical text equivalency +function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload; + +/// convert a floating-point value to its numerical text equivalency +procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload; + +/// recognize if the supplied text is NAN/INF/+INF/-INF, i.e. not a number +// - returns the number as text (stored into tmp variable), or "Infinity", +// "-Infinity", and "NaN" for corresponding IEEE special values +// - result is a PShortString either over tmp, or JSON_NAN[] +function FloatToJSONNan(const s: ShortString): PShortString; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a floating-point value to its JSON text equivalency +// - depending on the platform, it may either call str() or FloatToText() +// in ffGeneral mode (the shortest possible decimal string using fixed or +// scientific format) +// - returns the number as text (stored into tmp variable), or "Infinity", +// "-Infinity", and "NaN" for corresponding IEEE special values +// - result is a PShortString either over tmp, or JSON_NAN[] +function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; + Precision: integer; NoExp: boolean): PShortString; + +/// convert a 64-bit floating-point value to its numerical text equivalency +// - on Delphi Win32, calls FloatToText() in ffGeneral mode +// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own +// faster Fabian Loitsch's Grisu algorithm implementation +// - returns the count of chars stored into S, i.e. length(S) +function DoubleToShort(var S: ShortString; const Value: double): integer; + {$ifdef FPC}inline;{$endif} + +/// convert a 64-bit floating-point value to its numerical text equivalency +// without scientific notation +// - on Delphi Win32, calls FloatToText() in ffGeneral mode +// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own +// faster Fabian Loitsch's Grisu algorithm implementation +// - returns the count of chars stored into S, i.e. length(S) +function DoubleToShortNoExp(var S: ShortString; const Value: double): integer; + {$ifdef FPC}inline;{$endif} + +{$ifdef DOUBLETOSHORT_USEGRISU} +const + // special text returned if the double is not a number + C_STR_INF: string[3] = 'Inf'; + C_STR_QNAN: string[3] = 'Nan'; + + // min_width parameter special value, as used internally by FPC for str(d,s) + // - DoubleToAscii() only accept C_NO_MIN_WIDTH or 0 for min_width: space + // trailing has been removed in this cut-down version + C_NO_MIN_WIDTH = -32767; + +/// raw function to convert a 64-bit double into a shortstring, stored in str +// - implements Fabian Loitsch's Grisu algorithm dedicated to double values +// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid +// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to +// force the scientific notation when the double cannot be represented as +// a simple fractinal number) +procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); +{$endif DOUBLETOSHORT_USEGRISU} + +/// convert a 64-bit floating-point value to its JSON text equivalency +// - on Delphi Win32, calls FloatToText() in ffGeneral mode +// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own +// faster Fabian Loitsch's Grisu algorithm +// - returns the number as text (stored into tmp variable), or "Infinity", +// "-Infinity", and "NaN" for corresponding IEEE special values +// - result is a PShortString either over tmp, or JSON_NAN[] +function DoubleToJSON(var tmp: ShortString; Value: double; NoExp: boolean): PShortString; + +/// convert a 64-bit floating-point value to its numerical text equivalency +function DoubleToStr(Value: Double): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a 64-bit floating-point value to its numerical text equivalency +procedure DoubleToStr(Value: Double; var result: RawUTF8); overload; + +/// fast retrieve the position of a given character +function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// fast retrieve the position of any value of a given set of characters +// - see also strspn() function which is likely to be faster +function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; + +/// a non case-sensitive RawUTF8 version of Pos() +// - uppersubstr is expected to be already in upper case +// - this version handle only 7 bit ASCII (no accentuated characters) +function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; + +/// a non case-sensitive version of Pos() +// - uppersubstr is expected to be already in upper case +// - this version handle only 7 bit ASCII (no accentuated characters) +function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; + +/// a non case-sensitive RawUTF8 version of Pos() +// - substr is expected to be already in upper case +// - this version will decode the UTF-8 content before using NormToUpper[] +function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; + +/// internal fast integer val to text conversion +// - expect the last available temporary char position in P +// - return the last written char position (write in reverse order in P^) +// - typical use: +// !function Int32ToUTF8(Value: PtrInt): RawUTF8; +// !var tmp: array[0..23] of AnsiChar; +// ! P: PAnsiChar; +// !begin +// ! P := StrInt32(@tmp[23],Value); +// ! SetString(result,P,@tmp[23]-P); +// !end; +// - convert the input value as PtrInt, so as Int64 on 64-bit CPUs +// - not to be called directly: use IntToStr() or Int32ToUTF8() instead +function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; + +/// internal fast unsigned integer val to text conversion +// - expect the last available temporary char position in P +// - return the last written char position (write in reverse order in P^) +// - convert the input value as PtrUInt, so as QWord on 64-bit CPUs +function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; + +/// internal fast Int64 val to text conversion +// - same calling convention as with StrInt32() above +function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; + {$ifdef HASINLINE}inline;{$endif} + +/// internal fast unsigned Int64 val to text conversion +// - same calling convention as with StrInt32() above +function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; + {$ifdef CPU64}inline;{$endif} + +/// fast add some characters to a RawUTF8 string +// - faster than SetString(tmp,Buffer,BufferLen); Text := Text+tmp; +procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); + +/// fast add one character to a RawUTF8 string +// - faster than Text := Text + ch; +procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); + +/// fast add some characters to a RawUTF8 string +// - faster than Text := Text+RawUTF8(Buffers[0])+RawUTF8(Buffers[0])+... +procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); + +/// fast add some characters from a RawUTF8 string into a given buffer +// - warning: the Buffer should contain enough space to store the Text, otherwise +// you may encounter buffer overflows and random memory errors +function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; + +/// fast add text conversion of a 32-bit unsigned integer value into a given buffer +// - warning: the Buffer should contain enough space to store the text, otherwise +// you may encounter buffer overflows and random memory errors +function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; + +/// fast add text conversion of 0-999 integer value into a given buffer +// - warning: it won't check that Value is in 0-999 range +// - up to 4 bytes may be written to the buffer (including trailing #0) +function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// buffer-safe version of StrComp(), to be used with PUTF8Char/PAnsiChar +// - pure pascal StrComp() won't access the memory beyond the string, but this +// function is defined for compatibility with SSE 4.2 expectations +function StrCompFast(Str1, Str2: pointer): PtrInt; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar +// - won't use SSE4.2 instructions on supported CPUs by default, which may read +// some bytes beyond the s string, so should be avoided e.g. over memory mapped +// files - call explicitely StrCompSSE42() if you are confident on your input +var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast; + +/// pure pascal version of strspn(), to be used with PUTF8Char/PAnsiChar +// - please note that this optimized version may read up to 3 bytes beyond +// accept but never after s end, so is safe e.g. over memory mapped files +function strspnpas(s,accept: pointer): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// pure pascal version of strcspn(), to be used with PUTF8Char/PAnsiChar +// - please note that this optimized version may read up to 3 bytes beyond +// reject but never after s end, so is safe e.g. over memory mapped files +function strcspnpas(s,reject: pointer): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// fastest available version of strspn(), to be used with PUTF8Char/PAnsiChar +// - returns size of initial segment of s which appears in accept chars, e.g. +// ! strspn('abcdef','debca')=5 +// - won't use SSE4.2 instructions on supported CPUs by default, which may read +// some bytes beyond the s string, so should be avoided e.g. over memory mapped +// files - call explicitely strspnsse42() if you are confident on your input +var strspn: function (s,accept: pointer): integer = strspnpas; + +/// fastest available version of strcspn(), to be used with PUTF8Char/PAnsiChar +// - returns size of initial segment of s which doesn't appears in reject chars, e.g. +// ! strcspn('1234,6789',',')=4 +// - won't use SSE4.2 instructions on supported CPUs by default, which may read +// some bytes beyond the s string, so should be avoided e.g. over memory mapped +// files - call explicitely strcspnsse42() if you are confident on your input +var strcspn: function (s,reject: pointer): integer = strcspnpas; + +{$ifdef CPUINTEL} +{$ifndef ABSOLUTEPASCAL} +{$ifdef HASAESNI} +/// SSE 4.2 version of StrComp(), to be used with PUTF8Char/PAnsiChar +// - please note that this optimized version may read up to 15 bytes +// beyond the string; this is rarely a problem but it may generate protection +// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system +// - could be used instead of StrComp() when you are confident about your +// Str1/Str2 input buffers, checking if cfSSE42 in CpuFeatures +function StrCompSSE42(Str1, Str2: pointer): PtrInt; + +// - please note that this optimized version may read up to 15 bytes +// beyond the string; this is rarely a problem but it may generate protection +// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system +// - could be used instead of StrLen() when you are confident about your +// S input buffers, checking if cfSSE42 in CpuFeatures +function StrLenSSE42(S: pointer): PtrInt; +{$endif HASAESNI} + +/// SSE 4.2 version of strspn(), to be used with PUTF8Char/PAnsiChar +// - please note that this optimized version may read up to 15 bytes +// beyond the string; this is rarely a problem but it may generate protection +// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system +// - could be used instead of strspn() when you are confident about your +// s/accept input buffers, checking if cfSSE42 in CpuFeatures +function strspnsse42(s,accept: pointer): integer; + +/// SSE 4.2 version of strcspn(), to be used with PUTF8Char/PAnsiChar +// - please note that this optimized version may read up to 15 bytes +// beyond the string; this is rarely a problem but it may generate protection +// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system +// - could be used instead of strcspn() when you are confident about your +// s/reject input buffers, checking if cfSSE42 in CpuFeatures +function strcspnsse42(s,reject: pointer): integer; + +/// SSE 4.2 version of GetBitsCountPtrInt() +// - defined just for regression tests - call GetBitsCountPtrInt() instead +function GetBitsCountSSE42(value: PtrInt): PtrInt; +{$endif ABSOLUTEPASCAL} +{$endif CPUINTEL} + +/// use our fast version of StrIComp(), to be used with PUTF8Char/PAnsiChar +function StrIComp(Str1, Str2: pointer): PtrInt; + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} + +/// slower version of StrLen(), but which will never read beyond the string +// - this version won't access the memory beyond the string, so may be +// preferred to StrLen(), when using e.g. memory mapped files or any memory +// protected buffer +function StrLenPas(S: pointer): PtrInt; + +/// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar +// - if available, a fast SSE2 asm will be used on Intel/AMD CPUs +// - won't use SSE4.2 instructions on supported CPUs by default, which may read +// some bytes beyond the string, so should be avoided e.g. over memory mapped +// files - call explicitely StrLenSSE42() if you are confident on your input +var StrLen: function(S: pointer): PtrInt = StrLenPas; + +{$ifdef ABSOLUTEPASCAL} +var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = system.FillChar; +var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = system.Move; +{$else} +{$ifdef CPUX64} // will define its own self-dispatched SSE2/AVX functions +type + /// cpuERMS is slightly slower than cpuAVX so is not available by default + TX64CpuFeatures = set of(cpuAVX, cpuAVX2 {$ifdef WITH_ERMS}, cpuERMS{$endif}); +var + /// internal flags used by FillCharFast - easier from asm that CpuFeatures + CPUIDX64: TX64CpuFeatures; +procedure FillcharFast(var dst; cnt: PtrInt; value: byte); +procedure MoveFast(const src; var dst; cnt: PtrInt); +{$else} + +/// our fast version of FillChar() +// - on Intel i386/x86_64, will use fast SSE2/ERMS instructions (if available), +// or optimized X87 assembly implementation for older CPUs +// - on non-Intel CPUs, it will fallback to the default RTL FillChar() +// - note: Delphi x86_64 is far from efficient: even ERMS was wrongly +// introduced in latest updates +var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte); + +/// our fast version of move() +// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available), +// or optimized X87 assembly implementation for older CPUs +// - on non-Intel CPUs, it will fallback to the default RTL Move() +var MoveFast: procedure(const Source; var Dest; Count: PtrInt); + +{$endif CPUX64} +{$endif ABSOLUTEPASCAL} + +/// an alternative Move() function tuned for small unaligned counts +// - warning: expects Count>0 and Source/Dest not nil +// - warning: doesn't support buffers overlapping +procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); + {$ifdef HASINLINE}inline;{$endif} + +/// our fast version of StrLen(), to be used with PWideChar +function StrLenW(S: PWideChar): PtrInt; + +/// use our fast version of StrComp(), to be used with PWideChar +function StrCompW(Str1, Str2: PWideChar): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// use our fast version of StrCompL(), to be used with PUTF8Char +function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// use our fast version of StrCompIL(), to be used with PUTF8Char +function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +{$ifdef USENORMTOUPPER} +{$ifdef OWNNORMTOUPPER} +type + TNormTable = packed array[AnsiChar] of AnsiChar; + PNormTable = ^TNormTable; + TNormTableByte = packed array[byte] of byte; + PNormTableByte = ^TNormTableByte; + +var + /// the NormToUpper[] array is defined in our Enhanced RTL: define it now + // if it was not installed + // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) + NormToUpper: TNormTable; + NormToUpperByte: TNormTableByte absolute NormToUpper; + + /// the NormToLower[] array is defined in our Enhanced RTL: define it now + // if it was not installed + // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) + NormToLower: TNormTable; + NormToLowerByte: TNormTableByte absolute NormToLower; +{$endif} +{$else} +{$undef OWNNORMTOUPPER} +{$endif} + +var + /// this table will convert 'a'..'z' into 'A'..'Z' + // - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects + // WinAnsi encoding + NormToUpperAnsi7: TNormTable; + NormToUpperAnsi7Byte: TNormTableByte absolute NormToUpperAnsi7; + /// case sensitive NormToUpper[]/NormToLower[]-like table + // - i.e. NormToNorm[c] = c + NormToNorm: TNormTable; + NormToNormByte: TNormTableByte absolute NormToNorm; + + +/// get the signed 32-bit integer value stored in P^ +// - we use the PtrInt result type, even if expected to be 32-bit, to use +// native CPU register size (don't want any 32-bit overflow here) +// - will end parsing when P^ does not contain any number (e.g. it reaches any +// ending #0 char) +function GetInteger(P: PUTF8Char): PtrInt; overload; + +/// get the signed 32-bit integer value stored in P^..PEnd^ +// - will end parsing when P^ does not contain any number (e.g. it reaches any +// ending #0 char), or when P reached PEnd (avoiding any buffer overflow) +function GetInteger(P,PEnd: PUTF8Char): PtrInt; overload; + +/// get the signed 32-bit integer value stored in P^ +// - if P if nil or not start with a valid numerical value, returns Default +function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// get the signed 32-bit integer value stored in P^ +// - this version return 0 in err if no error occured, and 1 if an invalid +// character was found, not its exact index as for the val() function +function GetInteger(P: PUTF8Char; var err: integer): PtrInt; overload; + +/// get the unsigned 32-bit integer value stored in P^ +// - we use the PtrUInt result type, even if expected to be 32-bit, to use +// native CPU register size (don't want any 32-bit overflow here) +function GetCardinal(P: PUTF8Char): PtrUInt; + +/// get the unsigned 32-bit integer value stored in P^ +// - if P if nil or not start with a valid numerical value, returns Default +function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; + +/// get the unsigned 32-bit integer value stored as Unicode string in P^ +function GetCardinalW(P: PWideChar): PtrUInt; + +/// get a boolean value stored as true/false text in P^ +// - would also recognize any non 0 integer as true +function GetBoolean(P: PUTF8Char): boolean; + +/// get the 64-bit integer value stored in P^ +function GetInt64(P: PUTF8Char): Int64; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// get the 64-bit integer value stored in P^ +// - if P if nil or not start with a valid numerical value, returns Default +function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; + +/// get the 64-bit signed integer value stored in P^ +procedure SetInt64(P: PUTF8Char; var result: Int64); + {$ifdef CPU64}inline;{$endif} + +/// get the 64-bit unsigned integer value stored in P^ +procedure SetQWord(P: PUTF8Char; var result: QWord); + {$ifdef CPU64}inline;{$endif} + +/// get the 64-bit signed integer value stored in P^ +// - set the err content to the index of any faulty character, 0 if conversion +// was successful (same as the standard val function) +function GetInt64(P: PUTF8Char; var err: integer): Int64; overload; + {$ifdef CPU64}inline;{$endif} + +/// get the 64-bit unsigned integer value stored in P^ +// - set the err content to the index of any faulty character, 0 if conversion +// was successful (same as the standard val function) +function GetQWord(P: PUTF8Char; var err: integer): QWord; + +/// get the extended floating point value stored in P^ +// - set the err content to the index of any faulty character, 0 if conversion +// was successful (same as the standard val function) +function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; overload; + +/// get the extended floating point value stored in P^ +// - this overloaded version returns 0 as a result if the content of P is invalid +function GetExtended(P: PUTF8Char): TSynExtended; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// copy a floating-point text buffer with proper correction and validation +// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' +// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern +// - is used when the input comes from a third-party source with no regular +// output, e.g. a database driver, via TTextWriter.AddFloatStr +function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; + +/// get the WideChar stored in P^ (decode UTF-8 if necessary) +// - any surrogate (UCS4>$ffff) will be returned as '?' +function GetUTF8Char(P: PUTF8Char): cardinal; + {$ifdef HASINLINE}inline;{$endif} + +/// get the UCS4 char stored in P^ (decode UTF-8 if necessary) +function NextUTF8UCS4(var P: PUTF8Char): cardinal; + {$ifdef HASINLINE}inline;{$endif} + +/// get the signed 32-bit integer value stored in a RawUTF8 string +// - we use the PtrInt result type, even if expected to be 32-bit, to use +// native CPU register size (don't want any 32-bit overflow here) +function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// get and check range of a signed 32-bit integer stored in a RawUTF8 string +// - we use the PtrInt result type, even if expected to be 32-bit, to use +// native CPU register size (don't want any 32-bit overflow here) +function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// get the signed 32-bit integer value stored in a RawUTF8 string +// - returns TRUE if the supplied text was successfully converted into an integer +function ToInteger(const text: RawUTF8; out value: integer): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// get the unsigned 32-bit cardinal value stored in a RawUTF8 string +// - returns TRUE if the supplied text was successfully converted into a cardinal +function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal=0): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// get the signed 64-bit integer value stored in a RawUTF8 string +// - returns TRUE if the supplied text was successfully converted into an Int64 +function ToInt64(const text: RawUTF8; out value: Int64): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// get a 64-bit floating-point value stored in a RawUTF8 string +// - returns TRUE if the supplied text was successfully converted into a double +function ToDouble(const text: RawUTF8; out value: double): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// get the signed 64-bit integer value stored in a RawUTF8 string +// - returns the default value if the supplied text was not successfully +// converted into an Int64 +function UTF8ToInt64(const text: RawUTF8; const default: Int64=0): Int64; + +/// encode a string to be compatible with URI encoding +function UrlEncode(const svar: RawUTF8): RawUTF8; overload; + +/// encode a string to be compatible with URI encoding +function UrlEncode(Text: PUTF8Char): RawUTF8; overload; + +/// encode supplied parameters to be compatible with URI encoding +// - parameters must be supplied two by two, as Name,Value pairs, e.g. +// ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]); +// - parameters names should be plain ASCII-7 RFC compatible identifiers +// (0..9a..zA..Z_.~), otherwise their values are skipped +// - parameters values can be either textual, integer or extended, or any TObject +// - TObject serialization into UTF-8 will be processed by the ObjectToJSON() +// function +function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload; + +/// encode a JSON object UTF-8 buffer into URI parameters +// - you can specify property names to ignore during the object decoding +// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false +// - warning: the ParametersJSON input buffer will be modified in-place +function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; + const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; + +/// encode a JSON object UTF-8 buffer into URI parameters +// - you can specify property names to ignore during the object decoding +// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false +// - overloaded function which will make a copy of the input JSON before parsing +function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; + const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; + +/// decode a string compatible with URI encoding into its original value +// - you can specify the decoding range (as in copy(s,i,len) function) +function UrlDecode(const s: RawUTF8; i: PtrInt=1; len: PtrInt=-1): RawUTF8; overload; + +/// decode a string compatible with URI encoding into its original value +function UrlDecode(U: PUTF8Char): RawUTF8; overload; + +/// decode a specified parameter compatible with URI encoding into its original +// textual value +// - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next) +// will return Next^='where=...' and V='*' +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; + Next: PPUTF8Char=nil): boolean; + +/// decode a specified parameter compatible with URI encoding into its original +// integer numerical value +// - UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) +// will return Next^='where=...' and O=20 +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer; + Next: PPUTF8Char=nil): boolean; + +/// decode a specified parameter compatible with URI encoding into its original +// cardinal numerical value +// - UrlDecodeCardinal('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) +// will return Next^='where=...' and O=20 +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal; + Next: PPUTF8Char=nil): boolean; + +/// decode a specified parameter compatible with URI encoding into its original +// Int64 numerical value +// - UrlDecodeInt64('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) +// will return Next^='where=...' and O=20 +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64; + Next: PPUTF8Char=nil): boolean; + +/// decode a specified parameter compatible with URI encoding into its original +// floating-point value +// - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) +// will return Next^='where=...' and P=20.45 +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended; + Next: PPUTF8Char=nil): boolean; + +/// decode a specified parameter compatible with URI encoding into its original +// floating-point value +// - UrlDecodeDouble('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) +// will return Next^='where=...' and P=20.45 +// - if Upper is not found, Value is not modified, and result is FALSE +// - if Upper is found, Value is modified with the supplied content, and result is TRUE +function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; + Next: PPUTF8Char=nil): boolean; + +/// returns TRUE if all supplied parameters do exist in the URI encoded text +// - CSVNames parameter shall provide as a CSV list of names +// - e.g. UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') +// will return TRUE +function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; + +/// decode the next Name=Value&.... pair from input URI +// - Name is returned directly (should be plain ASCII 7 bit text) +// - Value is returned after URI decoding (from %.. patterns) +// - if a pair is decoded, return a PUTF8Char pointer to the next pair in +// the input buffer, or points to #0 if all content has been processed +// - if a pair is not decoded, return nil +function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; + +/// decode a URI-encoded Value from an input buffer +// - decoded value is set in Value out variable +// - returns a pointer just after the decoded value (may points e.g. to +// #0 or '&') - it is up to the caller to continue the process or not +function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char; + +/// decode a URI-encoded Name from an input buffer +// - decoded value is set in Name out variable +// - returns a pointer just after the decoded name, after the '=' +// - returns nil if there was no name=... pattern in U +function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; + +/// checks if the supplied UTF-8 text don't need URI encoding +// - returns TRUE if all its chars are non-void plain ASCII-7 RFC compatible +// identifiers (0..9a..zA..Z-_.~) +function IsUrlValid(P: PUTF8Char): boolean; + +/// checks if the supplied UTF-8 text values don't need URI encoding +// - returns TRUE if all its chars of all strings are non-void plain ASCII-7 RFC +// compatible identifiers (0..9a..zA..Z-_.~) +function AreUrlValid(const Url: array of RawUTF8): boolean; + +/// ensure the supplied URI contains a trailing '/' charater +function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; + +/// encode name/value pairs into CSV/INI raw format +function CSVEncode(const NameValuePairs: array of const; + const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10): RawUTF8; + +/// find a given name in name/value pairs, and returns the value as RawUTF8 +function ArrayOfConstValueAsText(const NameValuePairs: array of const; + const aName: RawUTF8): RawUTF8; + +/// returns TRUE if the given text buffer contains a..z,A..Z,0..9,_ characters +// - should match most usual property names values or other identifier names +// in the business logic source code +// - i.e. can be tested via IdemPropName*() functions, and the MongoDB-like +// extended JSON syntax as generated by dvoSerializeAsExtendedJson +// - first char must be alphabetical or '_', following chars can be +// alphanumerical or '_' +function PropNameValid(P: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if the given text buffers contains A..Z,0..9,_ characters +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +// - this function won't check the first char the same way than PropNameValid() +function PropNamesValid(const Values: array of RawUTF8): boolean; + +type + /// kind of character used from JSON_CHARS[] for efficient JSON parsing + TJsonChar = set of (jcJsonIdentifierFirstChar, jcJsonIdentifier, + jcEndOfJSONField, jcEndOfJSONFieldOr0, jcEndOfJSONValueField, + jcDigitChar, jcDigitFirstChar, jcDigitFloatChar); + /// defines a branch-less table used for JSON parsing + TJsonCharSet = array[AnsiChar] of TJsonChar; + PJsonCharSet = ^TJsonCharSet; +var + /// branch-less table used for JSON parsing + JSON_CHARS: TJsonCharSet; + +/// returns TRUE if the given text buffer contains simple characters as +// recognized by JSON extended syntax +// - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations +function JsonPropNameValid(P: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if the given text buffers would be escaped when written as JSON +// - e.g. if contains " or \ characters, as defined by +// http://www.ietf.org/rfc/rfc4627.txt +function NeedsJsonEscape(const Text: RawUTF8): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if the given text buffers would be escaped when written as JSON +// - e.g. if contains " or \ characters, as defined by +// http://www.ietf.org/rfc/rfc4627.txt +function NeedsJsonEscape(P: PUTF8Char): boolean; overload; + +/// returns TRUE if the given text buffers would be escaped when written as JSON +// - e.g. if contains " or \ characters, as defined by +// http://www.ietf.org/rfc/rfc4627.txt +function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; overload; + +/// case insensitive comparison of ASCII identifiers +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +function IdemPropName(const P1,P2: shortstring): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// case insensitive comparison of ASCII identifiers +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +// - this version expects P2 to be a PAnsiChar with a specified length +function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// case insensitive comparison of ASCII identifiers +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +// - this version expects P1 and P2 to be a PAnsiChar with specified lengths +function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// case insensitive comparison of ASCII identifiers +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +// - this version expects P2 to be a PAnsiChar with specified length +function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// case insensitive comparison of ASCII identifiers of same length +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +// - this version expects P1 and P2 to be a PAnsiChar with an already checked +// identical length, so may be used for a faster process, e.g. in a loop +// - if P1 and P2 are RawUTF8, you should better call overloaded function +// IdemPropNameU(const P1,P2: RawUTF8), which would be slightly faster by +// using the length stored before the actual text buffer of each RawUTF8 +function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; + {$ifndef ANDROID}{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} + +/// case insensitive comparison of ASCII identifiers +// - use it with property names values (i.e. only including A..Z,0..9,_ chars) +function IdemPropNameU(const P1,P2: RawUTF8): boolean; overload; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// returns true if the beginning of p^ is the same as up^ +// - ignore case - up^ must be already Upper +// - chars are compared as 7 bit Ansi only (no accentuated characters): but when +// you only need to search for field names e.g. IdemPChar() is prefered, because +// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory +// - if p is nil, will return FALSE +// - if up is nil, will return TRUE +function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// returns true if the beginning of p^ is the same as up^, ignoring white spaces +// - ignore case - up^ must be already Upper +// - any white space in the input p^ buffer is just ignored +// - chars are compared as 7 bit Ansi only (no accentuated characters): but when +// you only need to search for field names e.g. IdemPChar() is prefered, because +// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory +// - if p is nil, will return FALSE +// - if up is nil, will return TRUE +function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; + +/// returns the index of a matching beginning of p^ in upArray[] +// - returns -1 if no item matched +// - ignore case - upArray^ must be already Upper +// - chars are compared as 7 bit Ansi only (no accentuated characters) +// - warning: this function expects upArray[] items to have AT LEAST TWO +// CHARS (it will use a fast comparison of initial 2 bytes) +function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; overload; + +/// returns the index of a matching beginning of p^ in upArray two characters +// - returns -1 if no item matched +// - ignore case - upArray^ must be already Upper +// - chars are compared as 7 bit Ansi only (no accentuated characters) +function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns true if the beginning of p^ is the same as up^ +// - ignore case - up^ must be already Upper +// - this version will decode the UTF-8 content before using NormToUpper[], so +// it will be slower than the IdemPChar() function above, but will handle +// WinAnsi accentuated characters (e.g. 'e' acute will be matched as 'E') +function IdemPCharU(p, up: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// returns true if the beginning of p^ is same as up^ +// - ignore case - up^ must be already Upper +// - this version expects p^ to point to an Unicode char array +function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; + +/// check matching ending of p^ in upText +// - returns true if the item matched +// - ignore case - upText^ must be already Upper +// - chars are compared as 7 bit Ansi only (no accentuated characters) +function EndWith(const text, upText: RawUTF8): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// returns the index of a matching ending of p^ in upArray[] +// - returns -1 if no item matched +// - ignore case - upArray^ must be already Upper +// - chars are compared as 7 bit Ansi only (no accentuated characters) +function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; + +/// returns true if the file name extension contained in p^ is the same same as extup^ +// - ignore case - extup^ must be already Upper +// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 +// - could be used e.g. like IdemFileExt(aFileName,'.JP'); +function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean; + +/// returns matching file name extension index as extup^ +// - ignore case - extup[] must be already Upper +// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 +// - could be used e.g. like IdemFileExts(aFileName,['.PAS','.INC']); +function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; + sepChar: AnsiChar='.'): integer; + +/// internal function, used to retrieve a UCS4 char (>127) from UTF-8 +// - not to be called directly, but from inlined higher-level functions +// - here U^ shall be always >= #80 +// - typical use is as such: +// ! ch := ord(P^); +// ! if ch and $80=0 then +// ! inc(P) else +// ! ch := GetHighUTF8UCS4(P); +function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; + +/// retrieve the next UCS4 value stored in U, then update the U pointer +// - this function will decode the UTF-8 content before using NormToUpper[] +// - will return '?' if the UCS4 value is higher than #255: so use this function +// only if you need to deal with ASCII characters (e.g. it's used for Soundex +// and for ContainsUTF8 function) +function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// points to the beginning of the next word stored in U +// - returns nil if reached the end of U (i.e. #0 char) +// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' +function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char; + +/// return true if up^ is contained inside the UTF-8 buffer p^ +// - search up^ at the beginning of every UTF-8 word (aka in Soundex) +// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' +// - up^ must be already Upper +function ContainsUTF8(p, up: PUTF8Char): boolean; + +/// returns TRUE if the supplied uppercased text is contained in the text buffer +function GetLineContains(p,pEnd, up: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// copy source into a 256 chars dest^ buffer with 7 bits upper case conversion +// - used internally for short keys match or case-insensitive hash +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as +// array[byte] of AnsiChar on the caller stack) +function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion +// - used internally for short keys match or case-insensitive hash +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as +// array[byte] of AnsiChar on the caller stack) +// - won't use SSE4.2 instructions on supported CPUs by default, which may read +// some bytes beyond the s string, so should be avoided e.g. over memory mapped +// files - call explicitely UpperCopy255BufSSE42() if you are confident on your input +var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; + +/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion +// - used internally for short keys match or case-insensitive hash +// - this version is written in optimized pascal +// - you should not have to call this function, but rely on UpperCopy255Buf() +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as +// array[byte] of AnsiChar on the caller stack) +function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; + +{$ifndef PUREPASCAL} +{$ifndef DELPHI5OROLDER} +/// SSE 4.2 version of UpperCopy255Buf() +// - copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion +// - please note that this optimized version may read up to 15 bytes +// beyond the string; this is rarely a problem but it may generate protection +// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system +// - could be used instead of UpperCopy255Buf() when you are confident about your +// dest/source input buffers, checking if cfSSE42 in CpuFeatures +function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; +{$endif DELPHI5OROLDER} +{$endif PUREPASCAL} + +/// copy source into dest^ with WinAnsi 8 bits upper case conversion +// - used internally for short keys match or case-insensitive hash +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of +// AnsiChar) +function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; + +/// copy WideChar source into dest^ with upper case conversion +// - used internally for short keys match or case-insensitive hash +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of +// AnsiChar) +function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload; + +/// copy WideChar source into dest^ with upper case conversion +// - used internally for short keys match or case-insensitive hash +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of +// AnsiChar) +function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload; + +/// copy source into dest^ with 7 bits upper case conversion +// - returns final dest pointer +// - will copy up to the source buffer end: so Dest^ should be big enough - +// which will the case e.g. if Dest := pointer(source) +function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; + +/// copy source into dest^ with 7 bits upper case conversion +// - returns final dest pointer +// - this special version expect source to be a shortstring +function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; + +{$ifdef USENORMTOUPPER} + +/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values +// - this version expects u1 and u2 to be zero-terminated +// - this version will decode each UTF-8 glyph before using NormToUpper[] +// - current implementation handles UTF-16 surrogates +function UTF8IComp(u1, u2: PUTF8Char): PtrInt; + +/// copy WideChar source into dest^ with upper case conversion, using the +// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 +// - returns final dest pointer +// - current implementation handles UTF-16 surrogates +function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; + +/// copy WideChar source into dest^ with upper case conversion, using the +// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 +// - returns final dest pointer +// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of +// AnsiChar), with UTF-8 encoding +function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values +// - this version expects u1 and u2 not to be necessary zero-terminated, but +// uses L1 and L2 as length for u1 and u2 respectively +// - use this function for SQLite3 collation (TSQLCollateFunc) +// - this version will decode the UTF-8 content before using NormToUpper[] +// - current implementation handles UTF-16 surrogates +function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; + +/// fast case-insensitive Unicode comparison +// - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z' +// - this version expects u1 and u2 to be zero-terminated +function AnsiICompW(u1, u2: PWideChar): PtrInt; + +/// SameText() overloaded function with proper UTF-8 decoding +// - fast version using NormToUpper[] array for all Win-Ansi characters +// - this version will decode each UTF-8 glyph before using NormToUpper[] +// - current implementation handles UTF-16 surrogates as UTF8IComp() +function SameTextU(const S1, S2: RawUTF8): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion of the supplied text into 8 bit uppercase +// - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated +// latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array +// - it will therefore decode the supplied UTF-8 content to handle more than +// 7 bit of ascii characters (so this function is dedicated to WinAnsi code page +// 1252 characters set) +function UpperCaseU(const S: RawUTF8): RawUTF8; + +/// fast conversion of the supplied text into 8 bit lowercase +// - this will not only convert 'A'..'Z' into 'a'..'z', but also accentuated +// latin characters ('E' acute into 'e' e.g.), using NormToLower[] array +// - it will therefore decode the supplied UTF-8 content to handle more than +// 7 bit of ascii characters +function LowerCaseU(const S: RawUTF8): RawUTF8; + +/// fast conversion of the supplied text into 8 bit case sensitivity +// - convert the text in-place, returns the resulting length +// - it will decode the supplied UTF-8 content to handle more than 7 bit +// of ascii characters during the conversion (leaving not WinAnsi characters +// untouched) +// - will not set the last char to #0 (caller must do that if necessary) +function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt; + +{$endif USENORMTOUPPER} + +/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars +// - will therefore be correct with true UTF-8 content, but only for 7 bit +function IsCaseSensitive(const S: RawUTF8): boolean; overload; + +/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars +// - will therefore be correct with true UTF-8 content, but only for 7 bit +function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; overload; + +/// fast conversion of the supplied text into uppercase +// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and +// will therefore be correct with true UTF-8 content, but only for 7 bit +function UpperCase(const S: RawUTF8): RawUTF8; + +/// fast conversion of the supplied text into uppercase +// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and +// will therefore be correct with true UTF-8 content, but only for 7 bit +procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); overload; + +/// fast conversion of the supplied text into uppercase +// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and +// will therefore be correct with true UTF-8 content, but only for 7 bit +procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload; + +/// fast in-place conversion of the supplied variable text into uppercase +// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and +// will therefore be correct with true UTF-8 content, but only for 7 bit +procedure UpperCaseSelf(var S: RawUTF8); + +/// fast conversion of the supplied text into lowercase +// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and +// will therefore be correct with true UTF-8 content +function LowerCase(const S: RawUTF8): RawUTF8; + +/// fast conversion of the supplied text into lowercase +// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and +// will therefore be correct with true UTF-8 content +procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); + +/// fast in-place conversion of the supplied variable text into lowercase +// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and +// will therefore be correct with true UTF-8 content, but only for 7 bit +procedure LowerCaseSelf(var S: RawUTF8); + +/// accurate conversion of the supplied UTF-8 content into the corresponding +// upper-case Unicode characters +// - this version will use the Operating System API, and will therefore be +// much slower than UpperCase/UpperCaseU versions, but will handle all +// kind of unicode characters +function UpperCaseUnicode(const S: RawUTF8): RawUTF8; + +/// accurate conversion of the supplied UTF-8 content into the corresponding +// lower-case Unicode characters +// - this version will use the Operating System API, and will therefore be +// much slower than LowerCase/LowerCaseU versions, but will handle all +// kind of unicode characters +function LowerCaseUnicode(const S: RawUTF8): RawUTF8; + +/// trims leading whitespace characters from the string by removing +// new line, space, and tab characters +function TrimLeft(const S: RawUTF8): RawUTF8; + +/// trims trailing whitespace characters from the string by removing trailing +// newline, space, and tab characters +function TrimRight(const S: RawUTF8): RawUTF8; + +/// single-allocation (therefore faster) alternative to Trim(copy()) +procedure TrimCopy(const S: RawUTF8; start,count: PtrInt; + var result: RawUTF8); + +/// fast WinAnsi comparison using the NormToUpper[] array for all 8 bits values +function AnsiIComp(Str1, Str2: pointer): PtrInt; + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} + +/// extract a line from source array of chars +// - next will contain the beginning of next line, or nil if source if ended +function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean=false): RawUTF8; + +{$ifdef UNICODE} +/// extract a line from source array of chars +// - next will contain the beginning of next line, or nil if source if ended +// - this special version expect UnicodeString pointers, and return an UnicodeString +function GetNextLineW(source: PWideChar; out next: PWideChar): string; + +/// find the Value of UpperName in P, till end of current section +// - expect UpperName as 'NAME=' +// - this special version expect UnicodeString pointer, and return a VCL string +function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; + +/// find a Name= Value in a [Section] of a INI Unicode Content +// - this function scans the Content memory buffer, and is +// therefore very fast (no temporary TMemIniFile is created) +// - if Section equals '', find the Name= value before any [Section] +function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; +{$endif UNICODE} + +{$ifdef PUREPASCAL} +{$ifdef HASINLINE} +function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; +function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; inline; +{$else} +var PosEx: function(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; +{$endif} +{$else} + +/// faster RawUTF8 Equivalent of standard StrUtils.PosEx +function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): integer; + +{$endif PUREPASCAL} + +/// our own PosEx() function dedicated to VCL string process +// - Delphi XE or older don't support Pos() with an Offset +var PosExString: function(const SubStr, S: string; Offset: PtrUInt=1): PtrInt; + +/// optimized version of PosEx() with search text as one AnsiChar +function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// split a RawUTF8 string into two strings, according to SepStr separator +// - if SepStr is not found, LeftStr=Str and RightStr='' +// - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase +procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean=false); overload; + +/// split a RawUTF8 string into two strings, according to SepStr separator +// - this overloaded function returns the right string as function result +// - if SepStr is not found, LeftStr=Str and result='' +// - if ToUpperCase is TRUE, then LeftStr and result will be made uppercase +function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload; + +/// returns the left part of a RawUTF8 string, according to SepStr separator +// - if SepStr is found, returns Str first chars until (and excluding) SepStr +// - if SepStr is not found, returns Str +function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload; + +/// split a RawUTF8 string into several strings, according to SepStr separator +// - this overloaded function will fill a DestPtr[] array of PRawUTF8 +// - if any DestPtr[]=nil, the item will be skipped +// - if input Str end before al SepStr[] are found, DestPtr[] is set to '' +// - returns the number of values extracted into DestPtr[] +function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; + const DestPtr: array of PRawUTF8): PtrInt; overload; + +/// returns the last occurence of the given SepChar separated context +// - e.g. SplitRight('01/2/34','/')='34' +// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' +// - if LeftStr is supplied, the RawUTF8 it points to will be filled with +// the left part just before SepChar ('' if SepChar doesn't appear) +function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8=nil): RawUTF8; + +/// returns the last occurence of the given SepChar separated context +// - e.g. SplitRight('path/one\two/file.ext','/\')='file.ext', i.e. +// SepChars='/\' will be like ExtractFileName() over RawUTF8 string +// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' +function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; + +/// actual replacement function called by StringReplaceAll() on first match +// - not to be called as such, but defined globally for proper inlining +function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; + found: integer): RawUTF8; + +/// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]); +function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast version of several cascaded StringReplaceAll() +function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; overload; + +/// fast replace of a specified char by a given string +function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; + +/// fast replace of all #9 chars by a given string +function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; + +/// format a text content with SQL-like quotes +// - UTF-8 version of the function available in SysUtils +// - this function implements what is specified in the official SQLite3 +// documentation: "A string constant is formed by enclosing the string in single +// quotes ('). A single quote within the string can be encoded by putting two +// single quotes in a row - as in Pascal." +function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// format a text content with SQL-like quotes +// - UTF-8 version of the function available in SysUtils +// - this function implements what is specified in the official SQLite3 +// documentation: "A string constant is formed by enclosing the string in single +// quotes ('). A single quote within the string can be encoded by putting two +// single quotes in a row - as in Pascal." +procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); overload; + +/// convert UTF-8 content into a JSON string +// - with proper escaping of the content, and surounding " characters +procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; + const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert UTF-8 buffer into a JSON string +// - with proper escaping of the content, and surounding " characters +procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; + const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; + +/// convert UTF-8 content into a JSON string +// - with proper escaping of the content, and surounding " characters +function QuotedStrJSON(const aText: RawUTF8): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// unquote a SQL-compatible string +// - the first character in P^ must be either ' or " then internal double quotes +// are transformed into single quotes +// - 'text '' end' -> text ' end +// - "text "" end" -> text " end +// - returns nil if P doesn't contain a valid SQL string +// - returns a pointer just after the quoted text otherwise +function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; + +/// unquote a SQL-compatible string +function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; + +/// unquote a SQL-compatible symbol name +// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol' +function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; + +/// get the next character after a quoted buffer +// - the first character in P^ must be either ', either " +// - it will return the latest quote position, ignoring double quotes within +function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// get the next character after a quoted buffer +// - the first character in P^ must be " +// - it will return the latest " position, ignoring \" within +function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// get the next character not in [#1..' '] +function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// get the next character not in [#9,' '] +function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// get the next character in [#1..' '] +function GotoNextSpace(P: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// check if the next character not in [#1..' '] matchs a given value +// - first ignore any non space character +// - then returns TRUE if P^=ch, setting P to the character after ch +// - or returns FALSE if P^<>ch, leaving P at the level of the unexpected char +function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// go to the beginning of the SQL statement, ignoring all blanks and comments +// - used to check the SQL statement command (e.g. is it a SELECT?) +function SQLBegin(P: PUTF8Char): PUTF8Char; + +/// add a condition to a SQL WHERE clause, with an ' and ' if where is not void +procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); + +/// return true if the parameter is void or begin with a 'SELECT' SQL statement +// - used to avoid code injection and to check if the cache must be flushed +// - VACUUM, PRAGMA, or EXPLAIN statements also return true, since they won't +// change the data content +// - WITH recursive statement expect no INSERT/UPDATE/DELETE pattern in the SQL +// - if P^ is a SELECT and SelectClause is set to a variable, it would +// contain the field names, from SELECT ...field names... FROM +function isSelect(P: PUTF8Char; SelectClause: PRawUTF8=nil): boolean; + +/// return true if IdemPChar(source,searchUp), and go to the next line of source +function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; + +/// return true if IdemPChar(source,searchUp), and retrieve the value item +// - typical use may be: +// ! if IdemPCharAndGetNextItem(P, +// ! 'CONTENT-DISPOSITION: FORM-DATA; NAME="',Name,'"') then ... +function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; + var Item: RawUTF8; Sep: AnsiChar=#13): boolean; + +/// fast go to next text line, ended by #13 or #13#10 +// - returns the beginning of next line, or nil if source^=#0 was reached +function GotoNextLine(source: PUTF8Char): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// compute the line length from a size-delimited source array of chars +// - will use fast assembly on x86-64 CPU, and expects TextEnd to be not nil +// - is likely to read some bytes after the TextEnd buffer, so GetLineSize() +// may be preferred, e.g. on memory mapped files +function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; + {$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// compute the line length from source array of chars +// - if PEnd = nil, end counting at either #0, #13 or #10 +// - otherwise, end counting at either #13 or #10 +// - just a wrapper around BufferLineLength() checking PEnd=nil case +function GetLineSize(P,PEnd: PUTF8Char): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// returns true if the line length from source array of chars is not less than +// the specified count +function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; + +/// return next CSV string from P +// - P=nil after call when end of text is reached +function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return next CSV string from P +// - P=nil after call when end of text is reached +procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); overload; + +/// return next CSV string (unquoted if needed) from P +// - P=nil after call when end of text is reached +procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); overload; + +/// return trimmed next CSV string from P +// - P=nil after call when end of text is reached +procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); + +/// return next CRLF separated value string from P, ending #10 or #13#10 trimmed +// - any kind of line feed (CRLF or LF) will be handled, on all operating systems +// - as used e.g. by TSynNameValue.InitFromCSV and TDocVariantData.InitCSV +// - P=nil after call when end of text is reached +procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); + +/// return next CSV string from P, nil if no more +// - this function returns the generic string type of the compiler, and +// therefore can be used with ready to be displayed text (e.g. for the VCL) +function GetNextItemString(var P: PChar; Sep: Char= ','): string; + +/// return next string delimited with #13#10 from P, nil if no more +// - this function returns a RawUnicode string type +function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; + +/// append some text lines with the supplied Values[] +// - if any Values[] item is '', no line is added +// - otherwise, appends 'Caption: Value', with Caption taken from CSV +procedure AppendCSVValues(const CSV: string; const Values: array of string; + var Result: string; const AppendBefore: string=#13#10); + +/// return a CSV list of the iterated same value +// - e.g. CSVOfValue('?',3)='?,?,?' +function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8=','): RawUTF8; + + /// retrieve the next CSV separated bit index +// - each bit was stored as BitIndex+1, i.e. 0 to mark end of CSV chunk +// - several bits set to one can be regrouped via 'first-last,' syntax +procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); + +/// convert a set of bit into a CSV content +// - each bit is stored as BitIndex+1, and separated by a ',' +// - several bits set to one can be regrouped via 'first-last,' syntax +// - ',0' is always appended at the end of the CSV chunk to mark its end +function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; + +/// return next CSV string from P, nil if no more +// - output text would be trimmed from any left or right space +procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ','); + +/// decode next CSV hexadecimal string from P, nil if no more or not matching BinBytes +// - Bin is filled with 0 if the supplied CSV content is invalid +// - if Sep is #0, it will read the hexadecimal chars until a whitespace is reached +function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; + Sep: AnsiChar= ','): boolean; + + +type + /// some stack-allocated zero-terminated character buffer + // - as used by GetNextTChar64 + TChar64 = array[0..63] of AnsiChar; + +/// return next CSV string from P as a #0-ended buffer, false if no more +// - if Sep is #0, will copy all characters until next whitespace char +// - returns the number of bytes stored into Buf[] +function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; + +/// return next CSV string as unsigned integer from P, 0 if no more +// - if Sep is #0, it won't be searched for +function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar=','): PtrUInt; + +/// return next CSV string as signed integer from P, 0 if no more +// - if Sep is #0, it won't be searched for +function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar=','): PtrInt; + +/// return next CSV string as 64-bit signed integer from P, 0 if no more +// - if Sep is #0, it won't be searched for +function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar=','): Int64; + +/// return next CSV string as 64-bit unsigned integer from P, 0 if no more +// - if Sep is #0, it won't be searched for +function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar=','): QWord; + +/// return next CSV hexadecimal string as 64-bit unsigned integer from P +// - returns 0 if no valid hexadecimal text is available in P +// - if Sep is #0, it won't be searched for +// - will first fill the 64-bit value with 0, then decode each two hexadecimal +// characters available in P +// - could be used to decode TTextWriter.AddBinToHexDisplayMinChars() output +function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar=','): QWord; + +/// return next CSV string as unsigned integer from P, 0 if no more +// - P^ will point to the first non digit character (the item separator, e.g. +// ',' for CSV) +function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; + +/// return next CSV string as unsigned integer from P, 0 if no more +// - this version expects P^ to point to an Unicode char array +function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar=','): PtrUInt; + +/// return next CSV string as double from P, 0.0 if no more +// - if Sep is #0, will return all characters until next whitespace char +function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar=','): double; + +/// return next CSV string as currency from P, 0.0 if no more +// - if Sep is #0, will return all characters until next whitespace char +function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar=','): currency; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return next CSV string as currency from P, 0.0 if no more +// - if Sep is #0, will return all characters until next whitespace char +procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar=','); overload; + +/// return n-th indexed CSV string in P, starting at Index=0 for first one +function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','): RawUTF8; overload; + +/// return n-th indexed CSV string (unquoted if needed) in P, starting at Index=0 for first one +function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','; Quote: AnsiChar=''''): RawUTF8; overload; + +/// return n-th indexed CSV string in P, starting at Index=0 for first one +// - this function return the generic string type of the compiler, and +// therefore can be used with ready to be displayed text (i.e. the VCL) +function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char=','): string; + +/// return last CSV string in the supplied UTF-8 content +function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar=','): RawUTF8; + +/// return the index of a Value in a CSV string +// - start at Index=0 for first one +// - return -1 if specified Value was not found in CSV items +function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar = ','; + CaseSensitive: boolean=true; TrimValue: boolean=false): integer; + +/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings +procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; + Sep: AnsiChar=','; TrimItems: boolean=false; AddVoidItems: boolean=false); overload; + +/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings +procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); overload; + +/// return the corresponding CSV text from a dynamic array of UTF-8 strings +function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8= ','): RawUTF8; + +/// return the corresponding CSV quoted text from a dynamic array of UTF-8 strings +// - apply QuoteStr() function to each Values[] item +function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=','; + Quote: AnsiChar=''''): RawUTF8; + +/// append some prefix to all CSV values +// ! AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree' +function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; + Sep: AnsiChar = ','): RawUTF8; + +/// append a Value to a CSV string +procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ','); + {$ifdef HASINLINE}inline;{$endif} + +/// change a Value within a CSV string +function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; + const Sep: RawUTF8 = ','): boolean; + +/// quick helper to initialize a dynamic array of RawUTF8 from some constants +// - can be used e.g. as: +// ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']); +function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; + +/// check if the TypeInfo() points to an "array of RawUTF8" +// - e.g. returns true for TypeInfo(TRawUTF8DynArray) or other sub-types +// defined as "type aNewType = type TRawUTF8DynArray" +function IsRawUTF8DynArray(typeinfo: pointer): boolean; + +/// append one or several values to a local "array of const" variable +procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); + +/// low-level efficient search of Value in Values[] +// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence +function FindRawUTF8(Values: PRawUTF8; const Value: RawUTF8; ValuesCount: integer; + CaseSensitive: boolean): integer; overload; + +/// return the index of Value in Values[], -1 if not found +// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence +function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; + CaseSensitive: boolean=true): integer; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return the index of Value in Values[], -1 if not found +// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence +function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; + CaseSensitive: boolean=true): integer; overload; + +/// return the index of Value in Values[], -1 if not found +// - here name search would use fast IdemPropNameU() function +function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; overload; + +/// return the index of Value in Values[] using IdemPropNameU(), -1 if not found +// - typical use with a dynamic array is like: +// ! index := FindPropName(pointer(aDynArray),length(aDynArray),aValue); +function FindPropName(Values: PRawUTF8; const Value: RawUTF8; + ValuesCount: integer): integer; overload; + +/// true if Value was added successfully in Values[] +function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; + NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload; + +/// add the Value to Values[], with an external count variable, for performance +procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + const Value: RawUTF8); overload; + +/// true if both TRawUTF8DynArray are the same +// - comparison is case-sensitive +function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; overload; + +/// true if both TRawUTF8DynArray are the same for a given number of items +// - A and B are expected to have at least Count items +// - comparison is case-sensitive +function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; overload; + +/// convert the string dynamic array into a dynamic array of UTF-8 strings +procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; + var Result: TRawUTF8DynArray); + +/// convert the string list into a dynamic array of UTF-8 strings +procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); + +/// search for a value from its uppercased named entry +// - i.e. iterate IdemPChar(source,UpperName) over every line of the source +// - returns the text just after UpperName if it has been found at line beginning +// - returns nil if UpperName was not found was not found at any line beginning +// - could be used as alternative to FindIniNameValue() and FindIniNameValueInteger() +// if there is no section, i.e. if search should not stop at '[' but at source end +function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; overload; + +/// search and returns a value from its uppercased named entry +// - i.e. iterate IdemPChar(source,UpperName) over every line of the source +// - returns true and the trimmed text just after UpperName if it has been found +// at line beginning +// - returns false if UpperName was not found was not found at any line beginning +// - could be used e.g. to efficently extract a value from HTTP headers, whereas +// FindIniNameValue() is tuned for [section]-oriented INI files +function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; + var Value: RawUTF8): boolean; overload; + +/// find a Name= Value in a [Section] of a INI RawUTF8 Content +// - this function scans the Content memory buffer, and is +// therefore very fast (no temporary TMemIniFile is created) +// - if Section equals '', find the Name= value before any [Section] +function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; + +/// find a Name= Value in a [Section] of a INI WinAnsi Content +// - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8 +function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; + +/// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and +// return it as an integer, or 0 if not found +// - this function scans the Content memory buffer, and is +// therefore very fast (no temporary TMemIniFile is created) +// - if Section equals '', find the Name= value before any [Section] +function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// find a Name= Value in a [Section] of a .INI file +// - if Section equals '', find the Name= value before any [Section] +// - use internaly fast FindIniEntry() function above +function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; + +/// update a Name= Value in a [Section] of a INI RawUTF8 Content +// - this function scans and update the Content memory buffer, and is +// therefore very fast (no temporary TMemIniFile is created) +// - if Section equals '', update the Name= value before any [Section] +procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); + +/// update a Name= Value in a [Section] of a .INI file +// - if Section equals '', update the Name= value before any [Section] +// - use internaly fast UpdateIniEntry() function above +procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); + +/// find the position of the [SEARCH] section in source +// - return true if [SEARCH] was found, and store pointer to the line after it in source +function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; + +/// find the position of the [SEARCH] section in source +// - return true if [SEARCH] was found, and store pointer to the line after it in source +// - this version expects source^ to point to an Unicode char array +function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; + +/// retrieve the whole content of a section as a string +// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above +function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload; + +/// retrieve the whole content of a section as a string +// - use SectionFirstLine() then previous GetSectionContent() +function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload; + +/// delete a whole [Section] +// - if EraseSectionHeader is TRUE (default), then the [Section] line is also +// deleted together with its content lines +// - return TRUE if something was changed in Content +// - return FALSE if [Section] doesn't exist or is already void +function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; + EraseSectionHeader: boolean=true): boolean; overload; + +/// delete a whole [Section] +// - if EraseSectionHeader is TRUE (default), then the [Section] line is also +// deleted together with its content lines +// - return TRUE if something was changed in Content +// - return FALSE if [Section] doesn't exist or is already void +// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above +function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; + EraseSectionHeader: boolean=true): boolean; overload; + +/// replace a whole [Section] content by a new content +// - create a new [Section] if none was existing +procedure ReplaceSection(var Content: RawUTF8; const SectionName, + NewSectionContent: RawUTF8); overload; + +/// replace a whole [Section] content by a new content +// - create a new [Section] if none was existing +// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above +procedure ReplaceSection(SectionFirstLine: PUTF8Char; + var Content: RawUTF8; const NewSectionContent: RawUTF8); overload; + +/// return TRUE if Value of UpperName does exist in P, till end of current section +// - expect UpperName as 'NAME=' +function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; + +/// find the Value of UpperName in P, till end of current section +// - expect UpperName as 'NAME=' +function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; + +/// return TRUE if one of the Value of UpperName exists in P, till end of +// current section +// - expect UpperName e.g. as 'CONTENT-TYPE: ' +// - expect UpperValues to be any upper value with left side matching, e.g. as +// used by IsHTMLContentTypeTextual() function: +// ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER, +// ! ['TEXT/','APPLICATION/JSON','APPLICATION/XML']); +// - warning: this function calls IdemPCharArray(), so expects UpperValues[] +/// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare) +function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; + const UpperValues: array of PAnsiChar): boolean; + +/// find the integer Value of UpperName in P, till end of current section +// - expect UpperName as 'NAME=' +// - return 0 if no NAME= entry was found +function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// replace a value from a given set of name=value lines +// - expect UpperName as 'UPPERNAME=', otherwise returns false +// - if no UPPERNAME= entry was found, then Name+NewValue is added to Content +// - a typical use may be: +// ! UpdateIniNameValue(headers,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,contenttype); +function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; + +/// read a File content into a String +// - content can be binary or text +// - returns '' if file was not found or any read error occured +// - wil use GetFileSize() API by default, unless HasNoSize is defined, +// and read will be done using a buffer (required e.g. for char files under Linux) +// - uses RawByteString for byte storage, whatever the codepage is +function StringFromFile(const FileName: TFileName; HasNoSize: boolean=false): RawByteString; + +/// create a File from a string content +// - uses RawByteString for byte storage, whatever the codepage is +function FileFromString(const Content: RawByteString; const FileName: TFileName; + FlushOnDisk: boolean=false; FileDate: TDateTime=0): boolean; + +/// get text File contents (even Unicode or UTF8) and convert it into a +// Charset-compatible AnsiString (for Delphi 7) or an UnicodeString (for Delphi +// 2009 and up) according to any BOM marker at the beginning of the file +// - before Delphi 2009, the current string code page is used (i.e. CurrentAnsiConvert) +function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean=false): string; + +/// get text file contents (even Unicode or UTF8) and convert it into an +// Unicode string according to any BOM marker at the beginning of the file +// - any file without any BOM marker will be interpreted as plain ASCII: in this +// case, the current string code page is used (i.e. CurrentAnsiConvert class) +function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean=false): SynUnicode; + +/// get text file contents (even Unicode or UTF8) and convert it into an +// UTF-8 string according to any BOM marker at the beginning of the file +// - if AssumeUTF8IfNoBOM is FALSE, the current string code page is used (i.e. +// CurrentAnsiConvert class) for conversion from ANSI into UTF-8 +// - if AssumeUTF8IfNoBOM is TRUE, any file without any BOM marker will be +// interpreted as UTF-8 +function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean=false): RawUTF8; + +/// read a TStream content into a String +// - it will read binary or text content from the current position until the +// end (using TStream.Size) +// - uses RawByteString for byte storage, whatever the codepage is +function StreamToRawByteString(aStream: TStream): RawByteString; + +/// create a TStream from a string content +// - uses RawByteString for byte storage, whatever the codepage is +// - in fact, the returned TStream is a TRawByteString instance, since this +// function is just a wrapper around: +// ! result := TRawByteStringStream.Create(aString); +function RawByteStringToStream(const aString: RawByteString): TStream; + {$ifdef HASINLINE}inline;{$endif} + +/// read an UTF-8 text from a TStream +// - format is Length(Integer):Text, i.e. the one used by WriteStringToStream +// - will return '' if there is no such text in the stream +// - you can set a MaxAllowedSize value, if you know how long the size should be +// - it will read from the current position in S: so if you just write into S, +// it could be a good idea to rewind it before call, e.g.: +// ! WriteStringToStream(Stream,aUTF8Text); +// ! Stream.Seek(0,soBeginning); +// ! str := ReadStringFromStream(Stream); +function ReadStringFromStream(S: TStream; MaxAllowedSize: integer=255): RawUTF8; + +/// write an UTF-8 text into a TStream +// - format is Length(Integer):Text, i.e. the one used by ReadStringFromStream +function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; + +/// get a file date and time, from its name +// - returns 0 if file doesn't exist +// - under Windows, will use GetFileAttributesEx fast API +function FileAgeToDateTime(const FileName: TFileName): TDateTime; + +/// get a file size, from its name +// - returns 0 if file doesn't exist +// - under Windows, will use GetFileAttributesEx fast API +function FileSize(const FileName: TFileName): Int64; overload; + +/// get a file size, from its handle +// - returns 0 if file doesn't exist +function FileSize(F: THandle): Int64; overload; + +/// get low-level file information, in a cross-platform way +// - returns true on success +// - here file write/creation time are given as TUnixMSTime values, for better +// cross-platform process - note that FileCreateDateTime may not be supported +// by most Linux file systems, so the oldest timestamp available is returned +// as failover on such systems (probably the latest file metadata writing) +function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, + LastWriteAccess, FileCreateDateTime: Int64): Boolean; + +/// get a file date and time, from a FindFirst/FindNext search +// - the returned timestamp is in local time, not UTC +// - this method would use the F.Timestamp field available since Delphi XE2 +function SearchRecToDateTime(const F: TSearchRec): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// check if a FindFirst/FindNext found instance is actually a file +function SearchRecValidFile(const F: TSearchRec): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// check if a FindFirst/FindNext found instance is actually a folder +function SearchRecValidFolder(const F: TSearchRec): boolean; + {$ifdef HASINLINE}inline;{$endif} + +const + /// operating-system dependent wildchar to match all files in a folder + FILES_ALL = {$ifdef MSWINDOWS}'*.*'{$else}'*'{$endif}; + +/// delete the content of a specified directory +// - only one level of file is deleted within the folder: no recursive deletion +// is processed by this function (for safety) +// - if DeleteOnlyFilesNotDirectory is TRUE, it won't remove the folder itself, +// but just the files found in it +function DirectoryDelete(const Directory: TFileName; const Mask: TFileName=FILES_ALL; + DeleteOnlyFilesNotDirectory: Boolean=false; DeletedCount: PInteger=nil): Boolean; + +/// delete the files older than a given age in a specified directory +// - for instance, to delete all files older than one day: +// ! DirectoryDeleteOlderFiles(FolderName, 1); +// - only one level of file is deleted within the folder: no recursive deletion +// is processed by this function, unless Recursive is TRUE +// - if Recursive=true, caller should set TotalSize^=0 to have an accurate value +function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; + const Mask: TFileName=FILES_ALL; Recursive: Boolean=false; TotalSize: PInt64=nil): Boolean; + +/// creates a directory if not already existing +// - returns the full expanded directory name, including trailing backslash +// - returns '' on error, unless RaiseExceptionOnCreationFailure=true +function EnsureDirectoryExists(const Directory: TFileName; + RaiseExceptionOnCreationFailure: boolean=false): TFileName; + +/// check if the directory is writable for the current user +// - try to write a small file with a random name +function IsDirectoryWritable(const Directory: TFileName): boolean; + +/// compute an unique temporary file name +// - following 'exename_01234567.tmp' pattern, in the system temporary folder +function TemporaryFileName: TFileName; + +type + {$A-} + /// file found result item, as returned by FindFiles() + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TFindFiles = record + {$else}TFindFiles = object{$endif} + public + /// the matching file name, including its folder name + Name: TFileName; + /// the matching file attributes + Attr: Integer; + /// the matching file size + Size: Int64; + /// the matching file date/time + Timestamp: TDateTime; + /// fill the item properties from a FindFirst/FindNext's TSearchRec + procedure FromSearchRec(const Directory: TFileName; const F: TSearchRec); + /// returns some ready-to-be-loggued text + function ToText: shortstring; + end; + {$A+} + /// result list, as returned by FindFiles() + TFindFilesDynArray = array of TFindFiles; + + /// a pointer to a TFileName variable + PFileName = ^TFileName; + +/// search for matching file names +// - just a wrapper around FindFirst/FindNext +// - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg' +function FindFiles(const Directory,Mask: TFileName; + const IgnoreFileName: TFileName=''; SortByName: boolean=false; + IncludesDir: boolean=true; SubFolder: Boolean=false): TFindFilesDynArray; + +/// convert a result list, as returned by FindFiles(), into an array of Files[].Name +function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; + +/// ensure all files in Dest folder(s) do match the one in Reference +// - won't copy all files from Reference folders, but only update files already +// existing in Dest, which did change since last synchronization +// - will also process recursively nested folders if SubFolder is true +// - will use file content instead of file date check if ByContent is true +// - can optionally write the synched file name to the console +// - returns the number of files copied during the process +function SynchFolders(const Reference, Dest: TFileName; SubFolder: boolean=false; + ByContent: boolean=false; WriteFileNameToConsole: boolean=false): integer; + +{$ifdef DELPHI5OROLDER} + +/// DirectoryExists returns a boolean value that indicates whether the +// specified directory exists (and is actually a directory) +function DirectoryExists(const Directory: string): Boolean; + +/// case-insensitive comparison of filenames +function SameFileName(const S1, S2: TFileName): Boolean; + +/// retrieve the corresponding environment variable value +function GetEnvironmentVariable(const Name: string): string; + +/// retrieve the full path name of the given execution module (e.g. library) +function GetModuleName(Module: HMODULE): TFileName; + +/// try to encode a time +function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean; + +/// alias to ExcludeTrailingBackslash() function +function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName; + +/// alias to IncludeTrailingBackslash() function +function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName; + +type + EOSError = class(Exception) + public + ErrorCode: DWORD; + end; + +/// raise an EOSError exception corresponding to the last error reported by Windows +procedure RaiseLastOSError; + +{$endif DELPHI5OROLDER} + +{$ifdef DELPHI6OROLDER} +procedure VarCastError; +{$endif} + +/// compute the file name, including its path if supplied, but without its extension +// - e.g. GetFileNameWithoutExt('/var/toto.ext') = '/var/toto' +// - may optionally return the extracted extension, as '.ext' +function GetFileNameWithoutExt(const FileName: TFileName; + Extension: PFileName=nil): TFileName; + +/// extract a file extension from a file name, then compare with a comma +// separated list of extensions +// - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1 +// - will return -1 if no file extension match +// - will return any matching extension, starting count at 0 +// - extension match is case-insensitive +function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; + +/// copy one file to another, similar to the Windows API +function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; + +/// copy the date of one file to another +function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; + +/// retrieve a property value in a text-encoded class +// - follows the Delphi serialized text object format, not standard .ini +// - if the property is a string, the simple quotes ' are trimed +function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; + +/// retrieve a filename property value in a text-encoded class +// - follows the Delphi serialized text object format, not standard .ini +// - if the property is a string, the simple quotes ' are trimed +// - any file path and any extension are trimmed +function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; + + +/// return true if UpperValue (Ansi) is contained in A^ (Ansi) +// - find UpperValue starting at word beginning, not inside words +function FindAnsi(A, UpperValue: PAnsiChar): boolean; + +/// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded) +// - find UpperValue starting at word beginning, not inside words +// - UTF-8 decoding is done on the fly (no temporary decoding buffer is used) +function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; + +/// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded) +// - will use the slow but accurate Operating System API to perform the +// comparison at Unicode-level +function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: PtrInt): boolean; + +/// trim first lowercase chars ('otDone' will return 'Done' e.g.) +// - return a PUTF8Char to avoid any memory allocation +function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; + +/// trim first lowercase chars ('otDone' will return 'Done' e.g.) +// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 +// to 2007, and UTF-8 encoded with Delphi 2009+ +function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; + +/// trim first lowercase chars ('otDone' will return 'Done' e.g.) +// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 +// to 2007, and UTF-8 encoded with Delphi 2009+ +function TrimLeftLowerCaseToShort(V: PShortString): ShortString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// trim first lowercase chars ('otDone' will return 'Done' e.g.) +// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 +// to 2007, and UTF-8 encoded with Delphi 2009+ +procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload; + +/// convert a CamelCase string into a space separated one +// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' +// - will handle capital words at the beginning, middle or end of the text, e.g. +// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will +// return 'Good BBC program' +// - will handle a number at the beginning, middle or end of the text, e.g. +// 'Email12' will return 'Email 12' +// - '_' char is transformed into ' - ' +// - '__' chars are transformed into ': ' +// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 +// to 2007, and UTF-8 encoded with Delphi 2009+ +function UnCamelCase(const S: RawUTF8): RawUTF8; overload; + +/// convert a CamelCase string into a space separated one +// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' +// - will handle capital words at the beginning, middle or end of the text, e.g. +// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will +// return 'Good BBC program' +// - will handle a number at the beginning, middle or end of the text, e.g. +// 'Email12' will return 'Email 12' +// - return the char count written into D^ +// - D^ and P^ are expected to be UTF-8 encoded: enumeration and property names +// are pure 7bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+ +// - '_' char is transformed into ' - ' +// - '__' chars are transformed into ': ' +function UnCamelCase(D, P: PUTF8Char): integer; overload; + +/// convert a string into an human-friendly CamelCase identifier +// - replacing spaces or punctuations by an uppercase character +// - as such, it is not the reverse function to UnCamelCase() +procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; + const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; + +/// convert a string into an human-friendly CamelCase identifier +// - replacing spaces or punctuations by an uppercase character +// - as such, it is not the reverse function to UnCamelCase() +procedure CamelCase(const text: RawUTF8; var s: RawUTF8; + const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// UnCamelCase and translate a char buffer +// - P is expected to be #0 ended +// - return "string" type, i.e. UnicodeString for Delphi 2009+ +procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); + +/// will get a class name as UTF-8 +// - will trim 'T', 'TSyn', 'TSQL' or 'TSQLRecord' left side of the class name +// - will encode the class name as UTF-8 (for Unicode Delphi versions) +// - is used e.g. to extract the SQL table name for a TSQLRecord class +function GetDisplayNameFromClass(C: TClass): RawUTF8; + +/// UnCamelCase and translate the class name, triming any left 'T', 'TSyn', +// 'TSQL' or 'TSQLRecord' +// - return generic VCL string type, i.e. UnicodeString for Delphi 2009+ +function GetCaptionFromClass(C: TClass): string; + +/// just a wrapper around vmtClassName to avoid a string conversion +function ClassNameShort(C: TClass): PShortString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// just a wrapper around vmtClassName to avoid a string conversion +function ClassNameShort(Instance: TObject): PShortString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// just a wrapper around vmtParent to avoid a function call +// - slightly faster than TClass.ClassParent thanks to proper inlining +function GetClassParent(C: TClass): TClass; + {$ifdef HASINLINE}inline;{$endif} + +/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion +function ToText(C: TClass): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion +procedure ToText(C: TClass; var result: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + +type + /// information about one method, as returned by GetPublishedMethods + TPublishedMethodInfo = record + /// the method name + Name: RawUTF8; + /// a callback to the method, for the given class instance + Method: TMethod; + end; + /// information about all methods, as returned by GetPublishedMethods + TPublishedMethodInfoDynArray = array of TPublishedMethodInfo; + +/// retrieve published methods information about any class instance +// - will optionaly accept a Class, in this case Instance is ignored +// - will work with FPC and Delphi RTTI +function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; + aClass: TClass = nil): integer; + +{$ifdef LINUX} +const + ANSI_CHARSET = 0; + DEFAULT_CHARSET = 1; + SYMBOL_CHARSET = 2; + SHIFTJIS_CHARSET = $80; + HANGEUL_CHARSET = 129; + GB2312_CHARSET = 134; + CHINESEBIG5_CHARSET = 136; + OEM_CHARSET = 255; + JOHAB_CHARSET = 130; + HEBREW_CHARSET = 177; + ARABIC_CHARSET = 178; + GREEK_CHARSET = 161; + TURKISH_CHARSET = 162; + VIETNAMESE_CHARSET = 163; + THAI_CHARSET = 222; + EASTEUROPE_CHARSET = 238; + RUSSIAN_CHARSET = 204; + BALTIC_CHARSET = 186; +{$else} +{$ifdef FPC} +const + VIETNAMESE_CHARSET = 163; +{$endif} +{$endif} + +/// convert a char set to a code page +function CharSetToCodePage(CharSet: integer): cardinal; + +/// convert a code page to a char set +function CodePageToCharSet(CodePage: Cardinal): Integer; + +/// retrieve the MIME content type from a supplied binary buffer +// - inspect the first bytes, to guess from standard known headers +// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header +// - returns DefaultContentType if the binary buffer has an unknown layout +function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; + const DefaultContentType: RawUTF8): RawUTF8; + +/// retrieve the MIME content type from its file name or a supplied binary buffer +// - will first check for known file extensions, then inspect the binary content +// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header +// - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or +// 'application/fileextension' if FileName was specified +// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values +function GetMimeContentType(Content: Pointer; Len: PtrInt; + const FileName: TFileName=''): RawUTF8; + +/// retrieve the HTTP header for MIME content type from a supplied binary buffer +// - just append HEADER_CONTENT_TYPE and GetMimeContentType() result +// - can be used as such: +// ! Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName); +function GetMimeContentTypeHeader(const Content: RawByteString; + const FileName: TFileName=''): RawUTF8; + +/// retrieve if some content is compressed, from a supplied binary buffer +// - returns TRUE, if the header in binary buffer "may" be compressed (this method +// can trigger false positives), e.g. begin with most common already compressed +// zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers") +function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; + +/// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...', +// 'Content-Type: application/json' or 'Content-Type: application/xml' +function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; + +/// fast guess of the size, in pixels, of a JPEG memory buffer +// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk +// - returns TRUE if the buffer is likely to be a JPEG picture, and set the +// Height + Width variable with its dimensions - but there may be false positive +// recognition, and no waranty that the memory buffer holds a valid JPEG picture +// - returns FALSE if the buffer does not have any expected SOI/SOF markers +function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; overload; + +/// fast guess of the size, in pixels, of a JPEG file +// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk +// - returns TRUE if the buffer is likely to be a JPEG picture, and set the +// Height + Width variable with its dimensions - but there may be false positive +// recognition, and no waranty that the file is a valid JPEG picture +// - returns FALSE if the file content does not have any expected SOI/SOF markers +function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; overload; + +type + /// used by MultiPartFormDataDecode() to return one item of its data + TMultiPart = record + Name: RawUTF8; + FileName: RawUTF8; + ContentType: RawUTF8; + Encoding: RawUTF8; + Content: RawByteString; + end; + /// used by MultiPartFormDataDecode() to return all its data items + TMultiPartDynArray = array of TMultiPart; + +/// decode multipart/form-data POST request content +// - following RFC1867 +function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; + var MultiPart: TMultiPartDynArray): boolean; + +/// encode multipart fields and files +// - only one of them can be used because MultiPartFormDataDecode must implement +// both decodings +// - MultiPart: parts to build the multipart content from, which may be created +// using MultiPartFormDataAddFile/MultiPartFormDataAddField +// - MultiPartContentType: variable returning +// $ Content-Type: multipart/form-data; boundary=xxx +// where xxx is the first generated boundary +// - MultiPartContent: generated multipart content +function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; + var MultiPartContentType, MultiPartContent: RawUTF8): boolean; + +/// encode a file in a multipart array +// - FileName: file to encode +// - Multipart: where the part is added +// - Name: name of the part, is empty the name 'File###' is generated +function MultiPartFormDataAddFile(const FileName: TFileName; + var MultiPart: TMultiPartDynArray; const Name: RawUTF8 = ''): boolean; + +/// encode a field in a multipart array +// - FieldName: field name of the part +// - FieldValue: value of the field +// - Multipart: where the part is added +function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; + var MultiPart: TMultiPartDynArray): boolean; + +/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array +// - R is the last index of available entries in P^ (i.e. Count-1) +// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) +// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) +// - will use fast O(log(n)) binary search algorithm +function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array +// - this overloaded function accept a custom comparison function for sorting +// - R is the last index of available entries in P^ (i.e. Count-1) +// - string comparison is case-sensitive (so will work with any PAnsiChar) +// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) +// - will use fast O(log(n)) binary search algorithm +function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; + Compare: TUTF8Compare): PtrInt; overload; + +/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array +// - R is the last index of available entries in P^ (i.e. Count-1) +// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) +// - returns -1 if the specified Value was not found +// - will use inlined binary search algorithm with optimized x86_64 branchless asm +// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrComp) +function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; + +/// retrieve the index where is located a PUTF8Char in a sorted uppercase PUTF8Char array +// - P[] array is expected to be already uppercased +// - searched Value is converted to uppercase before search via UpperCopy255Buf(), +// so is expected to be short, i.e. length < 250 +// - R is the last index of available entries in P^ (i.e. Count-1) +// - returns -1 if the specified Value was not found +// - will use fast O(log(n)) binary search algorithm +// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrIComp) +function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; + Value: PUTF8Char; ValueLen: PtrInt): PtrInt; + +/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array +// - R is the last index of available entries in P^ (i.e. Count-1) +// - string comparison will use the specified Compare function +// - returns -1 if the specified Value was not found +// - will use fast O(log(n)) binary search algorithm +function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; + Compare: TUTF8Compare): PtrInt; overload; + +/// retrieve the index of a PUTF8Char in a PUTF8Char array via a sort indexed +// - will use fast O(log(n)) binary search algorithm +function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; + var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; + ItemComp: TUTF8Compare): PtrInt; + +/// add a RawUTF8 value in an alphaticaly sorted dynamic array of RawUTF8 +// - returns the index where the Value was added successfully in Values[] +// - returns -1 if the specified Value was alredy present in Values[] +// (we must avoid any duplicate for O(log(n)) binary search) +// - if CoValues is set, its content will be moved to allow inserting a new +// value at CoValues[result] position - a typical usage of CoValues is to store +// the corresponding ID to each RawUTF8 item +// - if FastLocatePUTF8CharSorted() has been already called, this index can +// be set to optional ForceIndex parameter +// - by default, exact (case-sensitive) match is used; you can specify a custom +// compare function if needed in Compare optional parameter +function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1; + Compare: TUTF8Compare=nil): PtrInt; + +/// delete a RawUTF8 item in a dynamic array of RawUTF8 +// - if CoValues is set, the integer item at the same index is also deleted +function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + Index: integer; CoValues: PIntegerDynArray=nil): boolean; overload; + +/// delete a RawUTF8 item in a dynamic array of RawUTF8; +function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; overload; + +/// sort a dynamic array of RawUTF8 items +// - if CoValues is set, the integer items are also synchronized +// - by default, exact (case-sensitive) match is used; you can specify a custom +// compare function if needed in Compare optional parameter +procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; + CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil); + +/// sort a dynamic array of PUTF8Char items, via an external array of indexes +// - you can use FastFindIndexedPUTF8Char() for fast O(log(n)) binary search +procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; + var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean=false); + +/// fast search of an unsigned integer position in an integer array +// - Count is the number of cardinal entries in P^ +// - returns P where P^=Value +// - returns nil if Value was not found +function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; + +/// fast search of an unsigned integer position in an integer array +// - Count is the number of integer entries in P^ +// - return index of P^[index]=Value +// - return -1 if Value was not found +function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; + +/// fast search of an integer position in a 64-bit integer array +// - Count is the number of Int64 entries in P^ +// - returns P where P^=Value +// - returns nil if Value was not found +function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; + +/// fast search of an integer position in a signed 64-bit integer array +// - Count is the number of Int64 entries in P^ +// - returns index of P^[index]=Value +// - returns -1 if Value was not found +function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; + +/// fast search of an integer position in an unsigned 64-bit integer array +// - Count is the number of QWord entries in P^ +// - returns index of P^[index]=Value +// - returns -1 if Value was not found +function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of an unsigned integer in an integer array +// - returns true if P^=Value within Count entries +// - returns false if Value was not found +function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; + +/// fast search of an integer value in a 64-bit integer array +// - returns true if P^=Value within Count entries +// - returns false if Value was not found +function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; + +/// fast search of a pointer-sized unsigned integer position +// in an pointer-sized integer array +// - Count is the number of pointer-sized integer entries in P^ +// - return index of P^[index]=Value +// - return -1 if Value was not found +function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array +// - Count is the number of pointer-sized integer entries in P^ +// - returns true if P^=Value within Count entries +// - returns false if Value was not found +function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of a pointer-sized unsigned integer position +// in an pointer-sized integer array +// - Count is the number of pointer-sized integer entries in P^ +// - returns true if P^=Value within Count entries +// - returns false if Value was not found +function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of an unsigned Byte value position in a Byte array +// - Count is the number of Byte entries in P^ +// - return index of P^[index]=Value +// - return -1 if Value was not found +function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of an unsigned Word value position in a Word array +// - Count is the number of Word entries in P^ +// - return index of P^[index]=Value +// - return -1 if Value was not found +function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// fast search of a binary value position in a fixed-size array +// - Count is the number of entries in P^[] +// - return index of P^[index]=Elem^, comparing ElemSize bytes +// - return -1 if Value was not found +function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; + +/// fast search of a binary value position in a fixed-size array +// - Count is the number of entries in P^[] +function AnyScanExists(P,Elem: pointer; Count,ElemSize: PtrInt): boolean; + +/// sort an Integer array, low values first +procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload; + +/// sort an Integer array, low values first +procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload; + +/// sort an Integer array, low values first +procedure QuickSortInteger(var ID: TIntegerDynArray); overload; + +/// sort a 16 bit unsigned Integer array, low values first +procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); + +/// sort a 64-bit signed Integer array, low values first +procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload; + +/// sort a 64-bit unsigned Integer array, low values first +// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - +// older compilers will use fast and exact SortDynArrayQWord() +procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload; + +/// sort a 64-bit Integer array, low values first +procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload; + +type + /// event handler called by NotifySortedIntegerChanges() + // - Sender is an opaque const value, maybe a TObject or any pointer + TOnNotifySortedIntegerChange = procedure(const Sender; Value: integer) of object; + +/// compares two 32-bit signed sorted integer arrays, and call event handlers +// to notify the corresponding modifications in an O(n) time +// - items in both old[] and new[] arrays are required to be sorted +procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; + const added, deleted: TOnNotifySortedIntegerChange; const sender); + +/// copy an integer array, then sort it, low values first +procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; + var Dest: TIntegerDynArray); + +/// copy an integer array, then sort it, low values first +procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; + var Dest: TInt64DynArray); + +/// fast O(log(n)) binary search of an integer value in a sorted integer array +// - R is the last index of available integer entries in P^ (i.e. Count-1) +// - return index of P^[result]=Value +// - return -1 if Value was not found +function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload; + +/// fast O(log(n)) binary search of an integer value in a sorted integer array +// - return index of Values[result]=Value +// - return -1 if Value was not found +function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast O(log(n)) binary search of a 16 bit unsigned integer value in a sorted array +function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; + +/// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array +// - R is the last index of available integer entries in P^ (i.e. Count-1) +// - return index of P^[result]=Value +// - return -1 if Value was not found +function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload; + +/// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array +// - R is the last index of available integer entries in P^ (i.e. Count-1) +// - return index of P^[result]=Value +// - return -1 if Value was not found +// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - +// older compilers will fast and exact SortDynArrayQWord() +function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload; + +/// sort a PtrInt array, low values first +procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// fast O(log(n)) binary search of a PtrInt value in a sorted array +function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// sort a pointer array, low values first +procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// fast O(log(n)) binary search of a Pointer value in a sorted array +function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// retrieve the index where to insert an integer value in a sorted integer array +// - R is the last index of available integer entries in P^ (i.e. Count-1) +// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) +function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; + +/// retrieve the index where to insert a word value in a sorted word array +// - R is the last index of available integer entries in P^ (i.e. Count-1) +// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) +function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; + +/// add an integer value in a sorted dynamic array of integers +// - returns the index where the Value was added successfully in Values[] +// - returns -1 if the specified Value was already present in Values[] +// (we must avoid any duplicate for O(log(n)) binary search) +// - if CoValues is set, its content will be moved to allow inserting a new +// value at CoValues[result] position +function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; + +/// add an integer value in a sorted dynamic array of integers +// - overloaded function which do not expect an external Count variable +function AddSortedInteger(var Values: TIntegerDynArray; + Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; + +/// insert an integer value at the specified index position of a dynamic array +// of integers +// - if Index is invalid, the Value is inserted at the end of the array +function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt; + +/// add an integer value at the end of a dynamic array of integers +// - returns TRUE if Value was added successfully in Values[], in this case +// length(Values) will be increased +function AddInteger(var Values: TIntegerDynArray; Value: integer; + NoDuplicates: boolean=false): boolean; overload; + +/// add an integer value at the end of a dynamic array of integers +// - this overloaded function will use a separate Count variable (faster) +// - it won't search for any existing duplicate +procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// add an integer array at the end of a dynamic array of integer +function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; overload; + +/// add an integer value at the end of a dynamic array of integers +// - this overloaded function will use a separate Count variable (faster), +// and would allow to search for duplicates +// - returns TRUE if Value was added successfully in Values[], in this case +// ValuesCount will be increased, but length(Values) would stay fixed most +// of the time (since it stores the Values[] array capacity) +function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer; NoDuplicates: boolean): boolean; overload; + +/// add a 16-bit integer value at the end of a dynamic array of integers +function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; + +/// add a 64-bit integer value at the end of a dynamic array of integers +function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// add a 64-bit integer value at the end of a dynamic array +function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// add a 64-bit integer array at the end of a dynamic array +function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; overload; + +/// if not already existing, add a 64-bit integer value to a dynamic array +function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; + +/// if not already existing, add a 64-bit integer value to a sorted dynamic array +procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); + +/// delete any 32-bit integer in Values[] +procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload; + +/// delete any 32-bit integer in Values[] +procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload; + +/// remove some 32-bit integer from Values[] +// - Excluded is declared as var, since it will be sorted in-place during process +// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) +procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; + ExcludedSortSize: Integer=32); + +/// ensure some 32-bit integer from Values[] will only contain Included[] +// - Included is declared as var, since it will be sorted in-place during process +// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) +procedure IncludeInteger(var Values, Included: TIntegerDynArray; + IncludedSortSize: Integer=32); + +/// sort and remove any 32-bit duplicated integer from Values[] +procedure DeduplicateInteger(var Values: TIntegerDynArray); overload; + +/// sort and remove any 32-bit duplicated integer from Values[] +// - returns the new Values[] length +function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; overload; + +/// low-level function called by DeduplicateInteger() +function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; + +/// create a new 32-bit integer dynamic array with the values from another one +procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); + +/// delete any 16-bit integer in Values[] +procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); + +/// delete any 64-bit integer in Values[] +procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload; + +/// delete any 64-bit integer in Values[] +procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); overload; + +/// remove some 64-bit integer from Values[] +// - Excluded is declared as var, since it will be sorted in-place during process +// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) +procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; + ExcludedSortSize: Integer=32); + +/// ensure some 64-bit integer from Values[] will only contain Included[] +// - Included is declared as var, since it will be sorted in-place during process +// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) +procedure IncludeInt64(var Values, Included: TInt64DynArray; + IncludedSortSize: Integer=32); + +/// sort and remove any 64-bit duplicated integer from Values[] +procedure DeduplicateInt64(var Values: TInt64DynArray); overload; + +/// sort and remove any 64-bit duplicated integer from Values[] +// - returns the new Values[] length +function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; overload; + +/// low-level function called by DeduplicateInt64() +// - warning: caller should ensure that last>0 +function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; + +/// create a new 64-bit integer dynamic array with the values from another one +procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); + +/// find the maximum 32-bit integer in Values[] +function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; + MaxStart: integer=-1): Integer; + +/// sum all 32-bit integers in Values[] +function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; + +/// fill already allocated Reversed[] so that Reversed[Values[i]]=i +procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; + Reversed: PIntegerArray); + +/// fill some values with i,i+1,i+2...i+Count-1 +procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt); + +/// copy some Int64 values into an unsigned integer array +procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); + +/// append the strings in the specified CSV text into a dynamic array of integer +procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; + Sep: AnsiChar= ','); + +/// append the strings in the specified CSV text into a dynamic array of integer +procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; + Sep: AnsiChar= ','); overload; + +/// convert the strings in the specified CSV text into a dynamic array of integer +function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar= ','): TInt64DynArray; overload; + +/// return the corresponding CSV text from a dynamic array of 32-bit integer +// - you can set some custom Prefix and Suffix text +function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; + const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; + +/// return the corresponding CSV text from a dynamic array of 32-bit integer +// - you can set some custom Prefix and Suffix text +function IntegerDynArrayToCSV(const Values: TIntegerDynArray; + const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// return the corresponding CSV text from a dynamic array of 64-bit integers +// - you can set some custom Prefix and Suffix text +function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; + const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; + +/// return the corresponding CSV text from a dynamic array of 64-bit integers +// - you can set some custom Prefix and Suffix text +function Int64DynArrayToCSV(const Values: TInt64DynArray; + const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// quick helper to initialize a dynamic array of integer from some constants +// - can be used e.g. as: +// ! MyArray := TIntegerDynArrayFrom([1,2,3]); +// - see also FromI32() +function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; + +/// quick helper to initialize a dynamic array of integer from 64-bit integers +// - will raise a ESynException if any Value[] can not fit into 32-bit, unless +// raiseExceptionOnOverflow is FALSE and the returned array slot is filled +// with maxInt/minInt +function TIntegerDynArrayFrom64(const Values: TInt64DynArray; + raiseExceptionOnOverflow: boolean=true): TIntegerDynArray; + +/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values +// - see also FromI64() for 64-bit signed integer values input +function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray; + +/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values +// - see also FromU64() for 64-bit unsigned integer values input +function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray; + +/// initializes a dynamic array from a set of 32-bit integer signed values +function FromI32(const Values: array of integer): TIntegerDynArray; + {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// initializes a dynamic array from a set of 32-bit integer unsigned values +function FromU32(const Values: array of cardinal): TCardinalDynArray; + {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// initializes a dynamic array from a set of 64-bit integer signed values +function FromI64(const Values: array of Int64): TInt64DynArray; + {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// initializes a dynamic array from a set of 64-bit integer unsigned values +function FromU64(const Values: array of QWord): TQWordDynArray; + {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + +type + /// used to store and retrieve Words in a sorted array + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TSortedWordArray = record + {$else}TSortedWordArray = object{$endif} + public + /// the actual 16-bit word storage + Values: TWordDynArray; + /// how many items are currently in Values[] + Count: PtrInt; + /// add a value into the sorted array + // - return the index of the new inserted value into the Values[] array + // - return -(foundindex+1) if this value is already in the Values[] array + function Add(aValue: Word): PtrInt; + /// return the index if the supplied value in the Values[] array + // - return -1 if not found + function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif} + end; + PSortedWordArray = ^TSortedWordArray; + + /// used to store and retrieve Integers in a sorted array + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TSortedIntegerArray = record + {$else}TSortedIntegerArray = object{$endif} + public + /// the actual 32-bit integers storage + Values: TIntegerDynArray; + /// how many items are currently in Values[] + Count: PtrInt; + /// add a value into the sorted array + // - return the index of the new inserted value into the Values[] array + // - return -(foundindex+1) if this value is already in the Values[] array + function Add(aValue: integer): PtrInt; + /// return the index if the supplied value in the Values[] array + // - return -1 if not found + function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif} + end; + PSortedIntegerArray = ^TSortedIntegerArray; + + /// comparison function as expected by MedianQuickSelect() + // - should return TRUE if Values[IndexA]>Values[IndexB] + TOnValueGreater = function(IndexA,IndexB: PtrInt): boolean of object; + +/// compute the median of an integer serie of values, using "Quickselect" +// - based on the algorithm described in "Numerical recipes in C", Second Edition, +// translated from Nicolas Devillard's C code: http://ndevilla.free.fr/median/median +// - warning: the supplied Integer array is modified in-place during the process, +// and won't be fully sorted on output (this is no QuickSort alternative) +function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; + +/// compute the median of a serie of values, using "Quickselect" +// - based on the algorithm described in "Numerical recipes in C", Second Edition +// - expect the values information to be available from a comparison callback +// - this version will use a temporary index list to exchange items order +// (supplied as a TSynTempBuffer), so won't change the supplied values themself +// - returns the index of the median Value +function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; + var TempBuffer: TSynTempBuffer): integer; + +/// compute GCD of two integers using substraction-based Euclidean algorithm +function gcd(a, b: cardinal): cardinal; + +/// performs a QuickSort using a comparison callback +procedure QuickSortCompare(const OnCompare: TOnValueGreater; + Index: PIntegerArray; L,R: PtrInt); + +/// convert a cardinal into a 32-bit variable-length integer buffer +function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; + +/// return the number of bytes necessary to store a 32-bit variable-length integer +// - i.e. the ToVarUInt32() buffer size +function ToVarUInt32Length(Value: PtrUInt): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// return the number of bytes necessary to store some data with a its +// 32-bit variable-length integer legnth +function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an integer into a 32-bit variable-length integer buffer +// - store negative values as cardinal two-complement, i.e. +// 0=0,1=1,2=-1,3=2,4=-2... +function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// convert a 32-bit variable-length integer buffer into a cardinal +// - fast inlined process for any number < 128 +// - use overloaded FromVarUInt32() or FromVarUInt32Safe() with a SourceMax +// pointer to avoid any potential buffer overflow +function FromVarUInt32(var Source: PByte): cardinal; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// safely convert a 32-bit variable-length integer buffer into a cardinal +// - slower but safer process checking out of boundaries memory access in Source +// - SourceMax is expected to be not nil, and to point to the first byte +// just after the Source memory buffer +// - returns nil on error, or point to next input data on successful decoding +function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; + +/// convert a 32-bit variable-length integer buffer into a cardinal +// - will call FromVarUInt32() if SourceMax=nil, or FromVarUInt32Safe() if set +// - returns false on error, true if Value has been set properly +function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a 32-bit variable-length integer buffer into a cardinal +// - this version could be called if number is likely to be > $7f, so it +// inlining the first byte won't make any benefit +function FromVarUInt32Big(var Source: PByte): cardinal; + +/// convert a 32-bit variable-length integer buffer into a cardinal +// - used e.g. when inlining FromVarUInt32() +// - this version must be called if Source^ has already been checked to be > $7f +// ! result := Source^; +// ! inc(Source); +// ! if result>$7f then +// ! result := (result and $7F) or FromVarUInt32Up128(Source); +function FromVarUInt32Up128(var Source: PByte): cardinal; + +/// convert a 32-bit variable-length integer buffer into a cardinal +// - this version must be called if Source^ has already been checked to be > $7f +function FromVarUInt32High(var Source: PByte): cardinal; + +/// convert a 32-bit variable-length integer buffer into an integer +// - decode negative values from cardinal two-complement, i.e. +// 0=0,1=1,2=-1,3=2,4=-2... +function FromVarInt32(var Source: PByte): integer; + +/// convert a UInt64 into a 64-bit variable-length integer buffer +function ToVarUInt64(Value: QWord; Dest: PByte): PByte; + +/// convert a 64-bit variable-length integer buffer into a UInt64 +function FromVarUInt64(var Source: PByte): QWord; overload; + +/// safely convert a 64-bit variable-length integer buffer into a UInt64 +// - slower but safer process checking out of boundaries memory access in Source +// - SourceMax is expected to be not nil, and to point to the first byte +// just after the Source memory buffer +// - returns nil on error, or point to next input data on successful decoding +function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; + +/// convert a 64-bit variable-length integer buffer into a UInt64 +// - will call FromVarUInt64() if SourceMax=nil, or FromVarUInt64Safe() if set +// - returns false on error, true if Value has been set properly +function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: Qword): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a Int64 into a 64-bit variable-length integer buffer +function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif} + +/// convert a 64-bit variable-length integer buffer into a Int64 +function FromVarInt64(var Source: PByte): Int64; + +/// convert a 64-bit variable-length integer buffer into a Int64 +// - this version won't update the Source pointer +function FromVarInt64Value(Source: PByte): Int64; + +/// jump a value in the 32-bit or 64-bit variable-length integer buffer +function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} + +/// convert a RawUTF8 into an UTF-8 encoded variable-length buffer +function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; + +/// jump a value in variable-length text buffer +function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} + +/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 +function FromVarString(var Source: PByte): RawUTF8; overload; + +/// safe retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 +// - supplied SourceMax value will avoid any potential buffer overflow +function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; overload; + +/// retrieve a variable-length text buffer +// - this overloaded function will set the supplied code page to the AnsiString +procedure FromVarString(var Source: PByte; var Value: RawByteString; + CodePage: integer); overload; + +/// retrieve a variable-length text buffer +// - this overloaded function will set the supplied code page to the AnsiString +// and will also check for the SourceMax end of buffer +// - returns TRUE on success, or FALSE on any buffer overload detection +function FromVarString(var Source: PByte; SourceMax: PByte; + var Value: RawByteString; CodePage: integer): boolean; overload; + +/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer +// - caller should call Value.Done after use of the Value.buf memory +// - this overloaded function would include a trailing #0, so Value.buf could +// be parsed as a valid PUTF8Char buffer (e.g. containing JSON) +procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload; + +/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer +// - caller should call Value.Done after use of the Value.buf memory +// - this overloaded function will also check for the SourceMax end of buffer, +// returning TRUE on success, or FALSE on any buffer overload detection +function FromVarString(var Source: PByte; SourceMax: PByte; + var Value: TSynTempBuffer): boolean; overload; + +type + /// kind of result returned by FromVarBlob() function + TValueResult = record + /// start of data value + Ptr: PAnsiChar; + /// value length (in bytes) + Len: PtrInt; + end; + +/// retrieve pointer and length to a variable-length text/blob buffer +function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif} + + + +{ ************ low-level RTTI types and conversion routines ***************** } + +type + /// specify ordinal (tkInteger and tkEnumeration) storage size and sign + // - note: Int64 is stored as its own TTypeKind, not as tkInteger + TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong + {$ifdef FPC_NEWRTTI},otSQWord,otUQWord{$endif}); + + /// specify floating point (ftFloat) storage size and precision + // - here ftDouble is renamed ftDoub to avoid confusion with TSQLDBFieldType + TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr); + +{$ifdef FPC} + /// available type families for FPC RTTI values + // - values differs from Delphi, and are taken from FPC typinfo.pp unit + // - here below, we defined tkLString instead of tkAString to match Delphi - + // see https://lists.freepascal.org/pipermail/fpc-devel/2013-June/032360.html + // "Compiler uses internally some LongStrings which is not possible to use + // for variable declarations" so tkLStringOld seems never used in practice + TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat, + tkSet,tkMethod,tkSString,tkLStringOld{=tkLString},tkLString{=tkAString}, + tkWString,tkVariant,tkArray,tkRecord,tkInterface, + tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord, + tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar, + tkHelper,tkFile,tkClassRef,tkPointer); + +const + /// potentially managed types in TTypeKind RTTI enumerate + // - should match ManagedType*() functions + tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray, + tkObject,tkRecord,tkDynArray,tkInterface,tkVariant]; + /// maps record or object in TTypeKind RTTI enumerate + tkRecordTypes = [tkObject,tkRecord]; + /// maps record or object in TTypeKind RTTI enumerate + tkRecordKinds = [tkObject,tkRecord]; + +type + /// TTypeKind RTTI enumerate as defined in Delphi 6 and up + TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat, + dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString, + dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray, + dkUString, dkClassRef, dkPointer, dkProcedure); + +const + /// convert FPC's TTypeKind to Delphi's RTTI enumerate + // - used internally for cross-compiler TDynArray binary serialization + FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = ( + dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat, + dkSet,dkMethod,dkString,dkLString,dkLString, + dkWString,dkVariant,dkArray,dkRecord,dkInterface, + dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64, + dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar, + dkPointer,dkPointer,dkClassRef,dkPointer); + + /// convert Delphi's TTypeKind to FPC's RTTI enumerate + DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = ( + tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, + tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, + tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, + tkUString, tkClassRef, tkPointer, tkProcVar); + +{$else} + /// available type families for Delphi 6 and up, similar to typinfo.pas + // - redefined here to be shared between SynCommons.pas and mORMot.pas, + // also leveraging FPC compatibility as much as possible (FPC's typinfo.pp + // is not convenient to share code with Delphi - see e.g. its tkLString) + TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, + tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, + tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray + {$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif}); + +const + /// maps record or object in TTypeKind RTTI enumerate + tkRecordTypes = [tkRecord]; + /// maps record or object in TTypeKind RTTI enumerate + tkRecordKinds = tkRecord; + +{$endif FPC} + + /// maps long string in TTypeKind RTTI enumerate + tkStringTypes = + [tkLString, {$ifdef FPC}tkLStringOld,{$endif} tkWString + {$ifdef HASVARUSTRING}, tkUString{$endif}]; + /// maps 1, 8, 16, 32 and 64-bit ordinal in TTypeKind RTTI enumerate + tkOrdinalTypes = + [tkInteger, tkChar, tkWChar, tkEnumeration, tkSet, tkInt64 + {$ifdef FPC},tkBool,tkQWord{$endif}]; + /// quick retrieve how many bytes an ordinal consist in + ORDTYPE_SIZE: array[TOrdType] of byte = + (1,1,2,2,4,4{$ifdef FPC_NEWRTTI},8,8{$endif}); + +type + PTypeKind = ^TTypeKind; + TTypeKinds = set of TTypeKind; + POrdType = ^TOrdType; + PFloatType = ^TFloatType; + +function ToText(k: TTypeKind): PShortString; overload; + +type + /// function prototype to be used for TDynArray Sort and Find method + // - common functions exist for base types: see e.g. SortDynArrayBoolean, + // SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, + // SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble, + // SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString, + // SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI + // - any custom type (even records) can be compared then sort by defining + // such a custom function + // - must return 0 if A=B, -1 if AB + TDynArraySortCompare = function(const A,B): integer; + + /// event oriented version of TDynArraySortCompare + TEventDynArraySortCompare = function(const A,B): integer of object; + + /// optional event called by TDynArray.LoadFrom method after each item load + // - could be used e.g. for string interning or some custom initialization process + // - won't be called if the dynamic array has ElemType=nil + TDynArrayAfterLoadFrom = procedure(var A) of object; + + /// internal enumeration used to specify some standard Delphi arrays + // - will be used e.g. to match JSON serialization or TDynArray search + // (see TDynArray and TDynArrayHash InitSpecific method) + // - djBoolean would generate an array of JSON boolean values + // - djByte .. djTimeLog match numerical JSON values + // - djDateTime .. djHash512 match textual JSON values + // - djVariant will match standard variant JSON serialization (including + // TDocVariant or other custom types, if any) + // - djCustom will be used for registered JSON serializer (invalid for + // InitSpecific methods call) + // - see also djPointer and djObject constant aliases for a pointer or + // TObject field hashing / comparison + // - is used also by TDynArray.InitSpecific() to define the main field type + TDynArrayKind = ( + djNone, + djBoolean, djByte, djWord, djInteger, djCardinal, djSingle, + djInt64, djQWord, djDouble, djCurrency, djTimeLog, + djDateTime, djDateTimeMS, djRawUTF8, djWinAnsi, djString, + djRawByteString, djWideString, djSynUnicode, + djHash128, djHash256, djHash512, + djInterface, {$ifndef NOVARIANTS}djVariant,{$endif} + djCustom); + + /// internal set to specify some standard Delphi arrays + TDynArrayKinds = set of TDynArrayKind; + + /// cross-compiler type used for string reference counter + // - FPC and Delphi don't always use the same type + TStrCnt = {$ifdef STRCNT32} longint {$else} SizeInt {$endif}; + /// pointer to cross-compiler type used for string reference counter + PStrCnt = ^TStrCnt; + + /// cross-compiler type used for dynarray reference counter + // - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64 + TDACnt = {$ifdef DACNT32} longint {$else} SizeInt {$endif}; + /// pointer to cross-compiler type used for dynarray reference counter + PDACnt = ^TDACnt; + + /// internal integer type used for string header length field + TStrLen = {$ifdef FPC}SizeInt{$else}longint{$endif}; + /// internal pointer integer type used for string header length field + PStrLen = ^TStrLen; + + /// internal pointer integer type used for dynamic array header length field + PDALen = PPtrInt; + +{$ifdef FPC} + /// map the Delphi/FPC dynamic array header (stored before each instance) + // - define globally for proper inlining with FPC + // - match tdynarray type definition in dynarr.inc + TDynArrayRec = {packed} record + /// dynamic array reference count (basic memory management mechanism) + refCnt: TDACnt; + /// equals length-1 + high: tdynarrayindex; + function GetLength: sizeint; inline; + procedure SetLength(len: sizeint); inline; + property length: sizeint read GetLength write SetLength; + end; + PDynArrayRec = ^TDynArrayRec; +{$endif FPC} + +const + /// cross-compiler negative offset to TStrRec.length field + // - to be used inlined e.g. as PStrLen(p-_STRLEN)^ + _STRLEN = SizeOf(TStrLen); + /// cross-compiler negative offset to TStrRec.refCnt field + // - to be used inlined e.g. as PStrCnt(p-_STRREFCNT)^ + _STRREFCNT = Sizeof(TStrCnt)+_STRLEN; + + /// cross-compiler negative offset to TDynArrayRec.high/length field + // - to be used inlined e.g. as PDALen(PtrUInt(Values)-_DALEN)^{$ifdef FPC}+1{$endif} + _DALEN = SizeOf(PtrInt); + /// cross-compiler negative offset to TDynArrayRec.refCnt field + // - to be used inlined e.g. as PDACnt(PtrUInt(Values)-_DAREFCNT)^ + _DAREFCNT = Sizeof(TDACnt)+_DALEN; + +function ToText(k: TDynArrayKind): PShortString; overload; + +{$ifndef NOVARIANTS} + +type + /// possible options for a TDocVariant JSON/BSON document storage + // - dvoIsArray and dvoIsObject will store the "Kind: TDocVariantKind" state - + // you should never have to define these two options directly + // - dvoNameCaseSensitive will be used for every name lookup - here + // case-insensitivity is restricted to a-z A-Z 0-9 and _ characters + // - dvoCheckForDuplicatedNames will be used for method + // TDocVariantData.AddValue(), but not when setting properties at + // variant level: for consistency, "aVariant.AB := aValue" will replace + // any previous value for the name "AB" + // - dvoReturnNullForUnknownProperty will be used when retrieving any value + // from its name (for dvObject kind of instance), or index (for dvArray or + // dvObject kind of instance) + // - by default, internal values will be copied by-value from one variant + // instance to another, to ensure proper safety - but it may be too slow: + // if you set dvoValueCopiedByReference, the internal + // TDocVariantData.VValue/VName instances will be copied by-reference, + // to avoid memory allocations, BUT it may break internal process if you change + // some values in place (since VValue/VName and VCount won't match) - as such, + // if you set this option, ensure that you use the content as read-only + // - any registered custom types may have an extended JSON syntax (e.g. + // TBSONVariant does for MongoDB types), and will be searched during JSON + // parsing, unless dvoJSONParseDoNotTryCustomVariants is set (slightly faster) + // - by default, it will only handle direct JSON [array] of {object}: but if + // you define dvoJSONObjectParseWithinString, it will also try to un-escape + // a JSON string first, i.e. handle "[array]" or "{object}" content (may be + // used e.g. when JSON has been retrieved from a database TEXT column) - is + // used for instance by VariantLoadJSON() + // - JSON serialization will follow the standard layout, unless + // dvoSerializeAsExtendedJson is set so that the property names would not + // be escaped with double quotes, writing '{name:"John",age:123}' instead of + // '{"name":"John","age":123}': this extended json layout is compatible with + // http://docs.mongodb.org/manual/reference/mongodb-extended-json and with + // TDocVariant JSON unserialization, also our SynCrossPlatformJSON unit, but + // NOT recognized by most JSON clients, like AJAX/JavaScript or C#/Java + // - by default, only integer/Int64/currency number values are allowed, unless + // dvoAllowDoubleValue is set and 32-bit floating-point conversion is tried, + // with potential loss of precision during the conversion + // - dvoInternNames and dvoInternValues will use shared TRawUTF8Interning + // instances to maintain a list of RawUTF8 names/values for all TDocVariant, + // so that redundant text content will be allocated only once on heap + TDocVariantOption = + (dvoIsArray, dvoIsObject, + dvoNameCaseSensitive, dvoCheckForDuplicatedNames, + dvoReturnNullForUnknownProperty, + dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants, + dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson, + dvoAllowDoubleValue, dvoInternNames, dvoInternValues); + + /// set of options for a TDocVariant storage + // - you can use JSON_OPTIONS[true] if you want to create a fast by-reference + // local document as with _ObjFast/_ArrFast/_JsonFast - i.e. + // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference] + // - when specifying the options, you should not include dvoIsArray nor + // dvoIsObject directly in the set, but explicitly define TDocVariantDataKind + TDocVariantOptions = set of TDocVariantOption; + + /// pointer to a set of options for a TDocVariant storage + // - you may use e.g. @JSON_OPTIONS[true], @JSON_OPTIONS[false], + // @JSON_OPTIONS_FAST_STRICTJSON or @JSON_OPTIONS_FAST_EXTENDED + PDocVariantOptions = ^TDocVariantOptions; + +const + /// some convenient TDocVariant options, as JSON_OPTIONS[CopiedByReference] + // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default + // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions + // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency + JSON_OPTIONS: array[Boolean] of TDocVariantOptions = ( + [dvoReturnNullForUnknownProperty], + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]); + + /// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions + // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency + // - as used by _JsonFast() + JSON_OPTIONS_FAST = + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]; + + /// same as JSON_OPTIONS_FAST, but including dvoAllowDoubleValue to parse any float + // - as used by _JsonFastFloat() + JSON_OPTIONS_FAST_FLOAT = + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,dvoAllowDoubleValue]; + + /// TDocVariant options which may be used for plain JSON parsing + // - this won't recognize any extended syntax + JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions = + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoJSONParseDoNotTryCustomVariants]; + + /// TDocVariant options to be used for case-sensitive TSynNameValue-like + // storage, with optional extended JSON syntax serialization + // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects + JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = ( + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoNameCaseSensitive], + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoNameCaseSensitive,dvoSerializeAsExtendedJson]); + + /// TDocVariant options to be used for case-sensitive TSynNameValue-like + // storage, RawUTF8 interning and optional extended JSON syntax serialization + // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects, + // or JSON_OPTIONS_NAMEVALUE[] if you don't expect names and values interning + JSON_OPTIONS_NAMEVALUEINTERN: array[boolean] of TDocVariantOptions = ( + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoNameCaseSensitive,dvoInternNames,dvoInternValues], + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoNameCaseSensitive,dvoInternNames,dvoInternValues, + dvoSerializeAsExtendedJson]); + + /// TDocVariant options to be used so that JSON serialization would + // use the unquoted JSON syntax for field names + // - you could use it e.g. on a TSQLRecord variant published field to + // reduce the JSON escape process during storage in the database, by + // customizing your TSQLModel instance: + // ! (aModel.Props[TSQLMyRecord]['VariantProp'] as TSQLPropInfoRTTIVariant). + // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; + // or - in a cleaner way - by overriding TSQLRecord.InternalDefineModel(): + // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); + // ! begin + // ! (Props.Fields.ByName('VariantProp') as TSQLPropInfoRTTIVariant). + // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; + // ! end; + // or to set all variant fields at once: + // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); + // ! begin + // ! Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED); + // ! end; + // - consider using JSON_OPTIONS_NAMEVALUE[true] for case-sensitive + // TSynNameValue-like storage, or JSON_OPTIONS_FAST_EXTENDEDINTERN if you + // expect RawUTF8 names and values interning + JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions = + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoSerializeAsExtendedJson]; + + /// TDocVariant options for JSON serialization with efficient storage + // - i.e. unquoted JSON syntax for field names and RawUTF8 interning + // - may be used e.g. for efficient persistence of similar data + // - consider using JSON_OPTIONS_FAST_EXTENDED if you don't expect + // RawUTF8 names and values interning, or need BSON variants parsing + JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions = + [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, + dvoSerializeAsExtendedJson,dvoJSONParseDoNotTryCustomVariants, + dvoInternNames,dvoInternValues]; + +{$endif NOVARIANTS} + +const + /// TDynArrayKind alias for a pointer field hashing / comparison + djPointer = {$ifdef CPU64}djInt64{$else}djCardinal{$endif}; + + /// TDynArrayKind alias for a TObject field hashing / comparison + djObject = djPointer; + +type + /// the available JSON format, for TTextWriter.AddJSONReformat() and its + // JSONBufferReformat() and JSONReformat() wrappers + // - jsonCompact is the default machine-friendly single-line layout + // - jsonHumanReadable will add line feeds and indentation, for a more + // human-friendly result + // - jsonUnquotedPropName will emit the jsonHumanReadable layout, but + // with all property names being quoted only if necessary: this format + // could be used e.g. for configuration files - this format, similar to the + // one used in the MongoDB extended syntax, is not JSON compatible: do not + // use it e.g. with AJAX clients, but is would be handled as expected by all + // our units as valid JSON input, without previous correction + // - jsonUnquotedPropNameCompact will emit single-line layout with unquoted + // property names + TTextWriterJSONFormat = ( + jsonCompact, jsonHumanReadable, + jsonUnquotedPropName, jsonUnquotedPropNameCompact); + + TDynArrayObjArray = (oaUnknown, oaFalse, oaTrue); + + /// a wrapper around a dynamic array with one dimension + // - provide TList-like methods using fast RTTI information + // - can be used to fast save/retrieve all memory content to a TStream + // - note that the "const Elem" is not checked at compile time nor runtime: + // you must ensure that Elem matchs the element type of the dynamic array + // - can use external Count storage to make Add() and Delete() much faster + // (avoid most reallocation of the memory buffer) + // - Note that TDynArray is just a wrapper around an existing dynamic array: + // methods can modify the content of the associated variable but the TDynArray + // doesn't contain any data by itself. It is therefore aimed to initialize + // a TDynArray wrapper on need, to access any existing dynamic array. + // - is defined as an object or as a record, due to a bug + // in Delphi 2009/2010 compiler (at least): this structure is not initialized + // if defined as an object on the stack, but will be as a record :( + {$ifdef UNDIRECTDYNARRAY}TDynArray = record + {$else}TDynArray = object {$endif} + private + fValue: PPointer; + fTypeInfo: pointer; + fElemType{$ifdef DYNARRAYELEMTYPE2}, fElemType2{$endif}: pointer; + fCountP: PInteger; + fCompare: TDynArraySortCompare; + fElemSize: cardinal; + fKnownSize: integer; + fParser: integer; // index to GlobalJSONCustomParsers.fParsers[] + fSorted: boolean; + fKnownType: TDynArrayKind; + fIsObjArray: TDynArrayObjArray; + function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} + procedure SetCount(aCount: PtrInt); + function GetCapacity: PtrInt; {$ifdef HASINLINE}inline;{$endif} + procedure SetCapacity(aCapacity: PtrInt); + procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif} + function FindIndex(const Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): PtrInt; + function GetArrayTypeName: RawUTF8; + function GetArrayTypeShort: PShortString; + function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif} + function ComputeIsObjArray: boolean; + procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif} + function LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; + function LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; + /// faster than RTL + handle T*ObjArray + ensure unique + procedure InternalSetLength(OldLength,NewLength: PtrUInt); + public + /// initialize the wrapper with a one-dimension dynamic array + // - the dynamic array must have been defined with its own type + // (e.g. TIntegerDynArray = array of Integer) + // - if aCountPointer is set, it will be used instead of length() to store + // the dynamic array items count - it will be much faster when adding + // elements to the array, because the dynamic array won't need to be + // resized each time - but in this case, you should use the Count property + // instead of length(array) or high(array) when accessing the data: in fact + // length(array) will store the memory size reserved, not the items count + // - if aCountPointer is set, its content will be set to 0, whatever the + // array length is, or the current aCountPointer^ value is + // - a sample usage may be: + // !var DA: TDynArray; + // ! A: TIntegerDynArray; + // !begin + // ! DA.Init(TypeInfo(TIntegerDynArray),A); + // ! (...) + // - a sample usage may be (using a count variable): + // !var DA: TDynArray; + // ! A: TIntegerDynArray; + // ! ACount: integer; + // ! i: integer; + // !begin + // ! DA.Init(TypeInfo(TIntegerDynArray),A,@ACount); + // ! for i := 1 to 100000 do + // ! DA.Add(i); // MUCH faster using the ACount variable + // ! (...) // now you should use DA.Count or Count instead of length(A) + procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil); + /// initialize the wrapper with a one-dimension dynamic array + // - this version accepts to specify how comparison should occur, using + // TDynArrayKind kind of first field + // - djNone and djCustom are too vague, and will raise an exception + // - no RTTI check is made over the corresponding array layout: you shall + // ensure that the aKind parameter matches the dynamic array element definition + // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison + procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; + aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); + /// define the reference to an external count integer variable + // - Init and InitSpecific methods will reset the aCountPointer to 0: you + // can use this method to set the external count variable without overriding + // the current value + procedure UseExternalCount(var aCountPointer: Integer); + {$ifdef HASINLINE}inline;{$endif} + /// low-level computation of KnownType and KnownSize fields from RTTI + // - do nothing if has already been set at initialization, or already computed + function GuessKnownType(exactType: boolean=false): TDynArrayKind; + /// check this dynamic array from the GlobalJSONCustomParsers list + // - returns TRUE if this array has a custom JSON parser + function HasCustomJSONParser: boolean; + /// initialize the wrapper to point to no dynamic array + procedure Void; + /// check if the wrapper points to a dynamic array + function IsVoid: boolean; + /// add an element to the dynamic array + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Add(i+10) e.g.) + // - returns the index of the added element in the dynamic array + // - note that because of dynamic array internal memory managment, adding + // may reallocate the list every time a record is added, unless an external + // count variable has been specified in Init(...,@Count) method + function Add(const Elem): PtrInt; + /// add an element to the dynamic array + // - this version add a void element to the array, and returns its index + // - note: if you use this method to add a new item with a reference to the + // dynamic array, using a local variable is needed under FPC: + // ! i := DynArray.New; + // ! with Values[i] do begin // otherwise Values is nil -> GPF + // ! Field1 := 1; + // ! ... + function New: integer; + /// add an element to the dynamic array at the position specified by Index + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Insert(10,i+10) e.g.) + procedure Insert(Index: PtrInt; const Elem); + /// get and remove the last element stored in the dynamic array + // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack + // - warning: Elem must be of the same exact type than the dynamic array + // - returns true if the item was successfully copied and removed + // - use Peek() if you don't want to remove the item + function Pop(var Dest): boolean; + /// get the last element stored in the dynamic array + // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack + // - warning: Elem must be of the same exact type than the dynamic array + // - returns true if the item was successfully copied into Dest + // - use Pop() if you also want to remove the item + function Peek(var Dest): boolean; + /// delete the whole dynamic array content + // - this method will recognize T*ObjArray types and free all instances + procedure Clear; {$ifdef HASINLINE}inline;{$endif} + /// delete the whole dynamic array content, ignoring exceptions + // - returns true if no exception occured when calling Clear, false otherwise + // - you should better not call this method, which will catch and ignore + // all exceptions - but it may somewhat make sense in a destructor + // - this method will recognize T*ObjArray types and free all instances + function ClearSafe: boolean; + /// delete one item inside the dynamic array + // - the deleted element is finalized if necessary + // - this method will recognize T*ObjArray types and free all instances + function Delete(aIndex: PtrInt): boolean; + /// search for an element value inside the dynamic array + // - return the index found (0..Count-1), or -1 if Elem was not found + // - will search for all properties content of the eLement: TList.IndexOf() + // searches by address, this method searches by content using the RTTI + // element description (and not the Compare property function) + // - use the Find() method if you want the search via the Compare property + // function, or e.g. to search only with some part of the element content + // - will work with simple types: binaries (byte, word, integer, Int64, + // Currency, array[0..255] of byte, packed records with no reference-counted + // type within...), string types (e.g. array of string), and packed records + // with binary and string types within (like TFileVersion) + // - won't work with not packed types (like a shorstring, or a record + // with byte or word fields with {$A+}): in this case, the padding data + // (i.e. the bytes between the aligned feeds can be filled as random, and + // there is no way with standard RTTI do know which they are) + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write IndexOf(i+10) e.g.) + function IndexOf(const Elem): PtrInt; + /// search for an element value inside the dynamic array + // - this method will use the Compare property function for the search + // - return the index found (0..Count-1), or -1 if Elem was not found + // - if the array is sorted, it will use fast O(log(n)) binary search + // - if the array is not sorted, it will use slower O(n) iterating search + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Find(i+10) e.g.) + function Find(const Elem): PtrInt; overload; + /// search for an element value inside the dynamic array, from an external + // indexed lookup table + // - return the index found (0..Count-1), or -1 if Elem was not found + // - this method will use a custom comparison function, with an external + // integer table, as created by the CreateOrderedIndex() method: it allows + // multiple search orders in the same dynamic array content + // - if an indexed lookup is supplied, it must already be sorted: + // this function will then use fast O(log(n)) binary search + // - if an indexed lookup is not supplied (i.e aIndex=nil), + // this function will use slower but accurate O(n) iterating search + // - warning; the lookup index should be synchronized if array content + // is modified (in case of adding or deletion) + function Find(const Elem; const aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare): PtrInt; overload; + /// search for an element value, then fill all properties if match + // - this method will use the Compare property function for the search, + // or the supplied indexed lookup table and its associated compare function + // - if Elem content matches, all Elem fields will be filled with the record + // - can be used e.g. as a simple dictionary: if Compare will match e.g. the + // first string field (i.e. set to SortDynArrayString), you can fill the + // first string field with the searched value (if returned index is >= 0) + // - return the index found (0..Count-1), or -1 if Elem was not found + // - if the array is sorted, it will use fast O(log(n)) binary search + // - if the array is not sorted, it will use slower O(n) iterating search + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Find(i+10) e.g.) + function FindAndFill(var Elem; aIndex: PIntegerDynArray=nil; + aCompare: TDynArraySortCompare=nil): integer; + /// search for an element value, then delete it if match + // - this method will use the Compare property function for the search, + // or the supplied indexed lookup table and its associated compare function + // - if Elem content matches, this item will be deleted from the array + // - can be used e.g. as a simple dictionary: if Compare will match e.g. the + // first string field (i.e. set to SortDynArrayString), you can fill the + // first string field with the searched value (if returned index is >= 0) + // - return the index deleted (0..Count-1), or -1 if Elem was not found + // - if the array is sorted, it will use fast O(log(n)) binary search + // - if the array is not sorted, it will use slower O(n) iterating search + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Find(i+10) e.g.) + function FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil; + aCompare: TDynArraySortCompare=nil): integer; + /// search for an element value, then update the item if match + // - this method will use the Compare property function for the search, + // or the supplied indexed lookup table and its associated compare function + // - if Elem content matches, this item will be updated with the supplied value + // - can be used e.g. as a simple dictionary: if Compare will match e.g. the + // first string field (i.e. set to SortDynArrayString), you can fill the + // first string field with the searched value (if returned index is >= 0) + // - return the index found (0..Count-1), or -1 if Elem was not found + // - if the array is sorted, it will use fast O(log(n)) binary search + // - if the array is not sorted, it will use slower O(n) iterating search + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Find(i+10) e.g.) + function FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil; + aCompare: TDynArraySortCompare=nil): integer; + /// search for an element value, then add it if none matched + // - this method will use the Compare property function for the search, + // or the supplied indexed lookup table and its associated compare function + // - if no Elem content matches, the item will added to the array + // - can be used e.g. as a simple dictionary: if Compare will match e.g. the + // first string field (i.e. set to SortDynArrayString), you can fill the + // first string field with the searched value (if returned index is >= 0) + // - return the index found (0..Count-1), or -1 if Elem was not found and + // the supplied element has been succesfully added + // - if the array is sorted, it will use fast O(log(n)) binary search + // - if the array is not sorted, it will use slower O(n) iterating search + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write Find(i+10) e.g.) + function FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil; + aCompare: TDynArraySortCompare=nil): integer; + /// sort the dynamic array elements, using the Compare property function + // - it will change the dynamic array content, and exchange all elements + // in order to be sorted in increasing order according to Compare function + procedure Sort(aCompare: TDynArraySortCompare=nil); overload; + /// sort some dynamic array elements, using the Compare property function + // - this method allows to sort only some part of the items + // - it will change the dynamic array content, and exchange all elements + // in order to be sorted in increasing order according to Compare function + procedure SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare=nil); + /// sort the dynamic array elements, using a Compare method (not function) + // - it will change the dynamic array content, and exchange all elements + // in order to be sorted in increasing order according to Compare function, + // unless aReverse is true + // - it won't mark the array as Sorted, since the comparer is local + procedure Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean=false); overload; + /// search the elements range which match a given value in a sorted dynamic array + // - this method will use the Compare property function for the search + // - returns TRUE and the matching indexes, or FALSE if none found + // - if the array is not sorted, returns FALSE + function FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; + /// search for an element value inside a sorted dynamic array + // - this method will use the Compare property function for the search + // - will be faster than a manual FindAndAddIfNotExisting+Sort process + // - returns TRUE and the index of existing Elem, or FALSE and the index + // where the Elem is to be inserted so that the array remains sorted + // - you should then call FastAddSorted() later with the returned Index + // - if the array is not sorted, returns FALSE and Index=-1 + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (no FastLocateSorted(i+10) e.g.) + function FastLocateSorted(const Elem; out Index: Integer): boolean; + /// insert a sorted element value at the proper place + // - the index should have been computed by FastLocateSorted(): false + // - you may consider using FastLocateOrAddSorted() instead + procedure FastAddSorted(Index: Integer; const Elem); + /// search and add an element value inside a sorted dynamic array + // - this method will use the Compare property function for the search + // - will be faster than a manual FindAndAddIfNotExisting+Sort process + // - returns the index of the existing Elem and wasAdded^=false + // - returns the sorted index of the inserted Elem and wasAdded^=true + // - if the array is not sorted, returns -1 and wasAdded^=false + // - is just a wrapper around FastLocateSorted+FastAddSorted + function FastLocateOrAddSorted(const Elem; wasAdded: PBoolean=nil): integer; + /// delete a sorted element value at the proper place + // - plain Delete(Index) would reset the fSorted flag to FALSE, so use + // this method with a FastLocateSorted/FastAddSorted array + procedure FastDeleteSorted(Index: Integer); + /// will reverse all array elements, in place + procedure Reverse; + /// sort the dynamic array elements using a lookup array of indexes + // - in comparison to the Sort method, this CreateOrderedIndex won't change + // the dynamic array content, but only create (or update) the supplied + // integer lookup array, using the specified comparison function + // - if aCompare is not supplied, the method will use fCompare (if defined) + // - you should provide either a void either a valid lookup table, that is + // a table with one to one lookup (e.g. created with FillIncreasing) + // - if the lookup table has less elements than the main dynamic array, + // its content will be recreated + procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); overload; + /// sort the dynamic array elements using a lookup array of indexes + // - this overloaded method will use the supplied TSynTempBuffer for + // index storage, so use PIntegerArray(aIndex.buf) to access the values + // - caller should always make aIndex.Done once done + procedure CreateOrderedIndex(out aIndex: TSynTempBuffer; + aCompare: TDynArraySortCompare); overload; + /// sort using a lookup array of indexes, after a Add() + // - will resize aIndex if necessary, and set aIndex[Count-1] := Count-1 + procedure CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); + /// save the dynamic array content into a (memory) stream + // - will handle array of binaries values (byte, word, integer...), array of + // strings or array of packed records, with binaries and string properties + // - will use a proprietary binary format, with some variable-length encoding + // of the string length - note that if you change the type definition, any + // previously-serialized content will fail, maybe triggering unexpected GPF: + // use SaveToTypeInfoHash if you share this binary data accross executables + // - Stream position will be set just after the added data + // - is optimized for memory streams, but will work with any kind of TStream + procedure SaveToStream(Stream: TStream); + /// load the dynamic array content from a (memory) stream + // - stream content must have been created using SaveToStream method + // - will handle array of binaries values (byte, word, integer...), array of + // strings or array of packed records, with binaries and string properties + // - will use a proprietary binary format, with some variable-length encoding + // of the string length - note that if you change the type definition, any + // previously-serialized content will fail, maybe triggering unexpected GPF: + // use SaveToTypeInfoHash if you share this binary data accross executables + procedure LoadFromStream(Stream: TCustomMemoryStream); + /// save the dynamic array content into an allocated memory buffer + // - Dest buffer must have been allocated to contain at least the number + // of bytes returned by the SaveToLength method + // - return a pointer at the end of the data written in Dest, nil in case + // of an invalid input buffer + // - will use a proprietary binary format, with some variable-length encoding + // of the string length - note that if you change the type definition, any + // previously-serialized content will fail, maybe triggering unexpected GPF: + // use SaveToTypeInfoHash if you share this binary data accross executables + // - this method will raise an ESynException for T*ObjArray types + // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer + function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; + /// compute the number of bytes needed by SaveTo() to persist a dynamic array + // - will use a proprietary binary format, with some variable-length encoding + // of the string length - note that if you change the type definition, any + // previously-serialized content will fail, maybe triggering unexpected GPF: + // use SaveToTypeInfoHash if you share this binary data accross executables + // - this method will raise an ESynException for T*ObjArray types + function SaveToLength: integer; + /// save the dynamic array content into a RawByteString + // - will use a proprietary binary format, with some variable-length encoding + // of the string length - note that if you change the type definition, any + // previously-serialized content will fail, maybe triggering unexpected GPF: + // use SaveToTypeInfoHash if you share this binary data accross executables + // - this method will raise an ESynException for T*ObjArray types + // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer + function SaveTo: RawByteString; overload; + /// compute a crc32c-based hash of the RTTI for this dynamic array + // - can be used to ensure that the TDynArray.SaveTo binary layout + // is compatible accross executables + // - won't include the RTTI type kind, as TypeInfoToHash(), but only + // ElemSize or ElemType information, or any previously registered + // TTextWriter.RegisterCustomJSONSerializerFromText definition + function SaveToTypeInfoHash(crc: cardinal=0): cardinal; + /// unserialize dynamic array content from binary written by TDynArray.SaveTo + // - return nil if the Source buffer is incorrect: invalid type, wrong + // checksum, or optional SourceMax overflow + // - return a non nil pointer just after the Source content on success + // - this method will raise an ESynException for T*ObjArray types + // - you can optionally call AfterEach callback for each row loaded + // - if you don't want to allocate all items on memory, but just want to + // iterate over all items stored in a TDynArray.SaveTo memory buffer, + // consider using TDynArrayLoadFrom object + function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; + NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; + /// unserialize the dynamic array content from a TDynArray.SaveTo binary string + // - same as LoadFrom, and will check for any buffer overflow since we + // know the actual end of input buffer + function LoadFromBinary(const Buffer: RawByteString; + NoCheckHash: boolean=false): boolean; + /// serialize the dynamic array content as JSON + // - is just a wrapper around TTextWriter.AddDynArrayJSON() + // - this method will therefore recognize T*ObjArray types + function SaveToJSON(EnumSetsAsText: boolean=false; + reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + /// serialize the dynamic array content as JSON + // - is just a wrapper around TTextWriter.AddDynArrayJSON() + // - this method will therefore recognize T*ObjArray types + procedure SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean=false; + reformat: TTextWriterJSONFormat=jsonCompact); overload; + /// load the dynamic array content from an UTF-8 encoded JSON buffer + // - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e. + // handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray, + // TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray, + // TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, + // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, + // TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized + // valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer + // - or any other kind of array as Base64 encoded binary stream precessed + // via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code) + // - typical handled content could be + // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' + // - return a pointer at the end of the data read from P, nil in case + // of an invalid input buffer + // - this method will recognize T*ObjArray types, and will first free + // any existing instance before unserializing, to avoid memory leak + // - warning: the content of P^ will be modified during parsing: please + // make a local copy if it will be needed later (using e.g. TSynTempBufer) + function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; + {$ifndef NOVARIANTS} + /// load the dynamic array content from a TDocVariant instance + // - will convert the TDocVariant into JSON, the call LoadFromJSON + function LoadFromVariant(const DocVariant: variant): boolean; + {$endif NOVARIANTS} + /// select a sub-section (slice) of a dynamic array content + procedure Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0); + /// add elements from a given dynamic array variable + // - the supplied source DynArray MUST be of the same exact type as the + // current used for this TDynArray - warning: pass here a reference to + // a "array of ..." variable, not another TDynArray instance; if you + // want to add another TDynArray, use AddDynArray() method + // - you can specify the start index and the number of items to take from + // the source dynamic array (leave as -1 to add till the end) + // - returns the number of items added to the array + function AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1): integer; + {$ifndef DELPHI5OROLDER} + /// fast initialize a wrapper for an existing dynamic array of the same type + // - is slightly faster than + // ! Init(aAnother.ArrayType,aValue,nil); + procedure InitFrom(const aAnother: TDynArray; var aValue); + {$ifdef HASINLINE}inline;{$endif} + /// add elements from a given TDynArray + // - the supplied source TDynArray MUST be of the same exact type as the + // current used for this TDynArray, otherwise it won't do anything + // - you can specify the start index and the number of items to take from + // the source dynamic array (leave as -1 to add till the end) + procedure AddDynArray(const aSource: TDynArray; aStartIndex: integer=0; aCount: integer=-1); + /// compare the content of the two arrays, returning TRUE if both match + // - this method compares using any supplied Compare property (unless + // ignorecompare=true), or by content using the RTTI element description + // of the whole array items + // - will call SaveToJSON to compare T*ObjArray kind of arrays + function Equals(const B: TDynArray; ignorecompare: boolean=false): boolean; + /// set all content of one dynamic array to the current array + // - both must be of the same exact type + // - T*ObjArray will be reallocated and copied by content (using a temporary + // JSON serialization), unless ObjArrayByRef is true and pointers are copied + procedure Copy(const Source: TDynArray; ObjArrayByRef: boolean=false); + /// set all content of one dynamic array to the current array + // - both must be of the same exact type + // - T*ObjArray will be reallocated and copied by content (using a temporary + // JSON serialization), unless ObjArrayByRef is true and pointers are copied + procedure CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean=false); + /// set all content of the current dynamic array to another array variable + // - both must be of the same exact type + // - resulting length(Dest) will match the exact items count, even if an + // external Count integer variable is used by this instance + // - T*ObjArray will be reallocated and copied by content (using a temporary + // JSON serialization), unless ObjArrayByRef is true and pointers are copied + procedure CopyTo(out Dest; ObjArrayByRef: boolean=false); + {$endif DELPHI5OROLDER} + /// returns a pointer to an element of the array + // - returns nil if aIndex is out of range + // - since TDynArray is just a wrapper around an existing array, you should + // better use direct access to its wrapped variable, and not using this + // slower and more error prone method (such pointer access lacks of strong + // typing abilities), which was designed for TDynArray internal use + function ElemPtr(index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} + /// will copy one element content from its index into another variable + // - do nothing if index is out of range + procedure ElemCopyAt(index: PtrInt; var Dest); {$ifdef FPC}inline;{$endif} + /// will move one element content from its index into another variable + // - will erase the internal item after copy + // - do nothing if index is out of range + procedure ElemMoveTo(index: PtrInt; var Dest); + /// will copy one variable content into an indexed element + // - do nothing if index is out of range + // - ClearBeforeCopy will call ElemClear() before the copy, which may be safer + // if the source item is a copy of Values[index] with some dynamic arrays + procedure ElemCopyFrom(const Source; index: PtrInt; + ClearBeforeCopy: boolean=false); {$ifdef FPC}inline;{$endif} + /// compare the content of two elements, returning TRUE if both values equal + // - this method compares first using any supplied Compare property, + // then by content using the RTTI element description of the whole record + function ElemEquals(const A,B): boolean; + /// will reset the element content + procedure ElemClear(var Elem); + /// will copy one element content + procedure ElemCopy(const A; var B); {$ifdef FPC}inline;{$endif} + /// will copy the first field value of an array element + // - will use the array KnownType to guess the copy routine to use + // - returns false if the type information is not enough for a safe copy + function ElemCopyFirstField(Source,Dest: Pointer): boolean; + /// save an array element into a serialized binary content + // - use the same layout as TDynArray.SaveTo, but for a single item + // - you can use ElemLoad method later to retrieve its content + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write ElemSave(i+10) e.g.) + function ElemSave(const Elem): RawByteString; + /// load an array element as saved by the ElemSave method into Elem variable + // - warning: Elem must be of the same exact type than the dynamic array, + // and must be a reference to a variable (you can't write ElemLoad(P,i+10) e.g.) + procedure ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar=nil); overload; + /// load an array element as saved by the ElemSave method + // - this overloaded method will retrieve the element as a memory buffer, + // which should be cleared by ElemLoadClear() before release + function ElemLoad(Source: PAnsiChar; SourceMax: PAnsiChar=nil): RawByteString; overload; + /// search for an array element as saved by the ElemSave method + // - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear() + // - will call Find() method if Compare property is set + // - will call generic IndexOf() method if no Compare property is set + function ElemLoadFind(Source: PAnsiChar; SourceMax: PAnsiChar=nil): integer; + /// finalize a temporary buffer used to store an element via ElemLoad() + // - will release any managed type referenced inside the RawByteString, + // then void the variable + // - is just a wrapper around ElemClear(pointer(ElemTemp)) + ElemTemp := '' + procedure ElemLoadClear(var ElemTemp: RawByteString); + + /// retrieve or set the number of elements of the dynamic array + // - same as length(DynArray) or SetLength(DynArray) + // - this property will recognize T*ObjArray types, so will free any stored + // instance if the array is sized down + property Count: PtrInt read GetCount write SetCount; + /// the internal buffer capacity + // - if no external Count pointer was set with Init, is the same as Count + // - if an external Count pointer is set, you can set a value to this + // property before a massive use of the Add() method e.g. + // - if no external Count pointer is set, set a value to this property + // will affect the Count value, i.e. Add() will append after this count + // - this property will recognize T*ObjArray types, so will free any stored + // instance if the array is sized down + property Capacity: PtrInt read GetCapacity write SetCapacity; + /// the compare function to be used for Sort and Find methods + // - by default, no comparison function is set + // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean, + // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, + // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString, + // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI, + // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI + property Compare: TDynArraySortCompare read fCompare write SetCompare; + /// must be TRUE if the array is currently in sorted order according to + // the compare function + // - Add/Delete/Insert/Load* methods will reset this property to false + // - Sort method will set this property to true + // - you MUST set this property to false if you modify the dynamic array + // content in your code, so that Find() won't try to wrongly use binary + // search in an unsorted array, and miss its purpose + property Sorted: boolean read fSorted write fSorted; + /// low-level direct access to the storage variable + property Value: PPointer read fValue; + /// the first field recognized type + // - could have been set at initialization, or after a GuessKnownType call + property KnownType: TDynArrayKind read fKnownType; + /// the raw storage size of the first field KnownType + property KnownSize: integer read fKnownSize; + /// the known RTTI information of the whole array + property ArrayType: pointer read fTypeInfo; + /// the known type name of the whole array, as RawUTF8 + property ArrayTypeName: RawUTF8 read GetArrayTypeName; + /// the known type name of the whole array, as PShortString + property ArrayTypeShort: PShortString read GetArrayTypeShort; + /// the internal in-memory size of one element, as retrieved from RTTI + property ElemSize: cardinal read fElemSize; + /// the internal type information of one element, as retrieved from RTTI + property ElemType: pointer read fElemType; + /// if this dynamic aray is a T*ObjArray + property IsObjArray: boolean read GetIsObjArray write SetIsObjArray; + end; + /// a pointer to a TDynArray wrapper instance + PDynArray = ^TDynArray; + + /// allows to iterate over a TDynArray.SaveTo binary buffer + // - may be used as alternative to TDynArray.LoadFrom, if you don't want + // to allocate all items at once, but retrieve items one by one + TDynArrayLoadFrom = object + protected + DynArray: TDynArray; // used to access RTTI + Hash: PCardinalArray; + PositionEnd: PAnsiChar; + public + /// how many items were saved in the TDynArray.SaveTo binary buffer + // - equals -1 if Init() failed to unserialize its header + Count: integer; + /// the zero-based index of the current item pointed by next Step() call + // - is in range 0..Count-1 until Step() returns false + Current: integer; + /// current position in the TDynArray.SaveTo binary buffer + // - after Step() returned false, points just after the binary buffer, + // like a regular TDynArray.LoadFrom + Position: PAnsiChar; + /// initialize iteration over a TDynArray.SaveTo binary buffer + // - returns true on success, with Count and Position being set + // - returns false if the supplied binary buffer is not correct + // - you can specify an optional SourceMaxLen to avoid any buffer overflow + function Init(ArrayTypeInfo: pointer; Source: PAnsiChar; + SourceMaxLen: PtrInt=0): boolean; overload; + /// initialize iteration over a TDynArray.SaveTo binary buffer + // - returns true on success, with Count and Position being set + // - returns false if the supplied binary buffer is not correct + function Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; overload; + /// iterate over the current stored item + // - Elem should point to a variable of the exact item type stored in this + // dynamic array + // - returns true if Elem was filled with one value, or false if all + // items were read, and Position contains the end of the binary buffer + function Step(out Elem): boolean; + /// extract the first field value of the current stored item + // - returns true if Field was filled with one value, or false if all + // items were read, and Position contains the end of the binary buffer + // - could be called before Step(), to pre-allocate a new item instance, + // or update an existing instance + function FirstField(out Field): boolean; + /// after all items are read by Step(), validate the stored hash + // - returns true if items hash is correct, false otherwise + function CheckHash: boolean; + end; + + /// function prototype to be used for hashing of a dynamic array element + // - this function must use the supplied hasher on the Elem data + TDynArrayHashOne = function(const Elem; Hasher: THasher): cardinal; + + /// event handler to be used for hashing of a dynamic array element + // - can be set as an alternative to TDynArrayHashOne + TEventDynArrayHashOne = function(const Elem): cardinal of object; + + {.$define DYNARRAYHASHCOLLISIONCOUNT} + + /// allow O(1) lookup to any dynamic array content + // - this won't handle the storage process (like add/update), just efficiently + // maintain a hash table over an existing dynamic array: several TDynArrayHasher + // could be applied to a single TDynArray wrapper + // - TDynArrayHashed will use a TDynArrayHasher for its own store + {$ifdef USERECORDWITHMETHODS}TDynArrayHasher = record + {$else}TDynArrayHasher = object {$endif} + private + DynArray: PDynArray; + HashElement: TDynArrayHashOne; + EventHash: TEventDynArrayHashOne; + Hasher: THasher; + HashTable: TIntegerDynArray; // store 0 for void entry, or Index+1 + HashTableSize: integer; + ScanCounter: integer; // Scan()>=0 up to CountTrigger*2 + State: set of (hasHasher, canHash); + function HashTableIndex(aHashCode: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif} + procedure HashAdd(aHashCode: cardinal; var result: integer); + procedure HashDelete(aArrayIndex, aHashTableIndex: integer; aHashCode: cardinal); + procedure RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal); + public + /// associated item comparison - may differ from DynArray^.Compare + Compare: TDynArraySortCompare; + /// custom method-based comparison function + EventCompare: TEventDynArraySortCompare; + /// after how many FindBeforeAdd() or Scan() the hashing starts - default 32 + CountTrigger: integer; + {$ifdef DYNARRAYHASHCOLLISIONCOUNT} + /// low-level access to an hash collisions counter + FindCollisions: cardinal; + {$endif} + /// initialize the hash table for a given dynamic array storage + // - you can call this method several times, e.g. if aCaseInsensitive changed + procedure Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; + aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; + aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); + /// initialize a known hash table for a given dynamic array storage + // - you can call this method several times, e.g. if aCaseInsensitive changed + procedure InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; aCaseInsensitive: boolean); + /// allow custom hashing via a method event + procedure SetEventHash(const event: TEventDynArrayHashOne); + /// search for an element value inside the dynamic array without hashing + // - trigger hashing if ScanCounter reaches CountTrigger*2 + function Scan(Elem: pointer): integer; + /// search for an element value inside the dynamic array with hashing + function Find(Elem: pointer): integer; overload; + /// search for a hashed element value inside the dynamic array with hashing + function Find(Elem: pointer; aHashCode: cardinal): integer; overload; + /// search for a hash position inside the dynamic array with hashing + function Find(aHashCode: cardinal; aForAdd: boolean): integer; overload; + /// returns position in array, or next void index in HashTable[] as -(index+1) + function FindOrNew(aHashCode: cardinal; Elem: pointer; aHashTableIndex: PInteger=nil): integer; + /// search an hashed element value for adding, updating the internal hash table + // - trigger hashing if Count reaches CountTrigger + function FindBeforeAdd(Elem: pointer; out wasAdded: boolean; aHashCode: cardinal): integer; + /// search and delete an element value, updating the internal hash table + function FindBeforeDelete(Elem: pointer): integer; + /// reset the hash table - no rehash yet + procedure Clear; + /// full computation of the internal hash table + // - returns the number of duplicated values found + function ReHash(forced: boolean): integer; + /// compute the hash of a given item + function HashOne(Elem: pointer): cardinal; {$ifdef FPC_OR_DELPHIXE4}inline;{$endif} + { not inlined to circumvent Delphi 2007=C1632, 2010=C1872, XE3=C2130 } + /// retrieve the low-level hash of a given item + function GetHashFromIndex(aIndex: PtrInt): cardinal; + end; + + /// pointer to a TDynArrayHasher instance + PDynArrayHasher = ^TDynArrayHasher; + + /// used to access any dynamic arrray elements using fast hash + // - by default, binary sort could be used for searching items for TDynArray: + // using a hash is faster on huge arrays for implementing a dictionary + // - in this current implementation, modification (update or delete) of an + // element is not handled yet: you should rehash all content - only + // TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate / + // FindHashedAndDelete will refresh the internal hash + // - this object extends the TDynArray type, since presence of Hashs[] dynamic + // array will increase code size if using TDynArrayHashed instead of TDynArray + // - in order to have the better performance, you should use an external Count + // variable, AND set the Capacity property to the expected maximum count (this + // will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate) + {$ifdef UNDIRECTDYNARRAY} + TDynArrayHashed = record + // pseudo inheritance for most used methods + private + function GetCount: PtrInt; inline; + procedure SetCount(aCount: PtrInt) ; inline; + procedure SetCapacity(aCapacity: PtrInt); inline; + function GetCapacity: PtrInt; inline; + public + InternalDynArray: TDynArray; + function Value: PPointer; inline; + function ElemSize: PtrUInt; inline; + function ElemType: Pointer; inline; + function KnownType: TDynArrayKind; inline; + procedure Clear; inline; + procedure ElemCopy(const A; var B); inline; + function ElemPtr(index: PtrInt): pointer; inline; + procedure ElemCopyAt(index: PtrInt; var Dest); inline; + // warning: you shall call ReHash() after manual Add/Delete + function Add(const Elem): integer; inline; + procedure Delete(aIndex: PtrInt); inline; + function SaveTo: RawByteString; overload; inline; + function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline; + function SaveToJSON(EnumSetsAsText: boolean=false; + reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; inline; + procedure Sort(aCompare: TDynArraySortCompare=nil); inline; + function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; inline; + function SaveToLength: integer; inline; + function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; + NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; inline; + function LoadFromBinary(const Buffer: RawByteString; + NoCheckHash: boolean=false): boolean; inline; + procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); + property Count: PtrInt read GetCount write SetCount; + property Capacity: PtrInt read GetCapacity write SetCapacity; + private + {$else UNDIRECTDYNARRAY} + TDynArrayHashed = object(TDynArray) + protected + {$endif UNDIRECTDYNARRAY} + fHash: TDynArrayHasher; + procedure SetEventHash(const event: TEventDynArrayHashOne); {$ifdef HASINLINE}inline;{$endif} + function GetHashFromIndex(aIndex: PtrInt): Cardinal; {$ifdef HASINLINE}inline;{$endif} + public + /// initialize the wrapper with a one-dimension dynamic array + // - this version accepts some hash-dedicated parameters: aHashElement to + // set how to hash each element, aCompare to handle hash collision + // - if no aHashElement is supplied, it will hash according to the RTTI, i.e. + // strings or binary types, and the first field for records (strings included) + // - if no aCompare is supplied, it will use default Equals() method + // - if no THasher function is supplied, it will use the one supplied in + // DefaultHasher global variable, set to crc32c() by default - using + // SSE4.2 instruction if available + // - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit + // alphabetic characters (e.g. compare 'a' and 'A' as equal) + procedure Init(aTypeInfo: pointer; var aValue; + aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; + aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); + /// initialize the wrapper with a one-dimension dynamic array + // - this version accepts to specify how both hashing and comparison should + // occur, setting the TDynArrayKind kind of first/hashed field + // - djNone and djCustom are too vague, and will raise an exception + // - no RTTI check is made over the corresponding array layout: you shall + // ensure that aKind matches the dynamic array element definition + // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison + procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; + aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); + /// will compute all hash from the current elements of the dynamic array + // - is called within the TDynArrayHashed.Init method to initialize the + // internal hash array + // - can be called on purpose, when modifications have been performed on + // the dynamic array content (e.g. in case of element deletion or update, + // or after calling LoadFrom/Clear method) - this is not necessary after + // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods + // - returns the number of duplicated items found - which won't be available + // by hashed FindHashed() by definition + function ReHash(forAdd: boolean=false): integer; + /// search for an element value inside the dynamic array using hashing + // - Elem should be of the type expected by both the hash function and + // Equals/Compare methods: e.g. if the searched/hashed field in a record is + // a string as first field, you can safely use a string variable as Elem + // - Elem must refer to a variable: e.g. you can't write FindHashed(i+10) + // - will call fHashElement(Elem,fHasher) to compute the needed hash + // - returns -1 if not found, or the index in the dynamic array if found + function FindHashed(const Elem): integer; + /// search for an element value inside the dynamic array using its hash + // - returns -1 if not found, or the index in the dynamic array if found + // - aHashCode parameter constains an already hashed value of the item, + // to be used e.g. after a call to HashFind() + function FindFromHash(const Elem; aHashCode: cardinal): integer; + /// search for an element value inside the dynamic array using hashing, and + // fill Elem with the found content + // - return the index found (0..Count-1), or -1 if Elem was not found + // - ElemToFill should be of the type expected by the dynamic array, since + // all its fields will be set on match + function FindHashedAndFill(var ElemToFill): integer; + /// search for an element value inside the dynamic array using hashing, and + // add a void entry to the array if was not found (unless noAddEntry is set) + // - this method will use hashing for fast retrieval + // - Elem should be of the type expected by both the hash function and + // Equals/Compare methods: e.g. if the searched/hashed field in a record is + // a string as first field, you can safely use a string variable as Elem + // - returns either the index in the dynamic array if found (and set wasAdded + // to false), either the newly created index in the dynamic array (and set + // wasAdded to true) + // - for faster process (avoid ReHash), please set the Capacity property + // - warning: in contrast to the Add() method, if an entry is added to the + // array (wasAdded=true), the entry is left VOID: you must set the field + // content to expecting value - in short, Elem is used only for searching, + // not copied to the newly created entry in the array - check + // FindHashedAndUpdate() for a method actually copying Elem fields + function FindHashedForAdding(const Elem; out wasAdded: boolean; + noAddEntry: boolean=false): integer; overload; + /// search for an element value inside the dynamic array using hashing, and + // add a void entry to the array if was not found (unless noAddEntry is set) + // - overloaded method acepting an already hashed value of the item, to be used + // e.g. after a call to HashFind() + function FindHashedForAdding(const Elem; out wasAdded: boolean; + aHashCode: cardinal; noAddEntry: boolean=false): integer; overload; + /// ensure a given element name is unique, then add it to the array + // - expected element layout is to have a RawUTF8 field at first position + // - the aName is searched (using hashing) to be unique, and if not the case, + // an ESynException.CreateUTF8() is raised with the supplied arguments + // - use internaly FindHashedForAdding method + // - this version will set the field content with the unique value + // - returns a pointer to the newly added element (to set other fields) + function AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8; + const ExceptionArgs: array of const; aNewIndex: PInteger=nil): pointer; overload; + /// ensure a given element name is unique, then add it to the array + // - just a wrapper to AddUniqueName(aName,'',[],aNewIndex) + function AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger=nil): pointer; overload; + /// search for a given element name, make it unique, and add it to the array + // - expected element layout is to have a RawUTF8 field at first position + // - the aName is searched (using hashing) to be unique, and if not the case, + // some suffix is added to make it unique + // - use internaly FindHashedForAdding method + // - this version will set the field content with the unique value + // - returns a pointer to the newly added element (to set other fields) + function AddAndMakeUniqueName(aName: RawUTF8): pointer; + /// search for an element value inside the dynamic array using hashing, then + // update any matching item, or add the item if none matched + // - by design, hashed field shouldn't have been modified by this update, + // otherwise the method won't be able to find and update the old hash: in + // this case, you should first call FindHashedAndDelete(OldElem) then + // FindHashedForAdding(NewElem) to properly handle the internal hash table + // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1), + // or -1 if Elem was not found - update will force slow rehash all content + // - if AddIfNotExisting is TRUE, returns the index found (0..Count-1), + // or the index newly created/added is the Elem value was not matching - + // add won't rehash all content - for even faster process (avoid ReHash), + // please set the Capacity property + // - Elem should be of the type expected by the dynamic array, since its + // content will be copied into the dynamic array, and it must refer to a + // variable: e.g. you can't write FindHashedAndUpdate(i+10) + function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; + /// search for an element value inside the dynamic array using hashing, and + // delete it if matchs + // - return the index deleted (0..Count-1), or -1 if Elem was not found + // - can optionally copy the deleted item to FillDeleted^ before erased + // - Elem should be of the type expected by both the hash function and + // Equals/Compare methods, and must refer to a variable: e.g. you can't + // write FindHashedAndDelete(i+10) + // - it won't call slow ReHash but refresh the hash table as needed + function FindHashedAndDelete(const Elem; FillDeleted: pointer=nil; + noDeleteEntry: boolean=false): integer; + /// will search for an element value inside the dynamic array without hashing + // - is used internally when Count < HashCountTrigger + // - is preferred to Find(), since EventCompare would be used if defined + // - Elem should be of the type expected by both the hash function and + // Equals/Compare methods, and must refer to a variable: e.g. you can't + // write Scan(i+10) + // - returns -1 if not found, or the index in the dynamic array if found + // - an internal algorithm can switch to hashing if Scan() is called often, + // even if the number of items is lower than HashCountTrigger + function Scan(const Elem): integer; + /// retrieve the hash value of a given item, from its index + property Hash[aIndex: PtrInt]: Cardinal read GetHashFromIndex; + /// alternative event-oriented Compare function to be used for Sort and Find + // - will be used instead of Compare, to allow object-oriented callbacks + property EventCompare: TEventDynArraySortCompare read fHash.EventCompare write fHash.EventCompare; + /// custom hash function to be used for hashing of a dynamic array element + property HashElement: TDynArrayHashOne read fHash.HashElement; + /// alternative event-oriented Hash function for ReHash + // - this object-oriented callback will be used instead of HashElement + // on each dynamic array entries - HashElement will still be used on + // const Elem values, since they may be just a sub part of the stored entry + property EventHash: TEventDynArrayHashOne read fHash.EventHash write SetEventHash; + /// after how many items the hashing take place + // - for smallest arrays, O(n) search if faster than O(1) hashing, since + // maintaining internal hash table has some CPU and memory costs + // - internal search is able to switch to hashing if it founds out that it + // may have some benefit, e.g. if Scan() is called 2*HashCountTrigger times + // - equals 32 by default, i.e. start hashing when Count reaches 32 or + // manual Scan() is called 64 times + property HashCountTrigger: integer read fHash.CountTrigger write fHash.CountTrigger; + /// access to the internal hash table + // - you can call e.g. Hasher.Clear to invalidate the whole hash table + property Hasher: TDynArrayHasher read fHash; + end; + + + /// defines a wrapper interface around a dynamic array of TObject + // - implemented by TObjectDynArrayWrapper for instance + // - i.e. most common methods are available to work with a dynamic array + // - warning: the IObjectDynArray MUST be defined in the stack, class or + // record BEFORE the dynamic array it is wrapping, otherwise you may leak + // memory - see for instance TSQLRestServer class: + // ! fSessionAuthentications: IObjectDynArray; // defined before the array + // ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray; + // note that allocation time as variable on the local stack may depend on the + // compiler, and its optimization + IObjectDynArray = interface + ['{A0D50BD0-0D20-4552-B365-1D63393511FC}'] + /// search one element within the TObject instances + function Find(Instance: TObject): integer; + /// add one element to the dynamic array of TObject instances + // - once added, the Instance will be owned by this TObjectDynArray instance + function Add(Instance: TObject): integer; + /// delete one element from the TObject dynamic array + // - deleted TObject instance will be freed as expected + procedure Delete(Index: integer); + /// sort the dynamic array content according to a specified comparer + procedure Sort(Compare: TDynArraySortCompare); + /// delete all TObject instances, and release the memory + // - is not to be called for most use, thanks to reference-counting memory + // handling, but can be handy for quick release + procedure Clear; + /// ensure the internal list capacity is set to the current Count + // - may be used to publish the associated dynamic array with the expected + // final size, once IObjectDynArray is out of scope + procedure Slice; + /// returns the number of TObject instances available + // - note that the length of the associated dynamic array is used to store + // the capacity of the list, so won't probably never match with this value + function Count: integer; + /// returns the internal array capacity of TObject instances available + // - which is in fact the length() of the associated dynamic array + function Capacity: integer; + end; + + /// a wrapper to own a dynamic array of TObject + // - this version behave list a TObjectList (i.e. owning the class instances) + // - but the dynamic array is NOT owned by the instance + // - will define an internal Count property, using the dynamic array length + // as capacity: adding and deleting will be much faster + // - implements IObjectDynArray, so that most common methods are available + // to work with the dynamic array + // - does not need any sub-classing of generic overhead to work, and will be + // reference counted + // - warning: the IObjectDynArray MUST be defined in the stack, class or + // record BEFORE the dynamic array it is wrapping, otherwise you may leak + // memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException + // - warning: issues with Delphi 10.4 Sydney were reported, which seemed to + // change the order of fields finalization, so the whole purpose of this + // wrapper may have become incompatible with Delphi 10.4 and up + // - a sample usage may be: + // !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself + // ! A: array of TMyObject; + // ! i: integer; + // !begin + // ! DA := TObjectDynArrayWrapper.Create(A); + // ! DA.Add(TMyObject.Create('one')); + // ! DA.Add(TMyObject.Create('two')); + // ! DA.Delete(0); + // ! assert(DA.Count=1); + // ! assert(A[0].Name='two'); + // ! DA.Clear; + // ! assert(DA.Count=0); + // ! DA.Add(TMyObject.Create('new')); + // ! assert(DA.Count=1); + // !end; // will auto-release DA (no need of try..finally DA.Free) + TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray) + protected + fValue: PPointer; + fCount: integer; + fOwnObjects: boolean; + public + /// initialize the wrapper with a one-dimension dynamic array of TObject + // - by default, objects will be owned by this class, but you may set + // aOwnObjects=false if you expect the dynamic array to remain available + constructor Create(var aValue; aOwnObjects: boolean=true); + /// will release all associated TObject instances + destructor Destroy; override; + /// search one element within the TObject instances + function Find(Instance: TObject): integer; + /// add one element to the dynamic array of TObject instances + // - once added, the Instance will be owned by this TObjectDynArray instance + // (unless aOwnObjects was false in Create) + function Add(Instance: TObject): integer; + /// delete one element from the TObject dynamic array + // - deleted TObject instance will be freed as expected (unless aOwnObjects + // was defined as false in Create) + procedure Delete(Index: integer); + /// sort the dynamic array content according to a specified comparer + procedure Sort(Compare: TDynArraySortCompare); + /// delete all TObject instances, and release the memory + // - is not to be called for most use, thanks to reference-counting memory + // handling, but can be handy for quick release + // - warning: won't release the instances if aOwnObjects was false in Create + procedure Clear; + /// ensure the internal list capacity is set to the current Count + // - may be used to publish the associated dynamic array with the expected + // final size, once IObjectDynArray is out of scope + procedure Slice; + /// returns the number of TObject instances available + // - note that the length() of the associated dynamic array is used to store + // the capacity of the list, so won't probably never match with this value + function Count: integer; + /// returns the internal array capacity of TObject instances available + // - which is in fact the length() of the associated dynamic array + function Capacity: integer; + end; + + /// abstract parent class with a virtual constructor, ready to be overridden + // to initialize the instance + // - you can specify such a class if you need an object including published + // properties (like TPersistent) with a virtual constructor (e.g. to + // initialize some nested class properties) + TPersistentWithCustomCreate = class(TPersistent) + public + /// this virtual constructor will be called at instance creation + // - this constructor does nothing, but is declared as virtual so that + // inherited classes may safely override this default void implementation + constructor Create; virtual; + end; + + {$M+} + /// abstract parent class with threadsafe implementation of IInterface and + // a virtual constructor + // - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if + // you need an interfaced object with a virtual constructor, ready to be + // overridden to initialize the instance + TInterfacedObjectWithCustomCreate = class(TInterfacedObject) + public + /// this virtual constructor will be called at instance creation + // - this constructor does nothing, but is declared as virtual so that + // inherited classes may safely override this default void implementation + constructor Create; virtual; + /// used to mimic TInterfacedObject reference counting + // - Release=true will call TInterfacedObject._Release + // - Release=false will call TInterfacedObject._AddRef + // - could be used to emulate proper reference counting of the instance + // via interfaces variables, but still storing plain class instances + // (e.g. in a global list of instances) + procedure RefCountUpdate(Release: boolean); virtual; + end; + + /// our own empowered TPersistent-like parent class + // - TPersistent has an unexpected speed overhead due a giant lock introduced + // to manage property name fixup resolution (which we won't use outside the VCL) + // - this class has a virtual constructor, so is a preferred alternative + // to both TPersistent and TPersistentWithCustomCreate classes + // - for best performance, any type inheriting from this class will bypass + // some regular steps: do not implement interfaces or use TMonitor with them! + TSynPersistent = class(TObject) + protected + // this default implementation will call AssignError() + procedure AssignTo(Dest: TSynPersistent); virtual; + procedure AssignError(Source: TSynPersistent); + public + /// this virtual constructor will be called at instance creation + // - this constructor does nothing, but is declared as virtual so that + // inherited classes may safely override this default void implementation + constructor Create; virtual; + /// allows to implement a TPersistent-like assignement mechanism + // - inherited class should override AssignTo() protected method + // to implement the proper assignment + procedure Assign(Source: TSynPersistent); virtual; + /// optimized initialization code + // - somewhat faster than the regular RTL implementation - especially + // since rewritten in pure asm on Delphi/x86 + // - warning: this optimized version won't initialize the vmtIntfTable + // for this class hierarchy: as a result, you would NOT be able to + // implement an interface with a TSynPersistent descendent (but you should + // not need to, but inherit from TInterfacedObject) + // - warning: under FPC, it won't initialize fields management operators + class function NewInstance: TObject; override; + {$ifndef FPC_OR_PUREPASCAL} + /// optimized x86 asm finalization code + // - warning: this version won't release either any allocated TMonitor + // (as available since Delphi 2009) - do not use TMonitor with + // TSynPersistent, but rather the faster TSynPersistentLock class + procedure FreeInstance; override; + {$endif} + end; + {$M-} + + /// simple and efficient TList, without any notification + // - regular TList has an internal notification mechanism which slows down + // basic process, and most used methods were not defined as virtual, so can't + // be easily inherited + // - stateless methods (like Add/Clear/Exists/Remove) are defined as virtual + // since can be overriden e.g. by TSynObjectListLocked to add a TSynLocker + TSynList = class(TSynPersistent) + protected + fCount: integer; + fList: TPointerDynArray; + function Get(index: Integer): pointer; {$ifdef HASINLINE} inline; {$endif} + public + /// add one item to the list + function Add(item: pointer): integer; virtual; + /// delete all items of the list + procedure Clear; virtual; + /// delete one item from the list + procedure Delete(index: integer); virtual; + /// fast retrieve one item in the list + function IndexOf(item: pointer): integer; virtual; + /// fast check if one item exists in the list + function Exists(item: pointer): boolean; virtual; + /// fast delete one item in the list + function Remove(item: pointer): integer; virtual; + /// how many items are stored in this TList instance + property Count: integer read fCount; + /// low-level access to the items stored in this TList instance + property List: TPointerDynArray read fList; + /// low-level array-like access to the items stored in this TList instance + // - warning: if index is out of range, will return nil and won't raise + // any exception + property Items[index: Integer]: pointer read Get; default; + end; + + /// simple and efficient TObjectList, without any notification + TSynObjectList = class(TSynList) + protected + fOwnObjects: boolean; + public + /// initialize the object list + constructor Create(aOwnObjects: boolean=true); reintroduce; + /// delete one object from the list + procedure Delete(index: integer); override; + /// delete all objects of the list + procedure Clear; override; + /// delete all objects of the list in reverse order + // - for some kind of processes, owned objects should be removed from the + // last added to the first + procedure ClearFromLast; virtual; + /// finalize the store items + destructor Destroy; override; + end; + + /// allow to add cross-platform locking methods to any class instance + // - typical use is to define a Safe: TSynLocker property, call Safe.Init + // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock + // methods in a try ... finally section + // - in respect to the TCriticalSection class, fix a potential CPU cache line + // conflict which may degrade the multi-threading performance, as reported by + // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection + // - internal padding is used to safely store up to 7 values protected + // from concurrent access with a mutex, so that SizeOf(TSynLocker)>128 + // - for object-level locking, see TSynPersistentLock which owns one such + // instance, or call low-level fSafe := NewSynLocker in your constructor, + // then fSafe^.DoneAndFreemem in your destructor + TSynLocker = object + protected + fSection: TRTLCriticalSection; + fLockCount: integer; + fInitialized: boolean; + {$ifndef NOVARIANTS} + function GetVariant(Index: integer): Variant; + procedure SetVariant(Index: integer; const Value: Variant); + function GetInt64(Index: integer): Int64; + procedure SetInt64(Index: integer; const Value: Int64); + function GetBool(Index: integer): boolean; + procedure SetBool(Index: integer; const Value: boolean); + function GetUnlockedInt64(Index: integer): Int64; + procedure SetUnlockedInt64(Index: integer; const Value: Int64); + function GetPointer(Index: integer): Pointer; + procedure SetPointer(Index: integer; const Value: Pointer); + function GetUTF8(Index: integer): RawUTF8; + procedure SetUTF8(Index: integer; const Value: RawUTF8); + function GetIsLocked: boolean; {$ifdef HASINLINE}inline;{$endif} + {$endif NOVARIANTS} + public + /// number of values stored in the internal Padding[] array + // - equals 0 if no value is actually stored, or a 1..7 number otherwise + // - you should not have to use this field, but for optimized low-level + // direct access to Padding[] values, within a Lock/UnLock safe block + PaddingUsedCount: integer; + /// internal padding data, also used to store up to 7 variant values + // - this memory buffer will ensure no CPU cache line mixup occurs + // - you should not use this field directly, but rather the Locked[], + // LockedInt64[], LockedUTF8[] or LockedPointer[] methods + // - if you want to access those array values, ensure you protect them + // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure, + // and maintain the PaddingUsedCount field accurately + Padding: array[0..6] of TVarData; + /// initialize the mutex + // - calling this method is mandatory (e.g. in the class constructor owning + // the TSynLocker instance), otherwise you may encounter unexpected + // behavior, like access violations or memory leaks + procedure Init; + /// finalize the mutex + // - calling this method is mandatory (e.g. in the class destructor owning + // the TSynLocker instance), otherwise you may encounter unexpected + // behavior, like access violations or memory leaks + procedure Done; + /// finalize the mutex, and call FreeMem() on the pointer of this instance + // - should have been initiazed with a NewSynLocker call + procedure DoneAndFreeMem; + /// lock the instance for exclusive access + // - this method is re-entrant from the same thread (you can nest Lock/UnLock + // calls in the same thread), but would block any other Lock attempt in + // another thread + // - use as such to avoid race condition (from a Safe: TSynLocker property): + // ! Safe.Lock; + // ! try + // ! ... + // ! finally + // ! Safe.Unlock; + // ! end; + procedure Lock; {$ifdef HASINLINE}inline;{$endif} + /// will try to acquire the mutex + // - use as such to avoid race condition (from a Safe: TSynLocker property): + // ! if Safe.TryLock then + // ! try + // ! ... + // ! finally + // ! Safe.Unlock; + // ! end; + function TryLock: boolean; {$ifdef HASINLINE}inline;{$endif} + /// will try to acquire the mutex for a given time + // - use as such to avoid race condition (from a Safe: TSynLocker property): + // ! if Safe.TryLockMS(100) then + // ! try + // ! ... + // ! finally + // ! Safe.Unlock; + // ! end; + function TryLockMS(retryms: integer): boolean; + /// release the instance for exclusive access + // - each Lock/TryLock should have its exact UnLock opposite, so a + // try..finally block is mandatory for safe code + procedure UnLock; {$ifdef HASINLINE}inline;{$endif} + /// will enter the mutex until the IUnknown reference is released + // - could be used as such under Delphi: + // !begin + // ! ... // unsafe code + // ! Safe.ProtectMethod; + // ! ... // thread-safe code + // !end; // local hidden IUnknown will release the lock for the method + // - warning: under FPC, you should assign its result to a local variable - + // see bug http://bugs.freepascal.org/view.php?id=26602 + // !var LockFPC: IUnknown; + // !begin + // ! ... // unsafe code + // ! LockFPC := Safe.ProtectMethod; + // ! ... // thread-safe code + // !end; // LockFPC will release the lock for the method + // or + // !begin + // ! ... // unsafe code + // ! with Safe.ProtectMethod do begin + // ! ... // thread-safe code + // ! end; // local hidden IUnknown will release the lock for the method + // !end; + function ProtectMethod: IUnknown; + /// returns true if the mutex is currently locked by another thread + property IsLocked: boolean read GetIsLocked; + /// returns true if the Init method has been called for this mutex + // - is only relevant if the whole object has been previously filled with 0, + // i.e. as part of a class or as global variable, but won't be accurate + // when allocated on stack + property IsInitialized: boolean read fInitialized; + {$ifndef NOVARIANTS} + /// safe locked access to a Variant value + // - you may store up to 7 variables, using an 0..6 index, shared with + // LockedBool, LockedInt64, LockedPointer and LockedUTF8 array properties + // - returns null if the Index is out of range + property Locked[Index: integer]: Variant read GetVariant write SetVariant; + /// safe locked access to a Int64 value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedUTF8 array properties + // - Int64s will be stored internally as a varInt64 variant + // - returns nil if the Index is out of range, or does not store a Int64 + property LockedInt64[Index: integer]: Int64 read GetInt64 write SetInt64; + /// safe locked access to a boolean value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked, LockedInt64, LockedPointer and LockedUTF8 array properties + // - value will be stored internally as a varBoolean variant + // - returns nil if the Index is out of range, or does not store a boolean + property LockedBool[Index: integer]: boolean read GetBool write SetBool; + /// safe locked access to a pointer/TObject value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked, LockedBool, LockedInt64 and LockedUTF8 array properties + // - pointers will be stored internally as a varUnknown variant + // - returns nil if the Index is out of range, or does not store a pointer + property LockedPointer[Index: integer]: Pointer read GetPointer write SetPointer; + /// safe locked access to an UTF-8 string value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedPointer array properties + // - UTF-8 string will be stored internally as a varString variant + // - returns '' if the Index is out of range, or does not store a string + property LockedUTF8[Index: integer]: RawUTF8 read GetUTF8 write SetUTF8; + /// safe locked in-place increment to an Int64 value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedUTF8 array properties + // - Int64s will be stored internally as a varInt64 variant + // - returns the newly stored value + // - if the internal value is not defined yet, would use 0 as default value + function LockedInt64Increment(Index: integer; const Increment: Int64): Int64; + /// safe locked in-place exchange of a Variant value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedUTF8 array properties + // - returns the previous stored value, or null if the Index is out of range + function LockedExchange(Index: integer; const Value: variant): variant; + /// safe locked in-place exchange of a pointer/TObject value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedUTF8 array properties + // - pointers will be stored internally as a varUnknown variant + // - returns the previous stored value, nil if the Index is out of range, + // or does not store a pointer + function LockedPointerExchange(Index: integer; Value: pointer): pointer; + /// unsafe access to a Int64 value + // - you may store up to 7 variables, using an 0..6 index, shared with + // Locked and LockedUTF8 array properties + // - Int64s will be stored internally as a varInt64 variant + // - returns nil if the Index is out of range, or does not store a Int64 + // - you should rather call LockedInt64[] property, or use this property + // with a Lock; try ... finally UnLock block + property UnlockedInt64[Index: integer]: Int64 read GetUnlockedInt64 write SetUnlockedInt64; + {$endif NOVARIANTS} + end; + PSynLocker = ^TSynLocker; + + /// adding locking methods to a TSynPersistent with virtual constructor + // - you may use this class instead of the RTL TCriticalSection, since it + // would use a TSynLocker which does not suffer from CPU cache line conflit + TSynPersistentLock = class(TSynPersistent) + protected + fSafe: PSynLocker; // TSynLocker would increase inherited fields offset + public + /// initialize the instance, and its associated lock + constructor Create; override; + /// finalize the instance, and its associated lock + destructor Destroy; override; + /// access to the associated instance critical section + // - call Safe.Lock/UnLock to protect multi-thread access on this storage + property Safe: PSynLocker read fSafe; + end; + + /// used for backward compatibility only with existing code + TSynPersistentLocked = class(TSynPersistentLock); + + /// adding locking methods to a TInterfacedObject with virtual constructor + TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate) + protected + fSafe: PSynLocker; // TSynLocker would increase inherited fields offset + public + /// initialize the object instance, and its associated lock + constructor Create; override; + /// release the instance (including the locking resource) + destructor Destroy; override; + /// access to the locking methods of this instance + // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block + property Safe: PSynLocker read fSafe; + end; + + /// used to determine the exact class type of a TInterfacedObjectWithCustomCreate + // - could be used to create instances using its virtual constructor + TInterfacedObjectWithCustomCreateClass = class of TInterfacedObjectWithCustomCreate; + + /// used to determine the exact class type of a TPersistentWithCustomCreateClass + // - could be used to create instances using its virtual constructor + TPersistentWithCustomCreateClass = class of TPersistentWithCustomCreate; + + /// used to determine the exact class type of a TSynPersistent + // - could be used to create instances using its virtual constructor + TSynPersistentClass = class of TSynPersistent; + + + /// used to store one list of hashed RawUTF8 in TRawUTF8Interning pool + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TRawUTF8InterningSlot = record + {$else}TRawUTF8InterningSlot = object{$endif} + public + /// actual RawUTF8 storage + Value: TRawUTF8DynArray; + /// hashed access to the Value[] list + Values: TDynArrayHashed; + /// associated mutex for thread-safe process + Safe: TSynLocker; + /// initialize the RawUTF8 slot (and its Safe mutex) + procedure Init; + /// finalize the RawUTF8 slot - mainly its associated Safe mutex + procedure Done; + /// returns the interned RawUTF8 value + procedure Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal); + /// ensure the supplied RawUTF8 value is interned + procedure UniqueText(var aText: RawUTF8; aTextHash: cardinal); + /// delete all stored RawUTF8 values + procedure Clear; + /// reclaim any unique RawUTF8 values + function Clean(aMaxRefCount: integer): integer; + /// how many items are currently stored in Value[] + function Count: integer; + end; + + /// allow to store only one copy of distinct RawUTF8 values + // - thanks to the Copy-On-Write feature of string variables, this may + // reduce a lot the memory overhead of duplicated text content + // - this class is thread-safe and optimized for performance + TRawUTF8Interning = class(TSynPersistent) + protected + fPool: array of TRawUTF8InterningSlot; + fPoolLast: integer; + public + /// initialize the storage and its internal hash pools + // - aHashTables is the pool size, and should be a power of two <= 512 + constructor Create(aHashTables: integer=4); reintroduce; + /// finalize the storage + destructor Destroy; override; + /// return a RawUTF8 variable stored within this class + // - if aText occurs for the first time, add it to the internal string pool + // - if aText does exist in the internal string pool, return the shared + // instance (with its reference counter increased), to reduce memory usage + function Unique(const aText: RawUTF8): RawUTF8; overload; + /// return a RawUTF8 variable stored within this class from a text buffer + // - if aText occurs for the first time, add it to the internal string pool + // - if aText does exist in the internal string pool, return the shared + // instance (with its reference counter increased), to reduce memory usage + function Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; overload; + /// return a RawUTF8 variable stored within this class + // - if aText occurs for the first time, add it to the internal string pool + // - if aText does exist in the internal string pool, return the shared + // instance (with its reference counter increased), to reduce memory usage + procedure Unique(var aResult: RawUTF8; const aText: RawUTF8); overload; + /// return a RawUTF8 variable stored within this class from a text buffer + // - if aText occurs for the first time, add it to the internal string pool + // - if aText does exist in the internal string pool, return the shared + // instance (with its reference counter increased), to reduce memory usage + procedure Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: PtrInt); overload; + {$ifdef HASINLINE}inline;{$endif} + /// ensure a RawUTF8 variable is stored within this class + // - if aText occurs for the first time, add it to the internal string pool + // - if aText does exist in the internal string pool, set the shared + // instance (with its reference counter increased), to reduce memory usage + procedure UniqueText(var aText: RawUTF8); + {$ifndef NOVARIANTS} + /// return a variant containing a RawUTF8 stored within this class + // - similar to RawUTF8ToVariant(), but with string interning + procedure UniqueVariant(var aResult: variant; const aText: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + /// return a variant containing a RawUTF8 stored within this class + // - similar to RawUTF8ToVariant(StringToUTF8()), but with string interning + // - this method expects the text to be supplied as a VCL string, which will + // be converted into a variant containing a RawUTF8 varString instance + procedure UniqueVariantString(var aResult: variant; const aText: string); + /// return a variant, may be containing a RawUTF8 stored within this class + // - similar to TextToVariant(), but with string interning + // - first try with GetNumericVariantFromJSON(), then fallback to + // RawUTF8ToVariant() with string variable interning + procedure UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: PtrInt; + aAllowVarDouble: boolean=false); overload; + /// ensure a variant contains only RawUTF8 stored within this class + // - supplied variant should be a varString containing a RawUTF8 value + procedure UniqueVariant(var aResult: variant); overload; {$ifdef HASINLINE}inline;{$endif} + {$endif NOVARIANTS} + /// delete any previous storage pool + procedure Clear; + /// reclaim any unique RawUTF8 values + // - i.e. run a garbage collection process of all values with RefCount=1 + // by default, i.e. all string which are not used any more; you may set + // aMaxRefCount to a higher value, depending on your expecations, i.e. 2 to + // delete all string which are referenced only once outside of the pool + // - returns the number of unique RawUTF8 cleaned from the internal pool + // - to be executed on a regular basis - but not too often, since the + // process can be time consumming, and void the benefit of interning + function Clean(aMaxRefCount: integer=1): integer; + /// how many items are currently stored in this instance + function Count: integer; + end; + + /// store one Name/Value pair, as used by TSynNameValue class + TSynNameValueItem = record + /// the name of the Name/Value pair + // - this property is hashed by TSynNameValue for fast retrieval + Name: RawUTF8; + /// the value of the Name/Value pair + Value: RawUTF8; + /// any associated Pointer or numerical value + Tag: PtrInt; + end; + + /// Name/Value pairs storage, as used by TSynNameValue class + TSynNameValueItemDynArray = array of TSynNameValueItem; + + /// event handler used to convert on the fly some UTF-8 text content + TOnSynNameValueConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object; + + /// callback event used by TSynNameValue + TOnSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object; + + /// pseudo-class used to store Name/Value RawUTF8 pairs + // - use internaly a TDynArrayHashed instance for fast retrieval + // - is therefore faster than TRawUTF8List + // - is defined as an object, not as a class: you can use this in any + // class, without the need to destroy the content + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TSynNameValue = record + {$else}TSynNameValue = object {$endif} + private + fOnAdd: TOnSynNameValueNotify; + function GetBlobData: RawByteString; + procedure SetBlobData(const aValue: RawByteString); + function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif} + function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif} + function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif} + public + /// the internal Name/Value storage + List: TSynNameValueItemDynArray; + /// the number of Name/Value pairs + Count: integer; + /// low-level access to the internal storage hasher + DynArray: TDynArrayHashed; + /// initialize the storage + // - will also reset the internal List[] and the internal hash array + procedure Init(aCaseSensitive: boolean); + /// add an element to the array + // - if aName already exists, its associated Value will be updated + procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0); + /// reset content, then add all name=value pairs from a supplied .ini file + // section content + // - will first call Init(false) to initialize the internal array + // - Section can be retrieved e.g. via FindSectionFirstLine() + procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TOnSynNameValueConvertRawUTF8=nil; + OnAdd: TOnSynNameValueNotify=nil); + /// reset content, then add all name=value; CSV pairs + // - will first call Init(false) to initialize the internal array + // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled + procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='='; + ItemSep: AnsiChar=#10); + /// reset content, then add all fields from an JSON object + // - will first call Init() to initialize the internal array + // - then parse the incoming JSON object, storing all its field values + // as RawUTF8, and returning TRUE if the supplied content is correct + // - warning: the supplied JSON buffer will be decoded and modified in-place + function InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean=false): boolean; + /// reset content, then add all name, value pairs + // - will first call Init(false) to initialize the internal array + procedure InitFromNamesValues(const Names, Values: array of RawUTF8); + /// search for a Name, return the index in List + // - using fast O(1) hash algoritm + function Find(const aName: RawUTF8): integer; + /// search for the first chars of a Name, return the index in List + // - using O(n) calls of IdemPChar() function + // - here aUpperName should be already uppercase, as expected by IdemPChar() + function FindStart(const aUpperName: RawUTF8): integer; + /// search for a Value, return the index in List + // - using O(n) brute force algoritm with case-sensitive aValue search + function FindByValue(const aValue: RawUTF8): integer; + /// search for a Name, and delete its entry in the List if it exists + function Delete(const aName: RawUTF8): boolean; + /// search for a Value, and delete its entry in the List if it exists + // - returns the number of deleted entries + // - you may search for more than one match, by setting a >1 Limit value + function DeleteByValue(const aValue: RawUTF8; Limit: integer=1): integer; + /// search for a Name, return the associated Value as a UTF-8 string + function Value(const aName: RawUTF8; const aDefaultValue: RawUTF8=''): RawUTF8; + /// search for a Name, return the associated Value as integer + function ValueInt(const aName: RawUTF8; const aDefaultValue: Int64=0): Int64; + /// search for a Name, return the associated Value as boolean + // - returns true only if the value is exactly '1' + function ValueBool(const aName: RawUTF8): Boolean; + /// search for a Name, return the associated Value as an enumerate + // - returns true and set aEnum if aName was found, and associated value + // matched an aEnumTypeInfo item + // - returns false if no match was found + function ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum; + aEnumDefault: byte=0): boolean; overload; + /// returns all values, as CSV or INI content + function AsCSV(const KeySeparator: RawUTF8='='; + const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): RawUTF8; + /// returns all values as a JSON object of string fields + function AsJSON: RawUTF8; + /// fill the supplied two arrays of RawUTF8 with the stored values + procedure AsNameValues(out Names,Values: TRawUTF8DynArray); + {$ifndef NOVARIANTS} + /// search for a Name, return the associated Value as variant + // - returns null if the name was not found + function ValueVariantOrNull(const aName: RawUTF8): variant; + /// compute a TDocVariant document from the stored values + // - output variant will be reset and filled as a TDocVariant instance, + // ready to be serialized as a JSON object + // - if there is no value stored (i.e. Count=0), set null + procedure AsDocVariant(out DocVariant: variant; + ExtendedJson: boolean=false; ValueAsString: boolean=true; + AllowVarDouble: boolean=false); overload; + /// compute a TDocVariant document from the stored values + function AsDocVariant(ExtendedJson: boolean=false; ValueAsString: boolean=true): variant; overload; {$ifdef HASINLINE}inline;{$endif} + /// merge the stored values into a TDocVariant document + // - existing properties would be updated, then new values will be added to + // the supplied TDocVariant instance, ready to be serialized as a JSON object + // - if ValueAsString is TRUE, values would be stored as string + // - if ValueAsString is FALSE, numerical values would be identified by + // IsString() and stored as such in the resulting TDocVariant + // - if you let ChangedProps point to a TDocVariantData, it would contain + // an object with the stored values, just like AsDocVariant + // - returns the number of updated values in the TDocVariant, 0 if + // no value was changed + function MergeDocVariant(var DocVariant: variant; + ValueAsString: boolean; ChangedProps: PVariant=nil; + ExtendedJson: boolean=false; AllowVarDouble: boolean=false): integer; + {$endif} + /// returns true if the Init() method has been called + function Initialized: boolean; + /// can be used to set all data from one BLOB memory buffer + procedure SetBlobDataPtr(aValue: pointer); + /// can be used to set or retrieve all stored data as one BLOB content + property BlobData: RawByteString read GetBlobData write SetBlobData; + /// event triggerred after an item has just been added to the list + property OnAfterAdd: TOnSynNameValueNotify read fOnAdd write fOnAdd; + /// search for a Name, return the associated Value as a UTF-8 string + // - returns '' if aName is not found in the stored keys + property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default; + /// search for a Name, return the associated Value as integer + // - returns 0 if aName is not found, or not a valid Int64 in the stored keys + property Int[const aName: RawUTF8]: Int64 read GetInt; + /// search for a Name, return the associated Value as boolean + // - returns true if aName stores '1' as associated value + property Bool[const aName: RawUTF8]: Boolean read GetBool; + end; + + /// a reference pointer to a Name/Value RawUTF8 pairs storage + PSynNameValue = ^TSynNameValue; + +/// allocate and initialize a TSynLocker instance +// - caller should call result^.DoneAndFreemem when not used any more +function NewSynLocker: PSynLocker; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to add an item to a array of pointer dynamic array storage +function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to add once an item to a array of pointer dynamic array storage +function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; + +/// wrapper to delete an item from a array of pointer dynamic array storage +function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger=nil): integer; overload; + +/// wrapper to delete an item from a array of pointer dynamic array storage +procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger=nil); overload; + +/// wrapper to find an item to a array of pointer dynamic array storage +function PtrArrayFind(var aPtrArray; aItem: pointer): integer; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to add an item to a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - could be used as such (note the T*ObjArray type naming convention): +// ! TUserObjArray = array of TUser; +// ! ... +// ! var arr: TUserObjArray; +// ! user: TUser; +// ! .. +// ! try +// ! user := TUser.Create; +// ! user.Name := 'Name'; +// ! index := ObjArrayAdd(arr,user); +// ! ... +// ! finally +// ! ObjArrayClear(arr); // release all items +// ! end; +// - return the index of the item in the dynamic array +function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to add items to a T*ObjArray dynamic array storage +// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched +// - return the new number of the items in aDestObjArray +function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; + +/// wrapper to add and move items to a T*ObjArray dynamic array storage +// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore +// aSourceObjArray is set to nil +// - return the new number of the items in aDestObjArray +function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; + +/// wrapper to add an item to a T*ObjArray dynamic array storage +// - this overloaded function will use a separated variable to store the items +// count, so will be slightly faster: but you should call SetLength() when done, +// to have an array as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - return the index of the item in the dynamic array +function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; + +/// wrapper to add once an item to a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - if the object is already in the array (searching by address/reference, +// not by content), return its current index in the dynamic array +// - if the object does not appear in the array, add it at the end +procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); + +// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched +// - will first check if aSourceObjArray[] items are not already in aDestObjArray +// - return the new number of the items in aDestObjArray +function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; + +/// wrapper to set the length of a T*ObjArray dynamic array storage +// - could be used as an alternative to SetLength() when you do not +// know the exact T*ObjArray type +procedure ObjArraySetLength(var aObjArray; aLength: integer); + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to search an item in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - search is performed by address/reference, not by content +// - returns -1 if the item is not found in the dynamic array +function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to search an item in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - search is performed by address/reference, not by content +// - returns -1 if the item is not found in the dynamic array +function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to count all not nil items in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +function ObjArrayCount(const aObjArray): integer; + +/// wrapper to delete an item in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - do nothing if the index is out of range in the dynamic array +procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; + aContinueOnException: boolean=false; aCount: PInteger=nil); overload; + +/// wrapper to delete an item in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - search is performed by address/reference, not by content +// - do nothing if the item is not found in the dynamic array +function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload; + +/// wrapper to delete an item in a T*ObjArray dynamic array storage +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - search is performed by address/reference, not by content +// - do nothing if the item is not found in the dynamic array +function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; + +/// wrapper to sort the items stored in a T*ObjArray dynamic array +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); + +/// wrapper to release all items stored in a T*ObjArray dynamic array +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - you should always use ObjArrayClear() before the array storage is released, +// e.g. in the owner class destructor +// - will also set the dynamic array length to 0, so could be used to re-use +// an existing T*ObjArray +procedure ObjArrayClear(var aObjArray); overload; + +/// wrapper to release all items stored in a T*ObjArray dynamic array +// - this overloaded function will use the supplied array length as parameter +// - you should always use ObjArrayClear() before the array storage is released, +// e.g. in the owner class destructor +// - will also set the dynamic array length to 0, so could be used to re-use +// an existing T*ObjArray +procedure ObjArrayClear(var aObjArray; aCount: integer); overload; + +/// wrapper to release all items stored in a T*ObjArray dynamic array +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +// - you should always use ObjArrayClear() before the array storage is released, +// e.g. in the owner class destructor +// - will also set the dynamic array length to 0, so could be used to re-use +// an existing T*ObjArray +procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; + aCount: PInteger=nil); overload; + +/// wrapper to release all items stored in an array of T*ObjArray dynamic array +// - e.g. aObjArray may be defined as "array of array of TSynFilter" +procedure ObjArrayObjArrayClear(var aObjArray); + +/// wrapper to release all items stored in several T*ObjArray dynamic arrays +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +procedure ObjArraysClear(const aObjArray: array of pointer); + +/// low-level function calling FreeAndNil(o^) successively n times +procedure RawObjectsClear(o: PObject; n: integer); + +{$ifndef DELPHI5OROLDER} + +/// wrapper to add an item to a T*InterfaceArray dynamic array storage +function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; + +/// wrapper to add once an item to a T*InterfaceArray dynamic array storage +procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); + +/// wrapper to search an item in a T*InterfaceArray dynamic array storage +// - search is performed by address/reference, not by content +// - return -1 if the item is not found in the dynamic array, or the index of +// the matching entry otherwise +function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; + {$ifdef HASINLINE}inline;{$endif} + +/// wrapper to delete an item in a T*InterfaceArray dynamic array storage +// - search is performed by address/reference, not by content +// - do nothing if the item is not found in the dynamic array +function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload; + +/// wrapper to delete an item in a T*InterfaceArray dynamic array storage +// - do nothing if the item is not found in the dynamic array +procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload; + +{$endif DELPHI5OROLDER} + + +/// helper to retrieve the text of an enumerate item +// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType +function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; + +/// helper to retrieve all texts of an enumerate +// - may be used as cache for overloaded ToText() content +procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); + +/// helper to retrieve all trimmed texts of an enumerate +// - may be used as cache to retrieve UTF-8 text without lowercase 'a'..'z' chars +procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); overload; + +/// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings +function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; overload; + +/// helper to retrieve all (translated) caption texts of an enumerate +// - may be used as cache for overloaded ToCaption() content +procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); + +/// UnCamelCase and translate the enumeration item +function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; + +/// low-level helper to retrieve a (translated) caption from a PShortString +// - as used e.g. by GetEnumCaptions or GetCaptionFromEnum +procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); + +/// helper to retrieve the index of an enumerate item from its text +// - returns -1 if aValue was not found +// - will search for the exact text and also trim the lowercase 'a'..'z' chars on +// left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE +// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType +function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; + AlsoTrimLowerCase: boolean=false): Integer; overload; + +/// retrieve the index of an enumerate item from its left-trimmed text +// - text comparison is case-insensitive for A-Z characters +// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text +// - returns -1 if aValue was not found +function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; + +/// retrieve the index of an enumerate item from its left-trimmed text +// - text comparison is case-sensitive for A-Z characters +// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text +// - returns -1 if aValue was not found +function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; + +/// helper to retrieve the index of an enumerate item from its text +function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; + AlsoTrimLowerCase: boolean=false): Integer; overload; + +/// helper to retrieve the bit mapped integer value of a set from its JSON text +// - if supplied P^ is a JSON integer number, will read it directly +// - if P^ maps some ["item1","item2"] content, would fill all matching bits +// - if P^ contains ['*'], would fill all bits +// - returns P=nil if reached prematurly the end of content, or returns +// the value separator (e.g. , or }) in EndOfObject (like GetJsonField) +function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; + out EndOfObject: AnsiChar): cardinal; + +/// helper to retrieve the CSV text of all enumerate items defined in a set +// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType +function GetSetName(aTypeInfo: pointer; const value): RawUTF8; + +/// helper to retrieve the CSV text of all enumerate items defined in a set +// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType +procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; + trimlowercase: boolean=false); + +/// low-level helper to retrive the base enumeration RTTI of a given set +function GetSetBaseEnum(aTypeInfo: pointer): pointer; + +/// fast append some UTF-8 text into a shortstring, with an ending ',' +procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; + trimlowercase: boolean); + +/// fast search of an exact case-insensitive match of a RTTI's PShortString array +function FindShortStringListExact(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; + +/// fast case-insensitive search of a left-trimmed lowercase match +// of a RTTI's PShortString array +function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; + +/// fast case-sensitive search of a left-trimmed lowercase match +// of a RTTI's PShortString array +function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; + +/// retrieve the type name from its low-level RTTI +function TypeInfoToName(aTypeInfo: pointer): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// retrieve the type name from its low-level RTTI +procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; + const default: RawUTF8=''); overload; + +/// retrieve the unit name and type name from its low-level RTTI +procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; + const default: RawUTF8=''); + +/// compute a crc32c-based hash of the RTTI for a managed given type +// - can be used to ensure that the RecordSave/TDynArray.SaveTo binary layout +// is compatible accross executables, even between FPC and Delphi +// - will ignore the type names, but will check the RTTI type kind and any +// nested fields (for records or arrays) - for a record/object type, will use +// TTextWriter.RegisterCustomJSONSerializerFromText definition, if available +function TypeInfoToHash(aTypeInfo: pointer): cardinal; + +/// retrieve the record size from its low-level RTTI +function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; + +/// retrieve the item type information of a dynamic array low-level RTTI +function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; + aDataSize: PInteger=nil): pointer; + +/// sort any dynamic array, via an external array of indexes +// - this function will use the supplied TSynTempBuffer for index storage, +// so use PIntegerArray(Indexes.buf) to access the values +// - caller should always make Indexes.Done once done +procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; + out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); + +/// compare two TGUID values +// - this version is faster than the one supplied by SysUtils +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// compare two TGUID values +// - this version is faster than the one supplied by SysUtils +function IsEqualGUID(guid1, guid2: PGUID): Boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns the index of a matching TGUID in an array +// - returns -1 if no item matched +function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; + +/// check if a TGUID value contains only 0 bytes +// - this version is faster than the one supplied by SysUtils +function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// append one TGUID item to a TGUID dynamic array +// - returning the newly inserted index in guids[], or an existing index in +// guids[] if NoDuplicates is TRUE and TGUID already exists +function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; + NoDuplicates: boolean=false): integer; + +/// append a TGUID binary content as text +// - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) +// - this will be the format used for JSON encoding, e.g. +// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } +function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; + +/// convert a TGUID into UTF-8 encoded text +// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - if you do not need the embracing { }, use ToUTF8() overloaded function +function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; + +/// convert a TGUID into text +// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - this version is faster than the one supplied by SysUtils +function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; + +type + /// low-level object implementing a 32-bit Pierre L'Ecuyer software generator + // - as used by Random32gsl, and Random32 if no RDRAND hardware is available + // - is not thread-safe by itself, but cross-compiler and cross-platform, still + // very fast with a much better distribution than Delphi system's Random() function + // - Random32gsl/Random32 will use a threadvar to have thread safety + TLecuyer = object + public + rs1, rs2, rs3, seedcount: cardinal; + /// force an immediate seed of the generator from current system state + // - should be called before any call to the Next method + procedure Seed(entropy: PByteArray; entropylen: PtrInt); + /// compute the next 32-bit generated value + // - will automatically reseed after around 65,000 generated values + function Next: cardinal; overload; + /// compute the next 32-bit generated value, in range [0..max-1] + // - will automatically reseed after around 65,000 generated values + function Next(max: cardinal): cardinal; overload; + end; + +/// fast compute of some 32-bit random value +// - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if +// available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period +// is 2^88, i.e. about 10^26) if the CPU doesn't support it +// - will detect known AMD CPUs RDRAND bugs, and fallback to gsl_rng_taus2 +// - consider Random32gsl to avoid slow RDRAND call (up to 1500 cycles needed!) +// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness +// - thread-safe function: each thread will maintain its own TLecuyer table +function Random32: cardinal; overload; + +/// fast compute of some 32-bit random value, with a maximum (excluded) upper value +// - i.e. returns a value in range [0..max-1] +// - calls internally the overloaded Random32 function +function Random32(max: cardinal): cardinal; overload; + +/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator +// - Random32 may call RDRAND opcode on Intel CPUs, wherease this function will use +// well documented, much faster, and proven Pierre L'Ecuyer software generator +// - may be used if you don't want/trust RDRAND, if you expect a well defined +// cross-platform generator, or have higher performance expectations +// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness +// - thread-safe function: each thread will maintain its own TLecuyer table +function Random32gsl: cardinal; overload; + +/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator +// - calls internally the overloaded Random32gsl function +function Random32gsl(max: cardinal): cardinal; overload; + +/// seed the gsl_rng_taus2 Random32/Random32gsl generator +// - this seeding won't affect RDRAND Intel x86/x64 opcode generation +// - by default, gsl_rng_taus2 generator is re-seeded every 256KB, much more +// often than the Pierre L'Ecuyer's algorithm period of 2^88 +// - you can specify some additional entropy buffer; note that calling this +// function with the same entropy again WON'T seed the generator with the same +// sequence (as with RTL's RandomSeed function), but initiate a new one +// - thread-specific function: each thread will maintain its own seed table +procedure Random32Seed(entropy: pointer=nil; entropylen: PtrInt=0); + +/// fill some memory buffer with random values +// - the destination buffer is expected to be allocated as 32-bit items +// - use internally crc32c() with some rough entropy source, and Random32 +// gsl_rng_taus2 generator or hardware RDRAND Intel x86/x64 opcode if available +// (and ForceGsl is kept to its default false) +// - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom() +// method from the SynCrypto unit, or set ForceGsl=true - in particular, RDRAND +// is reported as very slow: see https://en.wikipedia.org/wiki/RdRand#Performance +procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; ForceGsl: boolean=false); + +/// compute a random GUID value +procedure RandomGUID(out result: TGUID); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// compute a random GUID value +function RandomGUID: TGUID; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill a GUID with 0 +procedure FillZero(var result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif} + +type + /// stack-allocated ASCII string, used by GUIDToShort() function + TGUIDShortString = string[38]; + +const + /// a TGUID containing '{00000000-0000-0000-0000-00000000000}' + GUID_NULL: TGUID = (); + +/// convert a TGUID into text +// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - using a shortstring will allow fast allocation on the stack, so is +// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() +function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} + guid: TGUID): TGUIDShortString; overload; {$ifdef HASINLINE}inline;{$endif} + +/// convert a TGUID into text +// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - using a shortstring will allow fast allocation on the stack, so is +// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() +procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} + guid: TGUID; out dest: TGUIDShortString); overload; + +/// convert some text into its TGUID binary value +// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) +// - return nil if the supplied text buffer is not a valid TGUID +// - this will be the format used for JSON encoding, e.g. +// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } +function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; + +/// convert some text into a TGUID +// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer +// is not a valid TGUID +function StringToGUID(const text: string): TGUID; + +/// convert some UTF-8 encoded text into a TGUID +// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) +// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer +// is not a valid TGUID +function RawUTF8ToGUID(const text: RawByteString): TGUID; + + +/// check equality of two records by content +// - will handle packed records, with binaries (byte, word, integer...) and +// string types properties +// - will use binary-level comparison: it could fail to match two floating-point +// values because of rounding issues (Currency won't have this problem) +function RecordEquals(const RecA, RecB; TypeInfo: pointer; + PRecSize: PInteger=nil): boolean; + +/// save a record content into a RawByteString +// - will handle packed records, with binaries (byte, word, integer...) and +// string types properties (but not with internal raw pointers, of course) +// - will use a proprietary binary format, with some variable-length encoding +// of the string length - note that if you change the type definition, any +// previously-serialized content will fail, maybe triggering unexpected GPF: you +// may use TypeInfoToHash() if you share this binary data accross executables +// - warning: will encode generic string fields as AnsiString (one byte per char) +// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi +// 2009: if you want to use this function between UNICODE and NOT UNICODE +// versions of Delphi, you should use some explicit types like RawUTF8, +// WinAnsiString, SynUnicode or even RawUnicode/WideString +function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload; + +/// save a record content into a TBytes dynamic array +// - could be used as an alternative to RawByteString's RecordSave() +function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; + +/// save a record content into a destination memory buffer +// - Dest must be at least RecordSaveLength() bytes long +// - will return the Rec size, in bytes, into Len reference variable +// - will handle packed records, with binaries (byte, word, integer...) and +// string types properties (but not with internal raw pointers, of course) +// - will use a proprietary binary format, with some variable-length encoding +// of the string length - note that if you change the type definition, any +// previously-serialized content will fail, maybe triggering unexpected GPF: you +// may use TypeInfoToHash() if you share this binary data accross executables +// - warning: will encode generic string fields as AnsiString (one byte per char) +// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi +// 2009: if you want to use this function between UNICODE and NOT UNICODE +// versions of Delphi, you should use some explicit types like RawUTF8, +// WinAnsiString, SynUnicode or even RawUnicode/WideString +function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; + out Len: integer): PAnsiChar; overload; + +/// save a record content into a destination memory buffer +// - Dest must be at least RecordSaveLength() bytes long +// - will handle packed records, with binaries (byte, word, integer...) and +// string types properties (but not with internal raw pointers, of course) +// - will use a proprietary binary format, with some variable-length encoding +// of the string length - note that if you change the type definition, any +// previously-serialized content will fail, maybe triggering unexpected GPF: you +// may use TypeInfoToHash() if you share this binary data accross executables +// - warning: will encode generic string fields as AnsiString (one byte per char) +// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi +// 2009: if you want to use this function between UNICODE and NOT UNICODE +// versions of Delphi, you should use some explicit types like RawUTF8, +// WinAnsiString, SynUnicode or even RawUnicode/WideString +function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// save a record content into a destination memory buffer +// - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer +procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); overload; + +/// save a record content into a Base-64 encoded UTF-8 text content +// - will use RecordSave() format, with a left-sided binary CRC32C +function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8; + +/// compute the number of bytes needed to save a record content +// using the RecordSave() function +// - will return 0 in case of an invalid (not handled) record type (e.g. if +// it contains an unknown variant) +// - optional Len parameter will contain the Rec memory buffer length, in bytes +function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger=nil): integer; + +/// save record into its JSON serialization as saved by TTextWriter.AddRecordJSON +// - will use default Base64 encoding over RecordSave() binary - or custom true +// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via +// enhanced RTTI), if available (following EnumSetsAsText optional parameter +// for nested enumerates and sets) +function RecordSaveJSON(const Rec; TypeInfo: pointer; + EnumSetsAsText: boolean=false): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// fill a record content from a memory buffer as saved by RecordSave() +// - return nil if the Source buffer is incorrect +// - in case of success, return the memory buffer pointer just after the +// read content, and set the Rec size, in bytes, into Len reference variable +// - will use a proprietary binary format, with some variable-length encoding +// of the string length - note that if you change the type definition, any +// previously-serialized content will fail, maybe triggering unexpected GPF: you +// may use TypeInfoToHash() if you share this binary data accross executables +// - you can optionally provide in SourceMax the first byte after the input +// memory buffer, which will be used to avoid any unexpected buffer overflow - +// would be mandatory when decoding the content from any external process +// (e.g. a maybe-forged client) - only with slightly performance penalty +function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; + Len: PInteger=nil; SourceMax: PAnsiChar=nil): PAnsiChar; overload; + +/// fill a record content from a memory buffer as saved by RecordSave() +// - will use the Source length to detect and avoid any buffer overlow +// - returns false if the Source buffer was incorrect, true on success +function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload; + +/// read a record content from a Base-64 encoded content +// - expects RecordSaveBase64() format, with a left-sided binary CRC +function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; TypeInfo: pointer; + UriCompatible: boolean=false): boolean; + +/// fill a record content from a JSON serialization as saved by +// TTextWriter.AddRecordJSON / RecordSaveJSON +// - will use default Base64 encoding over RecordSave() binary - or custom true +// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via +// enhanced RTTI), if available +// - returns nil on error, or the end of buffer on success +// - warning: the JSON buffer will be modified in-place during process - use +// a temporary copy if you need to access it later or if the string comes from +// a constant (refcount=-1) - see e.g. the overloaded RecordLoadJSON() +function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; + EndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; overload; + +/// fill a record content from a JSON serialization as saved by +// TTextWriter.AddRecordJSON / RecordSaveJSON +// - this overloaded function will make a private copy before parsing it, +// so is safe with a read/only or shared string - but slightly slower +// - will use default Base64 encoding over RecordSave() binary - or custom true +// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via +// enhanced RTTI), if available +function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; + +/// copy a record content from source to Dest +// - this unit includes a fast optimized asm version for x86 on Delphi +procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} + +/// clear a record content +// - this unit includes a fast optimized asm version for x86 on Delphi +procedure RecordClear(var Dest; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} + +/// initialize a record content +// - calls RecordClear() and FillCharFast() with 0 +// - do nothing if the TypeInfo is not from a record/object +procedure RecordZero(var Dest; TypeInfo: pointer); + +/// low-level finalization of a dynamic array of variants +// - faster than RTL Finalize() or setting nil +procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); + +/// low-level finalization of a dynamic array of RawUTF8 +// - faster than RTL Finalize() or setting nil +procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); + {$ifdef HASINLINE}inline;{$endif} + +{$ifndef DELPHI5OROLDER} +/// copy a dynamic array content from source to Dest +// - uses internally the TDynArray.CopyFrom() method and two temporary +// TDynArray wrappers +procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; + TypeInfo: pointer); +{$endif DELPHI5OROLDER} + +/// fill a dynamic array content from a binary serialization as saved by +// DynArraySave() / TDynArray.Save() +// - Value shall be set to the target dynamic array field +// - just a function helper around TDynArray.Init + TDynArray.* +function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; + +/// serialize a dynamic array content as binary, ready to be loaded by +// DynArrayLoad() / TDynArray.Load() +// - Value shall be set to the source dynamic arry field +// - just a function helper around TDynArray.Init + TDynArray.SaveTo +function DynArraySave(var Value; TypeInfo: pointer): RawByteString; + +/// fill a dynamic array content from a JSON serialization as saved by +// TTextWriter.AddDynArrayJSON +// - Value shall be set to the target dynamic array field +// - is just a wrapper around TDynArray.LoadFromJSON(), creating a temporary +// TDynArray wrapper on the stack +// - return a pointer at the end of the data read from JSON, nil in case +// of an invalid input buffer +// - to be used e.g. for custom record JSON unserialization, within a +// TDynArrayJSONCustomReader callback +// - warning: the JSON buffer will be modified in-place during process - use +// a temporary copy if you need to access it later or if the string comes from +// a constant (refcount=-1) - see e.g. the overloaded DynArrayLoadJSON() +function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; + EndOfObject: PUTF8Char=nil): PUTF8Char; overload; + +/// fill a dynamic array content from a JSON serialization as saved by +// TTextWriter.AddDynArrayJSON, which won't be modified +// - this overloaded function will make a private copy before parsing it, +// so is safe with a read/only or shared string - but slightly slower +function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload; + +/// serialize a dynamic array content as JSON +// - Value shall be set to the source dynamic array field +// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating +// a temporary TDynArray wrapper on the stack +// - to be used e.g. for custom record JSON serialization, within a +// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() +// (following EnumSetsAsText optional parameter for nested enumerates and sets) +function DynArraySaveJSON(const Value; TypeInfo: pointer; + EnumSetsAsText: boolean=false): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +{$ifndef DELPHI5OROLDER} +/// compare two dynamic arrays by calling TDynArray.Equals +function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; + Array1Count: PInteger=nil; Array2Count: PInteger=nil): boolean; +{$endif DELPHI5OROLDER} + +/// serialize a dynamic array content, supplied as raw binary buffer, as JSON +// - Value shall be set to the source dynamic array field +// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating +// a temporary TDynArray wrapper on the stack +// - to be used e.g. for custom record JSON serialization, within a +// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() +function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; + +/// compute a dynamic array element information +// - will raise an exception if the supplied RTTI is not a dynamic array +// - will return the element type name and set ElemTypeInfo otherwise +// - if there is no element type information, an approximative element type name +// will be returned (e.g. 'byte' for an array of 1 byte items), and ElemTypeInfo +// will be set to nil +// - this low-level function is used e.g. by mORMotWrappers unit +function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer=nil; + ExactType: boolean=false): RawUTF8; + +/// trim ending 'DynArray' or 's' chars from a dynamic array type name +// - used internally to guess the associated item type name +function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; + +/// was dynamic array item after RegisterCustomJSONSerializerFromTextBinaryType() +// - calls DynArrayItemTypeLen() to guess the internal type name +function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; + + +/// compare two "array of boolean" elements +function SortDynArrayBoolean(const A,B): integer; + +/// compare two "array of shortint" elements +function SortDynArrayShortint(const A,B): integer; + +/// compare two "array of byte" elements +function SortDynArrayByte(const A,B): integer; + +/// compare two "array of smallint" elements +function SortDynArraySmallint(const A,B): integer; + +/// compare two "array of word" elements +function SortDynArrayWord(const A,B): integer; + +/// compare two "array of integer" elements +function SortDynArrayInteger(const A,B): integer; + +/// compare two "array of cardinal" elements +function SortDynArrayCardinal(const A,B): integer; + +/// compare two "array of Int64" or "array of Currency" elements +function SortDynArrayInt64(const A,B): integer; + +/// compare two "array of QWord" elements +// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you +// should better use this function or CompareQWord() to properly compare two +// QWord values over CPUX86 +function SortDynArrayQWord(const A,B): integer; + +/// compare two "array of THash128" elements +function SortDynArray128(const A,B): integer; + +/// compare two "array of THash256" elements +function SortDynArray256(const A,B): integer; + +/// compare two "array of THash512" elements +function SortDynArray512(const A,B): integer; + +/// compare two "array of TObject/pointer" elements +function SortDynArrayPointer(const A,B): integer; + +/// compare two "array of single" elements +function SortDynArraySingle(const A,B): integer; + +/// compare two "array of double" elements +function SortDynArrayDouble(const A,B): integer; + +/// compare two "array of AnsiString" elements, with case sensitivity +function SortDynArrayAnsiString(const A,B): integer; + +/// compare two "array of RawByteString" elements, with case sensitivity +// - can't use StrComp() or similar functions since RawByteString may contain #0 +function SortDynArrayRawByteString(const A,B): integer; + +/// compare two "array of AnsiString" elements, with no case sensitivity +function SortDynArrayAnsiStringI(const A,B): integer; + +/// compare two "array of PUTF8Char/PAnsiChar" elements, with case sensitivity +function SortDynArrayPUTF8Char(const A,B): integer; + +/// compare two "array of PUTF8Char/PAnsiChar" elements, with no case sensitivity +function SortDynArrayPUTF8CharI(const A,B): integer; + +/// compare two "array of WideString/UnicodeString" elements, with case sensitivity +function SortDynArrayUnicodeString(const A,B): integer; + +/// compare two "array of WideString/UnicodeString" elements, with no case sensitivity +function SortDynArrayUnicodeStringI(const A,B): integer; + +/// compare two "array of generic string" elements, with case sensitivity +// - the expected string type is the generic VCL string +function SortDynArrayString(const A,B): integer; + +/// compare two "array of generic string" elements, with no case sensitivity +// - the expected string type is the generic VCL string +function SortDynArrayStringI(const A,B): integer; + +/// compare two "array of TFileName" elements, as file names +// - i.e. with no case sensitivity, and grouped by file extension +// - the expected string type is the generic RTL string, i.e. TFileName +// - calls internally GetFileNameWithoutExt() and AnsiCompareFileName() +function SortDynArrayFileName(const A,B): integer; + +{$ifndef NOVARIANTS} +/// compare two "array of variant" elements, with case sensitivity +function SortDynArrayVariant(const A,B): integer; + +/// compare two "array of variant" elements, with no case sensitivity +function SortDynArrayVariantI(const A,B): integer; + +/// compare two "array of variant" elements, with or without case sensitivity +// - this low-level function is called by SortDynArrayVariant/VariantCompare +// - more optimized than the RTL function if A and B share the same type +function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; +{$endif NOVARIANTS} + + +{$ifdef CPU32DELPHI} +const + /// defined for inlining bitwise division in TDynArrayHasher.HashTableIndex + // - HashTableSize<=HASH_PO2 is expected to be a power of two (fast binary op); + // limit is set to 262,144 hash table slots (=1MB), for Capacity=131,072 items + // - above this limit, a set of increasing primes is used; using a prime as + // hashtable modulo enhances its distribution, especially for a weak hash function + // - 64-bit CPU and FPC can efficiently compute a prime reduction using Lemire + // algorithm, so no power of two is defined on those targets + HASH_PO2 = 1 shl 18; +{$endif CPU32DELPHI} + +/// compute the 32-bit default hash of a file content +// - you can specify your own hashing function if DefaultHasher is not what you expect +function HashFile(const FileName: TFileName; Hasher: THasher=nil): cardinal; + +/// hash one AnsiString content with the suppplied Hasher() function +function HashAnsiString(const Elem; Hasher: THasher): cardinal; + +/// case-insensitive hash one AnsiString content with the suppplied Hasher() function +function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; + +/// hash one SynUnicode content with the suppplied Hasher() function +// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ +function HashSynUnicode(const Elem; Hasher: THasher): cardinal; + +/// case-insensitive hash one SynUnicode content with the suppplied Hasher() function +// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ +function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; + +/// hash one WideString content with the suppplied Hasher() function +// - work with WideString for all Delphi versions +function HashWideString(const Elem; Hasher: THasher): cardinal; + +/// case-insensitive hash one WideString content with the suppplied Hasher() function +// - work with WideString for all Delphi versions +function HashWideStringI(const Elem; Hasher: THasher): cardinal; + +{$ifdef UNICODE} +/// hash one UnicodeString content with the suppplied Hasher() function +// - work with UnicodeString in Delphi 2009+ +function HashUnicodeString(const Elem; Hasher: THasher): cardinal; + +/// case-insensitive hash one UnicodeString content with the suppplied Hasher() function +// - work with UnicodeString in Delphi 2009+ +function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; +{$endif UNICODE} + +{$ifndef NOVARIANTS} +/// case-sensitive hash one variant content with the suppplied Hasher() function +function HashVariant(const Elem; Hasher: THasher): cardinal; + +/// case-insensitive hash one variant content with the suppplied Hasher() function +function HashVariantI(const Elem; Hasher: THasher): cardinal; +{$endif NOVARIANTS} + +/// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function +function HashPtrUInt(const Elem; Hasher: THasher): cardinal; + +/// hash one Byte value +function HashByte(const Elem; Hasher: THasher): cardinal; + +/// hash one Word value +function HashWord(const Elem; Hasher: THasher): cardinal; + +/// hash one Integer/cardinal value - simply return the value ignore Hasher() parameter +function HashInteger(const Elem; Hasher: THasher): cardinal; + +/// hash one Int64/Qword value with the suppplied Hasher() function +function HashInt64(const Elem; Hasher: THasher): cardinal; + +/// hash one THash128 value with the suppplied Hasher() function +function Hash128(const Elem; Hasher: THasher): cardinal; + +/// hash one THash256 value with the suppplied Hasher() function +function Hash256(const Elem; Hasher: THasher): cardinal; + +/// hash one THash512 value with the suppplied Hasher() function +function Hash512(const Elem; Hasher: THasher): cardinal; + +/// hash one pointer value with the suppplied Hasher() function +// - this version is not the same as HashPtrUInt, since it will always +// use the hasher function +function HashPointer(const Elem; Hasher: THasher): cardinal; + +var + /// helper array to get the comparison function corresponding to a given + // standard array type + // - e.g. as DYNARRAY_SORTFIRSTFIELD[CaseInSensitive,djRawUTF8] + // - not to be used as such, but e.g. when inlining TDynArray methods + DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = ( + (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, + SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, + SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, + SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, + SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString, + SortDynArrayRawByteString, SortDynArrayUnicodeString, + SortDynArrayUnicodeString, SortDynArray128, SortDynArray256, + SortDynArray512, SortDynArrayPointer, + {$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil), + (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, + SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, + SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, + SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, + SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI, + SortDynArrayRawByteString, SortDynArrayUnicodeStringI, + SortDynArrayUnicodeStringI, SortDynArray128, SortDynArray256, + SortDynArray512, SortDynArrayPointer, + {$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil)); + + /// helper array to get the hashing function corresponding to a given + // standard array type + // - e.g. as DYNARRAY_HASHFIRSTFIELD[CaseInSensitive,djRawUTF8] + // - not to be used as such, but e.g. when inlining TDynArray methods + DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = ( + (nil, HashByte, HashByte, HashWord, HashInteger, + HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, + HashInt64, HashInt64, HashInt64, HashInt64, + HashAnsiString, HashAnsiString, + {$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif}, + HashAnsiString, HashWideString, HashSynUnicode, Hash128, + Hash256, Hash512, HashPointer, + {$ifndef NOVARIANTS}HashVariant,{$endif} nil), + (nil, HashByte, HashByte, HashWord, HashInteger, + HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, + HashInt64, HashInt64, HashInt64, HashInt64, + HashAnsiStringI, HashAnsiStringI, + {$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif}, + HashAnsiStringI, HashWideStringI, HashSynUnicodeI, Hash128, + Hash256, Hash512, HashPointer, + {$ifndef NOVARIANTS}HashVariantI,{$endif} nil)); + + +/// initialize the structure with a one-dimension dynamic array +// - the dynamic array must have been defined with its own type +// (e.g. TIntegerDynArray = array of Integer) +// - if aCountPointer is set, it will be used instead of length() to store +// the dynamic array items count - it will be much faster when adding +// elements to the array, because the dynamic array won't need to be +// resized each time - but in this case, you should use the Count property +// instead of length(array) or high(array) when accessing the data: in fact +// length(array) will store the memory size reserved, not the items count +// - if aCountPointer is set, its content will be set to 0, whatever the +// array length is, or the current aCountPointer^ value is +// - a typical usage could be: +// !var IntArray: TIntegerDynArray; +// !begin +// ! with DynArray(TypeInfo(TIntegerDynArray),IntArray) do +// ! begin +// ! (...) +// ! end; +// ! (...) +// ! DynArray(TypeInfo(TIntegerDynArray),IntArrayA).SaveTo +function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray; + {$ifdef HASINLINE}inline;{$endif} + +/// wrap a simple dynamic array BLOB content as stored by TDynArray.SaveTo +// - a "simple" dynamic array contains data with no reference count, e.g. byte, +// word, integer, cardinal, Int64, double or Currency +// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so +// is much faster than creating a temporary dynamic array to load the data +// - will return nil if no or invalid data, or a pointer to the data +// array otherwise, with the items number stored in Count and the individual +// element size in ElemSize (e.g. 2 for a TWordDynArray) +function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; + var Count, ElemSize: integer; NoHash32Check: boolean=false): pointer; + +/// wrap an Integer dynamic array BLOB content as stored by TDynArray.SaveTo +// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so +// is much faster than creating a temporary dynamic array to load the data +// - will return nil if no or invalid data, or a pointer to the integer +// array otherwise, with the items number stored in Count +// - sligtly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count) +function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; + NoHash32Check: boolean=false): PIntegerArray; + +/// search in a RawUTF8 dynamic array BLOB content as stored by TDynArray.SaveTo +// - same as search within TDynArray.LoadFrom() with no memory allocation nor +// memory copy: so is much faster +// - will return -1 if no match or invalid data, or the matched entry index +function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; + Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; + + +{ ****************** text buffer and JSON functions and classes ************ } + +const + /// maximum number of fields in a database Table + // - is included in SynCommons so that all DB-related work will be able to + // share the same low-level types and functions (e.g. TSQLFieldBits, + // TJSONWriter, TSynTableStatement, TSynTable, TSQLRecordProperties) + // - default is 64, but can be set to any value (64, 128, 192 and 256 optimized) + // changing the source below or using MAX_SQLFIELDS_128, MAX_SQLFIELDS_192 or + // MAX_SQLFIELDS_256 conditional directives for your project + // - this constant is used internaly to optimize memory usage in the + // generated asm code, and statically allocate some arrays for better speed + // - note that due to compiler restriction, 256 is the maximum value + // (this is the maximum number of items in a Delphi/FPC set) + {$ifdef MAX_SQLFIELDS_128} + MAX_SQLFIELDS = 128; + {$else} + {$ifdef MAX_SQLFIELDS_192} + MAX_SQLFIELDS = 192; + {$else} + {$ifdef MAX_SQLFIELDS_256} + MAX_SQLFIELDS = 256; + {$else} + MAX_SQLFIELDS = 64; + {$endif} + {$endif} + {$endif} + + /// sometimes, the ID field is included in a bits set + MAX_SQLFIELDS_INCLUDINGID = MAX_SQLFIELDS+1; + + /// UTF-8 encoded \uFFF0 special code to mark Base64 binary content in JSON + // - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes + // - as generated by BinToBase64WithMagic() functions, and expected by + // SQLParamContent() and ExtractInlineParameters() functions + // - used e.g. when transmitting TDynArray.SaveTo() content + JSON_BASE64_MAGIC = $b0bfef; + + /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON + JSON_BASE64_MAGIC_QUOTE = ord('"')+cardinal(JSON_BASE64_MAGIC) shl 8; + + /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON + // - defined as a cardinal variable to be used as: + // ! AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); + JSON_BASE64_MAGIC_QUOTE_VAR: cardinal = JSON_BASE64_MAGIC_QUOTE; + + /// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON + // - e.g. '"\uFFF12012-05-04"' pattern + // - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes + // - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions, and + // expected by SQLParamContent() and ExtractInlineParameters() functions + JSON_SQLDATE_MAGIC = $b1bfef; + + /// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON + JSON_SQLDATE_MAGIC_QUOTE = ord('"')+cardinal(JSON_SQLDATE_MAGIC) shl 8; + + ///'"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON + // - defined as a cardinal variable to be used as: + // ! AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4); + JSON_SQLDATE_MAGIC_QUOTE_VAR: cardinal = JSON_SQLDATE_MAGIC_QUOTE; + + +type + TTextWriter = class; + TTextWriterWithEcho = class; + + /// method prototype for custom serialization of a dynamic array item + // - each element of the dynamic array will be called as aValue parameter + // of this callback + // - can be used also at record level, if the record has a type information + // (i.e. shall contain a managed type within its fields) + // - to be used with TTextWriter.RegisterCustomJSONSerializer() method + // - note that the generated JSON content will be appended after a '[' and + // before a ']' as a normal JSON arrray, but each item can be any JSON + // structure (i.e. a number, a string, but also an object or an array) + // - implementation code could call aWriter.Add/AddJSONEscapeString... + // - implementation code shall follow the same exact format for the + // associated TDynArrayJSONCustomReader callback + TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object; + + /// method prototype for custom unserialization of a dynamic array item + // - each element of the dynamic array will be called as aValue parameter + // of this callback + // - can be used also at record level, if the record has a type information + // (i.e. shall contain a managed type within its fields) + // - to be used with TTextWriter.RegisterCustomJSONSerializer() method + // - implementation code could call e.g. GetJSONField() low-level function, and + // returns a pointer to the last handled element of the JSON input buffer, + // as such (aka EndOfBuffer variable as expected by GetJSONField): + // ! var V: TFV absolute aValue; + // ! begin + // ! (...) + // ! V.Detailed := UTF8ToString(GetJSONField(P,P)); + // ! if P=nil then + // ! exit; + // ! aValid := true; + // ! result := P; // ',' or ']' for last item of array + // ! end; + // - implementation code shall follow the same exact format for the + // associated TDynArrayJSONCustomWriter callback + TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue; out aValid: Boolean + {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char of object; + + /// the kind of variables handled by TJSONCustomParser + // - the last item should be ptCustom, for non simple types + TJSONCustomParserRTTIType = ( + ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended, + ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord, + ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID, + ptID, ptTimeLog, {$ifdef HASVARUSTRING} ptUnicodeString, {$endif} + {$ifndef NOVARIANTS} ptVariant, {$endif} ptWideString, ptWord, ptCustom); + + /// how TJSONCustomParser would serialize/unserialize JSON content + TJSONCustomParserSerializationOption = ( + soReadIgnoreUnknownFields, soWriteHumanReadable, + soCustomVariantCopiedByReference, soWriteIgnoreDefault); + + /// how TJSONCustomParser would serialize/unserialize JSON content + // - by default, during reading any unexpected field will stop and fail the + // process - if soReadIgnoreUnknownFields is defined, such properties will + // be ignored (can be very handy when parsing JSON from a remote service) + // - by default, JSON content will be written in its compact standard form, + // ready to be parsed by any client - you can specify soWriteHumanReadable + // so that some line feeds and indentation will make the content more readable + // - by default, internal TDocVariant variants will be copied by-value from + // one instance to another, to ensure proper safety - but it may be too slow: + // if you set soCustomVariantCopiedByReference, any internal + // TDocVariantData.VValue/VName instances will be copied by-reference, + // to avoid memory allocations, BUT it may break internal process if you change + // some values in place (since VValue/VName and VCount won't match) - as such, + // if you set this option, ensure that you use the content as read-only + // - by default, all fields are persistented, unless soWriteIgnoreDefault is + // defined and void values (e.g. "" or 0) won't be written + // - you may use TTextWriter.RegisterCustomJSONSerializerSetOptions() class + // method to customize the serialization for a given type + TJSONCustomParserSerializationOptions = set of TJSONCustomParserSerializationOption; + + TJSONCustomParserRTTI = class; + + /// an array of RTTI properties information + // - we use dynamic arrays, since all the information is static and we + // do not need to remove any RTTI information + TJSONCustomParserRTTIs = array of TJSONCustomParserRTTI; + + /// used to store additional RTTI in TJSONCustomParser internal structures + TJSONCustomParserRTTI = class + protected + fPropertyName: RawUTF8; + fFullPropertyName: RawUTF8; + fPropertyType: TJSONCustomParserRTTIType; + fCustomTypeName: RawUTF8; + fNestedProperty: TJSONCustomParserRTTIs; + fDataSize: integer; + fNestedDataSize: integer; + procedure ComputeDataSizeAfterAdd; virtual; + procedure ComputeNestedDataSize; + procedure ComputeFullPropertyName; + procedure FinalizeNestedRecord(var Data: PByte); + procedure FinalizeNestedArray(var Data: PtrUInt); + procedure AllocateNestedArray(var Data: PtrUInt; NewLength: integer); + procedure ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer); + function IfDefaultSkipped(var Value: PByte): boolean; + procedure WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; + Options: TJSONCustomParserSerializationOptions); + public + /// initialize the instance + constructor Create(const aPropertyName: RawUTF8; + aPropertyType: TJSONCustomParserRTTIType); + /// initialize an instance from the RTTI type information + // - will return an instance of this class of any inherited class + class function CreateFromRTTI(const PropertyName: RawUTF8; + Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; + /// create an instance from a specified type name + // - will return an instance of this class of any inherited class + class function CreateFromTypeName(const aPropertyName, + aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; + /// recognize a simple type from a supplied type name + // - will return ptCustom for any unknown type + // - see also TypeInfoToRttiType() function + class function TypeNameToSimpleRTTIType( + const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload; + /// recognize a simple type from a supplied type name + // - will return ptCustom for any unknown type + // - see also TypeInfoToRttiType() function + class function TypeNameToSimpleRTTIType( + TypeName: PShortString): TJSONCustomParserRTTIType; overload; + /// recognize a simple type from a supplied type name + // - will return ptCustom for any unknown type + // - see also TypeInfoToRttiType() function + class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: PtrInt; + ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; overload; + /// recognize a simple type from a supplied type information + // - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom + // - will return ptCustom for any complex type (e.g. a record) + // - see also TypeInfoToRttiType() function + class function TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; + /// recognize a ktBinary simple type from a supplied type name + // - as registered by TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType + class function TypeNameToSimpleBinary(const aTypeName: RawUTF8; + out aDataSize, aFieldSize: integer): boolean; + /// unserialize some JSON content into its binary internal representation + // - on error, returns false and P should point to the faulty text input + function ReadOneLevel(var P: PUTF8Char; var Data: PByte; + Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): boolean; virtual; + /// serialize a binary internal representation into JSON content + // - this method won't append a trailing ',' character + procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte; + Options: TJSONCustomParserSerializationOptions); virtual; + /// the associated type name, e.g. for a record + property CustomTypeName: RawUTF8 read fCustomTypeName; + /// the property name + // - may be void for the Root element + // - e.g. 'SubProp' + property PropertyName: RawUTF8 read fPropertyName; + /// the property name, including all parent elements + // - may be void for the Root element + // - e.g. 'MainProp.SubProp' + property FullPropertyName: RawUTF8 read fFullPropertyName; + /// the property type + // - support only a limited set of simple types, or ptRecord for a nested + // record, or ptArray for a nested array + property PropertyType: TJSONCustomParserRTTIType read fPropertyType; + /// the nested array of properties (if any) + // - assigned only if PropertyType is [ptRecord,ptArray] + // - is either the record type of each ptArray item: + // ! SubProp: array of record ... + // - or one NestedProperty[0] entry with PropertyName='' and PropertyType + // not in [ptRecord,ptArray]: + // ! SubPropNumber: array of integer; + // ! SubPropText: array of RawUTF8; + property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty; + end; + + /// used to store additional RTTI as a ptCustom kind of property + TJSONCustomParserCustom = class(TJSONCustomParserRTTI) + protected + fCustomTypeInfo: pointer; + public + /// initialize the instance + constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual; + /// abstract method to write the instance as JSON + procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract; + /// abstract method to read the instance from JSON + // - should return nil on parsing error + function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; virtual; abstract; + /// release any memory used by the instance + procedure FinalizeItem(Data: Pointer); virtual; + /// the associated RTTI structure + property CustomTypeInfo: pointer read fCustomTypeInfo; + end; + + /// which kind of property does TJSONCustomParserCustomSimple refer to + TJSONCustomParserCustomSimpleKnownType = ( + ktNone, ktEnumeration, ktSet, ktGUID, + ktFixedArray, ktStaticArray, ktDynamicArray, ktBinary); + + /// used to store additional RTTI for simple type as a ptCustom kind + // - this class handle currently enumerate, TGUID or static/dynamic arrays + TJSONCustomParserCustomSimple = class(TJSONCustomParserCustom) + protected + fKnownType: TJSONCustomParserCustomSimpleKnownType; + fTypeData: pointer; + fFixedSize: integer; + fNestedArray: TJSONCustomParserRTTI; + public + /// initialize the instance from the given RTTI structure + constructor Create(const aPropertyName, aCustomTypeName: RawUTF8; + aCustomType: pointer); reintroduce; + /// initialize the instance for a static array + constructor CreateFixedArray(const aPropertyName: RawUTF8; + aFixedSize: cardinal); + /// initialize the instance for a binary blob + constructor CreateBinary(const aPropertyName: RawUTF8; + aDataSize, aFixedSize: cardinal); + /// released used memory + destructor Destroy; override; + /// method to write the instance as JSON + procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; + /// method to read the instance from JSON + function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; + /// which kind of simple property this instance does refer to + property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType; + /// the element type for ktStaticArray and ktDynamicArray + property NestedArray: TJSONCustomParserRTTI read fNestedArray; + end; + + /// implement a reference to a registered record type + // - i.e. ptCustom kind of property, handled by the + // TTextWriter.RegisterCustomJSONSerializer*() internal list + TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom) + protected + fCustomTypeIndex: integer; + function GetJSONCustomParserRegistration: pointer; + public + /// initialize the instance from the given record custom serialization index + constructor Create(const aPropertyName: RawUTF8; + aCustomTypeIndex: integer); reintroduce; overload; + /// method to write the instance as JSON + procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; + /// method to read the instance from JSON + function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; + /// release any memory used by the instance + procedure FinalizeItem(Data: Pointer); override; + end; + + /// how an RTTI expression is expected to finish + TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord); + + TJSONRecordAbstract = class; + + /// used to handle additional RTTI for JSON record serialization + // - this class is used to define how a record is defined, and will work + // with any version of Delphi + // - this Abstract class is not to be used as-this, but contains all + // needed information to provide CustomWriter/CustomReader methods + // - you can use e.g. TJSONRecordTextDefinition for text-based RTTI + // manual definition, or (not yet provided) a version based on Delphi 2010+ + // new RTTI information + TJSONRecordAbstract = class + protected + /// internal storage of TJSONCustomParserRTTI instances + fItems: TSynObjectList; + fRoot: TJSONCustomParserRTTI; + fOptions: TJSONCustomParserSerializationOptions; + function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType; + const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; + public + /// initialize the class instance + constructor Create; + /// callback for custom JSON serialization + // - will follow the RTTI textual information as supplied to the constructor + procedure CustomWriter(const aWriter: TTextWriter; const aValue); + /// callback for custom JSON unserialization + // - will follow the RTTI textual information as supplied to the constructor + function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; + /// release used memory + // - when created via Compute() call, instances of this class are managed + // via a GarbageCollector() global list, so you do not need to free them + destructor Destroy; override; + /// store the RTTI information of properties at root level + // - is one instance with PropertyType=ptRecord and PropertyName='' + property Root: TJSONCustomParserRTTI read fRoot; + /// how this class would serialize/unserialize JSON content + // - by default, no option is defined + // - you can customize the expected options with the instance returned by + // TTextWriter.RegisterCustomJSONSerializerFromText() method, or via the + // TTextWriter.RegisterCustomJSONSerializerSetOptions() overloaded methods + property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions; + end; + + /// used to handle JSON record serialization using RTTI + // - is able to handle any kind of record since Delphi 2010, thanks to + // enhanced RTTI + TJSONRecordRTTI = class(TJSONRecordAbstract) + protected + fRecordTypeInfo: pointer; + function AddItemFromRTTI(const PropertyName: RawUTF8; + Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; + {$ifdef ISDELPHI2010} + procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer); + {$endif} + public + /// initialize the instance + // - you should NOT use this constructor directly, but let e.g. + // TJSONCustomParsers.TryToGetFromRTTI() create it for you + constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce; + /// the low-level address of the enhanced RTTI + property RecordTypeInfo: pointer read fRecordTypeInfo; + end; + + /// used to handle text-defined additional RTTI for JSON record serialization + // - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method + TJSONRecordTextDefinition = class(TJSONRecordAbstract) + protected + fDefinition: RawUTF8; + procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char; + PEnd: TJSONCustomParserRTTIExpectedEnd); + public + /// initialize a custom JSON serializer/unserializer from pseudo RTTI + // - you should NOT use this constructor directly, but call the FromCache() + // class function, which will use an internal definition cache + constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce; + /// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI + // - returned class instance will be cached for any further use + // - the record where the data will be stored should be defined as PACKED: + // ! type TMyRecord = packed record + // ! A,B,C: integer; + // ! D: RawUTF8; + // ! E: record; // or array of record/integer/string/... + // ! E1,E2: double; + // ! end; + // ! end; + // - only known sub types are integer, cardinal, Int64, single, double, + // currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode, + // or a nested record or dynamic array + // - RTTI textual information shall be supplied as text, with the + // same format as with a pascal record, or with some shorter variations: + // ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;'); + // ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;'); + // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer' + // or a shorter alternative syntax for records and arrays: + // ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}'); + // ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]'); + // in fact ; could be ignored: + // ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}'); + // ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]'); + // or even : could be ignored: + // ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}'); + // ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]'); + class function FromCache(aTypeInfo: pointer; + const aDefinition: RawUTF8): TJSONRecordTextDefinition; + /// the textual definition of this RTTI information + property Definition: RawUTF8 read fDefinition; + end; + + /// the available logging events, as handled by TSynLog + // - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine + // - sllInfo will log general information events + // - sllDebug will log detailed debugging information + // - sllTrace will log low-level step by step debugging information + // - sllWarning will log unexpected values (not an error) + // - sllError will log errors + // - sllEnter will log every method start + // - sllLeave will log every method exit + // - sllLastError will log the GetLastError OS message + // - sllException will log all exception raised - available since Windows XP + // - sllExceptionOS will log all OS low-level exceptions (EDivByZero, + // ERangeError, EAccessViolation...) + // - sllMemory will log memory statistics + // - sllStackTrace will log caller's stack trace (it's by default part of + // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS, + // sllLastError and sllFail) + // - sllFail was defined for TSynTestsLogged.Failed method, and can be used + // to log some customer-side assertions (may be notifications, not errors) + // - sllSQL is dedicated to trace the SQL statements + // - sllCache should be used to trace the internal caching mechanism + // - sllResult could trace the SQL results, JSON encoded + // - sllDB is dedicated to trace low-level database engine features + // - sllHTTP could be used to trace HTTP process + // - sllClient/sllServer could be used to trace some Client or Server process + // - sllServiceCall/sllServiceReturn to trace some remote service or library + // - sllUserAuth to trace user authentication (e.g. for individual requests) + // - sllCustom* items can be used for any purpose + // - sllNewRun will be written when a process opens a rotated log + // - sllDDDError will log any DDD-related low-level error information + // - sllDDDInfo will log any DDD-related low-level debugging information + // - sllMonitoring will log the statistics information (if available), + // or may be used for real-time chat among connected people to ToolsAdmin + TSynLogInfo = ( + sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError, + sllEnter, sllLeave, + sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace, + sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer, + sllServiceCall, sllServiceReturn, sllUserAuth, + sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun, + sllDDDError, sllDDDInfo, sllMonitoring); + + /// used to define a set of logging level abilities + // - i.e. a combination of none or several logging event + // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE + // to log all errors and exceptions + TSynLogInfos = set of TSynLogInfo; + + /// a dynamic array of logging event levels + TSynLogInfoDynArray = array of TSynLogInfo; + + + /// event signature for TTextWriter.OnFlushToStream callback + TOnTextWriterFlush = procedure(Text: PUTF8Char; Len: PtrInt) of object; + + /// available options for TTextWriter.WriteObject() method + // - woHumanReadable will add some line feeds and indentation to the content, + // to make it more friendly to the human eye + // - woDontStoreDefault (which is set by default for WriteObject method) will + // avoid serializing properties including a default value (JSONToObject function + // will set the default values, so it may help saving some bandwidth or storage) + // - woFullExpand will generate a debugger-friendly layout, including instance + // class name, sets/enumerates as text, and reference pointer - as used by + // TSynLog and ObjectToJSONFull() + // - woStoreClassName will add a "ClassName":"TMyClass" field + // - woStorePointer will add a "Address":"0431298A" field, and .map/.mab + // source code line number corresponding to ESynException.RaisedAt + // - woStoreStoredFalse will write the 'stored false' properties, even + // if they are marked as such (used e.g. to persist all settings on file, + // but disallow the sensitive - password - fields be logged) + // - woHumanReadableFullSetsAsStar will store an human-readable set with + // all its enumerates items set to be stored as ["*"] + // - woHumanReadableEnumSetAsComment will add a comment at the end of the + // line, containing all available values of the enumaration or set, e.g: + // $ "Enum": "Destroying", // Idle,Started,Finished,Destroying + // - woEnumSetsAsText will store sets and enumerables as text (is also + // included in woFullExpand or woHumanReadable) + // - woDateTimeWithMagic will append the JSON_SQLDATE_MAGIC (i.e. U+FFF1) + // before the ISO-8601 encoded TDateTime value + // - woDateTimeWithZSuffix will append the Z suffix to the ISO-8601 encoded + // TDateTime value, to identify the content as strict UTC value + // - TTimeLog would be serialized as Int64, unless woTimeLogAsText is defined + // - since TSQLRecord.ID could be huge Int64 numbers, they may be truncated + // on client side, e.g. to 53-bit range in JavaScript: you could define + // woIDAsIDstr to append an additional "ID_str":"##########" field + // - by default, TSQLRawBlob properties are serialized as null, unless + // woSQLRawBlobAsBase64 is defined + // - if woHideSynPersistentPassword is set, TSynPersistentWithPassword.Password + // field will be serialized as "***" to prevent security issues (e.g. in log) + // - by default, TObjectList will set the woStoreClassName for its nested + // objects, unless woObjectListWontStoreClassName is defined + // - void strings would be serialized as "", unless woDontStoreEmptyString + // is defined so that such properties would not be written + // - all inherited properties would be serialized, unless woDontStoreInherited + // is defined, and only the topmost class level properties would be serialized + // - woInt64AsHex will force Int64/QWord to be written as hexadecimal string - + // see j2oAllowInt64Hex reverse option fot Json2Object + // - woDontStore0 will avoid serializating number properties equal to 0 + TTextWriterWriteObjectOption = ( + woHumanReadable, woDontStoreDefault, woFullExpand, + woStoreClassName, woStorePointer, woStoreStoredFalse, + woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment, + woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText, + woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword, + woObjectListWontStoreClassName, woDontStoreEmptyString, + woDontStoreInherited, woInt64AsHex, woDontStore0); + /// options set for TTextWriter.WriteObject() method + TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption; + + /// callback used to echo each line of TTextWriter class + // - should return TRUE on success, FALSE if the log was not echoed: but + // TSynLog will continue logging, even if this event returned FALSE + TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo; + const Text: RawUTF8): boolean of object; + /// callback used by TTextWriter.WriteObject to customize class instance + // serialization + // - should return TRUE if the supplied property has been written (including + // the property name and the ending ',' character), and doesn't need to be + // processed with the default RTTI-based serializer + TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject; + PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object; + + /// the potential places were TTextWriter.AddHtmlEscape should process + // proper HTML string escaping, unless hfNone is used + // $ < > & " -> < > & "e; + // by default (hfAnyWhere) + // $ < > & -> < > & + // outside HTML attributes (hfOutsideAttributes) + // $ & " -> & "e; + // within HTML attributes (hfWithinAttributes) + TTextWriterHTMLFormat = ( + hfNone, hfAnyWhere, hfOutsideAttributes, hfWithinAttributes); + + /// available global options for a TTextWriter instance + // - TTextWriter.WriteObject() method behavior would be set via their own + // TTextWriterWriteObjectOptions, and work in conjunction with those settings + // - twoStreamIsOwned would be set if the associated TStream is owned by + // the TTextWriter instance + // - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the + // internal memory buffer when it appears undersized - FlushFinal will set it + // before calling a last FlushToStream + // - by default, custom serializers defined via RegisterCustomJSONSerializer() + // would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets + // as integer numbers, unless twoEnumSetsAsTextInRecord or + // twoEnumSetsAsBooleanInRecord (exclusively) are set - for Mustache data + // context, twoEnumSetsAsBooleanInRecord will return a JSON object with + // "setname":true/false fields + // - variants and nested objects would be serialized with their default + // JSON serialization options, unless twoForceJSONExtended or + // twoForceJSONStandard is defined + // - when enumerates and sets are serialized as text into JSON, you may force + // the identifiers to be left-trimed for all their lowercase characters + // (e.g. sllError -> 'Error') by setting twoTrimLeftEnumSets: this option + // would default to the global TTextWriter.SetDefaultEnumTrim setting + // - twoEndOfLineCRLF would reflect the TTextWriter.EndOfLineCRLF property + // - twoBufferIsExternal would be set if the temporary buffer is not handled + // by the instance, but specified at constructor, maybe from the stack + // - twoIgnoreDefaultInRecord will force custom record serialization to avoid + // writing the fields with default values, i.e. enable soWriteIgnoreDefault + // when TJSONCustomParserRTTI.WriteOneLevel is called + // - twoDateTimeWithZ appends an ending 'Z' to TDateTime/TDateTimeMS values + TTextWriterOption = ( + twoStreamIsOwned, + twoFlushToStreamNoAutoResize, + twoEnumSetsAsTextInRecord, + twoEnumSetsAsBooleanInRecord, + twoFullSetsAsStar, + twoTrimLeftEnumSets, + twoForceJSONExtended, + twoForceJSONStandard, + twoEndOfLineCRLF, + twoBufferIsExternal, + twoIgnoreDefaultInRecord, + twoDateTimeWithZ); + /// options set for a TTextWriter instance + // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior; + // or set global process customization for a TTextWriter + TTextWriterOptions = set of TTextWriterOption; + + /// may be used to allocate on stack a 8KB work buffer for a TTextWriter + // - via the TTextWriter.CreateOwnedStream overloaded constructor + TTextWriterStackBuffer = array[0..8191] of AnsiChar; + PTextWriterStackBuffer = ^TTextWriterStackBuffer; + + /// simple writer to a Stream, specialized for the TEXT format + // - use an internal buffer, faster than string+string + // - some dedicated methods is able to encode any data with JSON/XML escape + // - see TTextWriterWithEcho below for optional output redirection (for TSynLog) + // - see SynTable.pas for SQL resultset export via TJSONWriter + // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject + TTextWriter = class + protected + B, BEnd: PUTF8Char; + fStream: TStream; + fInitialStreamPosition: PtrUInt; + fTotalFileSize: PtrUInt; + fCustomOptions: TTextWriterOptions; + // internal temporary buffer + fTempBufSize: Integer; + fTempBuf: PUTF8Char; + fOnFlushToStream: TOnTextWriterFlush; + fOnWriteObject: TOnTextWriterObjectProp; + /// used by WriteObjectAsString/AddDynArrayJSONAsString methods + fInternalJSONWriter: TTextWriter; + fHumanReadableLevel: integer; + procedure WriteToStream(data: pointer; len: PtrUInt); virtual; + function GetTextLength: PtrUInt; + procedure SetStream(aStream: TStream); + procedure SetBuffer(aBuf: pointer; aBufSize: integer); + procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; + AnsiToWide: PWordArray; Escape: TTextWriterKind); + public + /// the data will be written to the specified Stream + // - aStream may be nil: in this case, it MUST be set before using any + // Add*() method + // - default internal buffer size if 8192 + constructor Create(aStream: TStream; aBufSize: integer=8192); overload; + /// the data will be written to the specified Stream + // - aStream may be nil: in this case, it MUST be set before using any + // Add*() method + // - will use an external buffer (which may be allocated on stack) + constructor Create(aStream: TStream; aBuf: pointer; aBufSize: integer); overload; + /// the data will be written to an internal TRawByteStringStream + // - TRawByteStringStream.DataString method will be used by TTextWriter.Text + // to retrieve directly the content without any data move nor allocation + // - default internal buffer size if 4096 (enough for most JSON objects) + // - consider using a stack-allocated buffer and the overloaded method + constructor CreateOwnedStream(aBufSize: integer=4096); overload; + /// the data will be written to an internal TRawByteStringStream + // - will use an external buffer (which may be allocated on stack) + // - TRawByteStringStream.DataString method will be used by TTextWriter.Text + // to retrieve directly the content without any data move nor allocation + constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer); overload; + /// the data will be written to an internal TRawByteStringStream + // - will use the stack-allocated TTextWriterStackBuffer if possible + // - TRawByteStringStream.DataString method will be used by TTextWriter.Text + // to retrieve directly the content without any data move nor allocation + constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; + aBufSize: integer=SizeOf(TTextWriterStackBuffer)); overload; + /// the data will be written to an external file + // - you should call explicitly FlushFinal or FlushToStream to write + // any pending data to the file + constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192); + /// release all internal structures + // - e.g. free fStream if the instance was owned by this class + destructor Destroy; override; + /// allow to override the default JSON serialization of enumerations and + // sets as text, which would write the whole identifier (e.g. 'sllError') + // - calling SetDefaultEnumTrim(true) would force the enumerations to + // be trimmed for any lower case char, e.g. sllError -> 'Error' + // - this is global to the current process, and should be use mainly for + // compatibility purposes for the whole process + // - you may change the default behavior by setting twoTrimLeftEnumSets + // in the TTextWriter.CustomOptions property of a given serializer + // - note that unserialization process would recognize both formats + class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); + + /// retrieve the data as a string + function Text: RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + /// retrieve the data as a string + // - will avoid creation of a temporary RawUTF8 variable as for Text function + procedure SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat=jsonCompact); + /// set the internal stream content with the supplied UTF-8 text + procedure ForceContent(const text: RawUTF8); + /// write pending data to the Stream, with automatic buffer resizal + // - you should not have to call FlushToStream in most cases, but FlushFinal + // at the end of the process, just before using the resulting Stream + // - FlushToStream may be used to force immediate writing of the internal + // memory buffer to the destination Stream + // - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you + // do not want the automatic memory buffer resizal to take place + procedure FlushToStream; virtual; + /// write pending data to the Stream, without automatic buffer resizal + // - will append the internal memory buffer to the Stream + // - in short, FlushToStream may be called during the adding process, and + // FlushFinal at the end of the process, just before using the resulting Stream + // - if you don't call FlushToStream or FlushFinal, some pending characters + // may not be copied to the Stream: you should call it before using the Stream + procedure FlushFinal; + /// gives access to an internal temporary TTextWriter + // - may be used to escape some JSON espaced value (i.e. escape it twice), + // in conjunction with AddJSONEscape(Source: TTextWriter) + function InternalJSONWriter: TTextWriter; + + /// append one ASCII char to the buffer + procedure Add(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} + /// append one ASCII char to the buffer, if not already there as LastChar + procedure AddOnce(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} + /// append two chars to the buffer + procedure Add(c1,c2: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} + {$ifndef CPU64} // already implemented by Add(Value: PtrInt) method + /// append a 64-bit signed Integer Value as text + procedure Add(Value: Int64); overload; + {$endif} + /// append a 32-bit signed Integer Value as text + procedure Add(Value: PtrInt); overload; + /// append a boolean Value as text + // - write either 'true' or 'false' + procedure Add(Value: boolean); overload; {$ifdef HASINLINE}inline;{$endif} + /// append a Currency from its Int64 in-memory representation + procedure AddCurr64(const Value: Int64); overload; + /// append a Currency from its Int64 in-memory representation + procedure AddCurr64(const Value: currency); overload; {$ifdef HASINLINE}inline;{$endif} + /// append a TTimeLog value, expanded as Iso-8601 encoded text + procedure AddTimeLog(Value: PInt64); + /// append a TUnixTime value, expanded as Iso-8601 encoded text + procedure AddUnixTime(Value: PInt64); + /// append a TUnixMSTime value, expanded as Iso-8601 encoded text + procedure AddUnixMSTime(Value: PInt64; WithMS: boolean=false); + /// append a TDateTime value, expanded as Iso-8601 encoded text + // - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T') + // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' + // - if WithMS is TRUE, will append '.sss' for milliseconds resolution + // - if QuoteChar is not #0, it will be written before and after the date + procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar='T'; QuoteChar: AnsiChar=#0; + WithMS: boolean=false); overload; + /// append a TDateTime value, expanded as Iso-8601 encoded text + // - use 'YYYY-MM-DDThh:mm:ss' format + // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' + // - append nothing if Value=0 + // - if WithMS is TRUE, will append '.sss' for milliseconds resolution + procedure AddDateTime(const Value: TDateTime; WithMS: boolean=false); overload; + /// append a TDateTime value, expanded as Iso-8601 text with milliseconds + // and Time Zone designator + // - twoDateTimeWithZ CustomOption is ignored in favor of the TZD parameter + // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format + // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') + procedure AddDateTimeMS(const Value: TDateTime; Expanded: boolean=true; + FirstTimeChar: AnsiChar = 'T'; const TZD: RawUTF8='Z'); + /// append an Unsigned 32-bit Integer Value as a String + procedure AddU(Value: cardinal); + /// append an Unsigned 64-bit Integer Value as a String + procedure AddQ(Value: QWord); + /// append an Unsigned 64-bit Integer Value as a quoted hexadecimal String + procedure AddQHex(Value: Qword); {$ifdef HASINLINE}inline;{$endif} + /// append a GUID value, encoded as text without any {} + // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' + procedure Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); overload; + /// append a floating-point Value as a String + // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values + // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific + // notation in the resulting text + procedure AddDouble(Value: double; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} + /// append a floating-point Value as a String + // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values + // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific + // notation in the resulting text + procedure AddSingle(Value: single; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} + /// append a floating-point Value as a String + // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values + // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific + // notation in the resulting text + procedure Add(Value: Extended; precision: integer; noexp: boolean=false); overload; + /// append a floating-point text buffer + // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' + // - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern + // - is used when the input comes from a third-party source with no regular + // output, e.g. a database driver + procedure AddFloatStr(P: PUTF8Char); + /// append strings or integers with a specified format + // - % = #37 marks a string, integer, floating-point, or class parameter + // to be appended as text (e.g. class name) + // - if StringEscape is false (by default), the text won't be escaped before + // adding; but if set to true text will be JSON escaped at writing + // - note that due to a limitation of the "array of const" format, cardinal + // values should be type-casted to Int64() - otherwise the integer mapped + // value will be transmitted, therefore wrongly + {$ifdef OLDTEXTWRITERFORMAT} + // - $ dollar = #36 indicates an integer to be written with 2 digits and a comma + // - | vertical = #124 will write the next char e.g. Add('%|$',[10]) will write '10$' + // - pound = #163 indicates an integer to be written with 4 digits and a comma + // - micro = #181 indicates an integer to be written with 3 digits without any comma + // - currency = #164 indicates CR+LF chars + // - section = #167 indicates to trim last comma + // - since some of this characters above are > #127, they are not UTF-8 + // ready, so we expect the input format to be WinAnsi, i.e. mostly English + // text (with chars < #128) with some values to be inserted inside + {$endif} + procedure Add(const Format: RawUTF8; const Values: array of const; + Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; + /// append some values at once + // - text values (e.g. RawUTF8) will be escaped as JSON + procedure Add(const Values: array of const); overload; + /// append CR+LF (#13#10) chars + // - this method won't call EchoAdd() registered events - use AddEndOfLine() + // method instead + // - AddEndOfLine() will append either CR+LF (#13#10) or LF (#10) depending + // on a flag + procedure AddCR; + /// append CR+LF (#13#10) chars and #9 indentation + // - indentation depth is defined by fHumanReadableLevel protected field + procedure AddCRAndIndent; + /// write the same character multiple times + procedure AddChars(aChar: AnsiChar; aCount: integer); + /// append an Integer Value as a 2 digits String with comma + procedure Add2(Value: PtrUInt); + /// append the current UTC date and time, in our log-friendly format + // - e.g. append '20110325 19241502' - with no trailing space nor tab + // - you may set LocalTime=TRUE to write the local date and time instead + // - this method is very fast, and avoid most calculation or API calls + procedure AddCurrentLogTime(LocalTime: boolean); + /// append the current UTC date and time, in our log-friendly format + // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space + // - you may set LocalTime=TRUE to write the local date and time instead + // - this method is very fast, and avoid most calculation or API calls + procedure AddCurrentNCSALogTime(LocalTime: boolean); + /// append a time period, specified in micro seconds, in 00.000.000 TSynLog format + procedure AddMicroSec(MS: cardinal); + /// append an Integer Value as a 4 digits String with comma + procedure Add4(Value: PtrUInt); + /// append an Integer Value as a 3 digits String without any added comma + procedure Add3(Value: PtrUInt); + /// append a line of text with CR+LF at the end + procedure AddLine(const Text: shortstring); + /// append an UTF-8 String, with no JSON escaping + procedure AddString(const Text: RawUTF8); + /// append several UTF-8 strings + procedure AddStrings(const Text: array of RawUTF8); overload; + /// append an UTF-8 string several times + procedure AddStrings(const Text: RawUTF8; count: integer); overload; + /// append a ShortString + procedure AddShort(const Text: ShortString); + /// append a sub-part of an UTF-8 String + // - emulates AddString(copy(Text,start,len)) + procedure AddStringCopy(const Text: RawUTF8; start,len: PtrInt); + /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.) + procedure AddTrimLeftLowerCase(Text: PShortString); + /// append a UTF-8 String excluding any space or control char + // - this won't escape the text as expected by JSON + procedure AddTrimSpaces(const Text: RawUTF8); overload; + {$ifdef HASINLINE}inline;{$endif} + /// append a UTF-8 String excluding any space or control char + // - this won't escape the text as expected by JSON + procedure AddTrimSpaces(P: PUTF8Char); overload; + /// append a property name, as '"PropName":' + // - PropName content should not need to be JSON escaped (e.g. no " within, + // and only ASCII 7-bit characters) + // - if twoForceJSONExtended is defined in CustomOptions, it would append + // 'PropName:' without the double quotes + procedure AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); + /// append a ShortString property name, as '"PropName":' + // - PropName content should not need to be JSON escaped (e.g. no " within, + // and only ASCII 7-bit characters) + // - if twoForceJSONExtended is defined in CustomOptions, it would append + // 'PropName:' without the double quotes + // - is a wrapper around AddProp() + procedure AddPropName(const PropName: ShortString); + {$ifdef HASINLINE}inline;{$endif} + /// append a JSON field name, followed by an escaped UTF-8 JSON String and + // a comma (',') + procedure AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); + /// append a JSON field name, followed by a number value and a comma (',') + procedure AddPropJSONInt64(const PropName: shortstring; Value: Int64); + /// append a RawUTF8 property name, as '"FieldName":' + // - FieldName content should not need to be JSON escaped (e.g. no " within) + // - if twoForceJSONExtended is defined in CustomOptions, it would append + // 'PropName:' without the double quotes + // - is a wrapper around AddProp() + procedure AddFieldName(const FieldName: RawUTF8); + {$ifdef HASINLINE}inline;{$endif} + /// append the class name of an Object instance as text + // - aClass must be not nil + procedure AddClassName(aClass: TClass); + /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar + // - Instance must be not nil + procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar); + /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar + // - Instance must be not nil + // - overriden version in TJSONSerializer would implement IncludeUnitName + procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar; + IncludeUnitName, IncludePointer: boolean); virtual; + /// append a quoted string as JSON, with in-place decoding + // - if QuotedString does not start with ' or ", it will written directly + // (i.e. expects to be a number, or null/true/false constants) + // - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and + // JSONEncodeNameSQLValue() function + procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8); + /// append an array of integers as CSV + procedure AddCSVInteger(const Integers: array of Integer); overload; + /// append an array of doubles as CSV + procedure AddCSVDouble(const Doubles: array of double); overload; + /// append an array of RawUTF8 as CSV of JSON strings + procedure AddCSVUTF8(const Values: array of RawUTF8); overload; + /// append an array of const as CSV of JSON values + procedure AddCSVConst(const Values: array of const); + /// write some data Base64 encoded + // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"' + procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); + /// write some record content as binary, Base64 encoded with our magic prefix + procedure WrRecord(const Rec; TypeInfo: pointer); + /// write some #0 ended UTF-8 text, according to the specified format + // - if Escape is a constant, consider calling directly AddNoJSONEscape, + // AddJSONEscape or AddOnSameLine methods + procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload; + /// write some #0 ended UTF-8 text, according to the specified format + // - if Escape is a constant, consider calling directly AddNoJSONEscape, + // AddJSONEscape or AddOnSameLine methods + procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload; + /// write some #0 ended Unicode text as UTF-8, according to the specified format + // - if Escape is a constant, consider calling directly AddNoJSONEscapeW, + // AddJSONEscapeW or AddOnSameLineW methods + procedure AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); + /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type + // - use the current system code page for AnsiString parameter + procedure AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); overload; + /// append some UTF-8 encoded chars to the buffer, from any AnsiString value + // - if CodePage is left to its default value of -1, it will assume + // CurrentAnsiConvert.CodePage prior to Delphi 2009, but newer UNICODE + // versions of Delphi will retrieve the code page from string + // - if CodePage is defined to a >= 0 value, the encoding will take place + procedure AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind; + CodePage: Integer=-1); + /// append some UTF-8 encoded chars to the buffer, from any Ansi buffer + // - the codepage should be specified, e.g. CP_UTF8, CP_RAWBYTESTRING, + // CODEPAGE_US, or any version supported by the Operating System + // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used + // - will use TSynAnsiConvert to perform the conversion to UTF-8 + procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; + Escape: TTextWriterKind; CodePage: Integer); + /// append some UTF-8 chars to the buffer + // - input length is calculated from zero-ended char + // - don't escapes chars according to the JSON RFC + procedure AddNoJSONEscape(P: Pointer); overload; + /// append some UTF-8 chars to the buffer + // - don't escapes chars according to the JSON RFC + procedure AddNoJSONEscape(P: Pointer; Len: PtrInt); overload; + /// append some UTF-8 chars to the buffer + // - don't escapes chars according to the JSON RFC + procedure AddNoJSONEscapeUTF8(const text: RawByteString); + {$ifdef HASINLINE}inline;{$endif} + /// flush a supplied TTextWriter, and write pending data as JSON escaped text + // - may be used with InternalJSONWriter, as a faster alternative to + // ! AddNoJSONEscapeUTF8(Source.Text); + procedure AddNoJSONEscape(Source: TTextWriter); overload; + /// append some UTF-8 chars to the buffer + // - if supplied json is '', will write 'null' + procedure AddRawJSON(const json: RawJSON); + /// append some UTF-8 text, quoting all " chars + // - same algorithm than AddString(QuotedStr()) - without memory allocation, + // and with an optional maximum text length (truncated with ending '...') + // - this function implements what is specified in the official SQLite3 + // documentation: "A string constant is formed by enclosing the string in single + // quotes ('). A single quote within the string can be encoded by putting two + // single quotes in a row - as in Pascal." + procedure AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: PtrInt=0); + /// append some chars, escaping all HTML special chars as expected + procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; + /// append some chars, escaping all HTML special chars as expected + procedure AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; + Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; + /// append some chars, escaping all HTML special chars as expected + procedure AddHtmlEscapeString(const Text: string; + Fmt: TTextWriterHTMLFormat=hfAnyWhere); + /// append some chars, escaping all HTML special chars as expected + procedure AddHtmlEscapeUTF8(const Text: RawUTF8; + Fmt: TTextWriterHTMLFormat=hfAnyWhere); + /// append some chars, escaping all XML special chars as expected + // - i.e. < > & " ' as < > & "e; ' + // - and all control chars (i.e. #1..#31) as &#..; + // - see @http://www.w3.org/TR/xml/#syntax + procedure AddXmlEscape(Text: PUTF8Char); + /// append some chars, replacing a given character with another + procedure AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); + /// append some binary data as hexadecimal text conversion + procedure AddBinToHex(Bin: Pointer; BinBytes: integer); + /// fast conversion from binary data into hexa chars, ready to be displayed + // - using this function with Bin^ as an integer value will serialize it + // in big-endian order (most-significant byte first), as used by humans + // - up to the internal buffer bytes may be converted + procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer); + /// fast conversion from binary data into MSB hexa chars + // - up to the internal buffer bytes may be converted + procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); + /// fast conversion from binary data into quoted MSB lowercase hexa chars + // - up to the internal buffer bytes may be converted + procedure AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); + /// append a Value as significant hexadecimal text + // - append its minimal size, i.e. excluding highest bytes containing 0 + // - use GetNextItemHexa() to decode such a text value + procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); + /// add the pointer into significant hexa chars, ready to be displayed + procedure AddPointer(P: PtrUInt); {$ifdef HASINLINE}inline;{$endif} + /// write a byte as hexa chars + procedure AddByteToHex(Value: byte); + /// write a Int18 value (0..262143) as 3 chars + // - this encoding is faster than Base64, and has spaces on the left side + // - use function Chars3ToInt18() to decode the textual content + procedure AddInt18ToChars3(Value: cardinal); + /// append some unicode chars to the buffer + // - WideCharCount is the unicode chars count, not the byte size + // - don't escapes chars according to the JSON RFC + // - will convert the Unicode chars into UTF-8 + procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); + /// append some UTF-8 encoded chars to the buffer + // - escapes chars according to the JSON RFC + // - if Len is 0, writing will stop at #0 (default Len=0 is slightly faster + // than specifying Len>0 if you are sure P is zero-ended - e.g. from RawUTF8) + procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload; + /// append some UTF-8 encoded chars to the buffer, from a generic string type + // - faster than AddJSONEscape(pointer(StringToUTF8(string)) + // - escapes chars according to the JSON RFC + procedure AddJSONEscapeString(const s: string); {$ifdef HASINLINE}inline;{$endif} + /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type + // - escapes chars according to the JSON RFC + procedure AddJSONEscapeAnsiString(const s: AnsiString); + /// append some UTF-8 encoded chars to the buffer, from a generic string type + // - faster than AddNoJSONEscape(pointer(StringToUTF8(string)) + // - don't escapes chars according to the JSON RFC + // - will convert the Unicode chars into UTF-8 + procedure AddNoJSONEscapeString(const s: string); {$ifdef UNICODE}inline;{$endif} + /// append some Unicode encoded chars to the buffer + // - if Len is 0, Len is calculated from zero-ended widechar + // - escapes chars according to the JSON RFC + procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0); + /// append an open array constant value to the buffer + // - "" will be added if necessary + // - escapes chars according to the JSON RFC + // - very fast (avoid most temporary storage) + procedure AddJSONEscape(const V: TVarRec); overload; + /// flush a supplied TTextWriter, and write pending data as JSON escaped text + // - may be used with InternalJSONWriter, as a faster alternative to + // ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0); + procedure AddJSONEscape(Source: TTextWriter); overload; + /// append a UTF-8 JSON String, between double quotes and with JSON escaping + procedure AddJSONString(const Text: RawUTF8); + /// append an open array constant value to the buffer + // - "" won't be added for string values + // - string values may be escaped, depending on the supplied parameter + // - very fast (avoid most temporary storage) + procedure Add(const V: TVarRec; Escape: TTextWriterKind=twNone; + WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; + /// encode the supplied data as an UTF-8 valid JSON object content + // - data must be supplied two by two, as Name,Value pairs, e.g. + // ! aWriter.AddJSONEscape(['name','John','year',1972]); + // will append to the buffer: + // ! '{"name":"John","year":1972}' + // - or you can specify nested arrays or objects with '['..']' or '{'..'}': + // ! aWriter.AddJSONEscape(['doc','{','name','John','ab','[','a','b']','}','id',123]); + // will append to the buffer: + // ! '{"doc":{"name":"John","abc":["a","b"]},"id":123}' + // - note that, due to a Delphi compiler limitation, cardinal values should be + // type-casted to Int64() (otherwise the integer mapped value will be converted) + // - you can pass nil as parameter for a null JSON value + procedure AddJSONEscape(const NameValuePairs: array of const); overload; + {$ifndef NOVARIANTS} + /// encode the supplied (extended) JSON content, with parameters, + // as an UTF-8 valid JSON object content + // - in addition to the JSON RFC specification strict mode, this method will + // handle some BSON-like extensions, e.g. unquoted field names: + // ! aWriter.AddJSON('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); + // - you can use nested _Obj() / _Arr() instances + // ! aWriter.AddJSON('{%:{$in:[?,?]}}',['type'],['food','snack']); + // ! aWriter.AddJSON('{type:{$in:?}}',[],[_Arr(['food','snack'])]); + // ! // which are the same as: + // ! aWriter.AddShort('{"type":{"$in":["food","snack"]}}'); + // - if the SynMongoDB unit is used in the application, the MongoDB Shell + // syntax will also be recognized to create TBSONVariant, like + // ! new Date() ObjectId() MinKey MaxKey // + // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json + // ! aWriter.AddJSON('{name:?,field:/%/i}',['acme.*corp'],['John'])) + // ! // will write + // ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' + // - will call internally _JSONFastFmt() to create a temporary TDocVariant + // with all its features - so is slightly slower than other AddJSON* methods + procedure AddJSON(const Format: RawUTF8; const Args,Params: array of const); + {$endif} + /// append two JSON arrays of keys and values as one JSON object + // - i.e. makes the following transformation: + // $ [key1,key2...] + [value1,value2...] -> {key1:value1,key2,value2...} + // - this method won't allocate any memory during its process, nor + // modify the keys and values input buffers + // - is the reverse of the JSONObjectAsJSONArrays() function + procedure AddJSONArraysAsJSONObject(keys,values: PUTF8Char); + /// append a dynamic array content as UTF-8 encoded JSON array + // - expect a dynamic array TDynArray wrapper as incoming parameter + // - TIntegerDynArray, TInt64DynArray, TCardinalDynArray, TDoubleDynArray, + // TCurrencyDynArray, TWordDynArray and TByteDynArray will be written as + // numerical JSON values + // - TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, + // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, TTimeLogDynArray, + // and TDateTimeDynArray will be written as escaped UTF-8 JSON strings + // (and Iso-8601 textual encoding if necessary) + // - you can add some custom serializers via RegisterCustomJSONSerializer() + // class method, to serialize any dynamic array as valid JSON + // - any other non-standard or non-registered kind of dynamic array (including + // array of records) will be written as Base64 encoded binary stream, with a + // JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) - this will + // include TBytes (i.e. array of bytes) content, which is a good candidate + // for BLOB stream + // - typical content could be + // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' + // - by default, custom serializers defined via RegisterCustomJSONSerializer() + // would write enumerates and sets as integer numbers, unless + // twoEnumSetsAsTextInRecord is set in the instance Options + procedure AddDynArrayJSON(var aDynArray: TDynArray); overload; + /// append a dynamic array content as UTF-8 encoded JSON array + // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter + procedure AddDynArrayJSON(var aDynArray: TDynArrayHashed); overload; + {$ifdef HASINLINE}inline;{$endif} + /// append a dynamic array content as UTF-8 encoded JSON array + // - just a wrapper around the other overloaded method, creating a + // temporary TDynArray wrapper on the stack + // - to be used e.g. for custom record JSON serialization, within a + // TDynArrayJSONCustomWriter callback + procedure AddDynArrayJSON(aTypeInfo: pointer; const aValue); overload; + /// same as AddDynArrayJSON(), but will double all internal " and bound with " + // - this implementation will avoid most memory allocations + procedure AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); + /// append a T*ObjArray dynamic array as a JSON array + // - as expected by TJSONSerializer.RegisterObjArrayForJSON() + procedure AddObjArrayJSON(const aObjArray; + aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); + /// append a record content as UTF-8 encoded JSON or custom serialization + // - default serialization will use Base64 encoded binary stream, or + // a custom serialization, in case of a previous registration via + // RegisterCustomJSONSerializer() class method - from a dynamic array + // handling this kind of records, or directly from TypeInfo() of the record + // - by default, custom serializers defined via RegisterCustomJSONSerializer() + // would write enumerates and sets as integer numbers, unless + // twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in + // the instance CustomOptions + procedure AddRecordJSON(const Rec; TypeInfo: pointer); + {$ifndef NOVARIANTS} + /// append a variant content as number or string + // - default Escape=twJSONEscape will create valid JSON content, which + // can be converted back to a variant value using VariantLoadJSON() + // - default JSON serialization options would apply, unless + // twoForceJSONExtended or twoForceJSONStandard is defined + // - note that before Delphi 2009, any varString value is expected to be + // a RawUTF8 instance - which does make sense in the mORMot context + procedure AddVariant(const Value: variant; Escape: TTextWriterKind=twJSONEscape); + {$endif} + /// append a void record content as UTF-8 encoded JSON or custom serialization + // - this method will first create a void record (i.e. filled with #0 bytes) + // then save its content with default or custom serialization + procedure AddVoidRecordJSON(TypeInfo: pointer); + /// append a JSON value from its RTTI type + // - handle tkClass,tkEnumeration,tkSet,tkRecord,tkDynArray,tkVariant types + // - write null for other types + procedure AddTypedJSON(aTypeInfo: pointer; const aValue); + /// serialize as JSON the given object + // - this default implementation will write null, or only write the + // class name and pointer if FullExpand is true - use + // TJSONSerializer.WriteObject method for full RTTI handling + // - default implementation will write TList/TCollection/TStrings/TRawUTF8List + // as appropriate array of class name/pointer (if woFullExpand is set) + procedure WriteObject(Value: TObject; + Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); virtual; + /// same as WriteObject(), but will double all internal " and bound with " + // - this implementation will avoid most memory allocations + procedure WriteObjectAsString(Value: TObject; + Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); + /// append a JSON value, array or document as simple XML content + // - you can use JSONBufferToXML() and JSONToXML() functions as wrappers + // - this method is called recursively to handle all kind of JSON values + // - WARNING: the JSON buffer is decoded in-place, so will be changed + // - returns the end of the current JSON converted level, or nil if the + // supplied content was not correct JSON + function AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil; + EndOfObject: PUTF8Char=nil): PUTF8Char; + /// append a JSON value, array or document, in a specified format + // - will parse the JSON buffer and write its content with proper line + // feeds and indentation, according to the supplied TTextWriterJSONFormat + // - see also JSONReformat() and JSONBufferReformat() wrappers + // - this method is called recursively to handle all kind of JSON values + // - WARNING: the JSON buffer is decoded in-place, so will be changed + // - returns the end of the current JSON converted level, or nil if the + // supplied content was not valid JSON + function AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat; + EndOfObject: PUTF8Char): PUTF8Char; + + /// define a custom serialization for a given dynamic array or record + // - expects TypeInfo() from a dynamic array or a record (will raise an + // exception otherwise) + // - for a dynamic array, the associated item record RTTI will be registered + // - for a record, any matching dynamic array will also be registered + // - by default, TIntegerDynArray and such known classes are processed as + // true JSON arrays: but you can specify here some callbacks to perform + // the serialization process for any kind of dynamic array + // - any previous registration is overridden + // - setting both aReader=aWriter=nil will return back to the default + // binary + Base64 encoding serialization (i.e. undefine custom serializer) + class procedure RegisterCustomJSONSerializer(aTypeInfo: pointer; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); + {$ifndef NOVARIANTS} + /// define a custom serialization for a given variant custom type + // - used e.g. to serialize TBCD values + class procedure RegisterCustomJSONSerializerForVariant(aClass: TCustomVariantType; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); + /// define a custom serialization for a given variant custom type + // - used e.g. to serialize TBCD values + class procedure RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); + {$endif NOVARIANTS} + /// define a custom serialization for a given dynamic array or record + // - the RTTI information will here be defined as plain text + // - since Delphi 2010, you can call directly + // RegisterCustomJSONSerializerFromTextSimpleType() + // - aTypeInfo may be valid TypeInfo(), or any fixed pointer value if the + // record does not have any RTTI (e.g. a record without any nested reference- + // counted types) + // - the record where the data will be stored should be defined as PACKED: + // ! type TMyRecord = packed record + // ! A,B,C: integer; + // ! D: RawUTF8; + // ! E: record; // or array of record/integer/string/... + // ! E1,E2: double; + // ! end; + // ! end; + // - call this method with aRTTIDefinition='' to return back to the default + // binary + Base64 encoding serialization (i.e. undefine custom serializer) + // - only known sub types are byte, word, integer, cardinal, Int64, single, + // double, currency, TDateTime, TTimeLog, RawUTF8, String, WideString, + // SynUnicode, TGUID (encoded via GUIDToText) or a nested record or dynamic + // array of the same simple types or record + // - RTTI textual information shall be supplied as text, with the + // same format as with a pascal record: + // ! 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double;' + // ! 'A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double;' + // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of TGUID' + // or a shorter alternative syntax for records and arrays: + // ! 'A,B,C: integer; D: RawUTF8; E: {E1,E2: double}' + // ! 'A,B,C: integer; D: RawUTF8; E: [E1,E2: double]' + // in fact ; could be ignored: + // ! 'A,B,C:integer D:RawUTF8 E:{E1,E2:double}' + // ! 'A,B,C:integer D:RawUTF8 E:[E1,E2:double]' + // or even : could be ignored: + // ! 'A,B,C integer D RawUTF8 E{E1,E2 double}' + // ! 'A,B,C integer D RawUTF8 E[E1,E2 double]' + // - it will return the cached TJSONRecordTextDefinition + // instance corresponding to the supplied RTTI text definition + class function RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; + const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; overload; + /// define a custom serialization for several dynamic arrays or records + // - the TypeInfo() and textual RTTI information will here be defined as + // ([TypeInfo(TType1),_TType1,TypeInfo(TType2),_TType2]) pairs + // - a wrapper around the overloaded RegisterCustomJSONSerializerFromText() + class procedure RegisterCustomJSONSerializerFromText( + const aTypeInfoTextDefinitionPairs: array of const); overload; + /// change options for custom serialization of dynamic array or record + // - will return TRUE if the options have been changed, FALSE if the + // supplied type info was not previously registered + // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since + // Delphi 2010), you would be able to customize the options of this type + class function RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; + aOptions: TJSONCustomParserSerializationOptions; + aAddIfNotExisting: boolean=false): boolean; overload; + /// change options for custom serialization of dynamic arrays or records + // - will return TRUE if the options have been changed, FALSE if the + // supplied type info was not previously registered for at least one type + // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since + // Delphi 2010), you would be able to customize the options of this type + class function RegisterCustomJSONSerializerSetOptions( + const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; + aAddIfNotExisting: boolean=false): boolean; overload; + /// retrieve a previously registered custom parser instance from its type + // - will return nil if the type info was not available, or defined just + // with some callbacks + // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since + // Delphi 2010), you would be able to retrieve this type's parser even + // if the record type has not been previously used + class function RegisterCustomJSONSerializerFindParser( + aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract; + /// define a custom serialization for a given simple type + // - you should be able to use this type in the RTTI text definition + // of any further RegisterCustomJSONSerializerFromText() call + // - the RTTI information should be enough to serialize the type from + // its name (e.g. an enumeration for older Delphi revision, but all records + // since Delphi 2010) + // - you can supply a custom type name, which will be registered in addition + // to the "official" name defined at RTTI level + // - on older Delphi versions (up to Delphi 2009), it will handle only + // enumerations, which will be transmitted as JSON string instead of numbers + // - since Delphi 2010, any record type can be supplied - which is more + // convenient than calling RegisterCustomJSONSerializerFromText() + class procedure RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfo: pointer; + const aTypeName: RawUTF8=''); overload; + /// define a custom binary serialization for a given simple type + // - you should be able to use this type in the RTTI text definition + // of any further RegisterCustomJSONSerializerFromText() call + // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string + // - you can truncate the original data size (e.g. if all bits of an integer + // are not used) by specifying the aFieldSize optional parameter + class procedure RegisterCustomJSONSerializerFromTextBinaryType(aTypeInfo: pointer; + aDataSize: integer; aFieldSize: integer=0); overload; + /// define custom binary serialization for several simple types + // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string + // - the TypeInfo() and associated size information will here be defined as triplets: + // ([TypeInfo(TType1),SizeOf(TType1),TYPE1_BYTES,TypeInfo(TType2),SizeOf(TType2),TYPE2_BYTES]) + // - a wrapper around the overloaded RegisterCustomJSONSerializerFromTextBinaryType() + class procedure RegisterCustomJSONSerializerFromTextBinaryType( + const aTypeInfoDataFieldSize: array of const); overload; + /// define a custom serialization for several simple types + // - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType + // method for each supplied type information + class procedure RegisterCustomJSONSerializerFromTextSimpleType( + const aTypeInfos: array of pointer); overload; + /// undefine a custom serialization for a given dynamic array or record + // - it will un-register any callback or text-based custom serialization + // i.e. any previous RegisterCustomJSONSerializer() or + // RegisterCustomJSONSerializerFromText() call + // - expects TypeInfo() from a dynamic array or a record (will raise an + // exception otherwise) + // - it will set back to the default binary + Base64 encoding serialization + class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer); + /// retrieve low-level custom serialization callbaks for a dynamic array + // - returns TRUE if this array has a custom JSON parser, and set the + // corresponding serialization/unserialization callbacks + class function GetCustomJSONParser(var DynArray: TDynArray; + out CustomReader: TDynArrayJSONCustomReader; + out CustomWriter: TDynArrayJSONCustomWriter): boolean; + + /// append some chars to the buffer in one line + // - P should be ended with a #0 + // - will write #1..#31 chars as spaces (so content will stay on the same line) + procedure AddOnSameLine(P: PUTF8Char); overload; + /// append some chars to the buffer in one line + // - will write #0..#31 chars as spaces (so content will stay on the same line) + procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload; + /// append some wide chars to the buffer in one line + // - will write #0..#31 chars as spaces (so content will stay on the same line) + procedure AddOnSameLineW(P: PWord; Len: PtrInt); + + /// return the last char appended + // - returns #0 if no char has been written yet + function LastChar: AnsiChar; + /// how many bytes are currently in the internal buffer and not on disk + // - see TextLength for the total number of bytes, on both disk and memory + function PendingBytes: PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + /// how many bytes were currently written on disk + // - excluding the bytes in the internal buffer + // - see TextLength for the total number of bytes, on both disk and memory + property WrittenBytes: PtrUInt read fTotalFileSize; + /// low-level access to the current indentation level + property HumanReadableLevel: integer read fHumanReadableLevel write fHumanReadableLevel; + /// the last char appended is canceled + // - only one char cancelation is allowed at the same position: don't call + // CancelLastChar/CancelLastComma more than once without appending text inbetween + procedure CancelLastChar; overload; {$ifdef HASINLINE}inline;{$endif} + /// the last char appended is canceled, if match the supplied one + // - only one char cancelation is allowed at the same position: don't call + // CancelLastChar/CancelLastComma more than once without appending text inbetween + procedure CancelLastChar(aCharToCancel: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} + /// the last char appended is canceled if it was a ',' + // - only one char cancelation is allowed at the same position: don't call + // CancelLastChar/CancelLastComma more than once without appending text inbetween + procedure CancelLastComma; {$ifdef HASINLINE}inline;{$endif} + /// rewind the Stream to the position when Create() was called + // - note that this does not clear the Stream content itself, just + // move back its writing position to its initial place + procedure CancelAll; + + /// count of added bytes to the stream + // - see PendingBytes for the number of bytes currently in the memory buffer + // or WrittenBytes for the number of bytes already written to disk + property TextLength: PtrUInt read GetTextLength; + /// optional event called before FlushToStream method process + property OnFlushToStream: TOnTextWriterFlush read fOnFlushToStream write fOnFlushToStream; + /// allows to override default WriteObject property JSON serialization + property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject; + /// the internal TStream used for storage + // - you should call the FlushFinal (or FlushToStream) methods before using + // this TStream content, to flush all pending characters + // - if the TStream instance has not been specified when calling the + // TTextWriter constructor, it can be forced via this property, before + // any writting + property Stream: TStream read fStream write SetStream; + /// global options to customize this TTextWriter instance process + // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior + property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions; + end; + + /// class of our simple TEXT format writer to a Stream, with echoing + // - as used by TSynLog for writing its content + // - see TTextWriterWithEcho.SetAsDefaultJSONClass + TTextWriterClass = class of TTextWriterWithEcho; + + /// Stream TEXT writer, with optional echoing of the lines + // - as used e.g. by TSynLog writer for log optional redirection + // - is defined as a sub-class to reduce plain TTextWriter scope + // - see SynTable.pas for SQL resultset export via TJSONWriter + // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject + TTextWriterWithEcho = class(TTextWriter) + protected + fEchoStart: PtrInt; + fEchoBuf: RawUTF8; + fEchos: array of TOnTextWriterEcho; + function EchoFlush: PtrInt; + function GetEndOfLineCRLF: boolean; {$ifdef HASINLINE}inline;{$endif} + procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean); + public + /// write pending data to the Stream, with automatic buffer resizal and echoing + // - this overriden method will handle proper echoing + procedure FlushToStream; override; + /// mark an end of line, ready to be "echoed" to registered listeners + // - append a LF (#10) char or CR+LF (#13#10) chars to the buffer, depending + // on the EndOfLineCRLF property value (default is LF, to minimize storage) + // - any callback registered via EchoAdd() will monitor this line + // - used e.g. by TSynLog for console output, as stated by Level parameter + procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone); + /// add a callback to echo each line written by this class + // - this class expects AddEndOfLine to mark the end of each line + procedure EchoAdd(const aEcho: TOnTextWriterEcho); + /// remove a callback to echo each line written by this class + // - event should have been previously registered by a EchoAdd() call + procedure EchoRemove(const aEcho: TOnTextWriterEcho); + /// reset the internal buffer used for echoing content + procedure EchoReset; + /// define how AddEndOfLine method stores its line feed characters + // - by default (FALSE), it will append a LF (#10) char to the buffer + // - you can set this property to TRUE, so that CR+LF (#13#10) chars will + // be appended instead + // - is just a wrapper around twoEndOfLineCRLF item in CustomOptions + property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF; + end; + +var + /// contains the default JSON serialization class for WriteObject + // - if only SynCommons.pas is used, it will be TTextWriterWithEcho + // - mORMot.pas will assign TJSONSerializer which uses RTTI to serialize + // TSQLRecord and any class published properties as JSON + DefaultTextWriterSerializer: TTextWriterClass = TTextWriterWithEcho; + +/// recognize a simple type from a supplied type information +// - first try by name via TJSONCustomParserRTTI.TypeNameToSimpleRTTIType, +// then from RTTI via TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType +// - will return ptCustom for any unknown type +function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; + +/// serialize most kind of content as JSON, using its RTTI +// - is just a wrapper around TTextWriter.AddTypedJSON() +// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, +// tkVariant kind of content - other kinds would return 'null' +// - you can override serialization options if needed +procedure SaveJSON(const Value; TypeInfo: pointer; + Options: TTextWriterOptions; var result: RawUTF8); overload; + +/// serialize most kind of content as JSON, using its RTTI +// - is just a wrapper around TTextWriter.AddTypedJSON() +// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, +// tkVariant kind of content - other kinds would return 'null' +function SaveJSON(const Value; TypeInfo: pointer; + EnumSetsAsText: boolean=false): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// will serialize any TObject into its UTF-8 JSON representation +/// - serialize as JSON the published integer, Int64, floating point values, +// TDateTime (stored as ISO 8601 text), string, variant and enumerate +// (e.g. boolean) properties of the object (and its parents) +// - would set twoForceJSONStandard to force standard (non-extended) JSON +// - the enumerates properties are stored with their integer index value +// - will write also the properties published in the parent classes +// - nested properties are serialized as nested JSON objects +// - any TCollection property will also be serialized as JSON arrays +// - you can add some custom serializers for ANY Delphi class, via mORMot.pas' +// TJSONSerializer.RegisterCustomSerializer() class method +// - call internaly TJSONSerializer.WriteObject() method (or fallback to +// TJSONWriter if mORMot.pas is not linked to the executable) +function ObjectToJSON(Value: TObject; + Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; + +/// will serialize set of TObject into its UTF-8 JSON representation +// - follows ObjectToJSON()/TTextWriter.WriterObject() functions output +// - if Names is not supplied, the corresponding class names would be used +function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; + Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; + + +type + /// abstract ancestor to manage a dynamic array of TObject + // - do not use this abstract class directly, but rather the inherited + // TObjectListHashed and TObjectListPropertyHashed + TObjectListHashedAbstract = class + protected + fList: TObjectDynArray; + fCount: integer; + fHash: TDynArrayHashed; + public + /// initialize the class instance + // - if aFreeItems is TRUE (default), will behave like a TObjectList + // - if aFreeItems is FALSE, will behave like a TList + constructor Create(aFreeItems: boolean=true); reintroduce; + /// release used memory + destructor Destroy; override; + /// search and add an object reference to the list + // - returns the found/added index + function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract; + /// retrieve an object index within the list, using a fast hash table + // - returns -1 if not found + function IndexOf(aObject: TObject): integer; virtual; abstract; + /// delete an object from the list + // - the internal hash table is not recreated, just invalidated + // (i.e. this method calls HashInvalidate not FindHashedAndDelete) + // - will invalide the whole hash table + procedure Delete(aIndex: integer); overload; + /// delete an object from the list + // - will invalide the whole hash table + procedure Delete(aObject: TObject); overload; virtual; + /// direct access to the items list array + property List: TObjectDynArray read fList; + /// returns the count of stored objects + property Count: integer read fCount; + /// direct access to the underlying hashing engine + property Hash: TDynArrayHashed read fHash; + end; + + /// this class behaves like TList/TObjectList, but will use hashing + // for (much) faster IndexOf() method + TObjectListHashed = class(TObjectListHashedAbstract) + public + /// search and add an object reference to the list + // - returns the found/added index + // - if added, hash is stored and Items[] := aObject + function Add(aObject: TObject; out wasAdded: boolean): integer; override; + /// retrieve an object index within the list, using a fast hash table + // - returns -1 if not found + function IndexOf(aObject: TObject): integer; override; + /// delete an object from the list + // - overriden method won't invalidate the whole hash table, but refresh it + procedure Delete(aObject: TObject); override; + end; + + /// function prototype used to retrieve a pointer to the hashed property + // value of a TObjectListPropertyHashed list + TObjectListPropertyHashedAccessProp = function(aObject: TObject): pointer; + + /// this class will hash and search for a sub property of the stored objects + TObjectListPropertyHashed = class(TObjectListHashedAbstract) + protected + fSubPropAccess: TObjectListPropertyHashedAccessProp; + function IntHash(const Elem): cardinal; + function IntComp(const A,B): integer; + public + /// initialize the class instance with the corresponding callback in order + // to handle sub-property hashing and search + // - see TSetWeakZeroClass in mORMot.pas unit as example: + // ! function WeakZeroClassSubProp(aObject: TObject): TObject; + // ! begin + // ! result := TSetWeakZeroInstance(aObject).fInstance; + // ! end; + // - by default, aHashElement/aCompare will hash/search for pointers: + // you can specify the hash/search methods according to your sub property + // (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8) + // - if aFreeItems is TRUE (default), will behave like a TObjectList; + // if aFreeItems is FALSE, will behave like a TList + constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp; + aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; + aFreeItems: boolean=true); reintroduce; + /// search and add an object reference to the list + // - returns the found/added index + // - if added, only the hash is stored: caller has to set List[i] + function Add(aObject: TObject; out wasAdded: boolean): integer; override; + /// retrieve an object index within the list, using a fast hash table + // - returns -1 if not found + function IndexOf(aObject: TObject): integer; override; + end; + + /// abstract class stored by a TPointerClassHash list + TPointerClassHashed = class + protected + fInfo: pointer; + public + /// initialize the instance + constructor Create(aInfo: pointer); + /// the associated information of this instance + // - may be e.g. a PTypeInfo value, when caching RTTI information + property Info: pointer read fInfo write fInfo; + end; + /// a reference to a TPointerClassHashed instance + PPointerClassHashed = ^TPointerClassHashed; + + /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer + // - used e.g. to store RTTI information from its PTypeInfo value + // - if not thread safe, but could be used to store RTTI, since all type + // information should have been initialized before actual process + TPointerClassHash = class(TObjectListPropertyHashed) + public + /// initialize the storage list + constructor Create; + /// try to add an entry to the storage + // - returns nil if the supplied information is already in the list + // - returns a pointer to where a newly created TPointerClassHashed + // instance should be stored + // - this method is not thread-safe + function TryAdd(aInfo: pointer): PPointerClassHashed; + /// search for a stored instance, from its supplied pointer reference + // - returns nil if aInfo was not previously added by FindOrAdd() + // - this method is not thread-safe + function Find(aInfo: pointer): TPointerClassHashed; + end; + + /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer + // - this inherited class add a mutex to be thread-safe + TPointerClassHashLocked = class(TPointerClassHash) + protected + fSafe: TSynLocker; + public + /// initialize the storage list + constructor Create; + /// finalize the storage list + destructor Destroy; override; + /// try to add an entry to the storage + // - returns false if the supplied information is already in the list + // - returns true, and a pointer to where a newly created TPointerClassHashed + // instance should be stored: in this case, you should call UnLock once set + // - could be used as such: + // !var entry: PPointerClassHashed; + // !... + // ! if HashList.TryAddLocked(aTypeInfo,entry) then + // ! try + // ! entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...); + // ! finally + // ! HashList.Unlock; + // ! end; + // !... + function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean; + /// release the lock after a previous TryAddLocked()=true call + procedure Unlock; + /// search for a stored instance, from its supplied pointer reference + // - returns nil if aInfo was not previously added by FindOrAdd() + // - this overriden method is thread-safe, unless returned TPointerClassHashed + // instance is deleted in-between + function FindLocked(aInfo: pointer): TPointerClassHashed; + end; + + /// add locking methods to a TSynObjectList + // - this class overrides the regular TSynObjectList, and do not share any + // code with the TObjectListHashedAbstract/TObjectListHashed classes + // - you need to call the Safe.Lock/Unlock methods by hand to protect the + // execution of index-oriented methods (like Delete/Items/Count...): the + // list content may change in the background, so using indexes is thread-safe + // - on the other hand, Add/Clear/ClearFromLast/Remove stateless methods have + // been overriden in this class to call Safe.Lock/Unlock, and therefore are + // thread-safe and protected to any background change + TSynObjectListLocked = class(TSynObjectList) + protected + fSafe: TSynLocker; + public + /// initialize the list instance + // - the stored TObject instances will be owned by this TSynObjectListLocked, + // unless AOwnsObjects is set to false + constructor Create(aOwnsObjects: boolean=true); reintroduce; + /// release the list instance (including the locking resource) + destructor Destroy; override; + /// add one item to the list using the global critical section + function Add(item: pointer): integer; override; + /// delete all items of the list using the global critical section + procedure Clear; override; + /// delete all items of the list in reverse order, using the global critical section + procedure ClearFromLast; override; + /// fast delete one item in the list + function Remove(item: pointer): integer; override; + /// check an item using the global critical section + function Exists(item: pointer): boolean; override; + /// the critical section associated to this list instance + // - could be used to protect shared resources within the internal process, + // for index-oriented methods like Delete/Items/Count... + // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block + property Safe: TSynLocker read fSafe; + end; + + /// deprecated class name, for backward compatibility only + TObjectListLocked = TSynObjectListLocked; + + /// possible values used by TRawUTF8List.Flags + TRawUTF8ListFlags = set of ( + fObjectsOwned, fCaseSensitive, fNoDuplicate, fOnChangeTrigerred); + + /// TStringList-class optimized to work with our native UTF-8 string type + // - can optionally store associated some TObject instances + // - high-level methods of this class are thread-safe + // - if fNoDuplicate flag is defined, an internal hash table will be + // maintained to perform IndexOf() lookups in O(1) linear way + TRawUTF8List = class + protected + fCount: PtrInt; + fValue: TRawUTF8DynArray; + fValues: TDynArrayHashed; + fObjects: TObjectDynArray; + fFlags: TRawUTF8ListFlags; + fNameValueSep: AnsiChar; + fOnChange, fOnChangeBackupForBeginUpdate: TNotifyEvent; + fOnChangeLevel: integer; + fSafe: TSynLocker; + function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} + procedure SetCapacity(const capa: PtrInt); + function GetCapacity: PtrInt; + function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif} + procedure Put(Index: PtrInt; const Value: RawUTF8); + function GetObject(Index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} + procedure PutObject(Index: PtrInt; Value: pointer); + function GetName(Index: PtrInt): RawUTF8; + function GetValue(const Name: RawUTF8): RawUTF8; + procedure SetValue(const Name, Value: RawUTF8); + function GetTextCRLF: RawUTF8; + procedure SetTextCRLF(const Value: RawUTF8); + procedure SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); + function GetTextPtr: PPUtf8CharArray; {$ifdef HASINLINE}inline;{$endif} + function GetNoDuplicate: boolean; {$ifdef HASINLINE}inline;{$endif} + function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif} + function GetCaseSensitive: boolean; {$ifdef HASINLINE}inline;{$endif} + procedure SetCaseSensitive(Value: boolean); virtual; + procedure Changed; virtual; + procedure InternalDelete(Index: PtrInt); + procedure OnChangeHidden(Sender: TObject); + public + /// initialize the RawUTF8/Objects storage + // - by default, any associated Objects[] are just weak references; + // you may supply fOwnObjects flag to force object instance management + // - if you want the stored text items to be unique, set fNoDuplicate + // and then an internal hash table will be maintained for fast IndexOf() + // - you can unset fCaseSensitive to let the UTF-8 lookup be case-insensitive + constructor Create(aFlags: TRawUTF8ListFlags=[fCaseSensitive]); overload; + /// backward compatiliby overloaded constructor + // - please rather use the overloaded Create(TRawUTF8ListFlags) + constructor Create(aOwnObjects: boolean; aNoDuplicate: boolean=false; + aCaseSensitive: boolean=true); overload; + /// finalize the internal objects stored + // - if instance was created with fOwnObjects flag + destructor Destroy; override; + /// get a stored Object item by its associated UTF-8 text + // - returns nil and raise no exception if aText doesn't exist + // - thread-safe method, unless returned TObject is deleted in the background + function GetObjectFrom(const aText: RawUTF8): pointer; + /// store a new RawUTF8 item + // - without the fNoDuplicate flag, it will always add the supplied value + // - if fNoDuplicate was set and aText already exists (using the internal + // hash table), it will return -1 unless aRaiseExceptionIfExisting is forced + // - thread-safe method + function Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean=false): PtrInt; {$ifdef HASINLINE}inline;{$endif} + /// store a new RawUTF8 item, and its associated TObject + // - without the fNoDuplicate flag, it will always add the supplied value + // - if fNoDuplicate was set and aText already exists (using the internal hash + // table), it will return -1 unless aRaiseExceptionIfExisting is forced; + // optionally freeing the supplied aObject if aFreeAndReturnExistingObject + // is true, in which pointer the existing Objects[] is copied (see + // AddObjectUnique as a convenient wrapper around this behavior) + // - thread-safe method + function AddObject(const aText: RawUTF8; aObject: TObject; + aRaiseExceptionIfExisting: boolean=false; aFreeAndReturnExistingObject: PPointer=nil): PtrInt; + /// try to store a new RawUTF8 item and its associated TObject + // - fNoDuplicate should have been specified in the list flags + // - if aText doesn't exist, will add the values + // - if aText exist, will call aObjectToAddOrFree.Free and set the value + // already stored in Objects[] into aObjectToAddOrFree - allowing dual + // commit thread-safe update of the list, e.g. after a previous unsuccessful + // call to GetObjectFrom(aText) + // - thread-safe method, using an internal Hash Table to speedup IndexOf() + // - in fact, this method is just a wrapper around + // ! AddObject(aText,aObjectToAddOrFree^,false,@aObjectToAddOrFree); + procedure AddObjectUnique(const aText: RawUTF8; aObjectToAddOrFree: PPointer); + {$ifdef HASINLINE}inline;{$endif} + /// append a specified list to the current content + // - thread-safe method + procedure AddRawUTF8List(List: TRawUTF8List); + /// delete a stored RawUTF8 item, and its associated TObject + // - raise no exception in case of out of range supplied index + // - this method is not thread-safe: use Safe.Lock/UnLock if needed + procedure Delete(Index: PtrInt); overload; + /// delete a stored RawUTF8 item, and its associated TObject + // - will search for the value using IndexOf(aText), and returns its index + // - returns -1 if no entry was found and deleted + // - thread-safe method, using the internal Hash Table if fNoDuplicate is set + function Delete(const aText: RawUTF8): PtrInt; overload; + /// delete a stored RawUTF8 item, and its associated TObject, from + // a given Name when stored as 'Name=Value' pairs + // - raise no exception in case of out of range supplied index + // - thread-safe method, but not using the internal Hash Table + // - consider using TSynNameValue if you expect efficient name/value process + function DeleteFromName(const Name: RawUTF8): PtrInt; virtual; + /// find the index of a given Name when stored as 'Name=Value' pairs + // - search on Name is case-insensitive with 'Name=Value' pairs + // - this method is not thread-safe, and won't use the internal Hash Table + // - consider using TSynNameValue if you expect efficient name/value process + function IndexOfName(const Name: RawUTF8): PtrInt; + /// access to the Value of a given 'Name=Value' pair at a given position + // - this method is not thread-safe + // - consider using TSynNameValue if you expect efficient name/value process + function GetValueAt(Index: PtrInt): RawUTF8; + /// retrieve Value from an existing Name=Value, then optinally delete the entry + // - if Name is found, will fill Value with the stored content and return true + // - if Name is not found, Value is not modified, and false is returned + // - thread-safe method, but not using the internal Hash Table + // - consider using TSynNameValue if you expect efficient name/value process + function UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean): boolean; + /// retrieve and delete the first RawUTF8 item in the list + // - could be used as a FIFO, calling Add() as a "push" method + // - thread-safe method + function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; + /// retrieve and delete the last RawUTF8 item in the list + // - could be used as a FILO, calling Add() as a "push" method + // - thread-safe method + function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; + /// erase all stored RawUTF8 items + // - and corresponding objects (if aOwnObjects was true at constructor) + // - thread-safe method, also clearing the internal Hash Table + procedure Clear; virtual; + /// find a RawUTF8 item in the stored Strings[] list + // - this search is case sensitive if fCaseSensitive flag was set (which + // is the default) + // - this method is not thread-safe since the internal list may change + // and the returned index may not be accurate any more + // - see also GetObjectFrom() + // - uses the internal Hash Table if fNoDuplicate was set + function IndexOf(const aText: RawUTF8): PtrInt; + /// find a TObject item index in the stored Objects[] list + // - this method is not thread-safe since the internal list may change + // and the returned index may not be accurate any more + // - aObject lookup won't use the internal Hash Table + function IndexOfObject(aObject: TObject): PtrInt; + /// search for any RawUTF8 item containing some text + // - uses PosEx() on the stored lines + // - this method is not thread-safe since the internal list may change + // and the returned index may not be accurate any more + // - by design, aText lookup can't use the internal Hash Table + function Contains(const aText: RawUTF8; aFirstIndex: integer=0): PtrInt; + /// retrieve the all lines, separated by the supplied delimiter + // - this method is thread-safe + function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8; + /// the OnChange event will be raised only when EndUpdate will be called + // - this method will also call Safe.Lock for thread-safety + procedure BeginUpdate; + /// call the OnChange event if changes occured + // - this method will also call Safe.UnLock for thread-safety + procedure EndUpdate; + /// set low-level text and objects from existing arrays + procedure SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); + /// set all lines, separated by the supplied delimiter + // - this method is thread-safe + procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10); + /// set all lines from an UTF-8 text file + // - expect the file is explicitly an UTF-8 file + // - will ignore any trailing UTF-8 BOM in the file content, but will not + // expect one either + // - this method is thread-safe + procedure LoadFromFile(const FileName: TFileName); + /// write all lines into the supplied stream + // - this method is thread-safe + procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10); + /// write all lines into a new file + // - this method is thread-safe + procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10); + /// return the count of stored RawUTF8 + // - reading this property is not thread-safe, since size may change + property Count: PtrInt read GetCount; + /// set or retrieve the current memory capacity of the RawUTF8 list + // - reading this property is not thread-safe, since size may change + property Capacity: PtrInt read GetCapacity write SetCapacity; + /// set if IndexOf() shall be case sensitive or not + // - default is TRUE + // - matches fCaseSensitive in Flags + property CaseSensitive: boolean read GetCaseSensitive write SetCaseSensitive; + /// set if the list doesn't allow duplicated UTF-8 text + // - if true, an internal hash table is maintained for faster IndexOf() + // - matches fNoDuplicate in Flags + property NoDuplicate: boolean read GetNoDuplicate; + /// access to the low-level flags of this list + property Flags: TRawUTF8ListFlags read fFlags write fFlags; + /// get or set a RawUTF8 item + // - returns '' and raise no exception in case of out of range supplied index + // - if you want to use it with the VCL, use UTF8ToString() function + // - reading this property is not thread-safe, since content may change + property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default; + /// get or set a Object item + // - returns nil and raise no exception in case of out of range supplied index + // - reading this property is not thread-safe, since content may change + property Objects[Index: PtrInt]: pointer read GetObject write PutObject; + /// retrieve the corresponding Name when stored as 'Name=Value' pairs + // - reading this property is not thread-safe, since content may change + // - consider TSynNameValue if you expect more efficient name/value process + property Names[Index: PtrInt]: RawUTF8 read GetName; + /// access to the corresponding 'Name=Value' pairs + // - search on Name is case-insensitive with 'Name=Value' pairs + // - reading this property is thread-safe, but won't use the hash table + // - consider TSynNameValue if you expect more efficient name/value process + property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue; + /// the char separator between 'Name=Value' pairs + // - equals '=' by default + // - consider TSynNameValue if you expect more efficient name/value process + property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep; + /// set or retrieve all items as text lines + // - lines are separated by #13#10 (CRLF) by default; use GetText and + // SetText methods if you want to use another line delimiter (even a comma) + // - this property is thread-safe + property Text: RawUTF8 read GetTextCRLF write SetTextCRLF; + /// Event triggered when an entry is modified + property OnChange: TNotifyEvent read fOnChange write fOnChange; + /// direct access to the memory of the TRawUTF8DynArray items + // - reading this property is not thread-safe, since content may change + property TextPtr: PPUtf8CharArray read GetTextPtr; + /// direct access to the memory of the TObjectDynArray items + // - reading this property is not thread-safe, since content may change + property ObjectPtr: PPointerArray read GetObjectPtr; + /// direct access to the TRawUTF8DynArray items dynamic array wrapper + // - using this property is not thread-safe, since content may change + property ValuesArray: TDynArrayHashed read fValues; + /// access to the locking methods of this instance + // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block + property Safe: TSynLocker read fSafe; + end; + + // some declarations used for backward compatibility only + TRawUTF8ListLocked = type TRawUTF8List; + TRawUTF8ListHashed = type TRawUTF8List; + TRawUTF8ListHashedLocked = type TRawUTF8ListHashed; + // deprecated TRawUTF8MethodList should be replaced by a TSynDictionary + + /// define the implemetation used by TAlgoCompress.Decompress() + TAlgoCompressLoad = (aclNormal, aclSafeSlow, aclNoCrcFast); + + /// abstract low-level parent class for generic compression/decompression algorithms + // - will encapsulate the compression algorithm with crc32c hashing + // - all Algo* abstract methods should be overriden by inherited classes + TAlgoCompress = class(TSynPersistent) + public + /// should return a genuine byte identifier + // - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast + // (in mORMot.pas), 4/5/6 for TAlgoLizard/Fast/Huffman (in SynLizard.pas) + function AlgoID: byte; virtual; abstract; + /// computes by default the crc32c() digital signature of the buffer + function AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; virtual; + /// get maximum possible (worse) compressed size for the supplied length + function AlgoCompressDestLen(PlainLen: integer): integer; virtual; abstract; + /// this method will compress the supplied data + function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; virtual; abstract; + /// this method will return the size of the decompressed data + function AlgoDecompressDestLen(Comp: pointer): integer; virtual; abstract; + /// this method will decompress the supplied data + function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; virtual; abstract; + /// this method will partially and safely decompress the supplied data + // - expects PartialLen <= result < PartialLenMax, depending on the algorithm + function AlgoDecompressPartial(Comp: pointer; CompLen: integer; + Partial: pointer; PartialLen, PartialLenMax: integer): integer; virtual; abstract; + public + /// will register AlgoID in the global list, for Algo() class methods + // - no need to free this instance, since it will be owned by the global list + // - raise a ESynException if the class or its AlgoID are already registered + // - you should never have to call this constructor, but define a global + // variable holding a reference to a shared instance + constructor Create; override; + /// get maximum possible (worse) compressed size for the supplied length + // - including the crc32c + algo 9 bytes header + function CompressDestLen(PlainLen: integer): integer; + {$ifdef HASINLINE}inline;{$endif} + /// compress a memory buffer with crc32c hashing to a RawByteString + function Compress(const Plain: RawByteString; CompressionSizeTrigger: integer=100; + CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + /// compress a memory buffer with crc32c hashing to a RawByteString + function Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; + CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; + /// compress a memory buffer with crc32c hashing + // - supplied Comp buffer should contain at least CompressDestLen(PlainLen) bytes + function Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; + CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; + /// compress a memory buffer with crc32c hashing to a TByteDynArray + function CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer=100; + CheckMagicForCompressed: boolean=false): TByteDynArray; overload; + {$ifdef HASINLINE}inline;{$endif} + /// compress a memory buffer with crc32c hashing to a TByteDynArray + function CompressToBytes(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; + CheckMagicForCompressed: boolean=false): TByteDynArray; overload; + /// uncompress a RawByteString memory buffer with crc32c hashing + function Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad=aclNormal; + BufferOffset: integer=0): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + /// uncompress a RawByteString memory buffer with crc32c hashing + // - returns TRUE on success + function TryDecompress(const Comp: RawByteString; out Dest: RawByteString; + Load: TAlgoCompressLoad=aclNormal): boolean; + /// uncompress a memory buffer with crc32c hashing + procedure Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString; + Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0); overload; + /// uncompress a RawByteString memory buffer with crc32c hashing + function Decompress(const Comp: TByteDynArray): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + /// uncompress a RawByteString memory buffer with crc32c hashing + // - returns nil if crc32 hash failed, i.e. if the supplied Comp is not correct + // - returns a pointer to the uncompressed data and fill PlainLen variable, + // after crc32c hash + // - avoid any memory allocation in case of a stored content - otherwise, would + // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) + function Decompress(const Comp: RawByteString; out PlainLen: integer; + var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; + {$ifdef HASINLINE}inline;{$endif} + /// uncompress a RawByteString memory buffer with crc32c hashing + // - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct + // - returns a pointer to an uncompressed data buffer of PlainLen bytes + // - avoid any memory allocation in case of a stored content - otherwise, would + // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) + function Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer; + var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; + /// decode the header of a memory buffer compressed via the Compress() method + // - validates the crc32c of the compressed data (unless Load=aclNoCrcFast), + // then return the uncompressed size in bytes, or 0 if the crc32c does not match + // - should call DecompressBody() later on to actually retrieve the content + function DecompressHeader(Comp: PAnsiChar; CompLen: integer; + Load: TAlgoCompressLoad=aclNormal): integer; + /// decode the content of a memory buffer compressed via the Compress() method + // - PlainLen has been returned by a previous call to DecompressHeader() + function DecompressBody(Comp,Plain: PAnsiChar; CompLen,PlainLen: integer; + Load: TAlgoCompressLoad=aclNormal): boolean; + /// partial decoding of a memory buffer compressed via the Compress() method + // - returns 0 on error, or how many bytes have been written to Partial + // - will call virtual AlgoDecompressPartial() which is slower, but expected + // to avoid any buffer overflow on the Partial destination buffer + // - some algorithms (e.g. Lizard) may need some additional bytes in the + // decode buffer, so PartialLenMax bytes should be allocated in Partial^, + // with PartialLenMax > expected PartialLen, and returned bytes may be > + // PartialLen, but always <= PartialLenMax + function DecompressPartial(Comp,Partial: PAnsiChar; CompLen,PartialLen,PartialLenMax: integer): integer; + /// get the TAlgoCompress instance corresponding to the AlgoID stored + // in the supplied compressed buffer + // - returns nil if no algorithm was identified + class function Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; overload; + {$ifdef HASINLINE}inline;{$endif} + /// get the TAlgoCompress instance corresponding to the AlgoID stored + // in the supplied compressed buffer + // - returns nil if no algorithm was identified + // - also identifies "stored" content in IsStored variable + class function Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; overload; + /// get the TAlgoCompress instance corresponding to the AlgoID stored + // in the supplied compressed buffer + // - returns nil if no algorithm was identified + class function Algo(const Comp: RawByteString): TAlgoCompress; overload; + {$ifdef HASINLINE}inline;{$endif} + /// get the TAlgoCompress instance corresponding to the AlgoID stored + // in the supplied compressed buffer + // - returns nil if no algorithm was identified + class function Algo(const Comp: TByteDynArray): TAlgoCompress; overload; + {$ifdef HASINLINE}inline;{$endif} + /// get the TAlgoCompress instance corresponding to the supplied AlgoID + // - returns nil if no algorithm was identified + // - stored content is identified as TAlgoSynLZ + class function Algo(AlgoID: byte): TAlgoCompress; overload; + /// quickly validate a compressed buffer content, without uncompression + // - extract the TAlgoCompress, and call DecompressHeader() to check the + // hash of the compressed data, and return then uncompressed size + // - returns 0 on error (e.g. unknown algorithm or incorrect hash) + class function UncompressedSize(const Comp: RawByteString): integer; + /// returns the algorithm name, from its classname + // - e.g. TAlgoSynLZ->'synlz' TAlgoLizard->'lizard' nil->'none' + function AlgoName: TShort16; + end; + + /// implement our fast SynLZ compression as a TAlgoCompress class + // - please use the AlgoSynLZ global variable methods instead of the deprecated + // SynLZCompress/SynLZDecompress wrapper functions + TAlgoSynLZ = class(TAlgoCompress) + public + /// returns 1 as genuine byte identifier for SynLZ + function AlgoID: byte; override; + /// get maximum possible (worse) SynLZ compressed size for the supplied length + function AlgoCompressDestLen(PlainLen: integer): integer; override; + /// compress the supplied data using SynLZ + function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; + /// return the size of the SynLZ decompressed data + function AlgoDecompressDestLen(Comp: pointer): integer; override; + /// decompress the supplied data using SynLZ + function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; + /// partial (and safe) decompression of the supplied data using SynLZ + function AlgoDecompressPartial(Comp: pointer; CompLen: integer; + Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; + end; + + TAlgoCompressWithNoDestLenProcess = (doCompress, doUnCompress, doUncompressPartial); + + /// abstract class storing the plain length before calling compression API + // - some libraries (e.g. Deflate or Lizard) don't provide the uncompressed + // length from its output buffer - inherit from this class to store this value + // as ToVarUInt32, and override the RawProcess abstract protected method + TAlgoCompressWithNoDestLen = class(TAlgoCompress) + protected + /// inherited classes should implement this single method for the actual process + // - dstMax is oinly used for doUncompressPartial + function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer; + process: TAlgoCompressWithNoDestLenProcess): integer; virtual; abstract; + public + /// performs the compression, storing PlainLen and calling protected RawProcess + function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; + /// return the size of the decompressed data (using FromVarUInt32) + function AlgoDecompressDestLen(Comp: pointer): integer; override; + /// performs the decompression, retrieving PlainLen and calling protected RawProcess + function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; + /// performs the decompression, retrieving PlainLen and calling protected RawProcess + function AlgoDecompressPartial(Comp: pointer; CompLen: integer; + Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; + end; + + // internal flag, used only by TSynDictionary.InArray protected method + TSynDictionaryInArray = ( + iaFind, iaFindAndDelete, iaFindAndUpdate, iaFindAndAddIfNotExisting, iaAdd); + + /// event called by TSynDictionary.ForEach methods to iterate over stored items + // - if the implementation method returns TRUE, will continue the loop + // - if the implementation method returns FALSE, will stop values browsing + // - aOpaque is a custom value specified at ForEach() method call + TSynDictionaryEvent = function(const aKey; var aValue; aIndex,aCount: integer; + aOpaque: pointer): boolean of object; + + /// event called by TSynDictionary.DeleteDeprecated + // - called just before deletion: return false to by-pass this item + TSynDictionaryCanDeleteEvent = function(const aKey, aValue; aIndex: integer): boolean of object; + + /// thread-safe dictionary to store some values from associated keys + // - will maintain a dynamic array of values, associated with a hash table + // for the keys, so that setting or retrieving values would be O(1) + // - all process is protected by a TSynLocker, so will be thread-safe + // - TDynArray is a wrapper which do not store anything, whereas this class + // is able to store both keys and values, and provide convenient methods to + // access the stored data, including JSON serialization and binary storage + TSynDictionary = class(TSynPersistentLock) + protected + fKeys: TDynArrayHashed; + fValues: TDynArray; + fTimeOut: TCardinalDynArray; + fTimeOuts: TDynArray; + fCompressAlgo: TAlgoCompress; + fOnCanDelete: TSynDictionaryCanDeleteEvent; + function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean; + procedure SetTimeouts; + function ComputeNextTimeOut: cardinal; + function KeyFullHash(const Elem): cardinal; + function KeyFullCompare(const A,B): integer; + function GetCapacity: integer; + procedure SetCapacity(const Value: integer); + function GetTimeOutSeconds: cardinal; + public + /// initialize the dictionary storage, specifyng dynamic array keys/values + // - aKeyTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which + // would store the keys within this TSynDictionary instance + // - aValueTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which + // would store the values within this TSynDictionary instance + // - by default, string keys would be searched following exact case, unless + // aKeyCaseInsensitive is TRUE + // - you can set an optional timeout period, in seconds - you should call + // DeleteDeprecated periodically to search for deprecated items + constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer; + aKeyCaseInsensitive: boolean=false; aTimeoutSeconds: cardinal=0; + aCompressAlgo: TAlgoCompress=nil); reintroduce; virtual; + /// finalize the storage + // - would release all internal stored values + destructor Destroy; override; + /// try to add a value associated with a primary key + // - returns the index of the inserted item, -1 if aKey is already existing + // - this method is thread-safe, since it will lock the instance + function Add(const aKey, aValue): integer; + /// store a value associated with a primary key + // - returns the index of the matching item + // - if aKey does not exist, a new entry is added + // - if aKey does exist, the existing entry is overriden with aValue + // - this method is thread-safe, since it will lock the instance + function AddOrUpdate(const aKey, aValue): integer; + /// clear the value associated via aKey + // - does not delete the entry, but reset its value + // - returns the index of the matching item, -1 if aKey was not found + // - this method is thread-safe, since it will lock the instance + function Clear(const aKey): integer; + /// delete all key/value stored in the current instance + procedure DeleteAll; + /// delete a key/value association from its supplied aKey + // - this would delete the entry, i.e. matching key and value pair + // - returns the index of the deleted item, -1 if aKey was not found + // - this method is thread-safe, since it will lock the instance + function Delete(const aKey): integer; + /// delete a key/value association from its internal index + // - this method is not thread-safe: you should use fSafe.Lock/Unlock + // e.g. then Find/FindValue to retrieve the index value + function DeleteAt(aIndex: integer): boolean; + /// search and delete all deprecated items according to TimeoutSeconds + // - returns how many items have been deleted + // - you can call this method very often: it will ensure that the + // search process will take place at most once every second + // - this method is thread-safe, but blocking during the process + function DeleteDeprecated: integer; + /// search of a primary key within the internal hashed dictionary + // - returns the index of the matching item, -1 if aKey was not found + // - if you want to access the value, you should use fSafe.Lock/Unlock: + // consider using Exists or FindAndCopy thread-safe methods instead + // - aUpdateTimeOut will update the associated timeout value of the entry + function Find(const aKey; aUpdateTimeOut: boolean=false): integer; + /// search of a primary key within the internal hashed dictionary + // - returns a pointer to the matching item, nil if aKey was not found + // - if you want to access the value, you should use fSafe.Lock/Unlock: + // consider using Exists or FindAndCopy thread-safe methods instead + // - aUpdateTimeOut will update the associated timeout value of the entry + function FindValue(const aKey; aUpdateTimeOut: boolean=false; aIndex: PInteger=nil): pointer; + /// search of a primary key within the internal hashed dictionary + // - returns a pointer to the matching or already existing item + // - if you want to access the value, you should use fSafe.Lock/Unlock: + // consider using Exists or FindAndCopy thread-safe methods instead + // - will update the associated timeout value of the entry, if applying + function FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger=nil): pointer; + /// search of a stored value by its primary key, and return a local copy + // - so this method is thread-safe + // - returns TRUE if aKey was found, FALSE if no match exists + // - will update the associated timeout value of the entry, unless + // aUpdateTimeOut is set to false + function FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean=true): boolean; + /// search of a stored value by its primary key, then delete and return it + // - returns TRUE if aKey was found, fill aValue with its content, + // and delete the entry in the internal storage + // - so this method is thread-safe + // - returns FALSE if no match exists + function FindAndExtract(const aKey; out aValue): boolean; + /// search for a primary key presence + // - returns TRUE if aKey was found, FALSE if no match exists + // - this method is thread-safe + function Exists(const aKey): boolean; + /// apply a specified event over all items stored in this dictionnary + // - would browse the list in the adding order + // - returns the number of times OnEach has been called + // - this method is thread-safe, since it will lock the instance + function ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer=nil): integer; overload; + /// apply a specified event over matching items stored in this dictionnary + // - would browse the list in the adding order, comparing each key and/or + // value item with the supplied comparison functions and aKey/aValue content + // - returns the number of times OnMatch has been called, i.e. how many times + // KeyCompare(aKey,Keys[#])=0 or ValueCompare(aValue,Values[#])=0 + // - this method is thread-safe, since it will lock the instance + function ForEach(const OnMatch: TSynDictionaryEvent; + KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; + Opaque: pointer=nil): integer; overload; + /// touch the entry timeout field so that it won't be deprecated sooner + // - this method is not thread-safe, and is expected to be execute e.g. + // from a ForEach() TSynDictionaryEvent callback + procedure SetTimeoutAtIndex(aIndex: integer); + /// search aArrayValue item in a dynamic-array value associated via aKey + // - expect the stored value to be a dynamic array itself + // - would search for aKey as primary key, then use TDynArray.Find + // to delete any aArrayValue match in the associated dynamic array + // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue + // were not found + // - this method is thread-safe, since it will lock the instance + function FindInArray(const aKey, aArrayValue): boolean; + /// search of a stored key by its associated key, and return a key local copy + // - won't use any hashed index but TDynArray.IndexOf over fValues, + // so is much slower than FindAndCopy() + // - will update the associated timeout value of the entry, unless + // aUpdateTimeOut is set to false + // - so this method is thread-safe + // - returns TRUE if aValue was found, FALSE if no match exists + function FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean=true): boolean; + /// add aArrayValue item within a dynamic-array value associated via aKey + // - expect the stored value to be a dynamic array itself + // - would search for aKey as primary key, then use TDynArray.Add + // to add aArrayValue to the associated dynamic array + // - returns FALSE if Values is not a tkDynArray, or if aKey was not found + // - this method is thread-safe, since it will lock the instance + function AddInArray(const aKey, aArrayValue): boolean; + /// add once aArrayValue within a dynamic-array value associated via aKey + // - expect the stored value to be a dynamic array itself + // - would search for aKey as primary key, then use + // TDynArray.FindAndAddIfNotExisting to add once aArrayValue to the + // associated dynamic array + // - returns FALSE if Values is not a tkDynArray, or if aKey was not found + // - this method is thread-safe, since it will lock the instance + function AddOnceInArray(const aKey, aArrayValue): boolean; + /// clear aArrayValue item of a dynamic-array value associated via aKey + // - expect the stored value to be a dynamic array itself + // - would search for aKey as primary key, then use TDynArray.FindAndDelete + // to delete any aArrayValue match in the associated dynamic array + // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were + // not found + // - this method is thread-safe, since it will lock the instance + function DeleteInArray(const aKey, aArrayValue): boolean; + /// replace aArrayValue item of a dynamic-array value associated via aKey + // - expect the stored value to be a dynamic array itself + // - would search for aKey as primary key, then use TDynArray.FindAndUpdate + // to delete any aArrayValue match in the associated dynamic array + // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were + // not found + // - this method is thread-safe, since it will lock the instance + function UpdateInArray(const aKey, aArrayValue): boolean; + {$ifndef DELPHI5OROLDER} + /// make a copy of the stored values + // - this method is thread-safe, since it will lock the instance during copy + // - resulting length(Dest) will match the exact values count + // - T*ObjArray will be reallocated and copied by content (using a temporary + // JSON serialization), unless ObjArrayByRef is true and pointers are copied + procedure CopyValues(out Dest; ObjArrayByRef: boolean=false); + {$endif DELPHI5OROLDER} + /// serialize the content as a "key":value JSON object + procedure SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean=false); overload; + /// serialize the content as a "key":value JSON object + function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; overload; + /// serialize the Values[] as a JSON array + function SaveValuesToJSON(EnumSetsAsText: boolean=false): RawUTF8; + /// unserialize the content from "key":value JSON object + // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON), + // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation + function LoadFromJSON(const JSON: RawUTF8 {$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; + /// unserialize the content from "key":value JSON object + // - note that input JSON buffer is not modified in place: no need to create + // a temporary copy if the buffer is about to be re-used + function LoadFromJSON(JSON: PUTF8Char {$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; + /// save the content as SynLZ-compressed raw binary data + // - warning: this format is tied to the values low-level RTTI, so if you + // change the value/key type definitions, LoadFromBinary() would fail + function SaveToBinary(NoCompression: boolean=false): RawByteString; + /// load the content from SynLZ-compressed raw binary data + // - as previously saved by SaveToBinary method + function LoadFromBinary(const binary: RawByteString): boolean; + /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked + class function OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean; + /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked + class function OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean; + /// returns how many items are currently stored in this dictionary + // - this method is thread-safe + function Count: integer; + /// fast returns how many items are currently stored in this dictionary + // - this method is NOT thread-safe so should be protected by fSafe.Lock/UnLock + function RawCount: integer; {$ifdef HASINLINE}inline;{$endif} + /// direct access to the primary key identifiers + // - if you want to access the keys, you should use fSafe.Lock/Unlock + property Keys: TDynArrayHashed read fKeys; + /// direct access to the associated stored values + // - if you want to access the values, you should use fSafe.Lock/Unlock + property Values: TDynArray read fValues; + /// defines how many items are currently stored in Keys/Values internal arrays + property Capacity: integer read GetCapacity write SetCapacity; + /// direct low-level access to the internal access tick (GetTickCount64 shr 10) + // - may be nil if TimeOutSeconds=0 + property TimeOut: TCardinalDynArray read fTimeOut; + /// returns the aTimeOutSeconds parameter value, as specified to Create() + property TimeOutSeconds: cardinal read GetTimeOutSeconds; + /// the compression algorithm used for binary serialization + property CompressAlgo: TAlgoCompress read fCompressAlgo write fCompressAlgo; + /// callback to by-pass DeleteDeprecated deletion by returning false + // - can be assigned e.g. to OnCanDeleteSynPersistentLock if Value is a + // TSynPersistentLock instance, to avoid any potential access violation + property OnCanDeleteDeprecated: TSynDictionaryCanDeleteEvent read fOnCanDelete write fOnCanDelete; + end; + + /// event signature to locate a service for a given string key + // - used e.g. by TRawUTF8ObjectCacheList.OnKeyResolve property + TOnKeyResolve = function(const aInterface: TGUID; const Key: RawUTF8; out Obj): boolean of object; + /// event signature to notify a given string key + TOnKeyNotify = procedure(Sender: TObject; const Key: RawUTF8) of object; + +var + /// mORMot.pas will registry here its T*ObjArray serialization process + // - will be used by TDynArray.GetIsObjArray + DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): TPointerClassHashed; + +type + /// handle memory mapping of a file content + TMemoryMap = object + protected + fBuf: PAnsiChar; + fBufSize: PtrUInt; + fFile: THandle; + {$ifdef MSWINDOWS} + fMap: THandle; + {$endif} + fFileSize: Int64; + fFileLocal: boolean; + public + /// map the corresponding file handle + // - if aCustomSize and aCustomOffset are specified, the corresponding + // map view if created (by default, will map whole file) + function Map(aFile: THandle; aCustomSize: PtrUInt=0; aCustomOffset: Int64=0): boolean; overload; + /// map the file specified by its name + // - file will be closed when UnMap will be called + function Map(const aFileName: TFileName): boolean; overload; + /// set a fixed buffer for the content + // - emulated a memory-mapping from an existing buffer + procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload; + /// unmap the file + procedure UnMap; + /// retrieve the memory buffer mapped to the file content + property Buffer: PAnsiChar read fBuf; + /// retrieve the buffer size + property Size: PtrUInt read fBufSize; + /// retrieve the mapped file size + property FileSize: Int64 read fFileSize; + /// access to the low-level associated File handle (if any) + property FileHandle: THandle read fFile; + end; + + {$M+} + /// able to read a UTF-8 text file using memory map + // - much faster than TStringList.LoadFromFile() + // - will ignore any trailing UTF-8 BOM in the file content, but will not + // expect one either + TMemoryMapText = class + protected + fLines: PPointerArray; + fLinesMax: integer; + fCount: integer; + fMapEnd: PUTF8Char; + fMap: TMemoryMap; + fFileName: TFileName; + fAppendedLines: TRawUTF8DynArray; + fAppendedLinesCount: integer; + function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif} + function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif} + /// call once by Create constructors when fMap has been initialized + procedure LoadFromMap(AverageLineLength: integer=32); virtual; + /// call once per line, from LoadFromMap method + // - default implementation will set fLines[fCount] := LineBeg; + // - override this method to add some per-line process at loading: it will + // avoid reading the entire file more than once + procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual; + public + /// initialize the memory mapped text file + // - this default implementation just do nothing but is called by overloaded + // constructors so may be overriden to initialize an inherited class + constructor Create; overload; virtual; + /// read an UTF-8 encoded text file + // - every line beginning is stored into LinePointers[] + constructor Create(const aFileName: TFileName); overload; + /// read an UTF-8 encoded text file content + // - every line beginning is stored into LinePointers[] + // - this overloaded constructor accept an existing memory buffer (some + // uncompressed data e.g.) + constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload; + /// release the memory map and internal LinePointers[] + destructor Destroy; override; + /// save the whole content into a specified stream + // - including any runtime appended values via AddInMemoryLine() + procedure SaveToStream(Dest: TStream; const Header: RawUTF8); + /// save the whole content into a specified file + // - including any runtime appended values via AddInMemoryLine() + // - an optional header text can be added to the beginning of the file + procedure SaveToFile(FileName: TFileName; const Header: RawUTF8=''); + /// add a new line to the already parsed content + // - this line won't be stored in the memory mapped file, but stay in memory + // and appended to the existing lines, until this instance is released + procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual; + /// clear all in-memory appended rows + procedure AddInMemoryLinesClear; virtual; + /// retrieve the number of UTF-8 chars of the given line + // - warning: no range check is performed about supplied index + function LineSize(aIndex: integer): integer; + {$ifdef HASINLINE}inline;{$endif} + /// check if there is at least a given number of UTF-8 chars in the given line + // - this is faster than LineSize(aIndex) use this function to safe access files > 2 GB +// (thanks to sanyin for the report) +function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64; + +/// wrapper to serialize a T*ObjArray dynamic array as JSON +// - as expected by TJSONSerializer.RegisterObjArrayForJSON() +function ObjArrayToJSON(const aObjArray; + aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; + +/// encode the supplied data as an UTF-8 valid JSON object content +// - data must be supplied two by two, as Name,Value pairs, e.g. +// ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}' +// - or you can specify nested arrays or objects with '['..']' or '{'..'}': +// ! J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]); +// ! assert(J='{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +// - you can pass nil as parameter for a null JSON value +function JSONEncode(const NameValuePairs: array of const): RawUTF8; overload; + +{$ifndef NOVARIANTS} +/// encode the supplied (extended) JSON content, with parameters, +// as an UTF-8 valid JSON object content +// - in addition to the JSON RFC specification strict mode, this method will +// handle some BSON-like extensions, e.g. unquoted field names: +// ! aJSON := JSONEncode('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); +// - you can use nested _Obj() / _Arr() instances +// ! aJSON := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']); +// ! aJSON := JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])]); +// ! // will both return +// ! '{"type":{"$in":["food","snack"]}}') +// - if the SynMongoDB unit is used in the application, the MongoDB Shell +// syntax will also be recognized to create TBSONVariant, like +// ! new Date() ObjectId() MinKey MaxKey // +// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json +// ! aJSON := JSONEncode('{name:?,field:/%/i}',['acme.*corp'],['John'])) +// ! // will return +// ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' +// - will call internally _JSONFastFmt() to create a temporary TDocVariant with +// all its features - so is slightly slower than other JSONEncode* functions +function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; overload; +{$endif} + +/// encode the supplied RawUTF8 array data as an UTF-8 valid JSON array content +function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; overload; + +/// encode the supplied integer array data as a valid JSON array +function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; overload; + +/// encode the supplied floating-point array data as a valid JSON array +function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; overload; + +/// encode the supplied array data as a valid JSON array content +// - if WithoutBraces is TRUE, no [ ] will be generated +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +function JSONEncodeArrayOfConst(const Values: array of const; + WithoutBraces: boolean=false): RawUTF8; overload; + +/// encode the supplied array data as a valid JSON array content +// - if WithoutBraces is TRUE, no [ ] will be generated +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +procedure JSONEncodeArrayOfConst(const Values: array of const; + WithoutBraces: boolean; var result: RawUTF8); overload; + +/// encode as JSON {"name":value} object, from a potential SQL quoted value +// - will unquote the SQLValue using TTextWriter.AddQuotedStringAsJSON() +procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8); + +type + /// points to one value of raw UTF-8 content, decoded from a JSON buffer + // - used e.g. by JSONDecode() overloaded function to returns names/values + TValuePUTF8Char = object + public + /// a pointer to the actual UTF-8 text + Value: PUTF8Char; + /// how many UTF-8 bytes are stored in Value + ValueLen: PtrInt; + /// convert the value into a UTF-8 string + procedure ToUTF8(var Text: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} + /// convert the value into a UTF-8 string + function ToUTF8: RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} + /// convert the value into a VCL/generic string + function ToString: string; + /// convert the value into a signed integer + function ToInteger: PtrInt; {$ifdef HASINLINE}inline;{$endif} + /// convert the value into an unsigned integer + function ToCardinal: PtrUInt; {$ifdef HASINLINE}inline;{$endif} + /// will call IdemPropNameU() over the stored text Value + function Idem(const Text: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} + end; + /// used e.g. by JSONDecode() overloaded function to returns values + TValuePUTF8CharArray = array[0..maxInt div SizeOf(TValuePUTF8Char)-1] of TValuePUTF8Char; + PValuePUTF8CharArray = ^TValuePUTF8CharArray; + + /// store one name/value pair of raw UTF-8 content, from a JSON buffer + // - used e.g. by JSONDecode() overloaded function or UrlEncodeJsonObject() + // to returns names/values + TNameValuePUTF8Char = record + /// a pointer to the actual UTF-8 name text + Name: PUTF8Char; + /// a pointer to the actual UTF-8 value text + Value: PUTF8Char; + /// how many UTF-8 bytes are stored in Name (should be integer, not PtrInt) + NameLen: integer; + /// how many UTF-8 bytes are stored in Value + ValueLen: integer; + end; + /// used e.g. by JSONDecode() overloaded function to returns name/value pairs + TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char; + +/// decode the supplied UTF-8 JSON content for the supplied names +// - data will be set in Values, according to the Names supplied e.g. +// ! JSONDecode(JSON,['name','year'],@Values) -> Values[0].Value='John'; Values[1].Value='1972'; +// - if any supplied name wasn't found its corresponding Values[] will be nil +// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char +// array is created inside JSON, which is therefore modified: make a private +// copy first if you want to reuse the JSON content +// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle +// JSON arrays or objects +// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded +// just like '{"name":'"John","year":1972}' +procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; + +/// decode the supplied UTF-8 JSON content for the supplied names +// - an overloaded function when the JSON is supplied as a RawJSON variable +procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; + +/// decode the supplied UTF-8 JSON content for the supplied names +// - data will be set in Values, according to the Names supplied e.g. +// ! JSONDecode(P,['name','year'],Values) -> Values[0]^='John'; Values[1]^='1972'; +// - if any supplied name wasn't found its corresponding Values[] will be nil +// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char +// array is created inside P, which is therefore modified: make a private +// copy first if you want to reuse the JSON content +// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle +// JSON arrays or objects +// - if ValuesLen is set, ValuesLen[] will contain the length of each Values[] +// - returns a pointer to the next content item in the JSON buffer +function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; + +/// decode the supplied UTF-8 JSON content into an array of name/value pairs +// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char +// array is created inside JSON, which is therefore modified: make a private +// copy first if you want to reuse the JSON content +// - the supplied JSON buffer should stay available until Name/Value pointers +// from returned Values[] are accessed +// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle +// JSON arrays or objects +// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded +// just like '{"name":'"John","year":1972}' +function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; + HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; + +/// decode the supplied UTF-8 JSON content for the one supplied name +// - this function will decode the JSON content in-memory, so will unescape it +// in-place: it must be called only once with the same JSON data +function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result'; + wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload; + +/// retrieve a pointer to JSON string field content +// - returns either ':' for name field, either '}',',' for value field +// - returns nil on JSON content error +// - this function won't touch the JSON buffer, so you can call it before +// using in-place escape process via JSONDecode() or GetJSONField() +function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; + out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; + {$ifdef HASINLINE}inline;{$endif} + +/// efficient JSON field in-place decoding, within a UTF-8 encoded buffer +// - this function decodes in the P^ buffer memory itself (no memory allocation +// or copy), for faster process - so take care that P^ is not shared +// - PDest points to the next field to be decoded, or nil on JSON parsing error +// - EndOfObject (if not nil) is set to the JSON value char (',' ':' or '}' e.g.) +// - optional wasString is set to true if the JSON value was a JSON "string" +// - returns a PUTF8Char to the decoded value, with its optional length in Len^ +// - '"strings"' are decoded as 'strings', with wasString=true, properly JSON +// unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content) +// - null is decoded as nil, with wasString=false +// - true/false boolean values are returned as 'true'/'false', with wasString=false +// - any number value is returned as its ascii representation, with wasString=false +// - works for both field names or values (e.g. '"FieldName":' or 'Value,') +function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; + wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; Len: PInteger=nil): PUTF8Char; + +/// decode a JSON field name in an UTF-8 encoded buffer +// - this function decodes in the P^ buffer memory itself (no memory allocation +// or copy), for faster process - so take care that P^ is not shared +// - it will return the property name (with an ending #0) or nil on error +// - this function will handle strict JSON property name (i.e. a "string"), but +// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} +// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json +function GetJSONPropName(var P: PUTF8Char; Len: PInteger=nil): PUTF8Char; overload; + +/// decode a JSON field name in an UTF-8 encoded shortstring variable +// - this function would left the P^ buffer memory untouched, so may be safer +// than the overloaded GetJSONPropName() function in some cases +// - it will return the property name as a local UTF-8 encoded shortstring, +// or PropName='' on error +// - this function won't unescape the property name, as strict JSON (i.e. a "st\"ring") +// - but it will handle MongoDB syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} +// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json +procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); overload; + +/// decode a JSON content in an UTF-8 encoded buffer +// - GetJSONField() will only handle JSON "strings" or numbers - if +// HandleValuesAsObjectOrArray is TRUE, this function will process JSON { +// objects } or [ arrays ] and add a #0 at the end of it +// - this function decodes in the P^ buffer memory itself (no memory allocation +// or copy), for faster process - so take care that it is an unique string +// - returns a pointer to the value start, and moved P to the next field to +// be decoded, or P=nil in case of any unexpected input +// - wasString is set to true if the JSON value was a "string" +// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') +// - if Len is set, it will contain the length of the returned pointer value +function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil; + EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false; + NormalizeBoolean: Boolean=true; Len: PInteger=nil): PUTF8Char; + +/// retrieve the next JSON item as a RawJSON variable +// - buffer can be either any JSON item, i.e. a string, a number or even a +// JSON array (ending with ]) or a JSON object (ending with }) +// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') +procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; + EndOfObject: PAnsiChar=nil); + +/// retrieve the next JSON item as a RawUTF8 decoded buffer +// - buffer can be either any JSON item, i.e. a string, a number or even a +// JSON array (ending with ]) or a JSON object (ending with }) +// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') +// - just call GetJSONField(), and create a new RawUTF8 from the returned value, +// after proper unescape if wasString^=true +function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; + wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): boolean; + +/// test if the supplied buffer is a "string" value or a numerical value +// (floating point or integer), according to the characters within +// - this version will recognize null/false/true as strings +// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true +function IsString(P: PUTF8Char): boolean; + +/// test if the supplied buffer is a "string" value or a numerical value +// (floating or integer), according to the JSON encoding schema +// - this version will NOT recognize JSON null/false/true as strings +// - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true, +// but IsStringJSON('null')=false +// - will follow the JSON definition of number, i.e. '0123' is a string (i.e. +// '0' is excluded at the begining of a number) and '123' is not a string +function IsStringJSON(P: PUTF8Char): boolean; + +/// test if the supplied buffer is a correct JSON value +function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; overload; + +/// test if the supplied buffer is a correct JSON value +function IsValidJSON(const s: RawUTF8): boolean; overload; + +/// reach positon just after the current JSON item in the supplied UTF-8 buffer +// - buffer can be either any JSON item, i.e. a string, a number or even a +// JSON array (ending with ]) or a JSON object (ending with }) +// - returns nil if the specified buffer is not valid JSON content +// - returns the position in buffer just after the item excluding the separator +// character - i.e. result^ may be ',','}',']' +function GotoEndJSONItem(P: PUTF8Char; strict: boolean=false): PUTF8Char; + +/// reach the positon of the next JSON item in the supplied UTF-8 buffer +// - buffer can be either any JSON item, i.e. a string, a number or even a +// JSON array (ending with ]) or a JSON object (ending with }) +// - returns nil if the specified number of items is not available in buffer +// - returns the position in buffer after the item including the separator +// character (optionally in EndOfObject) - i.e. result will be at the start of +// the next object, and EndOfObject may be ',','}',']' +function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1; + EndOfObject: PAnsiChar=nil): PUTF8Char; + +/// read the position of the JSON value just after a property identifier +// - this function will handle strict JSON property name (i.e. a "string"), but +// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} +// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json +function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; + +/// reach the position of the next JSON object of JSON array +// - first char is expected to be either '[' or '{' +// - will return nil in case of parsing error or unexpected end (#0) +// - will return the next character after ending ] or } - i.e. may be , } ] +function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; overload; + {$ifdef FPC}inline;{$endif} + +/// reach the position of the next JSON object of JSON array +// - first char is expected to be just after the initial '[' or '{' +// - specify ']' or '}' as the expected EndChar +// - will return nil in case of parsing error or unexpected end (#0) +// - will return the next character after ending ] or } - i.e. may be , } ] +function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; overload; + {$ifdef FPC}inline;{$endif} + +/// reach the position of the next JSON object of JSON array +// - first char is expected to be either '[' or '{' +// - this version expects a maximum position in PMax: it may be handy to break +// the parsing for HUGE content - used e.g. by JSONArrayCount(P,PMax) +// - will return nil in case of parsing error or if P reached PMax limit +// - will return the next character after ending ] or { - i.e. may be , } ] +function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; + +/// compute the number of elements of a JSON array +// - this will handle any kind of arrays, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first char AFTER the initial '[' (which +// may be a closing ']') +// - returns -1 if the supplied input is invalid, or the number of identified +// items in the JSON array buffer +function JSONArrayCount(P: PUTF8Char): integer; overload; + +/// compute the number of elements of a JSON array +// - this will handle any kind of arrays, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first char after the initial '[' (which +// may be a closing ']') +// - this overloaded method will abort if P reaches a certain position: for +// really HUGE arrays, it is faster to allocate the content within the loop, +// not ahead of time +function JSONArrayCount(P,PMax: PUTF8Char): integer; overload; + +/// go to the #nth item of a JSON array +// - implemented via a fast SAX-like approach: the input buffer is not changed, +// nor no memory buffer allocated neither content copied +// - returns nil if the supplied index is out of range +// - returns a pointer to the index-nth item in the JSON array (first index=0) +// - this will handle any kind of arrays, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first initial '[' char +function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; + +/// retrieve all elements of a JSON array +// - this will handle any kind of arrays, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first char AFTER the initial '[' (which +// may be a closing ']') +// - returns false if the supplied input is invalid +// - returns true on success, with Values[] pointing to each unescaped value, +// may be a JSON string, object, array of constant +function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; + +/// compute the number of fields in a JSON object +// - this will handle any kind of objects, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first char after the initial '{' (which +// may be a closing '}') +function JSONObjectPropCount(P: PUTF8Char): integer; + +/// go to a named property of a JSON object +// - implemented via a fast SAX-like approach: the input buffer is not changed, +// nor no memory buffer allocated neither content copied +// - returns nil if the supplied property name does not exist +// - returns a pointer to the matching item in the JSON object +// - this will handle any kind of objects, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first initial '{' char +function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; + PropNameFound: PRawUTF8=nil): PUTF8Char; + +/// go to a property of a JSON object, by its full path, e.g. 'parent.child' +// - implemented via a fast SAX-like approach: the input buffer is not changed, +// nor no memory buffer allocated neither content copied +// - returns nil if the supplied property path does not exist +// - returns a pointer to the matching item in the JSON object +// - this will handle any kind of objects, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first initial '{' char +function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; + +/// return all matching properties of a JSON object +// - here the PropPath could be a comma-separated list of full paths, +// e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2' +// - returns '' if no property did match +// - returns a JSON object of all matching properties +// - this will handle any kind of objects, including those with nested +// JSON objects or arrays +// - incoming P^ should point to the first initial '{' char +function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; + +/// convert one JSON object into two JSON arrays of keys and values +// - i.e. makes the following transformation: +// $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...] +// - this function won't allocate any memory during its process, nor +// modify the JSON input buffer +// - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method +function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; + +/// remove comments and trailing commas from a text buffer before passing it to JSON parser +// - handle two types of comments: starting from // till end of line +// or /* ..... */ blocks anywhere in the text content +// - trailing commas is replaced by ' ', so resulting JSON is valid for parsers +// what not allows trailing commas (browsers for example) +// - may be used to prepare configuration files before loading; +// for example we store server configuration in file config.json and +// put some comments in this file then code for loading is: +// !var cfg: RawUTF8; +// ! cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json'); +// ! RemoveCommentsFromJSON(@cfg[1]); +// ! pLastChar := JSONToObject(sc,pointer(cfg),configValid); +procedure RemoveCommentsFromJSON(P: PUTF8Char); + +const + /// standard header for an UTF-8 encoded XML file + XMLUTF8_HEADER = ''#13#10; + + /// standard namespace for a generic XML File + XMLUTF8_NAMESPACE = ''; + +/// convert a JSON array or document into a simple XML content +// - just a wrapper around TTextWriter.AddJSONToXML, with an optional +// header before the XML converted data (e.g. XMLUTF8_HEADER), and an optional +// name space content node which will nest the generated XML data (e.g. +// '') - the +// corresponding ending token will be appended after (e.g. '') +// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified +procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; out result: RawUTF8); + +/// convert a JSON array or document into a simple XML content +// - just a wrapper around TTextWriter.AddJSONToXML, making a private copy +// of the supplied JSON buffer using TSynTempBuffer (so that JSON content +// would stay untouched) +// - the optional header is added at the beginning of the resulting string +// - an optional name space content node could be added around the generated XML, +// e.g. '' +function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8=XMLUTF8_HEADER; + const NameSpace: RawUTF8=''): RawUTF8; + +/// formats and indents a JSON array or document to the specified layout +// - just a wrapper around TTextWriter.AddJSONReformat() method +// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified +procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; + Format: TTextWriterJSONFormat=jsonHumanReadable); + +/// formats and indents a JSON array or document to the specified layout +// - just a wrapper around TTextWriter.AddJSONReformat, making a private +// of the supplied JSON buffer (so that JSON content would stay untouched) +function JSONReformat(const JSON: RawUTF8; + Format: TTextWriterJSONFormat=jsonHumanReadable): RawUTF8; + +/// formats and indents a JSON array or document as a file +// - just a wrapper around TTextWriter.AddJSONReformat() method +// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified +function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; + Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; + +/// formats and indents a JSON array or document as a file +// - just a wrapper around TTextWriter.AddJSONReformat, making a private +// of the supplied JSON buffer (so that JSON content would stay untouched) +function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; + Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; + + +const + /// map a PtrInt type to the TJSONCustomParserRTTIType set + ptPtrInt = {$ifdef CPU64}ptInt64{$else}ptInteger{$endif}; + /// map a PtrUInt type to the TJSONCustomParserRTTIType set + ptPtrUInt = {$ifdef CPU64}ptQWord{$else}ptCardinal{$endif}; + /// which TJSONCustomParserRTTIType types are not simple types + // - ptTimeLog is complex, since could be also TCreateTime or TModTime + PT_COMPLEXTYPES = [ptArray, ptRecord, ptCustom, ptTimeLog]; + /// could be used to compute the index in a pointer list from its position + POINTERSHR = {$ifdef CPU64}3{$else}2{$endif}; + /// could be used to compute the bitmask of a pointer integer + POINTERAND = {$ifdef CPU64}7{$else}3{$endif}; + /// could be used to check all bits on a pointer + POINTERBITS = {$ifdef CPU64}64{$else}32{$endif}; + + +{ ************ some other common types and conversion routines ************** } + +type + /// timestamp stored as second-based Unix Time + // - i.e. the number of seconds since 1970-01-01 00:00:00 UTC + // - is stored as 64-bit value, so that it won't be affected by the + // "Year 2038" overflow issue + // - see TUnixMSTime for a millisecond resolution Unix Timestamp + // - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from + // a regular TDateTime + // - use UnixTimeUTC to return the current timestamp, using fast OS API call + // - also one of the encodings supported by SQLite3 date/time functions + TUnixTime = type Int64; + + /// timestamp stored as millisecond-based Unix Time + // - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC + // - see TUnixTime for a second resolution Unix Timestamp + // - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it + // to/from a regular TDateTime + // - also one of the JavaScript date encodings + TUnixMSTime = type Int64; + + /// pointer to a timestamp stored as second-based Unix Time + PUnixTime = ^TUnixTime; + /// pointer to a timestamp stored as millisecond-based Unix Time + PUnixMSTime = ^TUnixMSTime; + /// dynamic array of timestamps stored as second-based Unix Time + TUnixTimeDynArray = array of TUnixTime; + /// dynamic array of timestamps stored as millisecond-based Unix Time + TUnixMSTimeDynArray = array of TUnixMSTime; + +type + /// calling context of TSynLogExceptionToStr callbacks + TSynLogExceptionContext = record + /// the raised exception class + EClass: ExceptClass; + /// the Delphi Exception instance + // - may be nil for external/OS exceptions + EInstance: Exception; + /// the OS-level exception code + // - could be $0EEDFAE0 of $0EEDFADE for Delphi-generated exceptions + ECode: DWord; + /// the address where the exception occured + EAddr: PtrUInt; + /// the optional stack trace + EStack: PPtrUInt; + /// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer + EStackCount: integer; + /// the timestamp of this exception, as number of seconds since UNIX Epoch + // - UnixTimeUTC is faster than NowUTC or GetSystemTime + // - use UnixTimeToDateTime() to convert it into a regular TDateTime + ETimestamp: TUnixTime; + /// the logging level corresponding to this exception + // - may be either sllException or sllExceptionOS + ELevel: TSynLogInfo; + end; + + /// global hook callback to customize exceptions logged by TSynLog + // - should return TRUE if all needed information has been logged by the + // event handler + // - should return FALSE if Context.EAddr and Stack trace is to be appended + TSynLogExceptionToStr = function(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; + + {$M+} + /// generic parent class of all custom Exception types of this unit + // - all our classes inheriting from ESynException are serializable, + // so you could use ObjectToJSONDebug(anyESynException) to retrieve some + // extended information + ESynException = class(Exception) + protected + fRaisedAt: pointer; + public + /// constructor which will use FormatUTF8() instead of Format() + // - expect % as delimiter, so is less error prone than %s %d %g + // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, + // appending class name for any class or object, the hexa value for a + // pointer, or the JSON representation of any supplied TDocVariant + constructor CreateUTF8(const Format: RawUTF8; const Args: array of const); + /// constructor appending some FormatUTF8() content to the GetLastError + // - message will contain GetLastError value followed by the formatted text + // - expect % as delimiter, so is less error prone than %s %d %g + // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, + // appending class name for any class or object, the hexa value for a + // pointer, or the JSON representation of any supplied TDocVariant + constructor CreateLastOSError(const Format: RawUTF8; const Args: array of const; + const Trailer: RawUtf8 = 'OSError'); + {$ifndef NOEXCEPTIONINTERCEPT} + /// can be used to customize how the exception is logged + // - this default implementation will call the DefaultSynLogExceptionToStr() + // function or the TSynLogExceptionToStrCustom global callback, if defined + // - override this method to provide a custom logging content + // - should return TRUE if Context.EAddr and Stack trace is not to be + // written (i.e. as for any TSynLogExceptionToStr callback) + function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual; + {$endif} + /// the code location when this exception was triggered + // - populated by SynLog unit, during interception - so may be nil + // - you can use TSynMapFile.FindLocation(ESynException) class function to + // guess the corresponding source code line + // - will be serialized as "Address": hexadecimal and source code location + // (using TSynMapFile .map/.mab information) in TJSONSerializer.WriteObject + // when woStorePointer option is defined - e.g. with ObjectToJSONDebug() + property RaisedAt: pointer read fRaisedAt write fRaisedAt; + published + property Message; + end; + {$M-} + ESynExceptionClass = class of ESynException; + + /// exception class associated to TDocVariant JSON/BSON document + EDocVariant = class(ESynException); + + /// exception raised during TFastReader decoding + EFastReader = class(ESynException); + +var + /// allow to customize the ESynException logging message + TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil; + + {$ifndef NOEXCEPTIONINTERCEPT} + /// default exception logging callback - will be set by the SynLog unit + // - will add the default Exception details, including any Exception.Message + // - if the exception inherits from ESynException + // - returns TRUE: caller will then append ' at EAddr' and the stack trace + DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil; + {$endif} + + +/// convert a string into its INTEGER Curr64 (value*10000) representation +// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ +// - fast conversion, using only integer operations +// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND +// the returned value will be an Int64 (not a PInt64(@Curr)^) +function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64; + +/// convert a string into its currency representation +// - will call StrToCurr64() +function StrToCurrency(P: PUTF8Char): currency; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a currency value into a string +// - fast conversion, using only integer operations +// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) +function CurrencyToStr(Value: currency): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an INTEGER Curr64 (value*10000) into a string +// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ +// - fast conversion, using only integer operations +// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) +function Curr64ToStr(const Value: Int64): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an INTEGER Curr64 (value*10000) into a string +// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ +// - fast conversion, using only integer operations +// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) +procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload; + +/// convert an INTEGER Curr64 (value*10000) into a string +// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ +// - fast conversion, using only integer operations +// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) +// - return the number of chars written to Dest^ +function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; + +/// internal fast INTEGER Curr64 (value*10000) value to text conversion +// - expect the last available temporary char position in P +// - return the last written char position (write in reverse order in P^) +// - will return 0 for Value=0, or a string representation with always 4 decimals +// (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000') +// - is called by Curr64ToPChar() and Curr64ToStr() functions +function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; + +/// truncate a Currency value to only 2 digits +// - implementation will use fast Int64 math to avoid any precision loss due to +// temporary floating-point conversion +function TruncTo2Digits(Value: Currency): Currency; + +/// truncate a Currency value, stored as Int64, to only 2 digits +// - implementation will use fast Int64 math to avoid any precision loss due to +// temporary floating-point conversion +procedure TruncTo2DigitsCurr64(var Value: Int64); + {$ifdef HASINLINE}inline;{$endif} + +/// truncate a Currency value, stored as Int64, to only 2 digits +// - implementation will use fast Int64 math to avoid any precision loss due to +// temporary floating-point conversion +function TruncTo2Digits64(Value: Int64): Int64; + {$ifdef HASINLINE}inline;{$endif} + +/// simple, no banker rounding of a Currency value to only 2 digits +// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## +// - implementation will use fast Int64 math to avoid any precision loss due to +// temporary floating-point conversion +function SimpleRoundTo2Digits(Value: Currency): Currency; + +/// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits +// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## +// - implementation will use fast Int64 math to avoid any precision loss due to +// temporary floating-point conversion +procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); + +var + /// a conversion table from hexa chars into binary data + // - returns 255 for any character out of 0..9,A..Z,a..z range + // - used e.g. by HexToBin() function + // - is defined globally, since may be used from an inlined function + ConvertHexToBin: TNormTableByte; + + /// naive but efficient cache to avoid string memory allocation for + // 0..999 small numbers by Int32ToUTF8/UInt32ToUTF8 + // - use around 16KB of heap (since each item consumes 16 bytes), but increase + // overall performance and reduce memory allocation (and fragmentation), + // especially during multi-threaded execution + // - noticeable when strings are used as array indexes (e.g. in SynMongoDB BSON) + // - is defined globally, since may be used from an inlined function + SmallUInt32UTF8: array[0..999] of RawUTF8; + +/// fast conversion from hexa chars into binary data +// - BinBytes contain the bytes count to be converted: Hex^ must contain +// at least BinBytes*2 chars to be converted, and Bin^ enough space +// - if Bin=nil, no output data is written, but the Hex^ format is checked +// - return false if any invalid (non hexa) char is found in Hex^ +// - using this function with Bin^ as an integer value will decode in big-endian +// order (most-signignifican byte first) +function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload; + +/// fast conversion with no validity check from hexa chars into binary data +procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); + +/// conversion from octal C-like escape into binary data +// - \xxx is converted into a single xxx byte from octal, and \\ into \ +// - will stop the conversion when Oct^=#0 or when invalid \xxx is reached +// - returns the number of bytes written to Bin^ +function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; overload; + +/// conversion from octal C-like escape into binary data +// - \xxx is converted into a single xxx byte from octal, and \\ into \ +function OctToBin(const Oct: RawUTF8): RawByteString; overload; + +/// fast conversion from one hexa char pair into a 8 bit AnsiChar +// - return false if any invalid (non hexa) char is found in Hex^ +// - similar to HexToBin(Hex,nil,1) +function HexToCharValid(Hex: PAnsiChar): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// fast check if the supplied Hex buffer is an hexadecimal representation +// of a binary buffer of a given number of bytes +function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; + +/// fast conversion from one hexa char pair into a 8 bit AnsiChar +// - return false if any invalid (non hexa) char is found in Hex^ +// - similar to HexToBin(Hex,Bin,1) but with Bin<>nil +// - use HexToCharValid if you want to check a hexadecimal char content +function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from two hexa bytes into a 16 bit UTF-16 WideChar +// - similar to HexToBin(Hex,@wordvar,2) + bswap(wordvar) +function HexToWideChar(Hex: PAnsiChar): cardinal; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from binary data into hexa chars +// - BinBytes contain the bytes count to be converted: Hex^ must contain +// enough space for at least BinBytes*2 chars +// - using this function with BinBytes^ as an integer value will encode it +// in low-endian order (less-signignifican byte first): don't use it for display +procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); overload; + +/// fast conversion from hexa chars into binary data +function HexToBin(const Hex: RawUTF8): RawByteString; overload; + +/// fast conversion from binary data into hexa chars +function BinToHex(const Bin: RawByteString): RawUTF8; overload; + +/// fast conversion from binary data into hexa chars +function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + +/// fast conversion from binary data into hexa chars, ready to be displayed +// - BinBytes contain the bytes count to be converted: Hex^ must contain +// enough space for at least BinBytes*2 chars +// - using this function with Bin^ as an integer value will encode it +// in big-endian order (most-signignifican byte first): use it for display +procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); overload; + +/// fast conversion from binary data into hexa chars, ready to be displayed +function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + +/// fast conversion from binary data into lowercase hexa chars +// - BinBytes contain the bytes count to be converted: Hex^ must contain +// enough space for at least BinBytes*2 chars +// - using this function with BinBytes^ as an integer value will encode it +// in low-endian order (less-signignifican byte first): don't use it for display +procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); overload; + +/// fast conversion from binary data into lowercase hexa chars +function BinToHexLower(const Bin: RawByteString): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from binary data into lowercase hexa chars +function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from binary data into lowercase hexa chars +procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); overload; + +/// fast conversion from binary data into lowercase hexa chars +// - BinBytes contain the bytes count to be converted: Hex^ must contain +// enough space for at least BinBytes*2 chars +// - using this function with Bin^ as an integer value will encode it +// in big-endian order (most-signignifican byte first): use it for display +procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); overload; + +/// fast conversion from binary data into lowercase hexa chars +function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + +/// fast conversion from up to 127 bytes of binary data into lowercase hexa chars +function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; + +/// fast conversion from up to 64-bit of binary data into lowercase hexa chars +function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; + +/// fast conversion from binary data into hexa lowercase chars, ready to be +// used as a convenient TFileName prefix +function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; + +/// append one byte as hexadecimal char pairs, into a text buffer +function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; + +/// fast conversion from binary data to escaped text +// - non printable characters will be written as $xx hexadecimal codes +// - will be #0 terminated, with '...' characters trailing on overflow +// - ensure the destination buffer contains at least max*3+3 bytes, which is +// always the case when using LogEscape() and its local TLogEscape variable +function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; + +const + /// maximum size, in bytes, of a TLogEscape / LogEscape() buffer + LOGESCAPELEN = 200; +type + /// buffer to be allocated on stack when using LogEscape() + TLogEscape = array[0..LOGESCAPELEN*3+5] of AnsiChar; + +/// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary +// - up to LOGESCAPELEN (i.e. 200) bytes will be escaped and appended to a +// Local temp: TLogEscape variable, using the EscapeBuffer() low-level function +// - you can then log the resulting escaped text by passing the returned +// PAnsiChar as % parameter to a TSynLog.Log() method +// - the "enabled" parameter can be assigned from a process option, avoiding to +// process the escape if verbose logs are disabled +// - used e.g. to implement logBinaryFrameContent option for WebSockets +function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; + enabled: boolean=true): PAnsiChar; + {$ifdef HASINLINE}inline;{$endif} + +/// returns a text buffer with the (hexadecimal) chars of the input binary +// - is much slower than LogEscape/EscapeToShort, but has no size limitation +function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; overload; + +/// returns a text buffer with the (hexadecimal) chars of the input binary +// - is much slower than LogEscape/EscapeToShort, but has no size limitation +function LogEscapeFull(const source: RawByteString): RawUTF8; overload; + +/// fill a shortstring with the (hexadecimal) chars of the input text/binary +function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; overload; + +/// fill a shortstring with the (hexadecimal) chars of the input text/binary +function EscapeToShort(const source: RawByteString): shortstring; overload; + +/// fast conversion from a pointer data into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +function PointerToHex(aPointer: Pointer): RawUTF8; overload; + +/// fast conversion from a pointer data into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); overload; + +/// fast conversion from a pointer data into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - such result type would avoid a string allocation on heap +function PointerToHexShort(aPointer: Pointer): TShort16; overload; + +/// fast conversion from a Cardinal value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - reverse function of HexDisplayToCardinal() +function CardinalToHex(aCardinal: Cardinal): RawUTF8; + +/// fast conversion from a Cardinal value into hexa chars, ready to be displayed +// - use internally BinToHexDisplayLower() +// - reverse function of HexDisplayToCardinal() +function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; + +/// fast conversion from a Cardinal value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - such result type would avoid a string allocation on heap +function CardinalToHexShort(aCardinal: Cardinal): TShort16; + +/// fast conversion from a Int64 value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - reverse function of HexDisplayToInt64() +function Int64ToHex(aInt64: Int64): RawUTF8; overload; + +/// fast conversion from a Int64 value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - reverse function of HexDisplayToInt64() +procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); overload; + +/// fast conversion from a Int64 value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - such result type would avoid a string allocation on heap +procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); overload; + +/// fast conversion from a Int64 value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - such result type would avoid a string allocation on heap +function Int64ToHexShort(aInt64: Int64): TShort16; overload; + +/// fast conversion from a Int64 value into hexa chars, ready to be displayed +// - use internally BinToHexDisplay() +// - reverse function of HexDisplayToInt64() +function Int64ToHexString(aInt64: Int64): string; + +/// fast conversion from hexa chars into a binary buffer +function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; + +/// fast conversion from hexa chars into a cardinal +// - reverse function of CardinalToHex() +// - returns false and set aValue=0 if Hex is not a valid hexadecimal 32-bit +// unsigned integer +// - returns true and set aValue with the decoded number, on success +function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; + {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + // inline gives an error under release conditions with FPC + +/// fast conversion from hexa chars into a cardinal +// - reverse function of Int64ToHex() +// - returns false and set aValue=0 if Hex is not a valid hexadecimal 64-bit +// signed integer +// - returns true and set aValue with the decoded number, on success +function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; overload; + {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} + { inline gives an error under release conditions with FPC } + +/// fast conversion from hexa chars into a cardinal +// - reverse function of Int64ToHex() +// - returns 0 if the supplied text buffer is not a valid hexadecimal 64-bit +// signed integer +function HexDisplayToInt64(const Hex: RawByteString): Int64; overload; + {$ifdef HASINLINE}inline;{$endif} + + +/// fast conversion from binary data into Base64 encoded UTF-8 text +function BinToBase64(const s: RawByteString): RawUTF8; overload; + +/// fast conversion from binary data into Base64 encoded UTF-8 text +function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + +/// fast conversion from a small binary data into Base64 encoded UTF-8 text +function BinToBase64Short(const s: RawByteString): shortstring; overload; + +/// fast conversion from a small binary data into Base64 encoded UTF-8 text +function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; overload; + +/// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text +// - with optional JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) +function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; overload; + +/// fast conversion from binary data into Base64 encoded UTF-8 text +// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) +function BinToBase64WithMagic(const data: RawByteString): RawUTF8; overload; + +/// fast conversion from binary data into Base64 encoded UTF-8 text +// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) +function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload; + +/// fast conversion from Base64 encoded text into binary data +// - is now just an alias to Base64ToBinSafe() overloaded function +// - returns '' if s was not a valid Base64-encoded input +function Base64ToBin(const s: RawByteString): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64 encoded text into binary data +// - is now just an alias to Base64ToBinSafe() overloaded function +// - returns '' if sp/len buffer was not a valid Base64-encoded input +function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64 encoded text into binary data +// - is now just an alias to Base64ToBinSafe() overloaded function +// - returns false and data='' if sp/len buffer was invalid +function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64 encoded text into binary data +// - returns TRUE on success, FALSE if sp/len buffer was invvalid +function Base64ToBin(sp: PAnsiChar; len: PtrInt; var Blob: TSynTempBuffer): boolean; overload; + +/// fast conversion from Base64 encoded text into binary data +// - returns TRUE on success, FALSE if base64 does not match binlen +// - nofullcheck is deprecated and not used any more, since nofullcheck=false +// is now processed with no performance cost +function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; + nofullcheck: boolean=true): boolean; overload; + +/// fast conversion from Base64 encoded text into binary data +// - returns TRUE on success, FALSE if base64 does not match binlen +// - nofullcheck is deprecated and not used any more, since nofullcheck=false +// is now processed with no performance cost +function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; + nofullcheck: boolean=true): boolean; overload; + +/// fast conversion from Base64 encoded text into binary data +// - will check supplied text is a valid Base64 encoded stream +function Base64ToBinSafe(const s: RawByteString): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64 encoded text into binary data +// - will check supplied text is a valid Base64 encoded stream +function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64 encoded text into binary data +// - will check supplied text is a valid Base64 encoded stream +function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; + +/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC +// '\uFFF0base64encodedbinary' content into binary +// - input ParamValue shall have been checked to match the expected pattern +procedure Base64MagicDecode(var ParamValue: RawUTF8); + +/// check and decode '\uFFF0base64encodedbinary' content into binary +// - this method will check the supplied value to match the expected +// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE +function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload; + +/// check and decode '\uFFF0base64encodedbinary' content into binary +// - this method will check the supplied value to match the expected +// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE +function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer; + var Blob: RawByteString): boolean; overload; + +/// check and decode '\uFFF0base64encodedbinary' content into binary +// - this method will check the supplied value to match the expected +// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE +function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload; + +/// check if the supplied text is a valid Base64 encoded stream +function IsBase64(const s: RawByteString): boolean; overload; + +/// check if the supplied text is a valid Base64 encoded stream +function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload; + +/// retrieve the expected encoded length after Base64 process +function BinToBase64Length(len: PtrUInt): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// retrieve the expected undecoded length of a Base64 encoded buffer +// - here len is the number of bytes in sp +function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; + +/// retrieve the expected undecoded length of a Base64 encoded buffer +// - here len is the number of bytes in sp +// - will check supplied text is a valid Base64 encoded stream +function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; + +/// direct low-level decoding of a Base64 encoded buffer +// - here len is the number of 4 chars chunks in sp input +// - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead +function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; + +/// fast conversion from binary data into Base64-like URI-compatible encoded text +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function BinToBase64uri(const s: RawByteString): RawUTF8; overload; + +/// fast conversion from a binary buffer into Base64-like URI-compatible encoded text +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; + +/// fast conversion from a binary buffer into Base64-like URI-compatible encoded shortstring +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +// - returns '' if BinBytes void or too big for the resulting shortstring +function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; + +/// conversion from any Base64 encoded value into URI-compatible encoded text +// - warning: will modify the supplied base64 string in-place +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +procedure Base64ToURI(var base64: RawUTF8); + +/// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text +// - you should rather use the overloaded BinToBase64uri() functions +procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); + +/// retrieve the expected encoded length after Base64-URI process +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function BinToBase64uriLength(len: PtrUInt): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} + +/// retrieve the expected undecoded length of a Base64-URI encoded buffer +// - here len is the number of bytes in sp +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function Base64uriToBinLength(len: PtrInt): PtrInt; + +/// fast conversion from Base64-URI encoded text into binary data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64-URI encoded text into binary data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload; + +/// fast conversion from Base64-URI encoded text into binary data +// - caller should always execute temp.Done when finished with the data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; overload; + +/// fast conversion from Base64-URI encoded text into binary data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +function Base64uriToBin(const s: RawByteString): RawByteString; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fast conversion from Base64-URI encoded text into binary data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +// - will check supplied text is a valid Base64-URI encoded stream +function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; overload; + +/// fast conversion from Base64-URI encoded text into binary data +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +// - will check supplied text is a valid Base64-URI encoded stream +function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// direct low-level decoding of a Base64-URI encoded buffer +// - the buffer is expected to be at least Base64uriToBinLength() bytes long +// - returns true if the supplied sp[] buffer has been successfully decoded +// into rp[] - will break at any invalid character, so is always safe to use +// - in comparison to Base64 standard encoding, will trim any right-sided '=' +// unsignificant characters, and replace '+' or '/' by '_' or '-' +// - you should better not use this, but Base64uriToBin() overloaded functions +function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; + + +/// generate some pascal source code holding some data binary as constant +// - can store sensitive information (e.g. certificates) within the executable +// - generates a source code snippet of the following format: +// ! const +// ! // Comment +// ! ConstName: array[0..2] of byte = ( +// ! $01,$02,$03); +procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; + Data: pointer; Len: integer; PerLine: integer=16); overload; + +/// generate some pascal source code holding some data binary as constant +// - can store sensitive information (e.g. certificates) within the executable +// - generates a source code snippet of the following format: +// ! const +// ! // Comment +// ! ConstName: array[0..2] of byte = ( +// ! $01,$02,$03); +function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer; + Len: integer; PerLine: integer=16; const Suffix: RawUTF8=''): RawUTF8; overload; + + +/// revert the value as encoded by TTextWriter.AddInt18ToChars3() or Int18ToChars3() +// - no range check is performed: you should ensure that the incoming text +// follows the expected 3-chars layout +function Chars3ToInt18(P: pointer): cardinal; + {$ifdef HASINLINE}inline;{$endif} + +/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method +function Int18ToChars3(Value: cardinal): RawUTF8; overload; + +/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method +procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); overload; + +/// add the 4 digits of integer Y to P^ as '0000'..'9999' +procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} + +/// creates a 3 digits string from a 0..999 value as '000'..'999' +// - consider using UInt3DigitsToShort() to avoid temporary memory allocation, +// e.g. when used as FormatUTF8() parameter +function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// creates a 4 digits string from a 0..9999 value as '0000'..'9999' +// - consider using UInt4DigitsToShort() to avoid temporary memory allocation, +// e.g. when used as FormatUTF8() parameter +function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +type + /// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort + // - such result type would avoid a string allocation on heap + TShort4 = string[4]; + +/// creates a 4 digits short string from a 0..9999 value +// - using TShort4 as returned string would avoid a string allocation on heap +// - could be used e.g. as parameter to FormatUTF8() +function UInt4DigitsToShort(Value: Cardinal): TShort4; + {$ifdef HASINLINE}inline;{$endif} + +/// creates a 3 digits short string from a 0..999 value +// - using TShort4 as returned string would avoid a string allocation on heap +// - could be used e.g. as parameter to FormatUTF8() +function UInt3DigitsToShort(Value: Cardinal): TShort4; + {$ifdef HASINLINE}inline;{$endif} + +/// creates a 2 digits short string from a 0..99 value +// - using TShort4 as returned string would avoid a string allocation on heap +// - could be used e.g. as parameter to FormatUTF8() +function UInt2DigitsToShort(Value: byte): TShort4; + {$ifdef HASINLINE}inline;{$endif} + +/// creates a 2 digits short string from a 0..99 value +// - won't test Value>99 as UInt2DigitsToShort() +function UInt2DigitsToShortFast(Value: byte): TShort4; + {$ifdef HASINLINE}inline;{$endif} + + +/// compute CRC16-CCITT checkum on the supplied buffer +// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021) +// and $ffff as initial value +// - this version is not optimized for speed, but for correctness +function crc16(Data: PAnsiChar; Len: integer): cardinal; + +// our custom efficient 32-bit hash/checksum function +// - a Fletcher-like checksum algorithm, not a hash function: has less colisions +// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c +// - written in simple plain pascal, with no L1 CPU cache pollution, but we +// also provide optimized x86/x64 assembly versions, since the algorithm is used +// heavily e.g. for TDynArray binary serialization, TSQLRestStorageInMemory +// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ +// - some numbers on Linux x86_64: +// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s +// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s +// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s (SSE4.2 disabled) +// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled) +function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload; + +// our custom efficient 32-bit hash/checksum function +// - a Fletcher-like checksum algorithm, not a hash function: has less colisions +// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c +// - overloaded function using RawByteString for binary content hashing, +// whatever the codepage is +function Hash32(const Text: RawByteString): cardinal; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition +// - simple and efficient code, but too much collisions for THasher +// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s +function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; + +/// simple FNV-1a hashing function +// - when run over our regression suite, is similar to crc32c() about collisions, +// and 4 times better than kr32(), but also slower than the others +// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s +// - this hash function should not be usefull, unless you need several hashing +// algorithms at once (e.g. if crc32c with diverse seeds is not enough) +function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; + +/// perform very fast xxHash hashing in 32-bit mode +// - will use optimized asm for x86/x64, or a pascal version on other CPUs +function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; + +type + TCrc32tab = array[0..7,byte] of cardinal; + PCrc32tab = ^TCrc32tab; + +var + /// tables used by crc32cfast() function + // - created with a polynom diverse from zlib's crc32() algorithm, but + // compatible with SSE 4.2 crc32 instruction + // - tables content is created from code in initialization section below + // - will also be used internally by SymmetricEncrypt, FillRandom and + // TSynUniqueIdentifierGenerator as 1KB master/reference key tables + crc32ctab: TCrc32tab; + +/// compute CRC32C checksum on the supplied buffer on processor-neutral code +// - result is compatible with SSE 4.2 based hardware accelerated instruction +// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM +// - result is not compatible with zlib's crc32() - not the same polynom +// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s +// - you should use crc32c() function instead of crc32cfast() or crc32csse42() +function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; + +/// compute CRC32C checksum on the supplied buffer using inlined code +// - if the compiler supports inlining, will compute a slow but safe crc32c +// checksum of the binary buffer, without calling the main crc32c() function +// - may be used e.g. to identify patched executable at runtime, for a licensing +// protection system +function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; + {$ifdef HASINLINE}inline;{$endif} + +/// compute CRC64C checksum on the supplied buffer, cascading two crc32c +// - will use SSE 4.2 hardware accelerated instruction, if available +// - will combine two crc32c() calls into a single Int64 result +// - by design, such combined hashes cannot be cascaded +function crc64c(buf: PAnsiChar; len: cardinal): Int64; + +/// compute CRC63C checksum on the supplied buffer, cascading two crc32c +// - similar to crc64c, but with 63-bit, so no negative value: may be used +// safely e.g. as mORMot's TID source +// - will use SSE 4.2 hardware accelerated instruction, if available +// - will combine two crc32c() calls into a single Int64 result +// - by design, such combined hashes cannot be cascaded +function crc63c(buf: PAnsiChar; len: cardinal): Int64; + +type + /// binary access to an unsigned 32-bit value (4 bytes in memory) + TDWordRec = record + case integer of + 0: (V: DWord); + 1: (L,H: word); + 2: (B: array[0..3] of byte); + end; + /// points to the binary of an unsigned 32-bit value + PDWordRec = ^TDWordRec; + + /// binary access to an unsigned 64-bit value (8 bytes in memory) + TQWordRec = record + case integer of + 0: (V: Qword); + 1: (L,H: cardinal); + 2: (W: array[0..3] of word); + 3: (B: array[0..7] of byte); + end; + /// points to the binary of an unsigned 64-bit value + PQWordRec = ^TQWordRec; + + /// store a 128-bit hash value + // - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128) + // - consumes 16 bytes of memory + THash128 = array[0..15] of byte; + /// pointer to a 128-bit hash value + PHash128 = ^THash128; + /// store a 160-bit hash value + // - e.g. a SHA-1 digest + // - consumes 20 bytes of memory + THash160 = array[0..19] of byte; + /// pointer to a 160-bit hash value + PHash160 = ^THash160; + /// store a 192-bit hash value + // - consumes 24 bytes of memory + THash192 = array[0..23] of byte; + /// pointer to a 192-bit hash value + PHash192 = ^THash192; + /// store a 256-bit hash value + // - e.g. a SHA-256 digest, a TECCSignature result, or array[0..7] of cardinal + // - consumes 32 bytes of memory + THash256 = array[0..31] of byte; + /// pointer to a 256-bit hash value + PHash256 = ^THash256; + /// store a 384-bit hash value + // - e.g. a SHA-384 digest + // - consumes 48 bytes of memory + THash384 = array[0..47] of byte; + /// pointer to a 384-bit hash value + PHash384 = ^THash384; + /// store a 512-bit hash value + // - e.g. a SHA-512 digest, a TECCSignature result, or array[0..15] of cardinal + // - consumes 64 bytes of memory + THash512 = array[0..63] of byte; + /// pointer to a 512-bit hash value + PHash512 = ^THash512; + + /// store a 128-bit buffer + // - e.g. an AES block + // - consumes 16 bytes of memory + TBlock128 = array[0..3] of cardinal; + /// pointer to a 128-bit buffer + PBlock128 = ^TBlock128; + + /// map an infinite array of 128-bit hash values + // - each item consumes 16 bytes of memory + THash128Array = array[0..(maxInt div SizeOf(THash128))-1] of THash128; + /// pointer to an infinite array of 128-bit hash values + PHash128Array = ^THash128Array; + /// store several 128-bit hash values + // - e.g. MD5 digests + // - consumes 16 bytes of memory per item + THash128DynArray = array of THash128; + /// map a 128-bit hash as an array of lower bit size values + // - consumes 16 bytes of memory + THash128Rec = packed record + case integer of + 0: (Lo,Hi: Int64); + 1: (L,H: QWord); + 2: (i0,i1,i2,i3: integer); + 3: (c0,c1,c2,c3: cardinal); + 4: (c: TBlock128); + 5: (b: THash128); + 6: (w: array[0..7] of word); + 7: (l64,h64: Int64Rec); + end; + /// pointer to 128-bit hash map variable record + PHash128Rec = ^THash128Rec; + + /// map an infinite array of 256-bit hash values + // - each item consumes 32 bytes of memory + THash256Array = array[0..(maxInt div SizeOf(THash256))-1] of THash256; + /// pointer to an infinite array of 256-bit hash values + PHash256Array = ^THash256Array; + /// store several 256-bit hash values + // - e.g. SHA-256 digests, TECCSignature results, or array[0..7] of cardinal + // - consumes 32 bytes of memory per item + THash256DynArray = array of THash256; + /// map a 256-bit hash as an array of lower bit size values + // - consumes 32 bytes of memory + THash256Rec = packed record + case integer of + 0: (Lo,Hi: THash128); + 1: (d0,d1,d2,d3: Int64); + 2: (i0,i1,i2,i3,i4,i5,i6,i7: integer); + 3: (c0,c1: TBlock128); + 4: (b: THash256); + 5: (q: array[0..3] of QWord); + 6: (c: array[0..7] of cardinal); + 7: (w: array[0..15] of word); + 8: (l,h: THash128Rec); + end; + /// pointer to 256-bit hash map variable record + PHash256Rec = ^THash256Rec; + + /// map an infinite array of 512-bit hash values + // - each item consumes 64 bytes of memory + THash512Array = array[0..(maxInt div SizeOf(THash512))-1] of THash512; + /// pointer to an infinite array of 512-bit hash values + PHash512Array = ^THash512Array; + /// store several 512-bit hash values + // - e.g. SHA-512 digests, or array[0..15] of cardinal + // - consumes 64 bytes of memory per item + THash512DynArray = array of THash512; + /// map a 512-bit hash as an array of lower bit size values + // - consumes 64 bytes of memory + THash512Rec = packed record + case integer of + 0: (Lo,Hi: THash256); + 1: (h0,h1,h2,h3: THash128); + 2: (d0,d1,d2,d3,d4,d5,d6,d7: Int64); + 3: (i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14,i15: integer); + 4: (c0,c1,c2,c3: TBlock128); + 5: (b: THash512); + 6: (b160: THash160); + 7: (b384: THash384); + 8: (w: array[0..31] of word); + 9: (c: array[0..15] of cardinal); + 10: (i: array[0..7] of Int64); + 11: (r: array[0..3] of THash128Rec); + 12: (l,h: THash256Rec); + end; + /// pointer to 512-bit hash map variable record + PHash512Rec = ^THash512Rec; + +/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c +// - will use SSE 4.2 hardware accelerated instruction, if available +// - will combine two crc32c() calls into a single TAESBlock result +// - by design, such combined hashes cannot be cascaded +procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); + +/// compute a proprietary 128-bit CRC of 128-bit binary buffers +// - to be used for regression tests only: crcblocks will use the fastest +// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) +procedure crcblocksfast(crc128, data128: PBlock128; count: integer); + +/// compute a proprietary 128-bit CRC of 128-bit binary buffers +// - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc +// - its output won't match crc128c() value, which works on 8-bit input +// - will use SSE 4.2 hardware accelerated instruction, if available +// - is used e.g. by SynEcc's TECDHEProtocol.ComputeMAC for macCrc128c +var crcblocks: procedure(crc128, data128: PBlock128; count: integer)=crcblocksfast; + +/// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2 +// - to be used for regression tests only: crcblock will use the fastest +// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) +procedure crcblockNoSSE42(crc128, data128: PBlock128); + +/// compute a proprietary 128-bit CRC of a 128-bit binary buffer +// - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc +// - its output won't match crc128c() value, which works on 8-bit input +// - will use SSE 4.2 hardware accelerated instruction, if available +// - is used e.g. by SynCrypto's TAESCFBCRC to check for data integrity +var crcblock: procedure(crc128, data128: PBlock128) = crcblockNoSSE42; + +/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero +// - e.g. a MD5 digest, or an AES block +function IsZero(const dig: THash128): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all 16 bytes of both 128-bit buffers do match +// - e.g. a MD5 digest, or an AES block +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purpose - and it is also branchless therefore fast +function IsEqual(const A,B: THash128): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill all 16 bytes of this 128-bit buffer with zero +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(digest); end; +procedure FillZero(out dig: THash128); overload; + +/// fast O(n) search of a 128-bit item in an array of such values +function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; + {$ifdef CPU64} inline; {$endif} + +/// convert a 32-bit integer (storing a IP4 address) into its full notation +// - returns e.g. '1.2.3.4' for any valid address, or '' if ip4=0 +function IP4Text(ip4: cardinal): shortstring; overload; + +/// convert a 128-bit buffer (storing an IP6 address) into its full notation +// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' +function IP6Text(ip6: PHash128): shortstring; overload; {$ifdef HASINLINE}inline;{$endif} + +/// convert a 128-bit buffer (storing an IP6 address) into its full notation +// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' +procedure IP6Text(ip6: PHash128; result: PShortString); overload; + +/// compute a 256-bit checksum on the supplied buffer using crc32c +// - will use SSE 4.2 hardware accelerated instruction, if available +// - will combine two crc32c() calls into a single THash256 result +// - by design, such combined hashes cannot be cascaded +procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); + +/// returns TRUE if all 20 bytes of this 160-bit buffer equal zero +// - e.g. a SHA-1 digest +function IsZero(const dig: THash160): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all 20 bytes of both 160-bit buffers do match +// - e.g. a SHA-1 digest +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purpose +function IsEqual(const A,B: THash160): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill all 20 bytes of this 160-bit buffer with zero +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(digest); end; +procedure FillZero(out dig: THash160); overload; + +/// returns TRUE if all 32 bytes of this 256-bit buffer equal zero +// - e.g. a SHA-256 digest, or a TECCSignature result +function IsZero(const dig: THash256): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all 32 bytes of both 256-bit buffers do match +// - e.g. a SHA-256 digest, or a TECCSignature result +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purpose +function IsEqual(const A,B: THash256): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill all 32 bytes of this 256-bit buffer with zero +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(digest); end; +procedure FillZero(out dig: THash256); overload; + +/// fast O(n) search of a 256-bit item in an array of such values +function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; overload; + +/// returns TRUE if all 48 bytes of this 384-bit buffer equal zero +// - e.g. a SHA-384 digest +function IsZero(const dig: THash384): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all 48 bytes of both 384-bit buffers do match +// - e.g. a SHA-384 digest +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purpose +function IsEqual(const A,B: THash384): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill all 32 bytes of this 384-bit buffer with zero +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(digest); end; +procedure FillZero(out dig: THash384); overload; + +/// returns TRUE if all 64 bytes of this 512-bit buffer equal zero +// - e.g. a SHA-512 digest +function IsZero(const dig: THash512): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all 64 bytes of both 512-bit buffers do match +// - e.g. two SHA-512 digests +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purpose +function IsEqual(const A,B: THash512): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// fill all 64 bytes of this 512-bit buffer with zero +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(digest); end; +procedure FillZero(out dig: THash512); overload; + +/// compute a 512-bit checksum on the supplied buffer using crc32c +// - will use SSE 4.2 hardware accelerated instruction, if available +// - will combine two crc32c() calls into a single THash512 result +// - by design, such combined hashes cannot be cascaded +procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); + +/// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 +// - will write the memory buffer directly, so if this string instance is shared +// (i.e. has refcount>1), all other variables will contains zeros +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(secret); end; +procedure FillZero(var secret: RawByteString); overload; + {$ifdef FPC}inline;{$endif} + +/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0 +// - will write the memory buffer directly, so if this string instance is shared +// (i.e. has refcount>1), all other variables will contains zeros +// - may be used to cleanup stack-allocated content +// ! ... finally FillZero(secret); end; +procedure FillZero(var secret: RawUTF8); overload; + {$ifdef FPC}inline;{$endif} + +/// fill all bytes of a memory buffer with zero +// - just redirect to FillCharFast(..,...,0) +procedure FillZero(var dest; count: PtrInt); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all bytes of both buffers do match +// - this function is not sensitive to any timing attack, so is designed +// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed +// as faster alternatives for general-purpose code +function IsEqual(const A,B; count: PtrInt): boolean; overload; + +/// fast computation of two 64-bit unsigned integers into a 128-bit value +procedure mul64x64(const left, right: QWord; out product: THash128Rec); + {$ifndef CPUINTEL}inline;{$endif} + +type + /// the potential features, retrieved from an Intel CPU + // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits + // - is defined on all platforms, since an ARM desktop could browse Intel logs + TIntelCpuFeature = ( + { CPUID 1 in EDX } + cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE, + cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV, + cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX, + cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE, + { CPUID 1 in ECX } + cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST, + cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM, + cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT, + cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP, + { extended features CPUID 7 in EBX, ECX, EDX } + cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP, + cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, + cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH, + cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL, + cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cfAVX512VBMI2, cfCETSS, + cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI, cfAVX512BITALG, cf_c13, cfAVX512VPC, cf_c15, + cfFLP, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23, + cf_c24, cfCLDEMOTE, cf_c26, cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS, + cf_d0, cf_d1, cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cf_d5, cf_d6, cf_d7, + cfAVX512VP2I, cfSRBDS, cfMDCLR, cf_d11, cf_d12, cfTSXFA, cfSER, cfHYBRID, + cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cf_d23, + cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD); + + /// all features, as retrieved from an Intel CPU + TIntelCpuFeatures = set of TIntelCpuFeature; + +/// convert Intel CPU features as plain CSV text +function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; + const Sep: RawUTF8=','): RawUTF8; overload; + +{$ifdef CPUINTEL} +var + /// the available CPU features, as recognized at program startup + CpuFeatures: TIntelCpuFeatures; + +/// compute CRC32C checksum on the supplied buffer using SSE 4.2 +// - use Intel Streaming SIMD Extensions 4.2 hardware accelerated instruction +// - SSE 4.2 shall be available on the processor (i.e. cfSSE42 in CpuFeatures) +// - result is not compatible with zlib's crc32() - not the same polynom +// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s +// - you should use crc32c() function instead of crc32cfast() or crc32csse42() +function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$endif CPUINTEL} + +/// naive symmetric encryption scheme using a 32-bit key +// - fast, but not very secure, since uses crc32ctab[] content as master cypher +// key: consider using SynCrypto proven AES-based algorithms instead +procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); + +type + TCrc32cBy4 = function(crc, value: cardinal): cardinal; + +var + /// compute CRC32C checksum on the supplied buffer + // - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C is not + // the same polynom - but will use the fastest mean available, e.g. SSE 4.2, + // to achieve up to 16GB/s with the optimized implementation from SynCrypto.pas + // - you should use this function instead of crc32cfast() or crc32csse42() + crc32c: THasher; + /// compute CRC32C checksum on one 32-bit unsigned integer + // - can be used instead of crc32c() for inlined process during data acquisition + // - doesn't make "crc := not crc" before and after the computation: caller has + // to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end, + // to compute the very same hash value than regular crc32c() + // - this variable will use the fastest mean available, e.g. SSE 4.2 + crc32cBy4: TCrc32cBy4; + +/// compute the hexadecimal representation of the crc32 checkum of a given text +// - wrapper around CardinalToHex(crc32c(...)) +function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; + +var + /// the default hasher used by TDynArrayHashed + // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, + // or fallback to xxHash32() which performs better than crc32cfast() + DefaultHasher: THasher; + + /// the hash function used by TRawUTF8Interning + // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, + // or fallback to xxHash32() which performs better than crc32cfast() + InterningHasher: THasher; + +/// retrieve a particular bit status from a bit array +// - this function can't be inlined, whereas GetBitPtr() function can +function GetBit(const Bits; aIndex: PtrInt): boolean; + +/// set a particular bit into a bit array +// - this function can't be inlined, whereas SetBitPtr() function can +procedure SetBit(var Bits; aIndex: PtrInt); + +/// unset/clear a particular bit into a bit array +// - this function can't be inlined, whereas UnSetBitPtr() function can +procedure UnSetBit(var Bits; aIndex: PtrInt); + +/// retrieve a particular bit status from a bit array +// - GetBit() can't be inlined, whereas this pointer-oriented function can +function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// set a particular bit into a bit array +// - SetBit() can't be inlined, whereas this pointer-oriented function can +procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// unset/clear a particular bit into a bit array +// - UnSetBit() can't be inlined, whereas this pointer-oriented function can +procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// compute the number of bits set in a bit array +// - Count is the bit count, not byte size +// - will use fast SSE4.2 popcnt instruction if available on the CPU +function GetBitsCount(const Bits; Count: PtrInt): PtrInt; + +/// pure pascal version of GetBitsCountPtrInt() +// - defined just for regression tests - call GetBitsCountPtrInt() instead +// - has optimized asm on x86_64 and i386 +function GetBitsCountPas(value: PtrInt): PtrInt; + +/// compute how many bits are set in a given pointer-sized integer +// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs, +// and default implementation is 5 times slower than our GetBitsCountPas() on x64 +// - this redirected function will use fast SSE4.2 popcnt opcode, if available +var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas; + +const + /// constant array used by GetAllBits() function (when inlined) + ALLBITS_CARDINAL: array[1..32] of Cardinal = ( + 1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1, + 1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1, + 1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1, + 1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1, + 1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1, + $7fffffff, $ffffffff); + +/// returns TRUE if all BitCount bits are set in the input 32-bit cardinal +function GetAllBits(Bits, BitCount: cardinal): boolean; + {$ifdef HASINLINE}inline;{$endif} + +type + /// fast access to 8-bit integer bits + // - the compiler will generate bt/btr/bts opcodes + TBits8 = set of 0..7; + PBits8 = ^TBits8; + TBits8Array = array[0..maxInt-1] of TBits8; + /// fast access to 32-bit integer bits + // - the compiler will generate bt/btr/bts opcodes + TBits32 = set of 0..31; + PBits32 = ^TBits32; + /// fast access to 64-bit integer bits + // - the compiler will generate bt/btr/bts opcodes + // - as used by GetBit64/SetBit64/UnSetBit64 + TBits64 = set of 0..63; + PBits64 = ^TBits64; + +/// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63) +function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// set a particular bit into a 64-bit integer bits (max aIndex is 63) +procedure SetBit64(var Bits: Int64; aIndex: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63) +procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// logical OR of two memory buffers +// - will perform on all buffer bytes: +// ! Dest[i] := Dest[i] or Source[i]; +procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// logical XOR of two memory buffers +// - will perform on all buffer bytes: +// ! Dest[i] := Dest[i] xor Source[i]; +procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// logical XOR of two memory buffers into a third +// - will perform on all buffer bytes: +// ! Dest[i] := Source1[i] xor Source2[i]; +procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// logical AND of two memory buffers +// - will perform on all buffer bytes: +// ! Dest[i] := Dest[i] and Source[i]; +procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if all bytes equal zero +function IsZero(P: pointer; Length: integer): boolean; overload; + +/// returns TRUE if all of a few bytes equal zero +// - to be called instead of IsZero() e.g. for 1..8 bytes +function IsZeroSmall(P: pointer; Length: PtrInt): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if Value is nil or all supplied Values[] equal '' +function IsZero(const Values: TRawUTF8DynArray): boolean; overload; + +/// returns TRUE if Value is nil or all supplied Values[] equal 0 +function IsZero(const Values: TIntegerDynArray): boolean; overload; + +/// returns TRUE if Value is nil or all supplied Values[] equal 0 +function IsZero(const Values: TInt64DynArray): boolean; overload; + +/// fill all entries of a supplied array of RawUTF8 with '' +procedure FillZero(var Values: TRawUTF8DynArray); overload; + +/// fill all entries of a supplied array of 32-bit integers with 0 +procedure FillZero(var Values: TIntegerDynArray); overload; + +/// fill all entries of a supplied array of 64-bit integers with 0 +procedure FillZero(var Values: TInt64DynArray); overload; + + +/// name the current thread so that it would be easily identified in the IDE debugger +procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); + +/// name a thread so that it would be easily identified in the IDE debugger +// - you can force this function to do nothing by setting the NOSETTHREADNAME +// conditional, if you have issues with this feature when debugging your app +// - most meanling less characters (like 'TSQL') are trimmed to reduce the +// resulting length - which is convenient e.g. with POSIX truncation to 16 chars +procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; + const Args: array of const); + +/// could be used to override SetThreadNameInternal() +// - under Linux/FPC, calls pthread_setname_np API which truncates to 16 chars +procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); + +var + /// is overriden e.g. by mORMot.pas to log the thread name + SetThreadNameInternal: procedure(ThreadID: TThreadID; const Name: RawUTF8) = SetThreadNameDefault; + + + +/// low-level wrapper to add a callback to a dynamic list of events +// - by default, you can assign only one callback to an Event: but by storing +// it as a dynamic array of events, you can use this wrapper to add one callback +// to this list of events +// - if the event was already registered, do nothing (i.e. won't call it twice) +// - since this function uses an unsafe typeless EventList parameter, you should +// not use it in high-level code, but only as wrapper within dedicated methods +// - will add Event to EventList[] unless Event is already registered +// - is used e.g. by TTextWriter as such: +// ! ... +// ! fEchos: array of TOnTextWriterEcho; +// ! ... +// ! procedure EchoAdd(const aEcho: TOnTextWriterEcho); +// ! ... +// ! procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho); +// ! begin +// ! MultiEventAdd(fEchos,TMethod(aEcho)); +// ! end; +// then callbacks are then executed as such: +// ! if fEchos<>nil then +// ! for i := 0 to length(fEchos)-1 do +// ! fEchos[i](self,fEchoBuf); +// - use MultiEventRemove() to un-register a callback from the list +function MultiEventAdd(var EventList; const Event: TMethod): boolean; + +/// low-level wrapper to remove a callback from a dynamic list of events +// - by default, you can assign only one callback to an Event: but by storing +// it as a dynamic array of events, you can use this wrapper to remove one +// callback already registered by MultiEventAdd() to this list of events +// - since this function uses an unsafe typeless EventList parameter, you should +// not use it in high-level code, but only as wrapper within dedicated methods +// - is used e.g. by TTextWriter as such: +// ! ... +// ! fEchos: array of TOnTextWriterEcho; +// ! ... +// ! procedure EchoRemove(const aEcho: TOnTextWriterEcho); +// ! ... +// ! procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho); +// ! begin +// ! MultiEventRemove(fEchos,TMethod(aEcho)); +// ! end; +procedure MultiEventRemove(var EventList; const Event: TMethod); overload; + +/// low-level wrapper to remove a callback from a dynamic list of events +// - same as the same overloaded procedure, but accepting an EventList[] index +// to identify the Event to be suppressed +procedure MultiEventRemove(var EventList; Index: Integer); overload; + +/// low-level wrapper to check if a callback is in a dynamic list of events +// - by default, you can assign only one callback to an Event: but by storing +// it as a dynamic array of events, you can use this wrapper to check if +// a callback has already been registered to this list of events +// - used internally by MultiEventAdd() and MultiEventRemove() functions +function MultiEventFind(const EventList; const Event: TMethod): integer; + +/// low-level wrapper to add one or several callbacks from another list of events +// - all events of the ToBeAddedList would be added to DestList +// - the list is not checked for duplicates +procedure MultiEventMerge(var DestList; const ToBeAddedList); + +/// compare two TMethod instances +function EventEquals(const eventA,eventB): boolean; + + +{ ************ fast ISO-8601 types and conversion routines ***************** } + +type + /// a type alias, which will be serialized as ISO-8601 with milliseconds + // - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format + TDateTimeMS = type TDateTime; + + /// a dynamic array of TDateTimeMS values + TDateTimeMSDynArray = array of TDateTimeMS; + PDateTimeMSDynArray = ^TDateTimeMSDynArray; + + {$A-} + /// a simple way to store a date as Year/Month/Day + // - with no needed computation as with TDate/TUnixTime values + // - consider using TSynSystemTime if you need to handle both Date and Time + // - match the first 4 fields of TSynSystemTime - so PSynDate(@aSynSystemTime)^ + // is safe to be used + // - DayOfWeek field is not handled by its methods by default, but could be + // filled on demand via ComputeDayOfWeek - making this record 64-bit long + // - some Delphi revisions have trouble with "object" as own method parameters + // (e.g. IsEqual) so we force to use "record" type if possible + {$ifdef USERECORDWITHMETHODS}TSynDate = record{$else} + TSynDate = object{$endif} + Year, Month, DayOfWeek, Day: word; + /// set all fields to 0 + procedure Clear; {$ifdef HASINLINE}inline;{$endif} + /// set internal date to 9999-12-31 + procedure SetMax; {$ifdef HASINLINE}inline;{$endif} + /// returns true if all fields are zero + function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} + /// try to parse a YYYY-MM-DD or YYYYMMDD ISO-8601 date from the supplied buffer + // - on success, move P^ just after the date, and return TRUE + function ParseFromText(var P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} + /// fill fields with the current UTC/local date, using a 8-16ms thread-safe cache + procedure FromNow(localtime: boolean=false); + /// fill fields with the supplied date + procedure FromDate(date: TDate); + /// returns true if all fields do match - ignoring DayOfWeek field value + function IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; + /// compare the stored value to a supplied value + // - returns <0 if the stored value is smaller than the supplied value, + // 0 if both are equals, and >0 if the stored value is bigger + // - DayOfWeek field value is not compared + function Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; + {$ifdef HASINLINE}inline;{$endif} + /// fill the DayOfWeek field from the stored Year/Month/Day + // - by default, most methods will just store 0 in the DayOfWeek field + // - sunday is DayOfWeek 1, saturday is 7 + procedure ComputeDayOfWeek; + /// convert the stored date into a Delphi TDate floating-point value + function ToDate: TDate; {$ifdef HASINLINE}inline;{$endif} + /// encode the stored date as ISO-8601 text + // - returns '' if the stored date is 0 (i.e. after Clear) + function ToText(Expanded: boolean=true): RawUTF8; + end; + /// store several dates as Year/Month/Day + TSynDateDynArray = array of TSynDate; + /// a pointer to a TSynDate instance + PSynDate = ^TSynDate; + + /// a cross-platform and cross-compiler TSystemTime 128-bit structure + // - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields! + // - also used to store a Date/Time in TSynTimeZone internal structures, or + // for fast conversion from TDateTime to its ready-to-display members + // - DayOfWeek field is not handled by most methods by default (left as 0), + // but could be filled on demand via ComputeDayOfWeek into its 1..7 value + // - some Delphi revisions have trouble with "object" as own method parameters + // (e.g. IsEqual) so we force to use "record" type if possible + {$ifdef USERECORDWITHMETHODS}TSynSystemTime = record{$else} + TSynSystemTime = object{$endif} + public + Year, Month, DayOfWeek, Day, + Hour, Minute, Second, MilliSecond: word; + /// set all fields to 0 + procedure Clear; {$ifdef HASINLINE}inline;{$endif} + /// returns true if all fields are zero + function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} + /// returns true if all fields do match + function IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; + /// returns true if date fields do match (ignoring DayOfWeek) + function IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; + /// used by TSynTimeZone + function EncodeForTimeChange(const aYear: word): TDateTime; + /// fill fields with the current UTC time, using a 8-16ms thread-safe cache + procedure FromNowUTC; + /// fill fields with the current Local time, using a 8-16ms thread-safe cache + procedure FromNowLocal; + /// fill fields from the given value - but not DayOfWeek + procedure FromDateTime(const dt: TDateTime); + /// fill Year/Month/Day fields from the given value - but not DayOfWeek + // - faster than the RTL DecodeDate() function + procedure FromDate(const dt: TDateTime); + /// fill Hour/Minute/Second/Millisecond fields from the given number of milliseconds + // - faster than the RTL DecodeTime() function + procedure FromMS(ms: PtrUInt); + /// fill Hour/Minute/Second/Millisecond fields from the given number of seconds + // - faster than the RTL DecodeTime() function + procedure FromSec(s: PtrUInt); + /// fill Hour/Minute/Second/Millisecond fields from the given TDateTime value + // - faster than the RTL DecodeTime() function + procedure FromTime(const dt: TDateTime); + /// fill Year/Month/Day and Hour/Minute/Second fields from the given ISO-8601 text + // - returns true on success + function FromText(const iso: RawUTF8): boolean; + /// encode the stored date/time as ISO-8601 text with Milliseconds + function ToText(Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; + /// append the stored date and time, in a log-friendly format + // - e.g. append '20110325 19241502' - with no trailing space nor tab + // - as called by TTextWriter.AddCurrentLogTime() + procedure AddLogTime(WR: TTextWriter); + /// append the stored date and time, in apache-like format, to a TTextWriter + // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space + procedure AddNCSAText(WR: TTextWriter); + /// append the stored date and time, in apache-like format, to a memory buffer + // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space + // - returns the number of chars added to P, i.e. always 21 + function ToNCSAText(P: PUTF8Char): PtrInt; + /// convert the stored date and time to its text in HTTP-like format + // - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of + // "Date", "Expires" or "Last-Modified" HTTP header + // - handle UTC/GMT time zone by default + procedure ToHTTPDate(out text: RawUTF8; const tz: RawUTF8='GMT'); + /// convert the stored date and time into its Iso-8601 text, with no Milliseconds + procedure ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar='T'); + /// convert the stored date into its Iso-8601 text with no time part + procedure ToIsoDate(out text: RawUTF8); + /// convert the stored time into its Iso-8601 text with no date part nor Milliseconds + procedure ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8='T'); + /// convert the stored time into a TDateTime + function ToDateTime: TDateTime; + /// copy Year/Month/DayOfWeek/Day fields to a TSynDate + procedure ToSynDate(out date: TSynDate); {$ifdef HASINLINE}inline;{$endif} + /// fill the DayOfWeek field from the stored Year/Month/Day + // - by default, most methods will just store 0 in the DayOfWeek field + // - sunday is DayOfWeek 1, saturday is 7 + procedure ComputeDayOfWeek; {$ifdef HASINLINE}inline;{$endif} + /// add some 1..999 milliseconds to the stored time + // - not to be used for computation, but e.g. for fast AddLogTime generation + procedure IncrementMS(ms: integer); + end; + PSynSystemTime = ^TSynSystemTime; + {$A+} + + /// fast bit-encoded date and time value + // - faster than Iso-8601 text and TDateTime, e.g. can be used as published + // property field in mORMot's TSQLRecord (see also TModTime and TCreateTime) + // - use internally for computation an abstract "year" of 16 months of 32 days + // of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog() + // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or + // type-cast any TTimeLog value with the TTimeLogBits memory structure for + // direct access to its bit-oriented content (or via PTimeLogBits pointer) + // - since TTimeLog type is bit-oriented, you can't just add or substract two + // TTimeLog values when doing date/time computation: use a TDateTime temporary + // conversion in such case: + // ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp))); + TTimeLog = type Int64; + + /// dynamic array of TTimeLog + // - used by TDynArray JSON serialization to handle textual serialization + TTimeLogDynArray = array of TTimeLog; + + /// pointer to a memory structure for direct access to a TTimeLog type value + PTimeLogBits = ^TTimeLogBits; + + /// internal memory structure for direct access to a TTimeLog type value + // - most of the time, you should not use this object, but higher level + // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions + // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract + // two TTimeLog values when doing date/time computation: use a TDateTime + // temporary conversion in such case + // - TTimeLogBits.Value needs up to 40-bit precision, so features exact + // representation as JavaScript numbers (stored in a 52-bit mantissa) + TTimeLogBits = object + public + /// the bit-encoded value itself, which follows an abstract "year" of 16 + // months of 32 days of 32 hours of 64 minutes of 64 seconds + // - bits 0..5 = Seconds (0..59) + // - bits 6..11 = Minutes (0..59) + // - bits 12..16 = Hours (0..23) + // - bits 17..21 = Day-1 (0..31) + // - bits 22..25 = Month-1 (0..11) + // - bits 26..40 = Year (0..9999) + Value: Int64; + /// extract the date and time content in Value into individual values + procedure Expand(out Date: TSynSystemTime); + /// convert to Iso-8601 encoded text, truncated to date/time only if needed + function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload; + /// convert to Iso-8601 encoded text, truncated to date/time only if needed + function Text(Dest: PUTF8Char; Expanded: boolean; + FirstTimeChar: AnsiChar = 'T'): integer; overload; + /// convert to Iso-8601 encoded text with date and time part + // - never truncate to date/time nor return '' as Text() does + function FullText(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'; + QuotedChar: AnsiChar = #0): RawUTF8; overload; + {$ifdef FPC}inline;{$endif} // URW1111 on Delphi 2010 and URW1136 on XE + /// convert to Iso-8601 encoded text with date and time part + // - never truncate to date/time or return '' as Text() does + function FullText(Dest: PUTF8Char; Expanded: boolean; + FirstTimeChar: AnsiChar = 'T'; QuotedChar: AnsiChar = #0): PUTF8Char; overload; + /// convert to ready-to-be displayed text + // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas) + function i18nText: string; + /// convert to a Delphi Time + function ToTime: TDateTime; + /// convert to a Delphi Date + // - will return 0 if the stored value is not a valid date + function ToDate: TDateTime; + /// convert to a Delphi Date and Time + // - will return 0 if the stored value is not a valid date + function ToDateTime: TDateTime; + /// convert to a second-based c-encoded time (from Unix epoch 1/1/1970) + function ToUnixTime: TUnixTime; + /// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970) + // - of course, milliseconds will be 0 due to TTimeLog second resolution + function ToUnixMSTime: TUnixMSTime; + /// fill Value from specified Date and Time + procedure From(Y,M,D, HH,MM,SS: cardinal); overload; + /// fill Value from specified TDateTime + procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload; + /// fill Value from specified File Date + procedure From(FileDate: integer); overload; + /// fill Value from Iso-8601 encoded text + procedure From(P: PUTF8Char; L: integer); overload; {$ifdef HASINLINE}inline;{$endif} + /// fill Value from Iso-8601 encoded text + procedure From(const S: RawUTF8); overload; + /// fill Value from specified Date/Time individual fields + procedure From(Time: PSynSystemTime); overload; + /// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970) + procedure FromUnixTime(const UnixTime: TUnixTime); + /// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970) + // - of course, millisecond resolution will be lost during conversion + procedure FromUnixMSTime(const UnixMSTime: TUnixMSTime); + /// fill Value from current local system Date and Time + procedure FromNow; + /// fill Value from current UTC system Date and Time + // - FromNow uses local time: this function retrieves the system time + // expressed in Coordinated Universal Time (UTC) + procedure FromUTCTime; + /// get the year (e.g. 2015) of the TTimeLog value + function Year: Integer; {$ifdef HASINLINE}inline;{$endif} + /// get the month (1..12) of the TTimeLog value + function Month: Integer; {$ifdef HASINLINE}inline;{$endif} + /// get the day (1..31) of the TTimeLog value + function Day: Integer; {$ifdef HASINLINE}inline;{$endif} + /// get the hour (0..23) of the TTimeLog value + function Hour: integer; {$ifdef HASINLINE}inline;{$endif} + /// get the minute (0..59) of the TTimeLog value + function Minute: integer; {$ifdef HASINLINE}inline;{$endif} + /// get the second (0..59) of the TTimeLog value + function Second: integer; {$ifdef HASINLINE}inline;{$endif} + end; + +/// get TTimeLog value from current local system date and time +// - handle TTimeLog bit-encoded Int64 format +function TimeLogNow: TTimeLog; + {$ifdef HASINLINE}inline;{$endif} + +/// get TTimeLog value from current UTC system Date and Time +// - handle TTimeLog bit-encoded Int64 format +function TimeLogNowUTC: TTimeLog; + {$ifdef HASINLINE}inline;{$endif} + +/// get TTimeLog value from a file date and time +// - handle TTimeLog bit-encoded Int64 format +function TimeLogFromFile(const FileName: TFileName): TTimeLog; + +/// get TTimeLog value from a given Delphi date and time +// - handle TTimeLog bit-encoded Int64 format +// - just a wrapper around PTimeLogBits(@aTime)^.From() +// - we defined such a function since TTimeLogBits(aTimeLog).From() won't change +// the aTimeLog variable content +function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; + {$ifdef HASINLINE}inline;{$endif} + +/// get TTimeLog value from a given Unix seconds since epoch timestamp +// - handle TTimeLog bit-encoded Int64 format +// - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime() +function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; + {$ifdef HASINLINE}inline;{$endif} + +/// Date/Time conversion from a TTimeLog value +// - handle TTimeLog bit-encoded Int64 format +// - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime +// - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an +// internall compiler error on some Delphi IDE versions (e.g. Delphi 6) +function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// Unix seconds since epoch timestamp conversion from a TTimeLog value +// - handle TTimeLog bit-encoded Int64 format +// - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime +function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a Iso8601 encoded string into a TTimeLog value +// - handle TTimeLog bit-encoded Int64 format +// - use this function only for fast comparison between two Iso8601 date/time +// - conversion is faster than Iso8601ToDateTime: use only binary integer math +// - ContainsNoTime optional pointer can be set to a boolean, which will be +// set according to the layout in P (e.g. TRUE for '2012-05-26') +// - returns 0 in case of invalid input string +function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog; + +/// convert a Iso8601 encoded string into a TTimeLog value +// - handle TTimeLog bit-encoded Int64 format +// - use this function only for fast comparison between two Iso8601 date/time +// - conversion is faster than Iso8601ToDateTime: use only binary integer math +function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} + +/// test if P^ contains a valid ISO-8601 text encoded value +// - calls internally Iso8601ToTimeLogPUTF8Char() and returns true if contains +// at least a valid year (YYYY) +function IsIso8601(P: PUTF8Char; L: integer): boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// Date/Time conversion from ISO-8601 +// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format +// - will also recognize '.sss' milliseconds suffix, if any +function Iso8601ToDateTime(const S: RawByteString): TDateTime; overload; + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} + +/// Date/Time conversion from ISO-8601 +// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format +// - will also recognize '.sss' milliseconds suffix, if any +// - if L is left to default 0, it will be computed from StrLen(P) +function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// Date/Time conversion from ISO-8601 +// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format, with potentially +// shorten versions has handled by the ISO-8601 standard (e.g. 'YYYY') +// - will also recognize '.sss' milliseconds suffix, if any +// - if L is left to default 0, it will be computed from StrLen(P) +procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); + +/// Date/Time conversion from strict ISO-8601 content +// - recognize 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]' +// patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON() +// - will also recognize '.sss' milliseconds suffix, if any +function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean; + +/// Time conversion from ISO-8601 (with no Date part) +// - handle 'hhmmss' and 'hh:mm:ss' format +// - will also recognize '.sss' milliseconds suffix, if any +// - if L is left to default 0, it will be computed from StrLen(P) +function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// Time conversion from ISO-8601 (with no Date part) +// - handle 'hhmmss' and 'hh:mm:ss' format +// - will also recognize '.sss' milliseconds suffix, if any +// - if L is left to default 0, it will be computed from StrLen(P) +procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); + +/// Time conversion from ISO-8601 (with no Date part) +// - recognize 'hhmmss' and 'hh:mm:ss' format into H,M,S variables +// - will also recognize '.sss' milliseconds suffix, if any, into MS +// - if L is left to default 0, it will be computed from StrLen(P) +function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; overload; + +/// Date conversion from ISO-8601 (with no Time part) +// - recognize 'YYYY-MM-DD' and 'YYYYMMDD' format into Y,M,D variables +// - if L is left to default 0, it will be computed from StrLen(P) +function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; + +/// Interval date/time conversion from simple text +// - expected format does not match ISO-8601 Time intervals format, but Oracle +// interval litteral representation, i.e. '+/-D HH:MM:SS' +// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and +// IntervalTextToDateTime('-20 06:03:20') -20.252314815 +// - as a consequence, negative intervals will be written as TDateTime values: +// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20' +// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20' +// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20' +function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// Interval date/time conversion from simple text +// - expected format does not match ISO-8601 Time intervals format, but Oracle +// interval litteral representation, i.e. '+/-D HH:MM:SS' +// - e.g. '+1 06:03:20' will return 1.25231481481 +procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); + +/// basic Date/Time conversion into ISO-8601 +// - use 'YYYYMMDDThhmmss' format if not Expanded +// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +// - if QuotedChar is not default #0, will (double) quote the resulted text +// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values +function DateTimeToIso8601(D: TDateTime; Expanded: boolean; + FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): RawUTF8; overload; + +/// basic Date/Time conversion into ISO-8601 +// - use 'YYYYMMDDThhmmss' format if not Expanded +// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +// - if QuotedChar is not default #0, will (double) quote the resulted text +// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values +// - returns the number of chars written to P^ buffer +function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; + FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): integer; overload; + +/// basic Date conversion into ISO-8601 +// - use 'YYYYMMDD' format if not Expanded +// - use 'YYYY-MM-DD' format if Expanded +function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload; + +/// basic Date conversion into ISO-8601 +// - use 'YYYYMMDD' format if not Expanded +// - use 'YYYY-MM-DD' format if Expanded +function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload; + +/// basic Date period conversion into ISO-8601 +// - will convert an elapsed number of days as ISO-8601 text +// - use 'YYYYMMDD' format if not Expanded +// - use 'YYYY-MM-DD' format if Expanded +function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; + +/// basic Time conversion into ISO-8601 +// - use 'Thhmmss' format if not Expanded +// - use 'Thh:mm:ss' format if Expanded +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'; + WithMS: boolean=false): RawUTF8; + +/// Write a Date to P^ Ansi buffer +// - if Expanded is false, 'YYYYMMDD' date format is used +// - if Expanded is true, 'YYYY-MM-DD' date format is used +function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; overload; + +/// convert a date into 'YYYY-MM-DD' date format +// - resulting text is compatible with all ISO-8601 functions +function DateToIso8601Text(Date: TDateTime): RawUTF8; + +/// Write a Date/Time to P^ Ansi buffer +function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; overload; + +/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer +// - if DT=0, returns '' +// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' +// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' +// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; + FirstChar: AnsiChar='T'; WithMS: boolean=false): PUTF8Char; + +/// write a TDateTime into strict ISO-8601 date and/or time text +// - if DT=0, returns '' +// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' +// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' +// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods +function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T'; + WithMS: boolean=false): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + +/// write a TDateTime into strict ISO-8601 date and/or time text +// - if DT=0, returns '' +// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' +// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' +// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods +procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8; + WithMS: boolean=false); + +/// write a TDateTime into strict ISO-8601 date and/or time text +// - if DT=0, returns '' +// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' +// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' +// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods +procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string; + WithMS: boolean=false); + +/// Write a Time to P^ Ansi buffer +// - if Expanded is false, 'Thhmmss' time format is used +// - if Expanded is true, 'Thh:mm:ss' time format is used +// - you can custom the first char in from of the resulting text time +// - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution +function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; + FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; + +/// Write a Time to P^ Ansi buffer +// - if Expanded is false, 'Thhmmss' time format is used +// - if Expanded is true, 'Thh:mm:ss' time format is used +// - you can custom the first char in from of the resulting text time +// - if WithMS is TRUE, will append '.sss' for milliseconds resolution +function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; + FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; + +var + /// custom TTimeLog date to ready to be displayed text function + // - you can override this pointer in order to display the text according + // to your expected i18n settings + // - this callback will therefore be set by the mORMoti18n.pas unit + // - used e.g. by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString() + // methods, i.e. TSQLTableToGrid.DrawCell() + i18nDateText: function(const Iso: TTimeLog): string = nil; + /// custom date to ready to be displayed text function + // - you can override this pointer in order to display the text according + // to your expected i18n settings + // - this callback will therefore be set by the mORMoti18n.pas unit + // - used e.g. by TSQLTable.ExpandAsString() method, + // i.e. TSQLTableToGrid.DrawCell() + i18nDateTimeText: function(const DateTime: TDateTime): string = nil; + +/// wrapper calling global i18nDateTimeText() callback if set, +// or returning ISO-8601 standard layout on default +function DateTimeToi18n(const DateTime: TDateTime): string; + + +/// fast conversion of 2 digit characters into a 0..99 value +// - returns FALSE on success, TRUE if P^ is not correct +function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; + +/// fast conversion of 3 digit characters into a 0..9999 value +// - returns FALSE on success, TRUE if P^ is not correct +function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; + +/// fast conversion of 4 digit characters into a 0..9999 value +// - returns FALSE on success, TRUE if P^ is not correct +function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; + +/// our own fast version of the corresponding low-level RTL function +function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; + +/// our own fast version of the corresponding low-level RTL function +function IsLeapYear(Year: cardinal): boolean; + {$ifdef HASINLINE} inline; {$endif} + +/// retrieve the current Date, in the ISO 8601 layout, but expanded and +// ready to be displayed +function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; + +/// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and +// ready to be displayed +function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; + +/// convert some date/time to the ISO 8601 text layout, including milliseconds +// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format +// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') +// - see also TTextWriter.AddDateTimeMS method +function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true; + FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; + +/// convert some date/time to the ISO 8601 text layout, including milliseconds +// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format +// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') +// - see also TTextWriter.AddDateTimeMS method +function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; + FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; + +/// convert some date/time to the "HTTP-date" format as defined by RFC 7231 +// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of +// "Date", "Expires" or "Last-Modified" HTTP header +// - if you care about timezones Value must be converted to UTC first +// using TSynTimeZone.LocalToUtc, or tz should be properly set +function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8='GMT'): RawUTF8; overload; + +/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file +// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting +// a date > 1999 (a current date would be fine) +function DateTimeToFileShort(const DateTime: TDateTime): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file +// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting +// a date > 1999 (a current date would be fine) +procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); overload; + +/// retrieve the current Time (whithout Date), in the ISO 8601 layout +// - useful for direct on screen logging e.g. +function TimeToString: RawUTF8; + +const + /// a contemporary, but elapsed, TUnixTime second-based value + // - corresponds to Thu, 08 Dec 2016 08:50:20 GMT + // - may be used to check for a valid just-generated Unix timestamp value + UNIXTIME_MINIMAL = 1481187020; + +/// convert a second-based c-encoded time as TDateTime +// - i.e. number of seconds elapsed since Unix epoch 1/1/1970 into TDateTime +function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a TDateTime into a second-based c-encoded time +// - i.e. TDateTime into number of seconds elapsed since Unix epoch 1/1/1970 +function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; + {$ifdef HASINLINE}inline;{$endif} + +/// returns the current UTC date/time as a second-based c-encoded time +// - i.e. current number of seconds elapsed since Unix epoch 1/1/1970 +// - faster than NowUTC or GetTickCount64, on Windows or Unix platforms +// (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, +// or GetSystemTimeAsFileTime under Windows) +// - returns a 64-bit unsigned value, so is "Year2038bug" free +function UnixTimeUTC: TUnixTime; + {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to +// the ISO 8601 text layout +// - use 'YYYYMMDDThhmmss' format if not Expanded +// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded +function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean=true; + FirstTimeChar: AnsiChar='T'): RawUTF8; + +/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to +// a small text layout, perfect e.g. for naming a local file +// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting +// a date > 1999 (a current date would be fine) +procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); overload; + +/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to +// a small text layout, perfect e.g. for naming a local file +// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting +// a date > 1999 (a current date would be fine) +function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert some second-based c-encoded time to the ISO 8601 text layout, either +// as time or date elapsed period +// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp +// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value +function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar='T'): RawUTF8; + +/// returns the current UTC date/time as a millisecond-based c-encoded time +// - i.e. current number of milliseconds elapsed since Unix epoch 1/1/1970 +// - faster and more accurate than NowUTC or GetTickCount64, on Windows or Unix +// - will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, +// or GetSystemTimeAsFileTime/GetSystemTimePreciseAsFileTime under Windows - the +// later being more accurate, but slightly slower than the former, so you may +// consider using UnixMSTimeUTCFast on Windows if its 10-16ms accuracy is enough +function UnixMSTimeUTC: TUnixMSTime; + {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// returns the current UTC date/time as a millisecond-based c-encoded time +// - under Linux/POSIX, is the very same than UnixMSTimeUTC +// - under Windows 8+, will call GetSystemTimeAsFileTime instead of +// GetSystemTimePreciseAsFileTime, which has higher precision, but is slower +// - prefer it under Windows, if a dozen of ms resolution is enough for your task +function UnixMSTimeUTCFast: TUnixMSTime; + {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} + +/// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime +function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970) +// - if AValue is 0, will return 0 (since is likely to be an error constant) +function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime; + {$ifdef HASINLINE}inline;{$endif} + +/// convert some millisecond-based c-encoded time (from Unix epoch 1/1/1970) to +// the ISO 8601 text layout, including milliseconds +// - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' or 'YYYYMMDDThhmmss.sssZ' format +// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') +function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean=true; + FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; + +/// convert some milllisecond-based c-encoded time (from Unix epoch 1/1/1970) to +// a small text layout, trimming to the second resolution, perfect e.g. for +// naming a local file +// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting +// a date > 1999 (a current date would be fine) +function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert some millisecond-based c-encoded time to the ISO 8601 text layout, +// as time or date elapsed period +// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp +// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value +function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar='T'): RawUTF8; + +/// returns the current UTC system date and time +// - SysUtils.Now returns local time: this function returns the system time +// expressed in Coordinated Universal Time (UTC) +// - under Windows, will use GetSystemTimeAsFileTime() so will achieve about +// 16 ms of resolution +// - under POSIX, will call clock_gettime(CLOCK_REALTIME_COARSE) +function NowUTC: TDateTime; + +{$ifndef ENHANCEDRTL} +{$ifndef LVCL} { don't define these twice } + +var + /// these procedure type must be defined if a default system.pas is used + // - mORMoti18n.pas unit will hack default LoadResString() procedure + // - already defined in our Extended system.pas unit + // - needed with FPC, Delphi 2009 and up, i.e. when ENHANCEDRTL is not defined + // - expect generic "string" type, i.e. UnicodeString for Delphi 2009+ + // - not needed with the LVCL framework (we should be on server side) + LoadResStringTranslate: procedure(var Text: string) = nil; + + /// current LoadResString() cached entries count + // - i.e. resourcestring caching for faster use + // - used only if a default system.pas is used, not our Extended version + // - defined here, but resourcestring caching itself is implemented in the + // mORMoti18n.pas unit, if the ENHANCEDRTL conditional is not defined + CacheResCount: integer = -1; + +{$endif} +{$endif} + +type + /// a generic callback, which can be used to translate some text on the fly + // - maps procedure TLanguageFile.Translate(var English: string) signature + // as defined in mORMoti18n.pas + // - can be used e.g. for TSynMustache's {{"English text}} callback + TOnStringTranslate = procedure (var English: string) of object; + + +const + /// Rotate local log file if reached this size (1MB by default) + // - .log file will be save as .log.bak file + // - a new .log file is created + // - used by AppendToTextFile() and LogToTextFile() functions (not TSynLog) + MAXLOGSIZE = 1024*1024; + +/// log a message to a local text file +// - the text file is located in the executable directory, and its name is +// simply the executable file name with the '.log' extension instead of '.exe' +// - format contains the current date and time, then the Msg on one line +// - date and time format used is 'YYYYMMDD hh:mm:ss (i.e. ISO-8601)' +procedure LogToTextFile(Msg: RawUTF8); + +/// log a message to a local text file +// - this version expects the filename to be specified +// - format contains the current date and time, then the Msg on one line +// - date and time format used is 'YYYYMMDD hh:mm:ss' +procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; aMaxSize: Int64=MAXLOGSIZE; + aUTCTimeStamp: boolean=false); + + +{ ************ fast low-level lookup types used by internal conversion routines } + +{$ifndef ENHANCEDRTL} +{$ifndef LVCL} { don't define these const twice } + +const + /// fast lookup table for converting any decimal number from + // 0 to 99 into their ASCII equivalence + // - our enhanced SysUtils.pas (normal and LVCL) contains the same array + TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar = + ('00','01','02','03','04','05','06','07','08','09', + '10','11','12','13','14','15','16','17','18','19', + '20','21','22','23','24','25','26','27','28','29', + '30','31','32','33','34','35','36','37','38','39', + '40','41','42','43','44','45','46','47','48','49', + '50','51','52','53','54','55','56','57','58','59', + '60','61','62','63','64','65','66','67','68','69', + '70','71','72','73','74','75','76','77','78','79', + '80','81','82','83','84','85','86','87','88','89', + '90','91','92','93','94','95','96','97','98','99'); + +{$endif} +{$endif} + +var + /// fast lookup table for converting any decimal number from + // 0 to 99 into their ASCII ('0'..'9') equivalence + TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup; + /// fast lookup table for converting any decimal number from + // 0 to 99 into their byte digits (0..9) equivalence + // - used e.g. by DoubleToAscii() implementing Grisu algorithm + TwoDigitByteLookupW: packed array[0..99] of word; + +type + /// char categories for text line/word/identifiers/uri parsing + TTextChar = set of (tcNot01013, tc1013, tcCtrlNotLF, tcCtrlNot0Comma, + tcWord, tcIdentifierFirstChar, tcIdentifier, tcURIUnreserved); + TTextCharSet = array[AnsiChar] of TTextChar; + PTextCharSet = ^TTextCharSet; + TTextByteSet = array[byte] of TTextChar; + PTextByteSet = ^TTextByteSet; +var + /// branch-less table used for text line/word/identifiers/uri parsing + TEXT_CHARS: TTextCharSet; + TEXT_BYTES: TTextByteSet absolute TEXT_CHARS; + +{$M+} // to have existing RTTI for published properties +type + /// used to retrieve version information from any EXE + // - under Linux, all version numbers are set to 0 by default + // - you should not have to use this class directly, but via the + // ExeVersion global variable + TFileVersion = class + protected + fDetailed: string; + fFileName: TFileName; + fBuildDateTime: TDateTime; + /// change the version (not to be used in most cases) + procedure SetVersion(aMajor,aMinor,aRelease,aBuild: integer); + public + /// executable major version number + Major: Integer; + /// executable minor version number + Minor: Integer; + /// executable release version number + Release: Integer; + /// executable release build number + Build: Integer; + /// build year of this exe file + BuildYear: word; + /// version info of the exe file as '3.1' + // - return "string" type, i.e. UnicodeString for Delphi 2009+ + Main: string; + /// associated CompanyName string version resource + // - only available on Windows - contains '' under Linux/POSIX + CompanyName: RawUTF8; + /// associated FileDescription string version resource + // - only available on Windows - contains '' under Linux/POSIX + FileDescription: RawUTF8; + /// associated FileVersion string version resource + // - only available on Windows - contains '' under Linux/POSIX + FileVersion: RawUTF8; + /// associated InternalName string version resource + // - only available on Windows - contains '' under Linux/POSIX + InternalName: RawUTF8; + /// associated LegalCopyright string version resource + // - only available on Windows - contains '' under Linux/POSIX + LegalCopyright: RawUTF8; + /// associated OriginalFileName string version resource + // - only available on Windows - contains '' under Linux/POSIX + OriginalFilename: RawUTF8; + /// associated ProductName string version resource + // - only available on Windows - contains '' under Linux/POSIX + ProductName: RawUTF8; + /// associated ProductVersion string version resource + // - only available on Windows - contains '' under Linux/POSIX + ProductVersion: RawUTF8; + /// associated Comments string version resource + // - only available on Windows - contains '' under Linux/POSIX + Comments: RawUTF8; + /// retrieve application version from exe file name + // - DefaultVersion32 is used if no information Version was included into + // the executable resources (on compilation time) + // - you should not have to use this constructor, but rather access the + // ExeVersion global variable + constructor Create(const aFileName: TFileName; aMajor: integer=0; + aMinor: integer=0; aRelease: integer=0; aBuild: integer=0); + /// retrieve the version as a 32-bit integer with Major.Minor.Release + // - following Major shl 16+Minor shl 8+Release bit pattern + function Version32: integer; + /// build date and time of this exe file, as plain text + function BuildDateTimeString: string; + /// version info of the exe file as '3.1.0.123' or '' + // - this method returns '' if Detailed is '0.0.0.0' + function DetailedOrVoid: string; + /// returns the version information of this exe file as text + // - includes FileName (without path), Detailed and BuildDateTime properties + // - e.g. 'myprogram.exe 3.1.0.123 (2016-06-14 19:07:55)' + function VersionInfo: RawUTF8; + /// returns a ready-to-use User-Agent header with exe name, version and OS + // - e.g. 'myprogram/3.1.0.123W32' for myprogram running on Win32 + // - here OS_INITIAL[] character is used to identify the OS, with '32' + // appended on Win32 only (e.g. 'myprogram/3.1.0.2W', is for Win64) + function UserAgent: RawUTF8; + /// returns the version information of a specified exe file as text + // - includes FileName (without path), Detailed and BuildDateTime properties + // - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55' + class function GetVersionInfo(const aFileName: TFileName): RawUTF8; + published + /// version info of the exe file as '3.1.0.123' + // - return "string" type, i.e. UnicodeString for Delphi 2009+ + // - under Linux, always return '0.0.0.0' if no custom version number + // has been defined + // - consider using DetailedOrVoid method if '0.0.0.0' is not expected + property Detailed: string read fDetailed write fDetailed; + /// build date and time of this exe file + property BuildDateTime: TDateTime read fBuildDateTime write fBuildDateTime; + end; +{$M-} + + +{$ifdef DELPHI6OROLDER} + +// define some common constants not available prior to Delphi 7 +const + HoursPerDay = 24; + MinsPerHour = 60; + SecsPerMin = 60; + MSecsPerSec = 1000; + MinsPerDay = HoursPerDay * MinsPerHour; + SecsPerDay = MinsPerDay * SecsPerMin; + MSecsPerDay = SecsPerDay * MSecsPerSec; + DateDelta = 693594; + UnixDateDelta = 25569; + +/// GetFileVersion returns the most significant 32-bit of a file's binary +// version number +// - typically, this includes the major and minor version placed +// together in one 32-bit integer +// - generally does not include the release or build numbers +// - returns Cardinal(-1) in case of failure +function GetFileVersion(const FileName: TFileName): cardinal; + +{$endif DELPHI6OROLDER} + +type + /// the recognized operating systems + // - it will also recognize some Linux distributions + TOperatingSystem = (osUnknown, osWindows, osLinux, osOSX, osBSD, osPOSIX, + osArch, osAurox, osDebian, osFedora, osGentoo, osKnoppix, osMint, osMandrake, + osMandriva, osNovell, osUbuntu, osSlackware, osSolaris, osSuse, osSynology, + osTrustix, osClear, osUnited, osRedHat, osLFS, osOracle, osMageia, osCentOS, + osCloud, osXen, osAmazon, osCoreOS, osAlpine, osAndroid); + /// the recognized Windows versions + // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools + TWindowsVersion = ( + wUnknown, w2000, wXP, wXP_64, wServer2003, wServer2003_R2, + wVista, wVista_64, wServer2008, wServer2008_64, + wSeven, wSeven_64, wServer2008_R2, wServer2008_R2_64, + wEight, wEight_64, wServer2012, wServer2012_64, + wEightOne, wEightOne_64, wServer2012R2, wServer2012R2_64, + wTen, wTen_64, wServer2016, wServer2016_64, + wEleven, wEleven_64, wServer2019_64); + /// the running Operating System, encoded as a 32-bit integer + TOperatingSystemVersion = packed record + case os: TOperatingSystem of + osUnknown: (b: array[0..2] of byte); + osWindows: (win: TWindowsVersion); + osLinux: (utsrelease: array[0..2] of byte); + end; + +const + /// the recognized Windows versions, as plain text + // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools + WINDOWS_NAME: array[TWindowsVersion] of RawUTF8 = ( + '', '2000', 'XP', 'XP 64bit', 'Server 2003', 'Server 2003 R2', + 'Vista', 'Vista 64bit', 'Server 2008', 'Server 2008 64bit', + '7', '7 64bit', 'Server 2008 R2', 'Server 2008 R2 64bit', + '8', '8 64bit', 'Server 2012', 'Server 2012 64bit', + '8.1', '8.1 64bit', 'Server 2012 R2', 'Server 2012 R2 64bit', + '10', '10 64bit', 'Server 2016', 'Server 2016 64bit', + '11', '11 64bit', 'Server 2019 64bit'); + /// the recognized Windows versions which are 32-bit + WINDOWS_32 = [w2000, wXP, wServer2003, wServer2003_R2, wVista, wServer2008, + wSeven, wServer2008_R2, wEight, wServer2012, wEightOne, wServer2012R2, + wTen, wServer2016, wEleven]; + /// translate one operating system (and distribution) into a single character + // - may be used internally e.g. for a HTTP User-Agent header, as with + // TFileVersion.UserAgent + OS_INITIAL: array[TOperatingSystem] of AnsiChar = + ('?', 'W', 'L', 'X', 'B', 'P', 'A', 'a', 'D', 'F', 'G', 'K', 'M', 'm', + 'n', 'N', 'U', 'S', 's', 'u', 'Y', 'T', 'C', 't', 'R', 'l', 'O', 'G', + 'c', 'd', 'x', 'Z', 'r', 'p', 'J'); // for Android ... J = Java VM + /// the operating systems items which actually are Linux distributions + OS_LINUX = [osLinux, osArch .. osAndroid]; + + /// the compiler family used + COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif}; + /// the target Operating System used for compilation, as text + OS_TEXT = {$ifdef MSWINDOWS}'Win'{$else}{$ifdef DARWIN}'OSX'{$else} + {$ifdef BSD}'BSD'{$else}{$ifdef ANDROID}'Android'{$else}{$ifdef LINUX}'Linux'{$else}'Posix' + {$endif}{$endif}{$endif}{$endif}{$endif}; + /// the CPU architecture used for compilation + CPU_ARCH_TEXT = {$ifdef CPUX86}'x86'{$else}{$ifdef CPUX64}'x64'{$else} + {$ifdef CPUARM}'arm'+{$else} + {$ifdef CPUAARCH64}'arm'+{$else} + {$ifdef CPUPOWERPC}'ppc'+{$else} + {$ifdef CPUSPARC}'sparc'+{$endif}{$endif}{$endif}{$endif} + {$ifdef CPU32}'32'{$else}'64'{$endif}{$endif}{$endif}; + +function ToText(os: TOperatingSystem): PShortString; overload; +function ToText(const osv: TOperatingSystemVersion): ShortString; overload; +function ToTextOS(osint32: integer): RawUTF8; + +var + /// the target Operating System used for compilation, as TOperatingSystem + // - a specific Linux distribution may be detected instead of plain osLinux + OS_KIND: TOperatingSystem = {$ifdef MSWINDOWS}osWindows{$else}{$ifdef DARWIN}osOSX{$else} + {$ifdef BSD}osBSD{$else}{$ifdef Android}osAndroid{$else}{$ifdef LINUX}osLinux{$else}osPOSIX + {$endif}{$endif}{$endif}{$endif}{$endif}; + /// the current Operating System version, as retrieved for the current process + // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or + // 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017' + OSVersionText: RawUTF8; + /// some addition system information as text, e.g. 'Wine 1.1.5' + // - also always appended to OSVersionText high-level description + OSVersionInfoEx: RawUTF8; + /// some textual information about the current CPU + CpuInfoText: RawUTF8; + /// some textual information about the current computer hardware, from BIOS + BiosInfoText: RawUTF8; + /// the running Operating System + OSVersion32: TOperatingSystemVersion; + OSVersionInt32: integer absolute OSVersion32; + +{$ifdef MSWINDOWS} + {$ifndef UNICODE} +type + /// low-level API structure, not defined in older Delphi versions + TOSVersionInfoEx = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array[0..127] of char; + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; + {$endif UNICODE} + +var + /// is set to TRUE if the current process is a 32-bit image running under WOW64 + // - WOW64 is the x86 emulator that allows 32-bit Windows-based applications + // to run seamlessly on 64-bit Windows + // - equals always FALSE if the current executable is a 64-bit image + IsWow64: boolean; + /// the current System information, as retrieved for the current process + // - under a WOW64 process, it will use the GetNativeSystemInfo() new API + // to retrieve the real top-most system information + // - note that the lpMinimumApplicationAddress field is replaced by a + // more optimistic/realistic value ($100000 instead of default $10000) + // - under BSD/Linux, only contain dwPageSize and dwNumberOfProcessors fields + SystemInfo: TSystemInfo; + /// the current Operating System information, as retrieved for the current process + OSVersionInfo: TOSVersionInfoEx; + /// the current Operating System version, as retrieved for the current process + OSVersion: TWindowsVersion; + +/// this function can be used to create a GDI compatible window, able to +// receive Windows Messages for fast local communication +// - will return 0 on failure (window name already existing e.g.), or +// the created HWND handle on success +// - it will call the supplied message handler defined for a given Windows Message: +// for instance, define such a method in any object definition: +// ! procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA; +function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; + +/// delete the window resources used to receive Windows Messages +// - must be called for each CreateInternalWindow() function +// - both parameter values are then reset to ''/0 +function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; + +/// under Windows 7 and later, will set an unique application-defined +// Application User Model ID (AppUserModelID) that identifies the current +// process to the taskbar +// - this identifier allows an application to group its associated processes +// and windows under a single taskbar button +// - value can have no more than 128 characters, cannot contain spaces, and +// each section should be camel-cased, as such: +// $ CompanyName.ProductName.SubProduct.VersionInformation +// CompanyName and ProductName should always be used, while the SubProduct and +// VersionInformation portions are optional and depend on the application's requirements +// - if the supplied text does not contain an '.', 'ID.ID' will be used +function SetAppUserModelID(const AppUserModelID: string): boolean; + +var + /// the number of milliseconds that have elapsed since the system was started + // - compatibility function, to be implemented according to the running OS + // - will use the corresponding native API function under Vista+, or + // will emulate it for older Windows versions (XP) + // - warning: FPC's SysUtils.GetTickCount64 or TThread.GetTickCount64 don't + // handle properly 49 days wrapping under XP -> always use this safe version + GetTickCount64: function: Int64; stdcall; + + /// returns the highest resolution possible UTC timestamp on this system + // - detects newer API available since Windows 8, or fallback to good old + // GetSystemTimeAsFileTime() which may have the resolution of the HW timer, + // i.e. typically around 16 ms + // - GetSystemTimeAsFileTime() is always faster, so is to be preferred + // if second resolution is enough (e.g. for UnixTimeUTC) + // - see http://www.windowstimestamp.com/description + GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall; + +/// similar to Windows sleep() API call, to be truly cross-platform +// - it should have a millisecond resolution, and handle ms=0 as a switch to +// another pending thread, i.e. under Windows will call SwitchToThread API +procedure SleepHiRes(ms: cardinal); + +/// low-level wrapper to get the 64-bit value from a TFileTime +// - as recommended by MSDN to avoid dword alignment issue +procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); + {$ifdef HASINLINE}inline;{$endif} + +/// low-level conversion of a Windows 64-bit TFileTime into a Unix time seconds stamp +function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; + +/// low-level conversion of a Windows 64-bit TFileTime into a Unix time ms stamp +function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; + +type + /// direct access to the Windows Registry + // - could be used as alternative to TRegistry, which doesn't behave the same on + // all Delphi versions, and is enhanced on FPC (e.g. which supports REG_MULTI_SZ) + // - is also Unicode ready for text, using UTF-8 conversion on all compilers + TWinRegistry = object + public + /// the opened HKEY handle + key: HKEY; + /// start low-level read access to a Windows Registry node + // - on success (returned true), ReadClose() should be called + function ReadOpen(root: HKEY; const keyname: RawUTF8; closefirst: boolean=false): boolean; + /// finalize low-level read access to the Windows Registry after ReadOpen() + procedure Close; + /// low-level read a string from the Windows Registry after ReadOpen() + // - in respect to Delphi's TRegistry, will properly handle REG_MULTI_SZ + // (return the first value of the multi-list) + function ReadString(const entry: SynUnicode; andtrim: boolean=true): RawUTF8; + /// low-level read a Windows Registry content after ReadOpen() + // - works with any kind of key, but was designed for REG_BINARY + function ReadData(const entry: SynUnicode): RawByteString; + /// low-level read a Windows Registry 32-bit REG_DWORD value after ReadOpen() + function ReadDword(const entry: SynUnicode): cardinal; + /// low-level read a Windows Registry 64-bit REG_QWORD value after ReadOpen() + function ReadQword(const entry: SynUnicode): QWord; + /// low-level enumeration of all sub-entries names of a Windows Registry key + function ReadEnumEntries: TRawUTF8DynArray; + end; + +{$else MSWINDOWS} + +var + /// emulate only some used fields of Windows' TSystemInfo + SystemInfo: record + // retrieved from libc's getpagesize() - is expected to not be 0 + dwPageSize: cardinal; + // retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux) + dwNumberOfProcessors: cardinal; + // as returned by fpuname() + uts: UtsName; + // as from /etc/*-release + release: RawUTF8; + end; + +{$ifdef KYLIX3} + +/// compatibility function for Linux +function GetCurrentThreadID: TThreadID; cdecl; + external 'libpthread.so.0' name 'pthread_self'; + +/// overloaded function using open64() to allow 64-bit positions +function FileOpen(const FileName: string; Mode: LongWord): Integer; + +{$endif} + +/// compatibility function, to be implemented according to the running OS +// - expect more or less the same result as the homonymous Win32 API function, +// but usually with a better resolution (Windows has only around 10-16 ms) +// - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas, +// using the very fast CLOCK_MONOTONIC_COARSE if available on the kernel +function GetTickCount64: Int64; + +{$endif MSWINDOWS} + +/// overloaded function optimized for one pass file reading +// - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated +// by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx +// - note: under XP, we observed ERROR_NO_SYSTEM_RESOURCES problems when calling +// FileRead() for chunks bigger than 32MB on files opened with this flag, +// so it would use regular FileOpen() on this deprecated OS +// - under POSIX, calls plain fpOpen(FileName,O_RDONLY) which would avoid a +// syscall to fpFlock() which is not needed here +// - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create() +function FileOpenSequentialRead(const FileName: string): Integer; + {$ifdef HASINLINE}inline;{$endif} + +/// returns a TFileStream optimized for one pass file reading +// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN under +// Windows, and plain fpOpen(FileName, O_RDONLY) on POSIX +function FileStreamSequentialRead(const FileName: string): THandleStream; + +/// check if the current timestamp, in ms, matched a given period +// - will compare the current GetTickCount64 to the supplied PreviousTix +// - returns TRUE if the Internal ms period was not elapsed +// - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed +// - possible use case may be: +// !var Last: Int64; +// !... +// ! Last := GetTickCount64; +// ! repeat +// ! ... +// ! if Elapsed(Last,1000) then begin +// ! ... // do something every second +// ! end; +// ! until Terminated; +// !... +function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; + +/// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern +procedure RCU32(var src,dst); + +/// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern +procedure RCU64(var src,dst); + +/// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern +procedure RCU128(var src,dst); + +/// thread-safe move of a pointer value using a simple Read-Copy-Update pattern +procedure RCUPtr(var src,dst); + +/// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern +procedure RCU(var src,dst; len: integer); + +{$ifndef FPC} { FPC defines those functions as built-in } + +/// compatibility function, to be implemented according to the running CPU +// - expect the same result as the homonymous Win32 API function +function InterlockedIncrement(var I: Integer): Integer; + {$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} + +/// compatibility function, to be implemented according to the running CPU +// - expect the same result as the homonymous Win32 API function +function InterlockedDecrement(var I: Integer): Integer; + {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} + +{$endif FPC} + +/// low-level string reference counter unprocess +// - caller should have tested that refcnt>=0 +// - returns true if the managed variable should be released (i.e. refcnt was 1) +function StrCntDecFree(var refcnt: TStrCnt): boolean; + {$ifndef CPUINTEL} inline; {$endif} + +/// low-level dynarray reference counter unprocess +// - caller should have tested that refcnt>=0 +function DACntDecFree(var refcnt: TDACnt): boolean; + {$ifndef CPUINTEL} inline; {$endif} + +type + /// stores some global information about the current executable and computer + TExeVersion = record + /// the main executable name, without any path nor extension + // - e.g. 'Test' for 'c:\pathto\Test.exe' + ProgramName: RawUTF8; + /// the main executable details, as used e.g. by TSynLog + // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.123 (2011-03-29 11:09:06)' + ProgramFullSpec: RawUTF8; + /// the main executable file name (including full path) + // - same as paramstr(0) + ProgramFileName: TFileName; + /// the main executable full path (excluding .exe file name) + // - same as ExtractFilePath(paramstr(0)) + ProgramFilePath: TFileName; + /// the full path of the running executable or library + // - for an executable, same as paramstr(0) + // - for a library, will contain the whole .dll file name + InstanceFileName: TFileName; + /// the current executable version + Version: TFileVersion; + /// the current computer host name + Host: RawUTF8; + /// the current computer user name + User: RawUTF8; + /// some hash representation of this information + // - the very same executable on the very same computer run by the very + // same user will always have the same Hash value + // - is computed from the crc32c of this TExeVersion fields: c0 from + // Version32, CpuFeatures and Host, c1 from User, c2 from ProgramFullSpec + // and c3 from InstanceFileName + // - may be used as an entropy seed, or to identify a process execution + Hash: THash128Rec; + end; + +var + /// global information about the current executable and computer + // - this structure is initialized in this unit's initialization block below + // - you can call SetExecutableVersion() with a custom version, if needed + ExeVersion: TExeVersion; + +/// initialize ExeVersion global variable, supplying a custom version number +// - by default, the version numbers will be retrieved at startup from the +// executable itself (if it was included at build time) +// - but you can use this function to set any custom version numbers +procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); overload; + +/// initialize ExeVersion global variable, supplying the version as text +// - e.g. SetExecutableVersion('7.1.2.512'); +procedure SetExecutableVersion(const aVersionText: RawUTF8); overload; + +type + /// identify an operating system folder + TSystemPath = ( + spCommonData, spUserData, spCommonDocuments, spUserDocuments, spTempFolder, spLog); + +/// returns an operating system folder +// - will return the full path of a given kind of private or shared folder, +// depending on the underlying operating system +// - will use SHGetFolderPath and the corresponding CSIDL constant under Windows +// - under POSIX, will return $TMP/$TMPDIR folder for spTempFolder, ~/.cache/appname +// for spUserData, /var/log for spLog, or the $HOME folder +// - returned folder name contains the trailing path delimiter (\ or /) +function GetSystemPath(kind: TSystemPath): TFileName; + +/// self-modifying code - change some memory buffer in the code segment +// - if Backup is not nil, it should point to a Size array of bytes, ready +// to contain the overridden code buffer, for further hook disabling +procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil; + LeaveUnprotected: boolean=false); + +/// self-modifying code - change one PtrUInt in the code segment +procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; + LeaveUnprotected: boolean=false); + +{$ifdef CPUINTEL} +type + /// small memory buffer used to backup a RedirectCode() redirection hook + TPatchCode = array[0..4] of byte; + /// pointer to a small memory buffer used to backup a RedirectCode() hook + PPatchCode = ^TPatchCode; + +/// self-modifying code - add an asm JUMP to a redirected function +// - if Backup is not nil, it should point to a TPatchCode buffer, ready +// to contain the overridden code buffer, for further hook disabling +procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil); + +/// self-modifying code - restore a code from its RedirectCode() backup +procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); +{$endif CPUINTEL} + +type + /// to be used instead of TMemoryStream, for speed + // - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM) + // and not GlobalAlloc(), as was the case for oldest versions of Delphi + // - uses bigger growing size of the capacity + // - consider using TRawByteStringStream, as we do in our units +{$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc() + THeapMemoryStream = TMemoryStream; +{$else} + {$ifdef FPC} // FPC already use heap instead of GlobalAlloc() + THeapMemoryStream = TMemoryStream; + {$else} + {$ifndef UNICODE} // old Delphi used GlobalAlloc() + THeapMemoryStream = class(TMemoryStream) + protected + function Realloc(var NewCapacity: longint): Pointer; override; + end; + {$else} + THeapMemoryStream = TMemoryStream; + {$endif} + {$endif} +{$endif} + +var + /// a global "Garbage collector", for some classes instances which must + // live during whole main executable process + // - used to avoid any memory leak with e.g. 'class var RecordProps', i.e. + // some singleton or static objects + // - to be used, e.g. as: + // ! Version := TFileVersion.Create(InstanceFileName,DefaultVersion32); + // ! GarbageCollector.Add(Version); + // - see also GarbageCollectorFreeAndNil() as an alternative + GarbageCollector: TSynObjectList; + + /// set to TRUE when the global "Garbage collector" are beeing freed + GarbageCollectorFreeing: boolean; + +/// a global "Garbage collector" for some TObject global variables which must +// live during whole main executable process +// - this list expects a pointer to the TObject instance variable to be +// specified, and will be set to nil (like a FreeAndNil) +// - this may be useful when used when targetting Delphi IDE packages, +// to circumvent the bug of duplicated finalization of units, in the scope +// of global variables +// - to be used, e.g. as: +// ! if SynAnsiConvertList=nil then +// ! GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create); +procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); + +/// force the global "Garbage collector" list to be released immediately +// - this function is called in the finalization section of this unit +// - you should NEVER have to call this function, unless some specific cases +// (e.g. when using Delphi packages, just before releasing the package) +procedure GarbageCollectorFree; + +/// enter a giant lock for thread-safe shared process +// - shall be protected as such: +// ! GlobalLock; +// ! try +// ! .... do something thread-safe but as short as possible +// ! finally +// ! GlobalUnLock; +// ! end; +// - you should better not use such a giant-lock, but an instance-dedicated +// critical section - these functions are just here to be convenient, for +// non time-critical process +procedure GlobalLock; + +/// release the giant lock for thread-safe shared process +// - you should better not use such a giant-lock, but an instance-dedicated +// critical section - these functions are just here to be convenient, for +// non time-critical process +procedure GlobalUnLock; + + +var + /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' + // - can be used when a RawUTF8 string is expected + BOOL_UTF8: array[boolean] of RawUTF8; + +const + /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' + // - can be used e.g. in logs, or anything accepting a shortstring + BOOL_STR: array[boolean] of string[7] = ('false','true'); + + /// can be used to append to most English nouns to form a plural + // - see also the Plural function + PLURAL_FORM: array[boolean] of RawUTF8 = ('','s'); + +/// write count number and append 's' (if needed) to form a plural English noun +// - for instance, Plural('row',100) returns '100 rows' with no heap allocation +function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; + +/// returns TRUE if the specified field name is either 'ID', either 'ROWID' +function IsRowID(FieldName: PUTF8Char): boolean; + {$ifdef HASINLINE}inline;{$endif} overload; + +/// returns TRUE if the specified field name is either 'ID', either 'ROWID' +function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; + {$ifdef HASINLINE}inline;{$endif} overload; + +/// returns TRUE if the specified field name is either 'ID', either 'ROWID' +function IsRowIDShort(const FieldName: shortstring): boolean; + {$ifdef HASINLINE}inline;{$endif} overload; + +/// retrieve the next SQL-like identifier within the UTF-8 buffer +// - will also trim any space (or line feeds) and trailing ';' +// - any comment like '/*nocache*/' will be ignored +// - returns true if something was set to Prop +function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; + +/// retrieve the next identifier within the UTF-8 buffer on the same line +// - GetNextFieldProp() will just handle line feeds (and ';') as spaces - which +// is fine e.g. for SQL, but not for regular config files with name/value pairs +// - returns true if something was set to Prop +function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; + + +{ ************ variant-based process, including JSON/BSON document content } + +const + /// unsigned 64bit integer variant type + // - currently called varUInt64 in Delphi (not defined in older versions), + // and varQWord in FPC + varWord64 = 21; + + /// this variant type will map the current SynUnicode type + // - depending on the compiler version + varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif}; + + /// this variant type will map the current string type + // - depending on the compiler version + varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif}; + +{$ifdef HASINLINE} +/// overloaded function which can be properly inlined +procedure VarClear(var v: variant); inline; +{$endif HASINLINE} + +/// same as Dest := TVarData(Source) for simple values +// - will return TRUE for all simple values after varByRef unreference, and +// copying the unreferenced Source value into Dest raw storage +// - will return FALSE for not varByRef values, or complex values (e.g. string) +function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; + {$ifdef HASINLINE}inline;{$endif} + +{$ifndef LVCL} + +/// convert a raw binary buffer into a variant RawByteString varString +// - you can then use VariantToRawByteString() to retrieve the binary content +procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload; + +/// convert a RawByteString content into a variant varString +// - you can then use VariantToRawByteString() to retrieve the binary content +procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload; + +/// convert back a RawByteString from a variant +// - the supplied variant should have been created via a RawByteStringToVariant() +// function call +procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); + +/// same as Value := Null, but slightly faster +procedure SetVariantNull(var Value: variant); + {$ifdef HASINLINE}inline;{$endif} + +const + NullVarData: TVarData = (VType: varNull); +var + /// a slightly faster alternative to Variants.Null function + Null: variant absolute NullVarData; + +{$endif LVCL} + +/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster +// - we also discovered some issues with FPC's Variants unit, so this function +// may be used even in end-user cross-compiler code +function VarIsEmptyOrNull(const V: Variant): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster +// - we also discovered some issues with FPC's Variants unit, so this function +// may be used even in end-user cross-compiler code +function VarDataIsEmptyOrNull(VarData: pointer): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// fastcheck if a variant hold a value +// - varEmpty, varNull or a '' string would be considered as void +// - varBoolean=false or varDate=0 would be considered as void +// - a TDocVariantData with Count=0 would be considered as void +// - any other value (e.g. integer) would be considered as not void +function VarIsVoid(const V: Variant): boolean; + +/// returns a supplied string as variant, or null if v is void ('') +function VarStringOrNull(const v: RawUTF8): variant; + +type + TVarDataTypes = set of 0..255; + +/// allow to check for a specific set of TVarData.VType +function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +{$ifndef NOVARIANTS} + +type + /// custom variant handler with easier/faster access of variant properties, + // and JSON serialization support + // - default GetProperty/SetProperty methods are called via some protected + // virtual IntGet/IntSet methods, with less overhead (to be overriden) + // - these kind of custom variants will be faster than the default + // TInvokeableVariantType for properties getter/setter, but you should + // manually register each type by calling SynRegisterCustomVariantType() + // - also feature custom JSON parsing, via TryJSONToVariant() protected method + TSynInvokeableVariantType = class(TInvokeableVariantType) + protected + {$ifndef FPC} + {$ifndef DELPHI6OROLDER} + /// our custom call backs do not want the function names to be uppercased + function FixupIdent(const AText: string): string; override; + {$endif} + {$endif} + /// override those two abstract methods for fast getter/setter implementation + function IntGet(var Dest: TVarData; const Instance: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; + function IntSet(const Instance, Value: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; + public + /// search of a registered custom variant type from its low-level VarType + // - will first compare with its own VarType for efficiency + function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean; + /// customization of JSON parsing into variants + // - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON() + // with Options: PDocVariantOptions parameter not nil + // - this default implementation will always returns FALSE, + // meaning that the supplied JSON is not to be handled by this custom + // (abstract) variant type + // - this method could be overridden to identify any custom JSON content + // and convert it into a dedicated variant instance, then return TRUE + // - warning: should NOT modify JSON buffer in-place, unless it returns true + function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant; + EndOfObject: PUTF8Char): boolean; virtual; + /// customization of variant into JSON serialization + procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual; + /// retrieve the field/column value + // - this method will call protected IntGet abstract method + function GetProperty(var Dest: TVarData; const V: TVarData; + const Name: String): Boolean; override; + /// set the field/column value + // - this method will call protected IntSet abstract method + {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 + function SetProperty(var V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + {$else} + function SetProperty(const V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + {$endif} + /// clear the content + // - this default implementation will set VType := varEmpty + // - override it if your custom type needs to manage its internal memory + procedure Clear(var V: TVarData); override; + /// copy two variant content + // - this default implementation will copy the TVarData memory + // - override it if your custom type needs to manage its internal structure + procedure Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); override; + /// copy two variant content by value + // - this default implementation will call the Copy() method + // - override it if your custom types may use a by reference copy pattern + procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual; + /// this method will allow to look for dotted name spaces, e.g. 'parent.child' + // - should return Unassigned if the FullName does not match any value + // - will identify TDocVariant storage, or resolve and call the generic + // TSynInvokeableVariantType.IntGet() method until nested value match + procedure Lookup(var Dest: TVarData; const Instance: TVarData; FullName: PUTF8Char); + /// will check if the value is an array, and return the number of items + // - if the document is an array, will return the items count (0 meaning + // void array) - used e.g. by TSynMustacheContextVariant + // - this default implementation will return -1 (meaning this is not an array) + // - overridden method could implement it, e.g. for TDocVariant of kind dvArray + function IterateCount(const V: TVarData): integer; virtual; + /// allow to loop over an array document + // - Index should be in 0..IterateCount-1 range + // - this default implementation will do nothing + procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual; + /// returns TRUE if the supplied variant is of the exact custom type + function IsOfType(const V: variant): boolean; + {$ifdef HASINLINE}inline;{$endif} + end; + + /// class-reference type (metaclass) of custom variant type definition + // - used by SynRegisterCustomVariantType() function + TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType; + +/// register a custom variant type to handle properties +// - this will implement an internal mechanism used to bypass the default +// _DispInvoke() implementation in Variant.pas, to use a faster version +// - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or +// TSQLDBRowVariant +function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; + +/// same as Dest := Source, but copying by reference +// - i.e. VType is defined as varVariant or varByRef +// - for instance, it will be used for late binding of TDocVariant properties, +// to let following statements work as expected: +// ! V := _Json('{arr:[1,2]}'); +// ! V.arr.Add(3); // will work, since V.arr will be returned by reference +// ! writeln(V); // will write '{"arr":[1,2,3]}' +procedure SetVariantByRef(const Source: Variant; var Dest: Variant); + +/// same as Dest := Source, but copying by value +// - will unreference any varByRef content +// - will convert any string value into RawUTF8 (varString) for consistency +procedure SetVariantByValue(const Source: Variant; var Dest: Variant); + +/// same as FillChar(Value^,SizeOf(TVarData),0) +// - so can be used for TVarData or Variant +// - it will set V.VType := varEmpty, so Value will be Unassigned +// - it won't call VarClear(variant(Value)): it should have been cleaned before +procedure ZeroFill(Value: PVarData); {$ifdef HASINLINE}inline;{$endif} + +/// fill all bytes of the value's memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 +// - may be used to cleanup stack-allocated content +procedure FillZero(var value: variant); overload; + +/// retrieve a variant value from variable-length buffer +// - matches TFileBufferWriter.Write() +// - how custom type variants are created can be defined via CustomVariantOptions +// - is just a wrapper around VariantLoad() +procedure FromVarVariant(var Source: PByte; var Value: variant; + CustomVariantOptions: PDocVariantOptions=nil); {$ifdef HASINLINE}inline;{$endif} + +/// compute the number of bytes needed to save a Variant content +// using the VariantSave() function +// - will return 0 in case of an invalid (not handled) Variant type +function VariantSaveLength(const Value: variant): integer; + +/// save a Variant content into a destination memory buffer +// - Dest must be at least VariantSaveLength() bytes long +// - will handle standard Variant types and custom types (serialized as JSON) +// - will return nil in case of an invalid (not handled) Variant type +// - will use a proprietary binary format, with some variable-length encoding +// of the string length +// - warning: will encode generic string fields as within the variant type +// itself: using this function between UNICODE and NOT UNICODE +// versions of Delphi, will propably fail - you have been warned! +function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload; + +/// save a Variant content into a binary buffer +// - will handle standard Variant types and custom types (serialized as JSON) +// - will return '' in case of an invalid (not handled) Variant type +// - just a wrapper around VariantSaveLength()+VariantSave() +// - warning: will encode generic string fields as within the variant type +// itself: using this function between UNICODE and NOT UNICODE +// versions of Delphi, will propably fail - you have been warned! +function VariantSave(const Value: variant): RawByteString; overload; + +/// retrieve a variant value from our optimized binary serialization format +// - follow the data layout as used by RecordLoad() or VariantSave() function +// - return nil if the Source buffer is incorrect +// - in case of success, return the memory buffer pointer just after the +// read content +// - how custom type variants are created can be defined via CustomVariantOptions +function VariantLoad(var Value: variant; Source: PAnsiChar; + CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar=nil): PAnsiChar; overload; + +/// retrieve a variant value from our optimized binary serialization format +// - follow the data layout as used by RecordLoad() or VariantSave() function +// - return varEmpty if the Source buffer is incorrect +// - just a wrapper around VariantLoad() +// - how custom type variants are created can be defined via CustomVariantOptions +function VariantLoad(const Bin: RawByteString; + CustomVariantOptions: PDocVariantOptions): variant; overload; + +/// retrieve a variant value from a JSON number or string +// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) +// - will instantiate either an Integer, Int64, currency, double or string value +// (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except TryCustomVariants points to some options +// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or +// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some +// extended (e.g. BSON) syntax +// - warning: the JSON buffer will be modified in-place during process - use +// a temporary copy or the overloaded functions with RawUTF8 parameter +// if you need to access it later +function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; + EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil; + AllowDouble: boolean=false): PUTF8Char; overload; + +/// retrieve a variant value from a JSON number or string +// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) +// - will instantiate either an Integer, Int64, currency, double or string value +// (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except TryCustomVariants points to some options +// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or +// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some +// extended (e.g. BSON) syntax +// - this overloaded procedure will make a temporary copy before JSON parsing +// and return the variant as result +procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; + TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); overload; + +/// retrieve a variant value from a JSON number or string +// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) +// - will instantiate either an Integer, Int64, currency, double or string value +// (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except TryCustomVariants points to some options +// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or +// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some +// extended (e.g. BSON) syntax +// - this overloaded procedure will make a temporary copy before JSON parsing +// and return the variant as result +function VariantLoadJSON(const JSON: RawUTF8; + TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): variant; overload; + +/// save a variant value into a JSON content +// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format +// - is able to handle simple and custom variant types, for instance: +// ! VariantSaveJSON(1.5)='1.5' +// ! VariantSaveJSON('test')='"test"' +// ! o := _Json('{ BSON: [ "test", 5.05, 1986 ] }'); +// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' +// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); +// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' +// - note that before Delphi 2009, any varString value is expected to be +// a RawUTF8 instance - which does make sense in the mORMot area +function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind=twJSONEscape): RawUTF8; overload; + +/// save a variant value into a JSON content +// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format +// - is able to handle simple and custom variant types, for instance: +// ! VariantSaveJSON(1.5)='1.5' +// ! VariantSaveJSON('test')='"test"' +// ! o := _Json('{BSON: ["test", 5.05, 1986]}'); +// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' +// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); +// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' +// - note that before Delphi 2009, any varString value is expected to be +// a RawUTF8 instance - which does make sense in the mORMot area +procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; + var result: RawUTF8); overload; + +/// compute the number of chars needed to save a variant value into a JSON content +// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format +// - this will be much faster than length(VariantSaveJSON()) for huge content +// - note that before Delphi 2009, any varString value is expected to be +// a RawUTF8 instance - which does make sense in the mORMot area +function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind=twJSONEscape): integer; + +/// low-level function to set a variant from an unescaped JSON number or string +// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField() +// - is called e.g. by function VariantLoadJSON() +// - will instantiate either a null, boolean, Integer, Int64, currency, double +// (if AllowDouble is true or dvoAllowDoubleValue is in TryCustomVariants^) or +// string value (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except if TryCustomVariants points to some +// options (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known +// object or array, either encoded as strict-JSON (i.e. {..} or [..]), +// or with some extended (e.g. BSON) syntax +procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; + TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); + +/// low-level function to set a variant from an unescaped JSON non string +// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField(), +// and having returned wasString=TRUE (i.e. not surrounded by double quotes) +// - is called e.g. by function GetVariantFromJSON() +// - will recognize null, boolean, Integer, Int64, currency, double +// (if AllowDouble is true) input, then set Value and return TRUE +// - returns FALSE if the supplied input has no expected JSON format +function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; + AllowDouble: boolean): boolean; + +/// identify either varInt64, varDouble, varCurrency types following JSON format +// - any non valid number is returned as varString +// - is used e.g. by GetVariantFromJSON() to guess the destination variant type +// - warning: supplied JSON is expected to be not nil +function TextToVariantNumberType(JSON: PUTF8Char): cardinal; + +/// identify either varInt64 or varCurrency types following JSON format +// - this version won't return varDouble, i.e. won't handle more than 4 exact +// decimals (as varCurrency), nor scientific notation with exponent (1.314e10) +// - this will ensure that any incoming JSON will converted back with its exact +// textual representation, without digit truncation due to limited precision +// - any non valid number is returned as varString +// - is used e.g. by GetVariantFromJSON() to guess the destination variant type +// - warning: supplied JSON is expected to be not nil +function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): cardinal; + +/// low-level function to set a numerical variant from an unescaped JSON number +// - returns TRUE if TextToVariantNumberType/TextToVariantNumberTypeNoDouble(JSON) +// identified it as a number and set Value to the corresponding content +// - returns FALSE if JSON is a string, or null/true/false +function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; + AllowVarDouble: boolean): boolean; + +/// convert the next CSV item from an UTF-8 encoded text buffer +// into a variant number or RawUTF8 varString +// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant +// - is a wrapper around GetNextItem() + TextToVariant() +function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; + Sep: AnsiChar= ','; AllowDouble: boolean=true): boolean; + +/// retrieve a variant value from a JSON buffer as per RFC 8259, RFC 7159, RFC 7158 +// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) +// - will instantiate either an Integer, Int64, currency, double or string value +// (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except TryCustomVariants points to some options +// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or +// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some +// extended (e.g. BSON) syntax +// - warning: the JSON buffer will be modified in-place during process - use +// a temporary copy or the overloaded functions with RawUTF8 parameter +// if you need to access it later +procedure JSONToVariantInPlace(var Value: Variant; JSON: PUTF8Char; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; + AllowDouble: boolean=false); + +/// retrieve a variant value from a JSON UTF-8 text as per RFC 8259, RFC 7159, RFC 7158 +// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) +// - will instantiate either an Integer, Int64, currency, double or string value +// (as RawUTF8), guessing the best numeric type according to the textual content, +// and string in all other cases, except TryCustomVariants points to some options +// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or +// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some +// extended (e.g. BSON) syntax +// - this overloaded procedure will make a temporary copy before JSON parsing +// and return the variant as result +function JSONToVariant(const JSON: RawUTF8; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; + AllowDouble: boolean=false): variant; + +/// convert an UTF-8 encoded text buffer into a variant number or RawUTF8 varString +// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant +procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; + out aDest: variant); + +/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString +procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); overload; + +/// convert an UTF-8 encoded string into a variant RawUTF8 varString +procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); overload; + +/// convert a FormatUTF8() UTF-8 encoded string into a variant RawUTF8 varString +procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant); + +/// convert an UTF-8 encoded string into a variant RawUTF8 varString +function RawUTF8ToVariant(const Txt: RawUTF8): variant; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString +// - this overloaded version expects a destination variant type (e.g. varString +// varOleStr / varUString) - if the type is not handled, will raise an +// EVariantTypeCastError +procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; + ExpectedValueType: cardinal); overload; + +/// convert an open array (const Args: array of const) argument to a variant +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +procedure VarRecToVariant(const V: TVarRec; var result: variant); overload; + +/// convert an open array (const Args: array of const) argument to a variant +// - note that, due to a Delphi compiler limitation, cardinal values should be +// type-casted to Int64() (otherwise the integer mapped value will be converted) +function VarRecToVariant(const V: TVarRec): variant; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// convert a variant to an open array (const Args: array of const) argument +// - will always map to a vtVariant kind of argument +procedure VariantToVarRec(const V: variant; var result: TVarRec); + {$ifdef HASINLINE}inline;{$endif} + +/// convert a dynamic array of variants into its JSON serialization +// - will use a TDocVariantData temporary storage +function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; + +/// convert a JSON array into a dynamic array of variants +// - will use a TDocVariantData temporary storage +function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; + +/// convert an open array list into a dynamic array of variants +// - will use a TDocVariantData temporary storage +function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; + +type + /// pointer to a TDocVariant storage + // - since variants may be stored by reference (i.e. as varByRef), it may + // be a good idea to use such a pointer via DocVariantData(aVariant)^ or + // _Safe(aVariant)^ instead of TDocVariantData(aVariant), + // if you are not sure how aVariant was allocated (may be not _Obj/_Json) + PDocVariantData = ^TDocVariantData; + + /// a custom variant type used to store any JSON/BSON document-based content + // - i.e. name/value pairs for objects, or an array of values (including + // nested documents), stored in a TDocVariantData memory structure + // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or + // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants + // - property access may be done via late-binding - with some restrictions + // for older versions of FPC, e.g. allowing to write: + // ! TDocVariant.NewFast(aVariant); + // ! aVariant.Name := 'John'; + // ! aVariant.Age := 35; + // ! writeln(aVariant.Name,' is ',aVariant.Age,' years old'); + // - it also supports a small set of pseudo-properties or pseudo-methods: + // ! aVariant._Count = DocVariantData(aVariant).Count + // ! aVariant._Kind = ord(DocVariantData(aVariant).Kind) + // ! aVariant._JSON = DocVariantData(aVariant).JSON + // ! aVariant._(i) = DocVariantData(aVariant).Value[i] + // ! aVariant.Value(i) = DocVariantData(aVariant).Value[i] + // ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName] + // ! aVariant.Name(i) = DocVariantData(aVariant).Name[i] + // ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem) + // ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem) + // ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue) + // ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0 + // ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i) + // ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName) + // ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName) + // - it features direct JSON serialization/unserialization, e.g.: + // ! assert(_Json('["one",2,3]')._JSON='["one",2,3]'); + // - it features direct trans-typing into a string encoded as JSON, e.g.: + // ! assert(_Json('["one",2,3]')='["one",2,3]'); + TDocVariant = class(TSynInvokeableVariantType) + protected + /// name and values interning are shared among all TDocVariantData instances + fInternNames, fInternValues: TRawUTF8Interning; + /// fast getter/setter implementation + function IntGet(var Dest: TVarData; const Instance: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; override; + function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; + public + /// initialize a variant instance to store some document-based content + // - by default, every internal value will be copied, so access of nested + // properties can be slow - if you expect the data to be read-only or not + // propagated into another place, set aOptions=[dvoValueCopiedByReference] + // will increase the process speed a lot + class procedure New(out aValue: variant; + aOptions: TDocVariantOptions=[]); overload; + {$ifdef HASINLINE}inline;{$endif} + /// initialize a variant instance to store per-reference document-based content + // - same as New(aValue,JSON_OPTIONS[true]); + // - to be used e.g. as + // !var v: variant; + // !begin + // ! TDocVariant.NewFast(v); + // ! ... + class procedure NewFast(out aValue: variant); overload; + {$ifdef HASINLINE}inline;{$endif} + /// ensure a variant is a TDocVariant instance + // - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true] + class procedure IsOfTypeOrNewFast(var aValue: variant); + /// initialize several variant instances to store document-based content + // - replace several calls to TDocVariantData.InitFast + // - to be used e.g. as + // !var v1,v2,v3: TDocVariantData; + // !begin + // ! TDocVariant.NewFast([@v1,@v2,@v3]); + // ! ... + class procedure NewFast(const aValues: array of PDocVariantData); overload; + /// initialize a variant instance to store some document-based content + // - you can use this function to create a variant, which can be nested into + // another document, e.g.: + // ! aVariant := TDocVariant.New; + // ! aVariant.id := 10; + // - by default, every internal value will be copied, so access of nested + // properties can be slow - if you expect the data to be read-only or not + // propagated into another place, set Options=[dvoValueCopiedByReference] + // will increase the process speed a lot + // - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast() + // functions or TDocVariant.NewFast() + class function New(Options: TDocVariantOptions=[]): variant; overload; + {$ifdef HASINLINE}inline;{$endif} + /// initialize a variant instance to store some document-based object content + // - object will be initialized with data supplied two by two, as Name,Value + // pairs, e.g. + // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); + // which is the same as: + // ! TDocVariant.New(aVariant); + // ! TDocVariantData(aVariant).AddValue('name','John'); + // ! TDocVariantData(aVariant).AddValue('year',1972); + // - by default, every internal value will be copied, so access of nested + // properties can be slow - if you expect the data to be read-only or not + // propagated into another place, set Options=[dvoValueCopiedByReference] + // will increase the process speed a lot + // - in practice, you should better use the function _Obj() which is a + // wrapper around this class method + class function NewObject(const NameValuePairs: array of const; + Options: TDocVariantOptions=[]): variant; + /// initialize a variant instance to store some document-based array content + // - array will be initialized with data supplied as parameters, e.g. + // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); + // which is the same as: + // ! TDocVariant.New(aVariant); + // ! TDocVariantData(aVariant).AddItem('one'); + // ! TDocVariantData(aVariant).AddItem(2); + // ! TDocVariantData(aVariant).AddItem(3.0); + // - by default, every internal value will be copied, so access of nested + // properties can be slow - if you expect the data to be read-only or not + // propagated into another place, set aOptions=[dvoValueCopiedByReference] + // will increase the process speed a lot + // - in practice, you should better use the function _Arr() which is a + // wrapper around this class method + class function NewArray(const Items: array of const; + Options: TDocVariantOptions=[]): variant; overload; + /// initialize a variant instance to store some document-based array content + // - array will be initialized with data supplied dynamic array of variants + class function NewArray(const Items: TVariantDynArray; + Options: TDocVariantOptions=[]): variant; overload; + /// initialize a variant instance to store some document-based object content + // from a supplied (extended) JSON content + // - in addition to the JSON RFC specification strict mode, this method will + // handle some BSON-like extensions, e.g. unquoted field names + // - a private copy of the incoming JSON buffer will be used, then + // it will call the TDocVariantData.InitJSONInPlace() method + // - to be used e.g. as: + // ! var V: variant; + // ! begin + // ! V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}'); + // ! assert(V.id=10); + // ! assert(V.doc.name='John'); + // ! assert(V.doc.birthYear=1972); + // ! // and also some pseudo-properties: + // ! assert(V._count=2); + // ! assert(V.doc._kind=ord(dvObject)); + // - or with a JSON array: + // ! V := TDocVariant.NewJSON('["one",2,3]'); + // ! assert(V._kind=ord(dvArray)); + // ! for i := 0 to V._count-1 do + // ! writeln(V._(i)); + // - by default, every internal value will be copied, so access of nested + // properties can be slow - if you expect the data to be read-only or not + // propagated into another place, add dvoValueCopiedByReference in Options + // will increase the process speed a lot + // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency + // - in practice, you should better use the function _Json()/_JsonFast() + // which are handy wrappers around this class method + class function NewJSON(const JSON: RawUTF8; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; + {$ifdef HASINLINE}inline;{$endif} + /// initialize a variant instance to store some document-based object content + // from a supplied existing TDocVariant instance + // - use it on a value returned as varByRef (e.g. by _() pseudo-method), + // to ensure the returned variant will behave as a stand-alone value + // - for instance, the following: + // ! oSeasons := TDocVariant.NewUnique(o.Seasons); + // is the same as: + // ! oSeasons := o.Seasons; + // ! _Unique(oSeasons); + // or even: + // ! oSeasons := _Copy(o.Seasons); + class function NewUnique(const SourceDocVariant: variant; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; + {$ifdef HASINLINE}inline;{$endif} + /// will return the unique element of a TDocVariant array or a default + // - if the value is a dvArray with one single item, it will this value + // - if the value is not a TDocVariant nor a dvArray with one single item, + // it wil return the default value + class procedure GetSingleOrDefault(const docVariantArray, default: variant; + var result: variant); + + /// finalize the stored information + destructor Destroy; override; + /// used by dvoInternNames for string interning of all Names[] values + function InternNames: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} + /// used by dvoInternValues for string interning of all RawUTF8 Values[] + function InternValues: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} + // this implementation will write the content as JSON object or array + procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override; + /// will check if the value is an array, and return the number of items + // - if the document is an array, will return the items count (0 meaning + // void array) - used e.g. by TSynMustacheContextVariant + // - this overridden method will implement it for dvArray instance kind + function IterateCount(const V: TVarData): integer; override; + /// allow to loop over an array document + // - Index should be in 0..IterateCount-1 range + // - this default implementation will do handle dvArray instance kind + procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override; + /// low-level callback to access internal pseudo-methods + // - mainly the _(Index: integer): variant method to retrieve an item + // if the document is an array + function DoFunction(var Dest: TVarData; const V: TVarData; + const Name: string; const Arguments: TVarDataArray): Boolean; override; + /// low-level callback to clear the content + procedure Clear(var V: TVarData); override; + /// low-level callback to copy two variant content + // - such copy will by default be done by-value, for safety + // - if you are sure you will use the variants as read-only, you can set + // the dvoValueCopiedByReference Option to use faster by-reference copy + procedure Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); override; + /// copy two variant content by value + // - overridden method since instance may use a by-reference copy pattern + procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override; + /// handle type conversion + // - only types processed by now are string/OleStr/UnicodeString/date + procedure Cast(var Dest: TVarData; const Source: TVarData); override; + /// handle type conversion + // - only types processed by now are string/OleStr/UnicodeString/date + procedure CastTo(var Dest: TVarData; const Source: TVarData; + const AVarType: TVarType); override; + /// compare two variant values + // - it uses case-sensitive text comparison of the JSON representation + // of each variant (including TDocVariant instances) + procedure Compare(const Left, Right: TVarData; + var Relationship: TVarCompareResult); override; + end; + + /// define the TDocVariant storage layout + // - if it has one or more named properties, it is a dvObject + // - if it has no name property, it is a dvArray + TDocVariantKind = (dvUndefined, dvObject, dvArray); + + /// method used by TDocVariantData.ReduceAsArray to filter each object + // - should return TRUE if the item match the expectations + TOnReducePerItem = function(Item: PDocVariantData): boolean of object; + + /// method used by TDocVariantData.ReduceAsArray to filter each object + // - should return TRUE if the item match the expectations + TOnReducePerValue = function(const Value: variant): boolean of object; + + {$A-} { packet object not allowed since Delphi 2009 :( } + /// memory structure used for TDocVariant storage of any JSON/BSON + // document-based content as variant + // - i.e. name/value pairs for objects, or an array of values (including + // nested documents) + // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or + // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants + // - you can transtype such an allocated variant into TDocVariantData + // to access directly its internals (like Count or Values[]/Names[]): + // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]); + // ! aVariantObject := _ObjFast(['name','John','year',1972]); + // ! with _Safe(aVariantObject)^ do + // ! for i := 0 to Count-1 do + // ! writeln(Names[i],'=',Values[i]); // for an object + // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]); + // ! aVariantArray := _JsonFast('["one",2,3.0]'); + // ! with _Safe(aVariantArray)^ do + // ! for i := 0 to Count-1 do + // ! writeln(Values[i]); // for an array + // - use "with _Safe(...)^ do" and not "with TDocVariantData(...) do" as the + // former will handle internal variant redirection (varByRef), e.g. from late + // binding or assigned another TDocVariant + // - Delphi "object" is buggy on stack -> also defined as record with methods + {$ifdef USERECORDWITHMETHODS}TDocVariantData = record + {$else}TDocVariantData = object {$endif} + private + VType: TVarType; + VOptions: TDocVariantOptions; + (* this structure uses all TVarData available space: no filler needed! + {$HINTS OFF} // does not complain if Filler is declared but never used + Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(TDocVariantOptions)- + SizeOf(TDocVariantKind)-SizeOf(TRawUTF8DynArray)-SizeOf(TVariantDynArray)- + SizeOf(integer)] of byte; + {$HINTS ON} *) + VName: TRawUTF8DynArray; + VValue: TVariantDynArray; + VCount: integer; + // retrieve the value as varByRef + function GetValueOrItem(const aNameOrIndex: variant): variant; + procedure SetValueOrItem(const aNameOrIndex, aValue: variant); + function GetKind: TDocVariantKind; {$ifdef HASINLINE}inline;{$endif} + procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array + {$ifdef HASINLINE}inline;{$endif} + procedure SetCapacity(aValue: integer); + function GetCapacity: integer; + {$ifdef HASINLINE}inline;{$endif} + // implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties + function GetOrAddIndexByName(const aName: RawUTF8): integer; + {$ifdef HASINLINE}inline;{$endif} + function GetOrAddPVariantByName(const aName: RawUTF8): PVariant; + {$ifdef HASINLINE}inline;{$endif} + function GetPVariantByName(const aName: RawUTF8): PVariant; + function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; + procedure SetRawUTF8ByName(const aName, aValue: RawUTF8); + function GetStringByName(const aName: RawUTF8): string; + procedure SetStringByName(const aName: RawUTF8; const aValue: string); + function GetInt64ByName(const aName: RawUTF8): Int64; + procedure SetInt64ByName(const aName: RawUTF8; const aValue: Int64); + function GetBooleanByName(const aName: RawUTF8): Boolean; + procedure SetBooleanByName(const aName: RawUTF8; aValue: Boolean); + function GetDoubleByName(const aName: RawUTF8): Double; + procedure SetDoubleByName(const aName: RawUTF8; const aValue: Double); + function GetDocVariantExistingByName(const aName: RawUTF8; + aNotMatchingKind: TDocVariantKind): PDocVariantData; + function GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; + function GetDocVariantOrAddByName(const aName: RawUTF8; + aKind: TDocVariantKind): PDocVariantData; + function GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; + function GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; + function GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; + function GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; + public + /// initialize a TDocVariantData to store some document-based content + // - can be used with a stack-allocated TDocVariantData variable: + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.Init; + // ! Doc.AddValue('name','John'); + // ! assert(Doc.Value['name']='John'); + // ! assert(variant(Doc).name='John'); + // !end; + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure Init(aOptions: TDocVariantOptions=[]; aKind: TDocVariantKind=dvUndefined); + /// initialize a TDocVariantData to store per-reference document-based content + // - same as Doc.Init(JSON_OPTIONS[true]); + // - can be used with a stack-allocated TDocVariantData variable: + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.InitFast; + // ! Doc.AddValue('name','John'); + // ! assert(Doc.Value['name']='John'); + // ! assert(variant(Doc).name='John'); + // !end; + // - see also TDocVariant.NewFast() if you want to initialize several + // TDocVariantData variable instances at once + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitFast; overload; + /// initialize a TDocVariantData to store per-reference document-based content + // - this overloaded method allows to specify an estimation of how many + // properties or items this aKind document would contain + procedure InitFast(InitialCapacity: integer; aKind: TDocVariantKind); overload; + /// initialize a TDocVariantData to store document-based object content + // - object will be initialized with data supplied two by two, as Name,Value + // pairs, e.g. + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.InitObject(['name','John','year',1972]); + // which is the same as: + // ! var Doc: TDocVariantData; + // !begin + // ! Doc.Init; + // ! Doc.AddValue('name','John'); + // ! Doc.AddValue('year',1972); + // - this method is called e.g. by _Obj() and _ObjFast() global functions + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitObject(const NameValuePairs: array of const; + aOptions: TDocVariantOptions=[]); + /// initialize a variant instance to store some document-based array content + // - array will be initialized with data supplied as parameters, e.g. + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.InitArray(['one',2,3.0]); + // ! assert(Doc.Count=3); + // !end; + // which is the same as: + // ! var Doc: TDocVariantData; + // ! i: integer; + // !begin + // ! Doc.Init; + // ! Doc.AddItem('one'); + // ! Doc.AddItem(2); + // ! Doc.AddItem(3.0); + // ! assert(Doc.Count=3); + // ! for i := 0 to Doc.Count-1 do + // ! writeln(Doc.Value[i]); + // !end; + // - this method is called e.g. by _Arr() and _ArrFast() global functions + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitArray(const Items: array of const; + aOptions: TDocVariantOptions=[]); + /// initialize a variant instance to store some document-based array content + // - array will be initialized with data supplied as variant dynamic array + // - if Items is [], the variant will be set as null + // - will be almost immediate, since TVariantDynArray is reference-counted, + // unless ItemsCopiedByReference is set to FALSE + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitArrayFromVariants(const Items: TVariantDynArray; + aOptions: TDocVariantOptions=[]; ItemsCopiedByReference: boolean=true); + /// initialize a variant instance to store some RawUTF8 array content + procedure InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); overload; + /// initialize a variant instance to store some 32-bit integer array content + procedure InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); overload; + /// initialize a variant instance to store some 64-bit integer array content + procedure InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); overload; + /// initialize a variant instance to store a T*ObjArray content + // - will call internally ObjectToVariant() to make the conversion + procedure InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions; + aWriterOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); + /// initialize a variant instance to store document-based array content + // - array will be initialized from the supplied variable (which would be + // e.g. a T*ObjArray or a dynamic array), using RTTI + // - will use a temporary JSON serialization via SaveJSON() + procedure InitFromTypeInfo(const aValue; aTypeInfo: pointer; + aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); + /// initialize a variant instance to store some document-based object content + // - object will be initialized with names and values supplied as dynamic arrays + // - if aNames and aValues are [] or do have matching sizes, the variant + // will be set as null + // - will be almost immediate, since Names and Values are reference-counted + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitObjectFromVariants(const aNames: TRawUTF8DynArray; + const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]); + /// initialize a variant instance to store a document-based object with a + // single property + // - the supplied path could be 'Main.Second.Third', to create nested + // objects, e.g. {"Main":{"Second":{"Third":value}}} + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; + aOptions: TDocVariantOptions=[]); + /// initialize a variant instance to store some document-based object content + // from a supplied JSON array or JSON object content + // - warning: the incoming JSON buffer will be modified in-place: so you should + // make a private copy before running this method, e.g. using TSynTempBuffer + // - this method is called e.g. by _JsonFmt() _JsonFastFmt() global functions + // with a temporary JSON buffer content created from a set of parameters + // - if you call Init*() methods in a row, ensure you call Clear in-between + function InitJSONInPlace(JSON: PUTF8Char; + aOptions: TDocVariantOptions=[]; aEndOfObject: PUTF8Char=nil): PUTF8Char; + /// initialize a variant instance to store some document-based object content + // from a supplied JSON array of JSON object content + // - a private copy of the incoming JSON buffer will be used, then + // it will call the other overloaded InitJSONInPlace() method + // - this method is called e.g. by _Json() and _JsonFast() global functions + // - if you call Init*() methods in a row, ensure you call Clear in-between + function InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions=[]): boolean; + /// initialize a variant instance to store some document-based object content + // from a JSON array of JSON object content, stored in a file + // - any kind of file encoding will be handled, via AnyTextFileToRawUTF8() + // - you can optionally remove any comment from the file content + // - if you call Init*() methods in a row, ensure you call Clear in-between + function InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions=[]; + RemoveComments: boolean=false): boolean; + /// ensure a document-based variant instance will have one unique options set + // - this will create a copy of the supplied TDocVariant instance, forcing + // all nested events to have the same set of Options + // - you can use this function to ensure that all internal properties of this + // variant will be copied e.g. per-reference (if you set JSON_OPTIONS[false]) + // or per-value (if you set JSON_OPTIONS[false]) whatever options the nested + // objects or arrays were created with + // - will raise an EDocVariant if the supplied variant is not a TDocVariant + // - you may rather use _Unique() or _UniqueFast() wrappers if you want to + // ensure that a TDocVariant instance is unique + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions); + /// initialize a variant instance to store some document-based object content + // from a supplied CSV UTF-8 encoded text + // - the supplied content may have been generated by ToTextPairs() method + // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; + NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; + /// initialize a variant instance to store some document-based object content + // from a supplied CSV UTF-8 encoded text + // - the supplied content may have been generated by ToTextPairs() method + // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled + // - if you call Init*() methods in a row, ensure you call Clear in-between + procedure InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; + NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; + {$ifdef HASINLINE}inline;{$endif} + + /// to be called before any Init*() method call, when a previous Init*() + // has already be performed on the same instance, to avoid memory leaks + // - for instance: + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.InitArray(['one',2,3.0]); // no need of any Doc.Clear here + // ! assert(Doc.Count=3); + // ! Doc.Clear; // to release memory before following InitObject() + // ! Doc.InitObject(['name','John','year',1972]); + // !end; + // - implemented as just a wrapper around DocVariantType.Clear() + procedure Clear; + /// delete all internal stored values + // - like Clear + Init() with the same options + // - will reset Kind to dvUndefined + procedure Reset; + /// fill all Values[] with #0, then delete all values + // - could be used to specifically remove sensitive information from memory + procedure FillZero; + /// low-level method to force a number of items + // - could be used to fast add items to the internal Values[]/Names[] arrays + // - just set protected VCount field, do not resize the arrays: caller + // should ensure that Capacity is big enough + procedure SetCount(aCount: integer); {$ifdef HASINLINE}inline;{$endif} + /// low-level method called internally to reserve place for new values + // - returns the index of the newly created item in Values[]/Names[] arrays + // - you should not have to use it, unless you want to add some items + // directly within the Values[]/Names[] arrays, using e.g. + // InitFast(InitialCapacity) to initialize the document + // - if aName='', append a dvArray item, otherwise append a dvObject field + // - warning: FPC optimizer is confused by Values[InternalAdd(name)] so + // you should call InternalAdd() in an explicit previous step + function InternalAdd(const aName: RawUTF8): integer; + + /// save a document as UTF-8 encoded JSON + // - will write either a JSON object or array, depending of the internal + // layout of this instance (i.e. Kind property value) + // - will write 'null' if Kind is dvUndefined + // - implemented as just a wrapper around VariantSaveJSON() + function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; + Format: TTextWriterJSONFormat=jsonCompact): RawUTF8; + /// save an array of objects as UTF-8 encoded non expanded layout JSON + // - returned content would be a JSON object in mORMot's TSQLTable non + // expanded format, with reduced JSON size, i.e. + // $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']} + // - will write '' if Kind is dvUndefined or dvObject + // - will raise an exception if the array document is not an array of + // objects with identical field names + function ToNonExpandedJSON: RawUTF8; + /// save a document as an array of UTF-8 encoded JSON + // - will expect the document to be a dvArray - otherwise, will raise a + // EDocVariant exception + // - will use VariantToUTF8() to populate the result array: as a consequence, + // any nested custom variant types (e.g. TDocVariant) will be stored as JSON + procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload; + /// save a document as an array of UTF-8 encoded JSON + // - will expect the document to be a dvArray - otherwise, will raise a + // EDocVariant exception + // - will use VariantToUTF8() to populate the result array: as a consequence, + // any nested custom variant types (e.g. TDocVariant) will be stored as JSON + function ToRawUTF8DynArray: TRawUTF8DynArray; overload; + {$ifdef HASINLINE}inline;{$endif} + /// save a document as an CSV of UTF-8 encoded JSON + // - will expect the document to be a dvArray - otherwise, will raise a + // EDocVariant exception + // - will use VariantToUTF8() to populate the result array: as a consequence, + // any nested custom variant types (e.g. TDocVariant) will be stored as JSON + function ToCSV(const Separator: RawUTF8=','): RawUTF8; + /// save a document as UTF-8 encoded Name=Value pairs + // - will follow by default the .INI format, but you can specify your + // own expected layout + procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='='; + const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape); + /// save a document as UTF-8 encoded Name=Value pairs + // - will follow by default the .INI format, but you can specify your + // own expected layout + function ToTextPairs(const NameValueSep: RawUTF8='='; + const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8; + {$ifdef HASINLINE}inline;{$endif} + /// save an array document as an array of TVarRec, i.e. an array of const + // - will expect the document to be a dvArray - otherwise, will raise a + // EDocVariant exception + // - would allow to write code as such: + // ! Doc.InitArray(['one',2,3]); + // ! Doc.ToArrayOfConst(vr); + // ! s := FormatUTF8('[%,%,%]',vr,[],true); + // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters + // ! s := FormatUTF8('[?,?,?]',[],vr,true); + // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters + procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload; + /// save an array document as an array of TVarRec, i.e. an array of const + // - will expect the document to be a dvArray - otherwise, will raise a + // EDocVariant exception + // - would allow to write code as such: + // ! Doc.InitArray(['one',2,3]); + // ! s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true); + // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters + // ! s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true); + // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters + function ToArrayOfConst: TTVarRecDynArray; overload; + {$ifdef HASINLINE}inline;{$endif} + /// save an object document as an URI-encoded list of parameters + // - object field names should be plain ASCII-7 RFC compatible identifiers + // (0..9a..zA..Z_.~), otherwise their values are skipped + function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; + + /// find an item index in this document from its name + // - search will follow dvoNameCaseSensitive option of this document + // - lookup the value by name for an object document, or accept an integer + // text as index for an array document + // - returns -1 if not found + function GetValueIndex(const aName: RawUTF8): integer; overload; + {$ifdef HASINLINE}inline;{$endif} + /// find an item index in this document from its name + // - lookup the value by name for an object document, or accept an integer + // text as index for an array document + // - returns -1 if not found + function GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; overload; + /// find an item in this document, and returns its value + // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty + // is not set in Options (in this case, it will return Null) + function GetValueOrRaiseException(const aName: RawUTF8): variant; + /// find an item in this document, and returns its value + // - return the supplied default if aName is not found, or if the instance + // is not a TDocVariant + function GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant; + /// find an item in this document, and returns its value + // - return null if aName is not found, or if the instance is not a TDocVariant + function GetValueOrNull(const aName: RawUTF8): variant; + /// find an item in this document, and returns its value + // - return a cleared variant if aName is not found, or if the instance is + // not a TDocVariant + function GetValueOrEmpty(const aName: RawUTF8): variant; + /// find an item in this document, and returns its value as enumerate + // - return false if aName is not found, if the instance is not a TDocVariant, + // or if the value is not a string corresponding to the supplied enumerate + // - return true if the name has been found, and aValue stores the value + // - will call Delete() on the found entry, if aDeleteFoundEntry is true + function GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer; + out aValue; aDeleteFoundEntry: boolean=false): Boolean; + /// returns a TDocVariant object containing all properties matching the + // first characters of the supplied property name + // - returns null if the document is not a dvObject + // - will use IdemPChar(), so search would be case-insensitive + function GetValuesByStartName(const aStartName: RawUTF8; + TrimLeftStartName: boolean=false): variant; + /// returns a JSON object containing all properties matching the + // first characters of the supplied property name + // - returns null if the document is not a dvObject + // - will use IdemPChar(), so search would be case-insensitive + function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; + /// find an item in this document, and returns its value as TVarData + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true and set aValue if the name has been found + // - will use simple loop lookup to identify the name, unless aSortedCompare is + // set, and would let use a faster O(log(n)) binary search after a SortByName() + function GetVarData(const aName: RawUTF8; var aValue: TVarData; + aSortedCompare: TUTF8Compare=nil): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + /// find an item in this document, and returns its value as TVarData pointer + // - return nil if aName is not found, or if the instance is not a TDocVariant + // - return a pointer to the value if the name has been found + // - after a SortByName(aSortedCompare), could use faster binary search + function GetVarData(const aName: RawUTF8; + aSortedCompare: TUTF8Compare=nil): PVarData; overload; + /// find an item in this document, and returns its value as boolean + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found, and aValue stores the value + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using B[] property if you want simple read/write typed access + function GetAsBoolean(const aName: RawUTF8; out aValue: boolean; + aSortedCompare: TUTF8Compare=nil): Boolean; + /// find an item in this document, and returns its value as integer + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found, and aValue stores the value + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using I[] property if you want simple read/write typed access + function GetAsInteger(const aName: RawUTF8; out aValue: integer; + aSortedCompare: TUTF8Compare=nil): Boolean; + /// find an item in this document, and returns its value as integer + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found, and aValue stores the value + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using I[] property if you want simple read/write typed access + function GetAsInt64(const aName: RawUTF8; out aValue: Int64; + aSortedCompare: TUTF8Compare=nil): Boolean; + /// find an item in this document, and returns its value as floating point + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found, and aValue stores the value + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using D[] property if you want simple read/write typed access + function GetAsDouble(const aName: RawUTF8; out aValue: double; + aSortedCompare: TUTF8Compare=nil): Boolean; + /// find an item in this document, and returns its value as RawUTF8 + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found, and aValue stores the value + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using U[] property if you want simple read/write typed access + function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; + aSortedCompare: TUTF8Compare=nil): Boolean; + /// find an item in this document, and returns its value as a TDocVariantData + // - return false if aName is not found, or if the instance is not a TDocVariant + // - return true if the name has been found and points to a TDocVariant: + // then aValue stores a pointer to the value + // - after a SortByName(aSortedCompare), could use faster binary search + function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; + aSortedCompare: TUTF8Compare=nil): boolean; overload; + /// find an item in this document, and returns its value as a TDocVariantData + // - returns a void TDocVariant if aName is not a document + // - after a SortByName(aSortedCompare), could use faster binary search + // - consider using O[] or A[] properties if you want simple read-only + // access, or O_[] or A_[] properties if you want the ability to add + // a missing object or array in the document + function GetAsDocVariantSafe(const aName: RawUTF8; + aSortedCompare: TUTF8Compare=nil): PDocVariantData; + /// find an item in this document, and returns pointer to its value + // - return false if aName is not found + // - return true if the name has been found: then aValue stores a pointer + // to the value + // - after a SortByName(aSortedCompare), could use faster binary search + function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; + aSortedCompare: TUTF8Compare=nil): boolean; overload; {$ifdef HASINLINE}inline;{$endif} + /// find an item in this document, and returns pointer to its value + // - lookup the value by aName/aNameLen for an object document, or accept + // an integer text as index for an array document + // - return nil if aName is not found, or if the instance is not a TDocVariant + // - return a pointer to the stored variant, if the name has been found + function GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; overload; + {$ifdef HASINLINE}inline;{$endif} + /// retrieve a value, given its path + // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' + // - it will return Unassigned if the path does match the supplied aPath + function GetValueByPath(const aPath: RawUTF8): variant; overload; + /// retrieve a value, given its path + // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' + // - it will return FALSE if the path does not match the supplied aPath + // - returns TRUE and set the found value in aValue + function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload; + /// retrieve a value, given its path + // - path is defined as a list of names, e.g. ['doc','glossary','title'] + // - it will return Unassigned if the path does not match the data + // - this method will only handle nested TDocVariant values: use the + // slightly slower GetValueByPath() overloaded method, if any nested object + // may be of another type (e.g. a TBSONVariant) + function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload; + /// retrieve a reference to a value, given its path + // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' + // - if the supplied aPath does not match any object, it will return nil + // - if aPath is found, returns a pointer to the corresponding value + function GetPVariantByPath(const aPath: RawUTF8): PVariant; + /// retrieve a reference to a TDocVariant, given its path + // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' + // - if the supplied aPath does not match any object, it will return false + // - if aPath stores a valid TDocVariant, returns true and a pointer to it + function GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean; + /// retrieve a dvObject in the dvArray, from a property value + // - {aPropName:aPropValue} will be searched within the stored array, + // and the corresponding item will be copied into Dest, on match + // - returns FALSE if no match is found, TRUE if found and copied + // - create a copy of the variant by default, unless DestByRef is TRUE + // - will call VariantEquals() for value comparison + function GetItemByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean; + /// retrieve a reference to a dvObject in the dvArray, from a property value + // - {aPropName:aPropValue} will be searched within the stored array, + // and the corresponding item will be copied into Dest, on match + // - returns FALSE if no match is found, TRUE if found and copied by reference + function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; + /// find an item in this document, and returns its value + // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty + // is not set in Options (in this case, it will return Null) + // - create a copy of the variant by default, unless DestByRef is TRUE + function RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer; + aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; overload; + /// retrieve an item in this document from its index, and returns its value + // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 + // range and dvoReturnNullForUnknownProperty is set in Options + // - create a copy of the variant by default, unless DestByRef is TRUE + procedure RetrieveValueOrRaiseException(Index: integer; + var Dest: variant; DestByRef: boolean); overload; + /// retrieve an item in this document from its index, and returns its Name + // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 + // range and dvoReturnNullForUnknownProperty is set in Options + procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8); + /// set an item in this document from its index + // - raise an EDocVariant if the supplied Index is not in 0..Count-1 range + procedure SetValueOrRaiseException(Index: integer; const NewValue: variant); + + /// add a value in this document + // - if aName is set, if dvoCheckForDuplicatedNames option is set, any + // existing duplicated aName will raise an EDocVariant; if instance's + // kind is dvArray and aName is defined, it will raise an EDocVariant + // - aName may be '' e.g. if you want to store an array: in this case, + // dvoCheckForDuplicatedNames option should not be set; if instance's Kind + // is dvObject, it will raise an EDocVariant exception + // - if aValueOwned is true, then the supplied aValue will be assigned to + // the internal values - by default, it will use SetVariantByValue() + // - you can therefore write e.g.: + // ! TDocVariant.New(aVariant); + // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); + // ! TDocVariantData(aVariant).AddValue('name','John'); + // ! Assert(TDocVariantData(aVariant).Kind=dvObject); + // - returns the index of the corresponding newly added value + function AddValue(const aName: RawUTF8; const aValue: variant; + aValueOwned: boolean=false): integer; overload; + /// add a value in this document + // - overloaded function accepting a UTF-8 encoded buffer for the name + function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant; + aValueOwned: boolean=false): integer; overload; + /// add a value in this document, or update an existing entry + // - if instance's Kind is dvArray, it will raise an EDocVariant exception + // - any existing Name would be updated with the new Value, unless + // OnlyAddMissing is set to TRUE, in which case existing values would remain + // - returns the index of the corresponding value, which may be just added + function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant; + wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer; + /// add a value in this document, from its text representation + // - this function expects a UTF-8 text for the value, which would be + // converted to a variant number, if possible (as varInt/varInt64/varCurrency + // and/or as varDouble is AllowVarDouble is set) + // - if Update=TRUE, will set the property, even if it is existing + function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false; + AllowVarDouble: boolean=false): integer; + /// add some properties to a TDocVariantData dvObject + // - data is supplied two by two, as Name,Value pairs + // - caller should ensure that Kind=dvObject, otherwise it won't do anything + // - any existing Name would be duplicated + procedure AddNameValuesToObject(const NameValuePairs: array of const); + /// merge some properties to a TDocVariantData dvObject + // - data is supplied two by two, as Name,Value pairs + // - caller should ensure that Kind=dvObject, otherwise it won't do anything + // - any existing Name would be updated with the new Value + procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const); + /// merge some TDocVariantData dvObject properties to a TDocVariantData dvObject + // - data is supplied two by two, as Name,Value pairs + // - caller should ensure that both variants have Kind=dvObject, otherwise + // it won't do anything + // - any existing Name would be updated with the new Value, unless + // OnlyAddMissing is set to TRUE, in which case existing values would remain + procedure AddOrUpdateObject(const NewValues: variant; OnlyAddMissing: boolean=false; + RecursiveUpdate: boolean=false); + /// add a value to this document, handled as array + // - if instance's Kind is dvObject, it will raise an EDocVariant exception + // - you can therefore write e.g.: + // ! TDocVariant.New(aVariant); + // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); + // ! TDocVariantData(aVariant).AddItem('one'); + // ! Assert(TDocVariantData(aVariant).Kind=dvArray); + // - returns the index of the corresponding newly added item + function AddItem(const aValue: variant): integer; + /// add a value to this document, handled as array, from its text representation + // - this function expects a UTF-8 text for the value, which would be + // converted to a variant number, if possible (as varInt/varInt64/varCurrency + // unless AllowVarDouble is set) + // - if instance's Kind is dvObject, it will raise an EDocVariant exception + // - returns the index of the corresponding newly added item + function AddItemFromText(const aValue: RawUTF8; + AllowVarDouble: boolean=false): integer; + /// add a RawUTF8 value to this document, handled as array + // - if instance's Kind is dvObject, it will raise an EDocVariant exception + // - returns the index of the corresponding newly added item + function AddItemText(const aValue: RawUTF8): integer; + /// add one or several values to this document, handled as array + // - if instance's Kind is dvObject, it will raise an EDocVariant exception + procedure AddItems(const aValue: array of const); + /// add one or several values from another document + // - supplied document should be of the same kind than the current one, + // otherwise nothing is added + procedure AddFrom(const aDocVariant: Variant); + /// add or update or on several valeus from another object + // - current document should be an object + procedure AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean=false); + /// add one or several properties, specified by path, from another object + // - path are defined as a dotted name-space, e.g. 'doc.glossary.title' + // - matching values would be added as root values, with the path as name + // - instance and supplied aSource should be a dvObject + procedure AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8); + /// delete a value/item in this document, from its index + // - return TRUE on success, FALSE if the supplied index is not correct + function Delete(Index: integer): boolean; overload; + /// delete a value/item in this document, from its name + // - return TRUE on success, FALSE if the supplied name does not exist + function Delete(const aName: RawUTF8): boolean; overload; + /// delete a value in this document, by property name match + // - {aPropName:aPropValue} will be searched within the stored array or + // object, and the corresponding item will be deleted, on match + // - returns FALSE if no match is found, TRUE if found and deleted + // - will call VariantEquals() for value comparison + function DeleteByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean): boolean; + /// delete one or several value/item in this document, from its value + // - returns the number of deleted items + // - returns 0 if the document is not a dvObject, or if no match was found + // - if the value exists several times, all occurences would be removed + // - is optimized for DeleteByValue(null) call + function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): integer; + /// delete all values matching the first characters of a property name + // - returns the number of deleted items + // - returns 0 if the document is not a dvObject, or if no match was found + // - will use IdemPChar(), so search would be case-insensitive + function DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; + /// search a property match in this document, handled as array or object + // - {aPropName:aPropValue} will be searched within the stored array or + // object, and the corresponding item index will be returned, on match + // - returns -1 if no match is found + // - will call VariantEquals() for value comparison + function SearchItemByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean): integer; overload; + /// search a property match in this document, handled as array or object + // - {aPropName:aPropValue} will be searched within the stored array or + // object, and the corresponding item index will be returned, on match + // - returns -1 if no match is found + // - will call VariantEquals() for value comparison + function SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const; + const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload; + /// search a value in this document, handled as array + // - aValue will be searched within the stored array + // and the corresponding item index will be returned, on match + // - returns -1 if no match is found + // - you could make several searches, using the StartIndex optional parameter + function SearchItemByValue(const aValue: Variant; + CaseInsensitive: boolean=false; StartIndex: integer=0): integer; + /// sort the document object values by name + // - do nothing if the document is not a dvObject + // - will follow case-insensitive order (@StrIComp) by default, but you + // can specify @StrComp as comparer function for case-sensitive ordering + // - once sorted, you can use GetVarData(..,Compare) or GetAs*(..,Compare) + // methods for much faster O(log(n)) binary search + procedure SortByName(Compare: TUTF8Compare=nil); + /// sort the document object values by value + // - work for both dvObject and dvArray documents + // - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied + procedure SortByValue(Compare: TVariantCompare = nil); + /// sort the document array values by a field of some stored objet values + // - do nothing if the document is not a dvArray, or if the items are no dvObject + // - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied + procedure SortArrayByField(const aItemPropName: RawUTF8; + aValueCompare: TVariantCompare=nil; aValueCompareReverse: boolean=false; + aNameSortedCompare: TUTF8Compare=nil); + /// reverse the order of the document object or array items + procedure Reverse; + /// create a TDocVariant object, from a selection of properties of this + // document, by property name + // - if the document is a dvObject, to reduction will be applied to all + // its properties + // - if the document is a dvArray, the reduction will be applied to each + // stored item, if it is a document + procedure Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; + out result: TDocVariantData; aDoNotAddVoidProp: boolean=false); overload; + /// create a TDocVariant object, from a selection of properties of this + // document, by property name + // - always returns a TDocVariantData, even if no property name did match + // (in this case, it is dvUndefined) + function Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; + aDoNotAddVoidProp: boolean=false): variant; overload; + /// create a TDocVariant array, from the values of a single properties of + // this document, specified by name + // - you can optionally apply an additional filter to each reduced item + procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; + OnReduce: TOnReducePerItem=nil); overload; + /// create a TDocVariant array, from the values of a single properties of + // this document, specified by name + // - always returns a TDocVariantData, even if no property name did match + // (in this case, it is dvUndefined) + // - you can optionally apply an additional filter to each reduced item + function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem=nil): variant; overload; + /// create a TDocVariant array, from the values of a single properties of + // this document, specified by name + // - this overloaded method accepts an additional filter to each reduced item + procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; + OnReduce: TOnReducePerValue); overload; + /// create a TDocVariant array, from the values of a single properties of + // this document, specified by name + // - always returns a TDocVariantData, even if no property name did match + // (in this case, it is dvUndefined) + // - this overloaded method accepts an additional filter to each reduced item + function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; overload; + /// rename some properties of a TDocVariant object + // - returns the number of property names modified + function Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; + /// map {"obj.prop1"..,"obj.prop2":..} into {"obj":{"prop1":..,"prop2":...}} + // - the supplied aObjectPropName should match the incoming dotted value + // of all properties (e.g. 'obj' for "obj.prop1") + // - if any of the incoming property is not of "obj.prop#" form, the + // whole process would be ignored + // - return FALSE if the TDocVariant did not change + // - return TRUE if the TDocVariant has been flattened + function FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; + + /// how this document will behave + // - those options are set when creating the instance + // - dvoArray and dvoObject are not options, but define the document Kind, + // so those items are ignored when assigned to this property + property Options: TDocVariantOptions read VOptions write SetOptions; + /// returns the document internal layout + // - just after initialization, it will return dvUndefined + // - most of the time, you will add named values with AddValue() or by + // setting the variant properties: it will return dvObject + // - but is you use AddItem(), values will have no associated names: the + // document will be a dvArray + // - value computed from the dvoArray and dvoObject presence in Options + property Kind: TDocVariantKind read GetKind; + /// return the custom variant type identifier, i.e. DocVariantType.VarType + property VarType: word read VType; + /// number of items stored in this document + // - is 0 if Kind=dvUndefined + // - is the number of name/value pairs for Kind=dvObject + // - is the number of items for Kind=dvArray + property Count: integer read VCount; + /// the current capacity of this document + // - allow direct access to VValue[] length + property Capacity: integer read GetCapacity write SetCapacity; + /// direct acces to the low-level internal array of values + // - transtyping a variant and direct access to TDocVariantData is the + // fastest way of accessing all properties of a given dvObject: + // ! with TDocVariantData(aVariantObject) do + // ! for i := 0 to Count-1 do + // ! writeln(Names[i],'=',Values[i]); + // - or to access a dvArray items (e.g. a MongoDB collection): + // ! with TDocVariantData(aVariantArray) do + // ! for i := 0 to Count-1 do + // ! writeln(Values[i]); + property Values: TVariantDynArray read VValue; + /// direct acces to the low-level internal array of names + // - is void (nil) if Kind is not dvObject + // - transtyping a variant and direct access to TDocVariantData is the + // fastest way of accessing all properties of a given dvObject: + // ! with TDocVariantData(aVariantObject) do + // ! for i := 0 to Count-1 do + // ! writeln(Names[i],'=',Values[i]); + property Names: TRawUTF8DynArray read VName; + /// find an item in this document, and returns its value + // - raise an EDocVariant if aNameOrIndex is neither an integer nor a string + // - raise an EDocVariant if Kind is dvArray and aNameOrIndex is a string + // or if Kind is dvObject and aNameOrIndex is an integer + // - raise an EDocVariant if Kind is dvObject and if aNameOrIndex is a + // string, which is not found within the object property names and + // dvoReturnNullForUnknownProperty is set in Options + // - raise an EDocVariant if Kind is dvArray and if aNameOrIndex is a + // integer, which is not within 0..Count-1 and dvoReturnNullForUnknownProperty + // is set in Options + // - so you can use directly: + // ! // for an array document: + // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); + // ! for i := 0 to TDocVariantData(aVariant).Count-1 do + // ! aValue := TDocVariantData(aVariant).Value[i]; + // ! // for an object document: + // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); + // ! assert(aVariant.Name=TDocVariantData(aVariant)['name']); + // ! assert(aVariant.year=TDocVariantData(aVariant)['year']); + // - due to the internal implementation of variant execution (somewhat + // slow _DispInvoke() function), it is a bit faster to execute: + // ! aValue := TDocVariantData(aVariant).Value['name']; + // instead of + // ! aValue := aVariant.name; + // but of course, if want to want to access the content by index (typically + // for a dvArray), using Values[] - and Names[] - properties is much faster + // than this variant-indexed pseudo-property: + // ! with TDocVariantData(aVariant) do + // ! for i := 0 to Count-1 do + // ! Writeln(Values[i]); + // is faster than: + // ! with TDocVariantData(aVariant) do + // ! for i := 0 to Count-1 do + // ! Writeln(Value[i]); + // which is faster than: + // ! for i := 0 to aVariant.Count-1 do + // ! Writeln(aVariant._(i)); + // - this property will return the value as varByRef (just like with + // variant late binding of any TDocVariant instance), so you can write: + // !var Doc: TDocVariantData; // stack-allocated variable + // !begin + // ! Doc.InitJSON('{arr:[1,2]}'); + // ! assert(Doc.Count=2); + // ! Doc.Value['arr'].Add(3); // works since Doc.Value['arr'] is varByRef + // ! writeln(Doc.ToJSON); // will write '{"arr":[1,2,3]}' + // !end; + // - if you want to access a property as a copy, i.e. to assign it to a + // variant variable which will stay alive after this TDocVariant instance + // is release, you should not use Value[] but rather + // GetValueOrRaiseException or GetValueOrNull/GetValueOrEmpty + // - see U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties for direct access + // of strong typed values + property Value[const aNameOrIndex: Variant]: Variant read GetValueOrItem + write SetValueOrItem; default; + + /// direct access to a dvObject UTF-8 stored property value from its name + // - slightly faster than the variant-based Value[] default property + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - use GetAsRawUTF8() if you want to check the availability of the field + // - U['prop'] := 'value' would add a new property, or overwrite an existing + property U[const aName: RawUTF8]: RawUTF8 read GetRawUTF8ByName write SetRawUTF8ByName; + /// direct string access to a dvObject UTF-8 stored property value from its name + // - just a wrapper around U[] property, to avoid a compilation warning when + // using plain string variables (internaly, RawUTF8 will be used for storage) + // - slightly faster than the variant-based Value[] default property + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - use GetAsRawUTF8() if you want to check the availability of the field + // - S['prop'] := 'value' would add a new property, or overwrite an existing + property S[const aName: RawUTF8]: string read GetStringByName write SetStringByName; + /// direct access to a dvObject Integer stored property value from its name + // - slightly faster than the variant-based Value[] default property + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - use GetAsInt/GetAsInt64 if you want to check the availability of the field + // - I['prop'] := 123 would add a new property, or overwrite an existing + property I[const aName: RawUTF8]: Int64 read GetInt64ByName write SetInt64ByName; + /// direct access to a dvObject Boolean stored property value from its name + // - slightly faster than the variant-based Value[] default property + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - use GetAsBoolean if you want to check the availability of the field + // - B['prop'] := true would add a new property, or overwrite an existing + property B[const aName: RawUTF8]: Boolean read GetBooleanByName write SetBooleanByName; + /// direct access to a dvObject floating-point stored property value from its name + // - slightly faster than the variant-based Value[] default property + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - use GetAsDouble if you want to check the availability of the field + // - D['prop'] := 1.23 would add a new property, or overwrite an existing + property D[const aName: RawUTF8]: Double read GetDoubleByName write SetDoubleByName; + /// direct access to a dvObject existing dvObject property from its name + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - O['prop'] would return a fake void TDocVariant if the property is not + // existing or not a dvObject, just like GetAsDocVariantSafe() + // - use O_['prop'] to force adding any missing property + property O[const aName: RawUTF8]: PDocVariantData read GetObjectExistingByName; + /// direct access or add a dvObject's dvObject property from its name + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - O_['prop'] would add a new property if there is none existing, or + // overwrite an existing property which is not a dvObject + property O_[const aName: RawUTF8]: PDocVariantData read GetObjectOrAddByName; + /// direct access to a dvObject existing dvArray property from its name + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - A['prop'] would return a fake void TDocVariant if the property is not + // existing or not a dvArray, just like GetAsDocVariantSafe() + // - use A_['prop'] to force adding any missing property + property A[const aName: RawUTF8]: PDocVariantData read GetArrayExistingByName; + /// direct access or add a dvObject's dvArray property from its name + // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options + // - A_['prop'] would add a new property if there is none existing, or + // overwrite an existing property which is not a dvArray + property A_[const aName: RawUTF8]: PDocVariantData read GetArrayOrAddByName; + /// direct access to a dvArray's TDocVariant property from its index + // - simple values may directly use Values[] dynamic array, but to access + // a TDocVariantData members, this property is safer + // - follows dvoReturnNullForUnknownProperty option to raise an exception + // - _[ndx] would return a fake void TDocVariant if aIndex is out of range, + // if the property is not existing or not a TDocVariantData (just like + // GetAsDocVariantSafe) + property _[aIndex: integer]: PDocVariantData read GetAsDocVariantByIndex; + end; + {$A+} { packet object not allowed since Delphi 2009 :( } + +var + /// the internal custom variant type used to register TDocVariant + DocVariantType: TDocVariant = nil; + /// copy of DocVariantType.VarType + // - as used by inlined functions of TDocVariantData + DocVariantVType: integer = -1; + +/// retrieve the text representation of a TDocVairnatKind +function ToText(kind: TDocVariantKind): PShortString; overload; + +/// direct access to a TDocVariantData from a given variant instance +// - return a pointer to the TDocVariantData corresponding to the variant +// instance, which may be of kind varByRef (e.g. when retrieved by late binding) +// - raise an EDocVariant exception if the instance is not a TDocVariant +// - the following direct trans-typing may fail, e.g. for varByRef value: +// ! TDocVariantData(aVarDoc.ArrayProp).Add('new item'); +// - so you can write the following: +// ! DocVariantData(aVarDoc.ArrayProp).AddItem('new item'); +function DocVariantData(const DocVariant: variant): PDocVariantData; + +const + /// constant used e.g. by _Safe() overloaded functions + // - will be in code section of the exe, so will be read-only by design + // - would have Kind=dvUndefined and Count=0, so _Safe() would return + // a valid, but void document + // - its VType is varNull, so would be viewed as a null variant + // - dvoReturnNullForUnknownProperty is defined, so that U[]/I[]... methods + // won't raise any exception about unexpected field name + DocVariantDataFake: TDocVariantData = ( + VType:1; VOptions:[dvoReturnNullForUnknownProperty]); + +/// direct access to a TDocVariantData from a given variant instance +// - return a pointer to the TDocVariantData corresponding to the variant +// instance, which may be of kind varByRef (e.g. when retrieved by late binding) +// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the +// supplied variant is not a TDocVariant instance, so could be safely used +// in a with block (use "with" moderation, of course): +// ! with _Safe(aDocVariant)^ do +// ! for ndx := 0 to Count-1 do // here Count=0 for the "fake" result +// ! writeln(Names[ndx]); +// or excluding the "with" statement, as more readable code: +// ! var dv: PDocVariantData; +// ! ndx: PtrInt; +// ! begin +// ! dv := _Safe(aDocVariant); +// ! for ndx := 0 to dv.Count-1 do // here Count=0 for the "fake" result +// ! writeln(dv.Names[ndx]); +function _Safe(const DocVariant: variant): PDocVariantData; overload; + {$ifdef FPC}inline;{$endif} // Delphi has problems inlining this :( + +/// direct access to a TDocVariantData from a given variant instance +// - return a pointer to the TDocVariantData corresponding to the variant +// instance, which may be of kind varByRef (e.g. when retrieved by late binding) +// - will check the supplied document kind, i.e. either dvObject or dvArray and +// raise a EDocVariant exception if it does not match +function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload; + +/// initialize a variant instance to store some document-based object content +// - object will be initialized with data supplied two by two, as Name,Value +// pairs, e.g. +// ! aVariant := _Obj(['name','John','year',1972]); +// or even with nested objects: +// ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]); +// - this global function is an alias to TDocVariant.NewObject() +// - by default, every internal value will be copied, so access of nested +// properties can be slow - if you expect the data to be read-only or not +// propagated into another place, set Options=[dvoValueCopiedByReference] +// or using _ObjFast() will increase the process speed a lot +function _Obj(const NameValuePairs: array of const; + Options: TDocVariantOptions=[]): variant; + +/// add some property values to a document-based object content +// - if Obj is a TDocVariant object, will add the Name/Value pairs +// - if Obj is not a TDocVariant, will create a new fast document, +// initialized with supplied the Name/Value pairs +// - this function will also ensure that ensure Obj is not stored by reference, +// but as a true TDocVariantData +procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload; + +/// add the property values of a document to a document-based object content +// - if Document is not a TDocVariant object, will do nothing +// - if Obj is a TDocVariant object, will add Document fields to its content +// - if Obj is not a TDocVariant object, Document will be copied to Obj +procedure _ObjAddProps(const Document: variant; var Obj: variant); overload; + +/// initialize a variant instance to store some document-based array content +// - array will be initialized with data supplied as parameters, e.g. +// ! aVariant := _Arr(['one',2,3.0]); +// - this global function is an alias to TDocVariant.NewArray() +// - by default, every internal value will be copied, so access of nested +// properties can be slow - if you expect the data to be read-only or not +// propagated into another place, set Options=[dvoValueCopiedByReference] +// or using _ArrFast() will increase the process speed a lot +function _Arr(const Items: array of const; + Options: TDocVariantOptions=[]): variant; + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content +// - this global function is an alias to TDocVariant.NewJSON(), and +// will return an Unassigned variant if JSON content was not correctly converted +// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency +// - object or array will be initialized from the supplied JSON content, e.g. +// ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}'); +// ! // now you can access to the properties via late binding +// ! assert(aVariant.id=10); +// ! assert(aVariant.doc.name='John'); +// ! assert(aVariant.doc.birthYear=1972); +// ! // and also some pseudo-properties: +// ! assert(aVariant._count=2); +// ! assert(aVariant.doc._kind=ord(dvObject)); +// ! // or with a JSON array: +// ! aVariant := _Json('["one",2,3]'); +// ! assert(aVariant._kind=ord(dvArray)); +// ! for i := 0 to aVariant._count-1 do +// ! writeln(aVariant._(i)); +// - in addition to the JSON RFC specification strict mode, this method will +// handle some BSON-like extensions, e.g. unquoted field names: +// ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}'); +// - if the SynMongoDB unit is used in the application, the MongoDB Shell +// syntax will also be recognized to create TBSONVariant, like +// ! new Date() ObjectId() MinKey MaxKey // +// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json +// - by default, every internal value will be copied, so access of nested +// properties can be slow - if you expect the data to be read-only or not +// propagated into another place, add dvoValueCopiedByReference in Options +// will increase the process speed a lot, or use _JsonFast() +function _Json(const JSON: RawUTF8; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content, with parameters formating +// - wrapper around the _Json(FormatUTF8(...,JSONFormat=true)) function, +// i.e. every Args[] will be inserted for each % and Params[] for each ?, +// with proper JSON escaping of string values, and writing nested _Obj() / +// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency +// _Arr() instances as expected JSON objects / arrays +// - typical use (in the context of SynMongoDB unit) could be: +// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']); +// ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]); +// ! // which are the same as: +// ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}'); +// ! // in this context: +// ! u := VariantSaveJSON(aVariant); +// ! assert(u='{"type":{"$in":["food","snack"]}}'); +// ! u := VariantSaveMongoJSON(aVariant,modMongoShell); +// ! assert(u='{type:{$in:["food","snack"]}}'); +// - by default, every internal value will be copied, so access of nested +// properties can be slow - if you expect the data to be read-only or not +// propagated into another place, add dvoValueCopiedByReference in Options +// will increase the process speed a lot, or use _JsonFast() +function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content, with parameters formating +// - this overload function will set directly a local variant variable, +// and would be used by inlined _JsonFmt/_JsonFastFmt functions +procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; + Options: TDocVariantOptions; out result: variant); overload; + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content +// - this global function is an alias to TDocVariant.NewJSON(), and +// will return TRUE if JSON content was correctly converted into a variant +// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency +// - in addition to the JSON RFC specification strict mode, this method will +// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() +// - by default, every internal value will be copied, so access of nested +// properties can be slow - if you expect the data to be read-only or not +// propagated into another place, add dvoValueCopiedByReference in Options +// will increase the process speed a lot, or use _JsonFast() +function _Json(const JSON: RawUTF8; var Value: variant; + Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload; + {$ifdef HASINLINE}inline;{$endif} + +/// initialize a variant instance to store some document-based object content +// - this global function is an handy alias to: +// ! Obj(NameValuePairs,JSON_OPTIONS[true]); +// - so all created objects and arrays will be handled by reference, for best +// speed - but you should better write on the resulting variant tree with caution +function _ObjFast(const NameValuePairs: array of const): variant; overload; + +/// initialize a variant instance to store any object as a TDocVariant +// - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions)) +function _ObjFast(aObject: TObject; + aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload; + +/// initialize a variant instance to store some document-based array content +// - this global function is an handy alias to: +// ! _Array(Items,JSON_OPTIONS[true]); +// - so all created objects and arrays will be handled by reference, for best +// speed - but you should better write on the resulting variant tree with caution +function _ArrFast(const Items: array of const): variant; overload; + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content +// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency +// - this global function is an handy alias to: +// ! _Json(JSON,JSON_OPTIONS[true]); or _Json(JSON,JSON_OPTIONS_FAST) +// so it will return an Unassigned variant if JSON content was not correct +// - so all created objects and arrays will be handled by reference, for best +// speed - but you should better write on the resulting variant tree with caution +// - in addition to the JSON RFC specification strict mode, this method will +// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() +function _JsonFast(const JSON: RawUTF8): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content, parsing any kind of float +// - use JSON_OPTIONS_FAST_FLOAT including the dvoAllowDoubleValue option +function _JsonFastFloat(const JSON: RawUTF8): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// initialize a variant instance to store some extended document-based content +// - this global function is an handy alias to: +// ! _Json(JSON,JSON_OPTIONS_FAST_EXTENDED); +function _JsonFastExt(const JSON: RawUTF8): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// initialize a variant instance to store some document-based content +// from a supplied (extended) JSON content, with parameters formating +// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency +// - this global function is an handy alias e.g. to: +// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]); +// - so all created objects and arrays will be handled by reference, for best +// speed - but you should better write on the resulting variant tree with caution +// - in addition to the JSON RFC specification strict mode, this method will +// handle some BSON-like extensions, e.g. unquoted field names or ObjectID(): +function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; + +/// ensure a document-based variant instance will have only per-value nested +// objects or array documents +// - is just a wrapper around: +// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]) +// - you can use this function to ensure that all internal properties of this +// variant will be copied per-value whatever options the nested objects or +// arrays were created with +// - for huge document with a big depth of nested objects or arrays, a full +// per-value copy may be time and resource consuming, but will be also safe +// - will raise an EDocVariant if the supplied variant is not a TDocVariant or +// a varByRef pointing to a TDocVariant +procedure _Unique(var DocVariant: variant); + +/// ensure a document-based variant instance will have only per-value nested +// objects or array documents +// - is just a wrapper around: +// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true]) +// - you can use this function to ensure that all internal properties of this +// variant will be copied per-reference whatever options the nested objects or +// arrays were created with +// - for huge document with a big depth of nested objects or arrays, it will +// first create a whole copy of the document nodes, but further assignments +// of the resulting value will be per-reference, so will be almost instant +// - will raise an EDocVariant if the supplied variant is not a TDocVariant or +// a varByRef pointing to a TDocVariant +procedure _UniqueFast(var DocVariant: variant); + +/// return a full nested copy of a document-based variant instance +// - is just a wrapper around: +// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]) +// - you can use this function to ensure that all internal properties of this +// variant will be copied per-value whatever options the nested objects or +// arrays were created with: to be used on a value returned as varByRef +// (e.g. by _() pseudo-method) +// - for huge document with a big depth of nested objects or arrays, a full +// per-value copy may be time and resource consuming, but will be also safe - +// consider using _ByRef() instead if a fast copy-by-reference is enough +// - will raise an EDocVariant if the supplied variant is not a TDocVariant or +// a varByRef pointing to a TDocVariant +function _Copy(const DocVariant: variant): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// return a full nested copy of a document-based variant instance +// - is just a wrapper around: +// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[true]) +// - you can use this function to ensure that all internal properties of this +// variant will be copied per-value whatever options the nested objects or +// arrays were created with: to be used on a value returned as varByRef +// (e.g. by _() pseudo-method) +// - for huge document with a big depth of nested objects or arrays, a full +// per-value copy may be time and resource consuming, but will be also safe - +// consider using _ByRef() instead if a fast copy-by-reference is enough +// - will raise an EDocVariant if the supplied variant is not a TDocVariant or +// a varByRef pointing to a TDocVariant +function _CopyFast(const DocVariant: variant): variant; + {$ifdef HASINLINE}inline;{$endif} + +/// copy a TDocVariant to another variable, changing the options on the fly +// - note that the content (items or properties) is copied by reference, +// so consider using _Copy() instead if you expect to safely modify its content +// - will return null if the supplied variant is not a TDocVariant +function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; overload; + +/// copy a TDocVariant to another variable, changing the options on the fly +// - note that the content (items or properties) is copied by reference, +// so consider using _Copy() instead if you expect to safely modify its content +// - will return null if the supplied variant is not a TDocVariant +procedure _ByRef(const DocVariant: variant; out Dest: variant; + Options: TDocVariantOptions); overload; + +/// convert a TDocVariantData array or a string value into a CSV +// - will call either TDocVariantData.ToCSV, or return the string +// - returns '' if the supplied value is neither a TDocVariant or a string +// - could be used e.g. to store either a JSON CSV string or a JSON array of +// strings in a settings property +function _CSV(const DocVariantOrString: variant): RawUTF8; + +/// will convert any TObject into a TDocVariant document instance +// - a slightly faster alternative to Dest := _JsonFast(ObjectToJSON(Value)) +// - this would convert the TObject by representation, using only serializable +// published properties: do not use this function to store temporary a class +// instance, but e.g. to store an object values in a NoSQL database +// - if you expect lazy-loading of a TObject, see TObjectVariant.New() +procedure ObjectToVariant(Value: TObject; out Dest: variant); overload; + {$ifdef HASINLINE}inline;{$endif} + +/// will convert any TObject into a TDocVariant document instance +// - a faster alternative to _JsonFast(ObjectToJSON(Value)) +// - if you expect lazy-loading of a TObject, see TObjectVariant.New() +function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean=false): variant; overload; + +/// will convert any TObject into a TDocVariant document instance +// - a faster alternative to _Json(ObjectToJSON(Value),Options) +// - note that the result variable should already be cleared: no VarClear() +// is done by this function +// - would be used e.g. by VarRecToVariant() function +// - if you expect lazy-loading of a TObject, see TObjectVariant.New() +procedure ObjectToVariant(Value: TObject; var result: variant; + Options: TTextWriterWriteObjectOptions); overload; + +{$endif NOVARIANTS} + + +{ ******************* process monitoring / statistics ********************** } + +type + /// the kind of value stored in a TSynMonitor / TSynMonitorUsage property + // - i.e. match TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec, + // TSynMonitorOneCount, TSynMonitorOneBytes, TSynMonitorBytesPerSec, + // TSynMonitorTotalBytes, TSynMonitorCount and TSynMonitorCount64 types as + // used to store statistic information + // - "cumulative" values would sum each process values, e.g. total elapsed + // time for SOA execution, task count or total I/O bytes + // - "immediate" (e.g. svOneBytes or smvBytesPerSec) values would be an evolving + // single value, e.g. an average value or current disk free size + // - use SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount,smvCount64] + // constant to identify the kind of value + // - TSynMonitorUsage.Track() would use MonitorPropUsageValue() to guess + // the tracked properties type from class RTTI + TSynMonitorType = ( + smvUndefined, smvOneMicroSec, smvOneBytes, smvOneCount, smvBytesPerSec, + smvMicroSec, smvBytes, smvCount, smvCount64); + /// value types as stored in TSynMonitor / TSynMonitorUsage + TSynMonitorTypes = set of TSynMonitorType; + + /// would identify a cumulative time process information in micro seconds, during monitoring + // - "cumulative" time would add each process timing, e.g. for statistics about + // SOA computation of a given service + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorTotalMicroSec = type QWord; + + /// would identify an immediate time count information, during monitoring + // - "immediate" counts won't accumulate, e.g. may store the current number + // of thread used by a process + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorOneCount = type cardinal; + + /// would identify an immediate time process information in micro seconds, during monitoring + // - "immediate" time won't accumulate, i.e. may store the duration of the + // latest execution of a SOA computation + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorOneMicroSec = type QWord; + + /// would identify a process information as cumulative bytes count, during monitoring + // - "cumulative" size would add some byte for each process, e.g. input/output + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorTotalBytes = type QWord; + + /// would identify an immediate process information as bytes count, during monitoring + // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory + // at a given time + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorOneBytes = type QWord; + + /// would identify the process throughput, during monitoring + // - it indicates e.g. "immediate" bandwith usage + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorBytesPerSec = type QWord; + + /// would identify a cumulative number of processes, during monitoring + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorCount = type cardinal; + + /// would identify a cumulative number of processes, during monitoring + // - any property defined with this type would be identified by TSynMonitorUsage + TSynMonitorCount64 = type QWord; + + /// pointer to a high resolution timer object/record + PPrecisionTimer = ^TPrecisionTimer; + + /// indirect reference to a pointer to a high resolution timer object/record + PPPrecisionTimer = ^PPrecisionTimer; + + /// high resolution timer (for accurate speed statistics) + // - WARNING: under Windows, this record MUST be aligned to 32-bit, otherwise + // iFreq=0 - so you can use TLocalPrecisionTimer/ILocalPrecisionTimer if you + // want to alllocate a local timer instance on the stack + TPrecisionTimer = object + protected + fStart,fStop: Int64; + {$ifndef LINUX} // use QueryPerformanceMicroSeconds() fast API + fWinFreq: Int64; + {$endif} + /// contains the time elapsed in micro seconds between Start and Stop + fTime: TSynMonitorTotalMicroSec; + /// contains the time elapsed in micro seconds between Resume and Pause + fLastTime: TSynMonitorOneMicroSec; + fPauseCount: TSynMonitorCount; + public + /// initialize the timer + // - will fill all internal state with 0 + // - not necessary e.g. if TPrecisionTimer is defined as a TObject field + procedure Init; {$ifdef HASINLINE}inline;{$endif} + /// initialize and start the high resolution timer + // - similar to Init + Resume + procedure Start; + /// stop the timer, returning the total time elapsed as text + // - with appended time resolution (us,ms,s) - from MicroSecToString() + // - is just a wrapper around Pause + Time + // - you can call Resume to continue adding time to this timer + function Stop: TShort16; {$ifdef HASINLINE}inline;{$endif} + /// stop the timer, returning the total time elapsed as microseconds + // - is just a wrapper around Pause + Time + // - you can call Resume to continue adding time to this timer + function StopInMicroSec: TSynMonitorTotalMicroSec; {$ifdef HASINLINE}inline;{$endif} + /// stop the timer, ready to continue its time measurement via Resume + // - will also compute the global Time value + // - do nothing if no previous Start/Resume call is pending + procedure Pause; + /// resume a paused timer, or start an initialized timer + // - do nothing if no timer has been initialized or paused just before + // - if the previous method called was Init, will act like Start + // - if the previous method called was Pause, it will continue counting + procedure Resume; {$ifdef HASINLINE}inline;{$endif} + /// resume a paused timer until the method ends + // - will internaly create a TInterfaceObject class to let the compiler + // generate a try..finally block as expected to call Pause at method ending + // - is therefore very convenient to have consistent Resume/Pause calls + // - for proper use, expect TPrecisionTimer to be initialized to 0 before + // execution (e.g. define it as a protected member of a class) + // - typical use is to declare a fTimeElapsed: TPrecisionTimer protected + // member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of + // all process expecting some timing, then log/save fTimeElapsed.Stop content + // - FPC TIP: result should be assigned to a local variable of IUnknown type + function ProfileCurrentMethod: IUnknown; + /// low-level method to force values settings to allow thread safe timing + // - by default, this timer is not thread safe: you can use this method to + // set the timing values from manually computed performance counters + // - the caller should also use a mutex to prevent from race conditions: + // see e.g. TSynMonitor.FromExternalMicroSeconds implementation + // - warning: Start, Stop, Pause and Resume methods are then disallowed + procedure FromExternalMicroSeconds(const MicroSeconds: QWord); + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + /// low-level method to force values settings to allow thread safe timing + // - by default, this timer is not thread safe: you can use this method to + // set the timing values from manually computed performance counters + // - the caller should also use a mutex to prevent from race conditions: + // see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation + // - returns the time elapsed, in micro seconds (i.e. LastTime value) + // - warning: Start, Stop, Pause and Resume methods are then disallowed + function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; + {$ifdef FPCLINUX}inline;{$endif} + /// compute the per second count + function PerSec(const Count: QWord): QWord; + /// compute the time elapsed by count, with appened time resolution (us,ms,s) + function ByCount(Count: QWord): TShort16; + /// returns e.g. '16.9 MB in 102.20ms i.e. 165.5 MB/s' + function SizePerSec(Size: QWord): shortstring; + /// textual representation of total time elapsed + // - with appened time resolution (us,ms,s) - from MicroSecToString() + // - not to be used in normal code (which could rather call the Stop method), + // but e.g. for custom performance analysis + function Time: TShort16; + /// textual representation of last process timing after counter stopped + // - Time returns a total elapsed time, whereas this method only returns + // the latest resumed time + // - with appened time resolution (us,ms,s) - from MicroSecToString() + // - not to be used in normal code, but e.g. for custom performance analysis + function LastTime: TShort16; + /// check if Start/Resume were called at least once + function Started: boolean; + /// time elapsed in micro seconds after counter stopped + // - not to be used in normal code, but e.g. for custom performance analysis + property TimeInMicroSec: TSynMonitorTotalMicroSec read fTime write fTime; + /// timing in micro seconds of the last process + // - not to be used in normal code, but e.g. for custom performance analysis + property LastTimeInMicroSec: TSynMonitorOneMicroSec read fLastTime write fLastTime; + /// how many times the Pause method was called, i.e. the number of tasks + // processeed + property PauseCount: TSynMonitorCount read fPauseCount; + end; + + /// interface to a reference counted high resolution timer instance + // - implemented by TLocalPrecisionTimer + ILocalPrecisionTimer = interface + /// start the high resolution timer + procedure Start; + /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) + function Stop: TShort16; + /// stop the timer, ready to continue its time measure + procedure Pause; + /// resume a paused timer, or start it if it hasn't be started + procedure Resume; + /// compute the per second count + function PerSec(Count: cardinal): cardinal; + /// compute the time elapsed by count, with appened time resolution (us,ms,s) + function ByCount(Count: cardinal): RawUTF8; + end; + + /// reference counted high resolution timer (for accurate speed statistics) + // - since TPrecisionTimer shall be 32-bit aligned, you can use this class + // to initialize a local auto-freeing ILocalPrecisionTimer variable on stack + // - to be used as such: + // ! var Timer: ILocalPrecisionTimer; + // ! (...) + // ! Timer := TLocalPrecisionTimer.Create; + // ! Timer.Start; + // ! (...) + TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer) + protected + fTimer: TPrecisionTimer; + public + /// initialize the instance, and start the high resolution timer + constructor CreateAndStart; + /// start the high resolution timer + procedure Start; + /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) + function Stop: TShort16; + /// stop the timer, ready to continue its time measure + procedure Pause; + /// resume a paused timer, or start the timer + procedure Resume; + /// compute the per second count + function PerSec(Count: cardinal): cardinal; + /// compute the time elapsed by count, with appened time resolution (us,ms,s) + function ByCount(Count: cardinal): RawUTF8; + end; + + /// able to serialize any cumulative timing as raw micro-seconds number or text + // - "cumulative" time would add each process value, e.g. SOA methods execution + TSynMonitorTime = class(TSynPersistent) + protected + fMicroSeconds: TSynMonitorTotalMicroSec; + function GetAsText: TShort16; + public + /// compute a number per second, of the current value + function PerSecond(const Count: QWord): QWord; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + published + /// micro seconds time elapsed, as raw number + property MicroSec: TSynMonitorTotalMicroSec read fMicroSeconds write fMicroSeconds; + /// micro seconds time elapsed, as '... us-ns-ms-s' text + property Text: TShort16 read GetAsText; + end; + + /// able to serialize any immediate timing as raw micro-seconds number or text + // - "immediate" size won't accumulate, i.e. may be e.g. last process time + TSynMonitorOneTime = class(TSynPersistent) + protected + fMicroSeconds: TSynMonitorOneMicroSec; + function GetAsText: TShort16; + public + /// compute a number per second, of the current value + function PerSecond(const Count: QWord): QWord; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + published + /// micro seconds time elapsed, as raw number + property MicroSec: TSynMonitorOneMicroSec read fMicroSeconds write fMicroSeconds; + /// micro seconds time elapsed, as '... us-ns-ms-s' text + property Text: TShort16 read GetAsText; + end; + + TSynMonitorSizeParent = class(TSynPersistent) + protected + fTextNoSpace: boolean; + public + /// initialize the instance + constructor Create(aTextNoSpace: boolean); reintroduce; + end; + + /// able to serialize any cumulative size as bytes number + // - "cumulative" time would add each process value, e.g. global IO consumption + TSynMonitorSize = class(TSynMonitorSizeParent) + protected + fBytes: TSynMonitorTotalBytes; + function GetAsText: TShort16; + published + /// number of bytes, as raw number + property Bytes: TSynMonitorTotalBytes read fBytes write fBytes; + /// number of bytes, as '... B-KB-MB-GB' text + property Text: TShort16 read GetAsText; + end; + + /// able to serialize any immediate size as bytes number + // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory + // at a given time + TSynMonitorOneSize = class(TSynMonitorSizeParent) + protected + fBytes: TSynMonitorOneBytes; + function GetAsText: TShort16; + published + /// number of bytes, as raw number + property Bytes: TSynMonitorOneBytes read fBytes write fBytes; + /// number of bytes, as '... B-KB-MB-GB' text + property Text: TShort16 read GetAsText; + end; + + /// able to serialize any bandwith as bytes count per second + // - is usually associated with TSynMonitorOneSize properties, + // e.g. to monitor IO activity + TSynMonitorThroughput = class(TSynMonitorSizeParent) + protected + fBytesPerSec: QWord; + function GetAsText: TShort16; + published + /// number of bytes per second, as raw number + property BytesPerSec: QWord read fBytesPerSec write fBytesPerSec; + /// number of bytes per second, as '... B-KB-MB-GB/s' text + property Text: TShort16 read GetAsText; + end; + + /// a generic value object able to handle any task / process statistic + // - base class shared e.g. for ORM, SOA or DDD, when a repeatable data + // process is to be monitored + // - this class is thread-safe for its methods, but you should call explicitly + // Lock/UnLock to access its individual properties + TSynMonitor = class(TSynPersistentLock) + protected + fName: RawUTF8; + fTaskCount: TSynMonitorCount64; + fTotalTime: TSynMonitorTime; + fLastTime: TSynMonitorOneTime; + fMinimalTime: TSynMonitorOneTime; + fAverageTime: TSynMonitorOneTime; + fMaximalTime: TSynMonitorOneTime; + fPerSec: QWord; + fInternalErrors: TSynMonitorCount; + fProcessing: boolean; + fTaskStatus: (taskNotStarted,taskStarted); + fLastInternalError: variant; + procedure LockedPerSecProperties; virtual; + procedure LockedFromProcessTimer; virtual; + procedure LockedSum(another: TSynMonitor); virtual; + procedure WriteDetailsTo(W: TTextWriter); virtual; + procedure Changed; virtual; + public + /// low-level high-precision timer instance + InternalTimer: TPrecisionTimer; + /// initialize the instance nested class properties + // - you can specify identifier associated to this monitored resource + // which would be used for TSynMonitorUsage persistence + constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; + /// initialize the instance nested class properties + constructor Create; overload; override; + /// finalize the instance + destructor Destroy; override; + /// lock the instance for exclusive access + // - needed only if you access directly the instance properties + procedure Lock; {$ifdef HASINLINE}inline;{$endif} + /// release the instance for exclusive access + // - needed only if you access directly the instance properties + procedure UnLock; {$ifdef HASINLINE}inline;{$endif} + /// create Count instances of this actual class in the supplied ObjArr[] + class procedure InitializeObjArray(var ObjArr; Count: integer); virtual; + /// should be called when the process starts, to resume the internal timer + // - thread-safe method + procedure ProcessStart; virtual; + /// should be called each time a pending task is processed + // - will increase the TaskCount property + // - thread-safe method + procedure ProcessDoTask; virtual; + /// should be called when the process starts, and a task is processed + // - similar to ProcessStart + ProcessDoTask + // - thread-safe method + procedure ProcessStartTask; virtual; + /// should be called when an error occurred + // - typical use is with ObjectToVariantDebug(E,...) kind of information + // - thread-safe method + procedure ProcessError(const info: variant); virtual; + /// should be called when an error occurred + // - typical use is with a HTTP status, e.g. as ProcessError(Call.OutStatus) + // - just a wraper around overloaded ProcessError(), so a thread-safe method + procedure ProcessErrorNumber(info: integer); + /// should be called when an error occurred + // - just a wraper around overloaded ProcessError(), so a thread-safe method + procedure ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); + /// should be called when an Exception occurred + // - just a wraper around overloaded ProcessError(), so a thread-safe method + procedure ProcessErrorRaised(E: Exception); + /// should be called when the process stops, to pause the internal timer + // - thread-safe method + procedure ProcessEnd; virtual; + /// could be used to manage information average or sums + // - thread-safe method calling LockedSum protected virtual method + procedure Sum(another: TSynMonitor); + /// returns a JSON content with all published properties information + // - thread-safe method + function ComputeDetailsJSON: RawUTF8; + /// appends a JSON content with all published properties information + // - thread-safe method + procedure ComputeDetailsTo(W: TTextWriter); virtual; + {$ifndef NOVARIANTS} + /// returns a TDocVariant with all published properties information + // - thread-safe method + function ComputeDetails: variant; + {$endif NOVARIANTS} + /// used to allow thread safe timing + // - by default, the internal TPrecisionTimer is not thread safe: you can + // use this method to update the timing from many threads + // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd + // methods are disallowed, and the global fTimer won't be used any more + // - will return the processing time, converted into micro seconds, ready + // to be logged if needed + // - thread-safe method + function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; + /// used to allow thread safe timing + // - by default, the internal TPrecisionTimer is not thread safe: you can + // use this method to update the timing from many threads + // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd + // methods are disallowed, and the global fTimer won't be used any more + // - thread-safe method + procedure FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); + /// an identifier associated to this monitored resource + // - is used e.g. for TSynMonitorUsage persistence/tracking + property Name: RawUTF8 read fName write fName; + published + /// indicates if this thread is currently working on some process + property Processing: boolean read fProcessing write fProcessing; + /// how many times the task was performed + property TaskCount: TSynMonitorCount64 read fTaskCount write fTaskCount; + /// the whole time spend during all working process + property TotalTime: TSynMonitorTime read fTotalTime; + /// the time spend during the last task processing + property LastTime: TSynMonitorOneTime read fLastTime; + /// the lowest time spent during any working process + property MinimalTime: TSynMonitorOneTime read fMinimalTime; + /// the time spent in average during any working process + property AverageTime: TSynMonitorOneTime read fAverageTime; + /// the highest time spent during any working process + property MaximalTime: TSynMonitorOneTime read fMaximalTime; + /// average of how many tasks did occur per second + property PerSec: QWord read fPerSec; + /// how many errors did occur during the processing + property Errors: TSynMonitorCount read fInternalErrors; + /// information about the last error which occured during the processing + property LastError: variant read fLastInternalError; + end; + /// references a TSynMonitor instance + PSynMonitor = ^TSynMonitor; + + /// handle generic process statistic with a processing data size and bandwitdh + TSynMonitorWithSize = class(TSynMonitor) + protected + fSize: TSynMonitorSize; + fThroughput: TSynMonitorThroughput; + procedure LockedPerSecProperties; override; + procedure LockedSum(another: TSynMonitor); override; + public + /// initialize the instance nested class properties + constructor Create; override; + /// finalize the instance + destructor Destroy; override; + /// increase the internal size counter + // - thread-safe method + procedure AddSize(const Bytes: QWord); + published + /// how many total data has been hanlded during all working process + property Size: TSynMonitorSize read fSize; + /// data processing bandwith, returned as B/KB/MB per second + property Throughput: TSynMonitorThroughput read fThroughput; + end; + + /// handle generic process statistic with a incoming and outgoing processing + // data size and bandwitdh + TSynMonitorInputOutput = class(TSynMonitor) + protected + fInput: TSynMonitorSize; + fOutput: TSynMonitorSize; + fInputThroughput: TSynMonitorThroughput; + fOutputThroughput: TSynMonitorThroughput; + procedure LockedPerSecProperties; override; + procedure LockedSum(another: TSynMonitor); override; + public + /// initialize the instance nested class properties + constructor Create; override; + /// finalize the instance + destructor Destroy; override; + /// increase the internal size counters + // - thread-safe method + procedure AddSize(const Incoming, Outgoing: QWord); + published + /// how many data has been received + property Input: TSynMonitorSize read fInput; + /// how many data has been sent back + property Output: TSynMonitorSize read fOutput; + /// incoming data processing bandwith, returned as B/KB/MB per second + property InputThroughput: TSynMonitorThroughput read fInputThroughput; + /// outgoing data processing bandwith, returned as B/KB/MB per second + property OutputThroughput: TSynMonitorThroughput read fOutputThroughput; + end; + + /// could monitor a standard Server + // - including Input/Output statistics and connected Clients count + TSynMonitorServer = class(TSynMonitorInputOutput) + protected + fCurrentRequestCount: integer; + fClientsCurrent: TSynMonitorOneCount; + fClientsMax: TSynMonitorOneCount; + public + /// update ClientsCurrent and ClientsMax + // - thread-safe method + procedure ClientConnect; + /// update ClientsCurrent and ClientsMax + // - thread-safe method + procedure ClientDisconnect; + /// update ClientsCurrent to 0 + // - thread-safe method + procedure ClientDisconnectAll; + /// retrieve the number of connected clients + // - thread-safe method + function GetClientsCurrent: TSynMonitorOneCount; + /// how many concurrent requests are currently processed + // - returns the updated number of requests + // - thread-safe method + function AddCurrentRequestCount(diff: integer): integer; + published + /// current count of connected clients + property ClientsCurrent: TSynMonitorOneCount read fClientsCurrent; + /// max count of connected clients + property ClientsMax: TSynMonitorOneCount read fClientsMax; + /// how many concurrent requests are currently processed + // - modified via AddCurrentRequestCount() in TSQLRestServer.URI() + property CurrentRequestCount: integer read fCurrentRequestCount; + end; + + /// a list of simple process statistics + TSynMonitorObjArray = array of TSynMonitor; + + /// a list of data process statistics + TSynMonitorWithSizeObjArray = array of TSynMonitorWithSize; + + /// a list of incoming/outgoing data process statistics + TSynMonitorInputOutputObjArray = array of TSynMonitorInputOutput; + + /// class-reference type (metaclass) of a process statistic information + TSynMonitorClass = class of TSynMonitor; + + +{ ******************* cross-cutting classes and functions ***************** } + +type + /// an abstract ancestor, for implementing a custom TInterfacedObject like class + // - by default, will do nothing: no instance would be retrieved by + // QueryInterface unless the VirtualQueryInterface protected method is + // overriden, and _AddRef/_Release methods would call VirtualAddRef and + // VirtualRelease pure abstract methods + // - using this class will leverage the signature difference between Delphi + // and FPC, among all supported platforms + // - the class includes a RefCount integer field + TSynInterfacedObject = class(TObject,IUnknown) + protected + fRefCount: integer; + // returns E_NOINTERFACE + function VirtualQueryInterface(const IID: TGUID; out Obj): HResult; virtual; + // always return 1 for a "non allocated" instance (0 triggers release) + function VirtualAddRef: Integer; virtual; abstract; + function VirtualRelease: Integer; virtual; abstract; + {$ifdef FPC} + function QueryInterface( + {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; + out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; + function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; + function _Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; + {$else} + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + {$endif} + public + /// the associated reference count + property RefCount: integer read fRefCount write fRefCount; + end; + +{$ifdef CPUINTEL} +{$ifndef DELPHI5OROLDER} + /// a simple class which will set FPU exception flags for a code block + // - using an IUnknown interface to let the compiler auto-generate a + // try..finally block statement to reset the FPU exception register + // - to be used e.g. as such: + // !begin + // ! TSynFPUException.ForLibrayCode; + // ! ... now FPU exceptions will be ignored + // ! ... so here it is safe to call external libray code + // !end; // now FPU exception will be reset as with standard Delphi + // - it will avoid any unexpected invalid floating point operation in Delphi + // code, whereas it was in fact triggerred in some external library code + TSynFPUException = class(TSynInterfacedObject) + protected + {$ifndef CPU64} + fExpected8087, fSaved8087: word; + {$else} + fExpectedMXCSR, fSavedMXCSR: word; + {$endif} + function VirtualAddRef: Integer; override; + function VirtualRelease: Integer; override; + public + /// internal constructor + // - do not call this constructor directly, but rather use + // ForLibraryCode/ForDelphiCode class methods + // - for cpu32 flags are $1372 for Delphi, or $137F for library (mask all exceptions) + // - for cpu64 flags are $1920 for Delphi, or $1FA0 for library (mask all exceptions) + {$ifndef CPU64} + constructor Create(Expected8087Flag: word); reintroduce; + {$else} + constructor Create(ExpectedMXCSR: word); reintroduce; + {$endif} + /// after this method call, all FPU exceptions will be ignored + // - until the method finishes (a try..finally block is generated by + // the compiler), then FPU exceptions will be reset into "Delphi" mode + // - you have to put this e.g. before calling an external libray + // - this method is thread-safe and re-entrant (by reference-counting) + class function ForLibraryCode: IUnknown; + /// after this method call, all FPU exceptions will be enabled + // - this is the Delphi normal behavior + // - until the method finishes (a try..finally block is generated by + // the compiler), then FPU execptions will be disabled again + // - you have to put this e.g. before running an Delphi code from + // a callback executed in an external libray + // - this method is thread-safe and re-entrant (by reference-counting) + class function ForDelphiCode: IUnknown; + end; +{$endif DELPHI5OROLDER} +{$endif CPUINTEL} + + /// interface for TAutoFree to register another TObject instance + // to an existing IAutoFree local variable + IAutoFree = interface + procedure Another(var objVar; obj: TObject); + end; + + /// simple reference-counted storage for local objects + // - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance + // up to the end-of-method -> you should not use TAutoFree for new projects + // :( - see https://quality.embarcadero.com/browse/RSP-30050 + // - be aware that it won't implement a full ARC memory model, but may be + // just used to avoid writing some try ... finally blocks on local variables + // - use with caution, only on well defined local scope + TAutoFree = class(TInterfacedObject,IAutoFree) + protected + fObject: TObject; + fObjectList: array of TObject; + public + /// initialize the TAutoFree class for one local variable + // - do not call this constructor, but class function One() instead + constructor Create(var localVariable; obj: TObject); reintroduce; overload; + /// initialize the TAutoFree class for several local variables + // - do not call this constructor, but class function Several() instead + constructor Create(const varObjPairs: array of pointer); reintroduce; overload; + /// protect one local TObject variable instance life time + // - for instance, instead of writing: + // !var myVar: TMyClass; + // !begin + // ! myVar := TMyClass.Create; + // ! try + // ! ... use myVar + // ! finally + // ! myVar.Free; + // ! end; + // !end; + // - you may write: + // !var myVar: TMyClass; + // !begin + // ! TAutoFree.One(myVar,TMyClass.Create); + // ! ... use myVar + // !end; // here myVar will be released + // - warning: under FPC, you should assign the result of this method to a local + // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 + // - Delphi 10.4 also did change it and release the IAutoFree before the + // end of the current method, so you should better use a local variable + class function One(var localVariable; obj: TObject): IAutoFree; + /// protect several local TObject variable instances life time + // - specified as localVariable/objectInstance pairs + // - you may write: + // !var var1,var2: TMyClass; + // !begin + // ! TAutoFree.Several([ + // ! @var1,TMyClass.Create, + // ! @var2,TMyClass.Create]); + // ! ... use var1 and var2 + // !end; // here var1 and var2 will be released + // - warning: under FPC, you should assign the result of this method to a local + // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 + // - Delphi 10.4 also did change it and release the IAutoFree before the + // end of the current method, so you should better use a local variable + class function Several(const varObjPairs: array of pointer): IAutoFree; + /// protect another TObject variable to an existing IAutoFree instance life time + // - you may write: + // !var var1,var2: TMyClass; + // ! auto: IAutoFree; + // !begin + // ! auto := TAutoFree.One(var1,TMyClass.Create);, + // ! .... do something + // ! auto.Another(var2,TMyClass.Create); + // ! ... use var1 and var2 + // !end; // here var1 and var2 will be released + procedure Another(var localVariable; obj: TObject); + /// will finalize the associated TObject instances + // - note that releasing the TObject instances won't be protected, so + // any exception here may induce a memory leak: use only with "safe" + // simple objects, e.g. mORMot's TSQLRecord + destructor Destroy; override; + end; + +{$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :( + TAutoLocker = class + protected + fSafe: TSynLocker; + public + constructor Create; + destructor Destroy; override; + procedure Enter; virtual; + procedure Leave; virtual; + function ProtectMethod: IUnknown; + /// gives an access to the internal low-level TSynLocker instance used + function Safe: PSynLocker; + property Locker: TSynLocker read fSafe; + end; + IAutoLocker = TAutoLocker; +{$else DELPHI5OROLDER} + /// an interface used by TAutoLocker to protect multi-thread execution + IAutoLocker = interface + ['{97559643-6474-4AD3-AF72-B9BB84B4955D}'] + /// enter the mutex + // - any call to Enter should be ended with a call to Leave, and + // protected by a try..finally block, as such: + // !begin + // ! ... // unsafe code + // ! fSharedAutoLocker.Enter; + // ! try + // ! ... // thread-safe code + // ! finally + // ! fSharedAutoLocker.Leave; + // ! end; + // !end; + procedure Enter; + /// leave the mutex + // - any call to Leave should be preceded with a call to Enter + procedure Leave; + /// will enter the mutex until the IUnknown reference is released + // - using an IUnknown interface to let the compiler auto-generate a + // try..finally block statement to release the lock for the code block + // - could be used as such under Delphi: + // !begin + // ! ... // unsafe code + // ! fSharedAutoLocker.ProtectMethod; + // ! ... // thread-safe code + // !end; // local hidden IUnknown will release the lock for the method + // - warning: under FPC, you should assign its result to a local variable - + // see bug http://bugs.freepascal.org/view.php?id=26602 + // !var LockFPC: IUnknown; + // !begin + // ! ... // unsafe code + // ! LockFPC := fSharedAutoLocker.ProtectMethod; + // ! ... // thread-safe code + // !end; // LockFPC will release the lock for the method + // or + // !begin + // ! ... // unsafe code + // ! with fSharedAutoLocker.ProtectMethod do begin + // ! ... // thread-safe code + // ! end; // local hidden IUnknown will release the lock for the method + // !end; + function ProtectMethod: IUnknown; + /// gives an access to the internal low-level TSynLocker instance used + function Safe: PSynLocker; + end; + + /// reference-counted block code critical section + // - you can use one instance of this to protect multi-threaded execution + // - the main class may initialize a IAutoLocker property in Create, then call + // IAutoLocker.ProtectMethod in any method to make its execution thread safe + // - this class inherits from TInterfacedObjectWithCustomCreate so you + // could define one published property of a mORMot.pas' TInjectableObject + // as IAutoLocker so that this class may be automatically injected + // - you may use the inherited TAutoLockerDebug class, as defined in SynLog.pas, + // to debug unexpected race conditions due to such critical sections + // - consider inherit from high-level TSynPersistentLock or call low-level + // fSafe := NewSynLocker / fSafe^.DoneAndFreemem instead + TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker) + protected + fSafe: TSynLocker; + public + /// initialize the mutex + constructor Create; override; + /// finalize the mutex + destructor Destroy; override; + /// will enter the mutex until the IUnknown reference is released + // - as expected by IAutoLocker interface + // - could be used as such under Delphi: + // !begin + // ! ... // unsafe code + // ! fSharedAutoLocker.ProtectMethod; + // ! ... // thread-safe code + // !end; // local hidden IUnknown will release the lock for the method + // - warning: under FPC, you should assign its result to a local variable - + // see bug http://bugs.freepascal.org/view.php?id=26602 + // !var LockFPC: IUnknown; + // !begin + // ! ... // unsafe code + // ! LockFPC := fSharedAutoLocker.ProtectMethod; + // ! ... // thread-safe code + // !end; // LockFPC will release the lock for the method + // or + // !begin + // ! ... // unsafe code + // ! with fSharedAutoLocker.ProtectMethod do begin + // ! ... // thread-safe code + // ! end; // local hidden IUnknown will release the lock for the method + // !end; + function ProtectMethod: IUnknown; + /// enter the mutex + // - as expected by IAutoLocker interface + // - any call to Enter should be ended with a call to Leave, and + // protected by a try..finally block, as such: + // !begin + // ! ... // unsafe code + // ! fSharedAutoLocker.Enter; + // ! try + // ! ... // thread-safe code + // ! finally + // ! fSharedAutoLocker.Leave; + // ! end; + // !end; + procedure Enter; virtual; + /// leave the mutex + // - as expected by IAutoLocker interface + procedure Leave; virtual; + /// access to the locking methods of this instance + // - as expected by IAutoLocker interface + function Safe: PSynLocker; + /// direct access to the locking methods of this instance + // - faster than IAutoLocker.Safe function + property Locker: TSynLocker read fSafe; + end; +{$endif DELPHI5OROLDER} + + +{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( +{$ifndef NOVARIANTS} + /// ref-counted interface for thread-safe access to a TDocVariant document + // - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution + // - fast and safe storage of any JSON-like object, as property/value pairs, + // or a JSON-like array, as values + ILockedDocVariant = interface + ['{CADC2C20-3F5D-4539-9D23-275E833A86F3}'] + function GetValue(const Name: RawUTF8): Variant; + procedure SetValue(const Name: RawUTF8; const Value: Variant); + /// check and return a given property by name + // - returns TRUE and fill Value with the value associated with the supplied + // Name, using an internal lock for thread-safety + // - returns FALSE if the Name was not found, releasing the internal lock: + // use ExistsOrLock() if you want to add the missing value + function Exists(const Name: RawUTF8; out Value: Variant): boolean; + /// check and return a given property by name + // - returns TRUE and fill Value with the value associated with the supplied + // Name, using an internal lock for thread-safety + // - returns FALSE and set the internal lock if Name does not exist: + // caller should then release the lock via ReplaceAndUnlock() + function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; + /// set a value by property name, and set a local copy + // - could be used as such, for implementing a thread-safe cache: + // ! if not cache.ExistsOrLock('prop',local) then + // ! cache.ReplaceAndUnlock('prop',newValue,local); + // - call of this method should have been precedeed by ExistsOrLock() + // returning false, i.e. be executed on a locked instance + procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); + /// add an existing property value to the given TDocVariant document object + // - returns TRUE and add the Name/Value pair to Obj if Name is existing, + // using an internal lock for thread-safety + // - returns FALSE if Name is not existing in the stored document, and + // lock the internal storage: caller should eventually release the lock + // via AddNewPropAndUnlock() + // - could be used as such, for implementing a thread-safe cache: + // ! if not cache.AddExistingPropOrLock('Articles',Scope) then + // ! cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope); + // here GetArticlesFromDB would occur inside the main lock + function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; + /// add a property value to the given TDocVariant document object and + // to the internal stored document, then release a previous lock + // - call of this method should have been precedeed by AddExistingPropOrLock() + // returning false, i.e. be executed on a locked instance + procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); + /// add an existing property value to the given TDocVariant document object + // - returns TRUE and add the Name/Value pair to Obj if Name is existing + // - returns FALSE if Name is not existing in the stored document + // - this method would use a lock during the Name lookup, but would always + // release the lock, even if returning FALSE (see AddExistingPropOrLock) + function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; + /// add a property value to the given TDocVariant document object + // - this method would not expect the resource to be locked when called, + // as with AddNewPropAndUnlock + // - will use the internal lock for thread-safety + // - if the Name is already existing, would update/change the existing value + // - could be used as such, for implementing a thread-safe cache: + // ! if not cache.AddExistingProp('Articles',Scope) then + // ! cache.AddNewProp('Articles',GetArticlesFromDB,Scope); + // here GetArticlesFromDB would occur outside the main lock + procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); + /// append a value to the internal TDocVariant document array + // - you should not use this method in conjunction with other document-based + // alternatives, like Exists/AddExistingPropOrLock or AddExistingProp + procedure AddItem(const Value: variant); + /// makes a thread-safe copy of the internal TDocVariant document object or array + function Copy: variant; + /// delete all stored properties + procedure Clear; + /// save the stored values as UTF-8 encoded JSON Object + function ToJSON(HumanReadable: boolean=false): RawUTF8; + /// low-level access to the associated thread-safe mutex + function Lock: TAutoLocker; + /// the document fields would be safely accessed via this property + // - this is the main entry point of this storage + // - will raise an EDocVariant exception if Name does not exist at reading + // - implementation class would make a thread-safe copy of the variant value + property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; + end; + + /// allows thread-safe access to a TDocVariant document + // - this class inherits from TInterfacedObjectWithCustomCreate so you + // could define one published property of a mORMot.pas' TInjectableObject + // as ILockedDocVariant so that this class may be automatically injected + TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant) + protected + fValue: TDocVariantData; + fLock: TAutoLocker; + function GetValue(const Name: RawUTF8): Variant; + procedure SetValue(const Name: RawUTF8; const Value: Variant); + public + /// initialize the thread-safe document with a fast TDocVariant + // - i.e. call Create(true) aka Create(JSON_OPTIONS[true]) + // - will be the TInterfacedObjectWithCustomCreate default constructor, + // called e.g. during IoC/DI resolution + constructor Create; overload; override; + /// initialize the thread-safe document storage + constructor Create(FastStorage: boolean); reintroduce; overload; + /// initialize the thread-safe document storage with the corresponding options + constructor Create(options: TDocVariantOptions); reintroduce; overload; + /// finalize the storage + destructor Destroy; override; + /// check and return a given property by name + function Exists(const Name: RawUTF8; out Value: Variant): boolean; + /// check and return a given property by name + // - this version + function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; + /// set a value by property name, and set a local copy + procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); + /// add an existing property value to the given TDocVariant document object + // - returns TRUE and add the Name/Value pair to Obj if Name is existing + // - returns FALSE if Name is not existing in the stored document + function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; + /// add a property value to the given TDocVariant document object and + // to the internal stored document + procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); + /// add an existing property value to the given TDocVariant document object + // - returns TRUE and add the Name/Value pair to Obj if Name is existing + // - returns FALSE if Name is not existing in the stored document + // - this method would use a lock during the Name lookup, but would always + // release the lock, even if returning FALSE (see AddExistingPropOrLock) + function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; + /// add a property value to the given TDocVariant document object + // - this method would not expect the resource to be locked when called, + // as with AddNewPropAndUnlock + // - will use the internal lock for thread-safety + // - if the Name is already existing, would update/change the existing value + procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); + /// append a value to the internal TDocVariant document array + procedure AddItem(const Value: variant); + /// makes a thread-safe copy of the internal TDocVariant document object or array + function Copy: variant; + /// delete all stored properties + procedure Clear; + /// save the stored value as UTF-8 encoded JSON Object + // - implemented as just a wrapper around VariantSaveJSON() + function ToJSON(HumanReadable: boolean=false): RawUTF8; + /// low-level access to the associated thread-safe mutex + function Lock: TAutoLocker; + /// the document fields would be safely accessed via this property + // - will raise an EDocVariant exception if Name does not exist + // - result variant is returned as a copy, not as varByRef, since a copy + // will definitively be more thread safe + property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; + end; +{$endif} +{$endif} + +type + /// class-reference type (metaclass) of an TSynPersistentLock class + TSynPersistentLockClass = class of TSynPersistentLock; + + /// abstract dynamic array of TSynPersistentLock instance + // - note defined as T*ObjArray, since it won't + TSynPersistentLockDynArray = array of TSynPersistentLock; + +/// convert a size to a human readable value power-of-two metric value +// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); overload; + +/// convert a size to a human readable value +// - append EB, PB, TB, GB, MB, KB or B symbol with preceding space +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +function KB(bytes: Int64): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert a size to a human readable value +// - append EB, PB, TB, GB, MB, KB or B symbol without preceding space +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +function KBNoSpace(bytes: Int64): TShort16; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert a size to a human readable value +// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +function KB(bytes: Int64; nospace: boolean): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert a string size to a human readable value +// - append EB, PB, TB, GB, MB, KB or B symbol +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +function KB(const buffer: RawByteString): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} + +/// convert a size to a human readable value +// - append EB, PB, TB, GB, MB, KB or B symbol +// - for EB, PB, TB, GB, MB and KB, add one fractional digit +procedure KBU(bytes: Int64; var result: RawUTF8); + +/// convert a micro seconds elapsed time into a human readable value +// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, +// with two fractional digits +function MicroSecToString(Micro: QWord): TShort16; overload; + {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell + +/// convert a micro seconds elapsed time into a human readable value +// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, +// with two fractional digits +procedure MicroSecToString(Micro: QWord; out result: TShort16); overload; + +/// convert an integer value into its textual representation with thousands marked +// - ThousandSep is the character used to separate thousands in numbers with +// more than three digits to the left of the decimal separator +function IntToThousandString(Value: integer; const ThousandSep: TShort4=','): shortstring; + +/// return the Delphi/FPC Compiler Version +// - returns 'Delphi 2007', 'Delphi 2010' or 'Free Pascal 3.3.1' e.g. +function GetDelphiCompilerVersion: RawUTF8; + +/// returns TRUE if the supplied mutex has been initialized +// - will check if the supplied mutex is void (i.e. all filled with 0 bytes) +function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean; + {$ifdef HASINLINE}inline;{$endif} + +/// on need initialization of a mutex, then enter the lock +// - if the supplied mutex has been initialized, do nothing +// - if the supplied mutex is void (i.e. all filled with 0), initialize it +procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection); + {$ifdef HASINLINE}inline;{$endif} + +/// on need finalization of a mutex +// - if the supplied mutex has been initialized, delete it +// - if the supplied mutex is void (i.e. all filled with 0), do nothing +procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection); + +/// compress a data content using the SynLZ algorithm +// - as expected by THttpSocket.RegisterCompress +// - will return 'synlz' as ACCEPT-ENCODING: header parameter +// - will store a hash of both compressed and uncompressed stream: if the +// data is corrupted during transmission, will instantly return '' +function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString; + +/// compress a data content using the SynLZ algorithm from one stream into another +// - returns the number of bytes written to Dest +// - you should specify a Magic number to be used to identify the block +function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; + Magic: cardinal): integer; overload; + +/// compress a data content using the SynLZ algorithm from one stream into a file +// - returns the number of bytes written to the destination file +// - you should specify a Magic number to be used to identify the block +function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; + Magic: cardinal): integer; overload; + +/// uncompress using the SynLZ algorithm from one stream into another +// - returns a newly create memory stream containing the uncompressed data +// - returns nil if source data is invalid +// - you should specify a Magic number to be used to identify the block +// - this function will also recognize the block at the end of the source stream +// (if was appended to an existing data - e.g. a .mab at the end of a .exe) +// - on success, Source will point after all read data (so that you can e.g. +// append several data blocks to the same stream) +function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload; + +/// compute the real length of a given StreamSynLZ-compressed buffer +// - allows to replace an existing appended content, for instance +function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; + +/// uncompress using the SynLZ algorithm from one file into another +// - returns a newly create memory stream containing the uncompressed data +// - returns nil if source file is invalid (e.g. invalid name or invalid content) +// - you should specify a Magic number to be used to identify the block +// - this function will also recognize the block at the end of the source file +// (if was appended to an existing data - e.g. a .mab at the end of a .exe) +function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload; + +/// compress a file content using the SynLZ algorithm +// - source file is split into 128 MB blocks for fast in-memory compression of +// any file size, then SynLZ compressed and including a Hash32 checksum +// - it is not compatible with StreamSynLZ format, which has no 128 MB chunking +// - you should specify a Magic number to be used to identify the compressed +// file format +function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; + +/// uncompress a file previoulsy compressed via FileSynLZ( +// - you should specify a Magic number to be used to identify the compressed +// file format +function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; + +/// returns TRUE if the supplied file name is a SynLZ compressed file, +// matching the Magic number as supplied to FileSynLZ() function +function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; + +var + /// acccess to our fast SynLZ compression as a TAlgoCompress class + // - please use this global variable methods instead of the deprecated + // SynLZCompress/SynLZDecompress wrapper functions + AlgoSynLZ: TAlgoCompress; + +const + /// CompressionSizeTrigger parameter SYNLZTRIG[true] will disable then + // SynLZCompress() compression + SYNLZTRIG: array[boolean] of integer = (100, maxInt); + /// used e.g. as when ALGO_SAFE[SafeDecompression] for TAlgoCompress.Decompress + ALGO_SAFE: array[boolean] of TAlgoCompressLoad = (aclNormal, aclSafeSlow); + + +/// deprecated function - please call AlgoSynLZ.Compress() method +function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100; + CheckMagicForCompressed: boolean=false): RawByteString; overload; + +/// deprecated function - please call AlgoSynLZ.Compress() method +procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; + CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false); overload; + +/// deprecated function - please call AlgoSynLZ.Compress() method +function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; + CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; + +/// deprecated function - please call AlgoSynLZ.Decompress() method +function SynLZDecompress(const Data: RawByteString): RawByteString; overload; + +/// deprecated function - please call AlgoSynLZ.Decompress() method +procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; + SafeDecompression: boolean=false); overload; + +/// deprecated function - please call AlgoSynLZ.DecompressToBytes() method +function SynLZCompressToBytes(const Data: RawByteString; + CompressionSizeTrigger: integer=100): TByteDynArray; overload; + +/// deprecated function - please call AlgoSynLZ.CompressToBytes() method +function SynLZCompressToBytes(P: PAnsiChar; PLen: integer; + CompressionSizeTrigger: integer=100): TByteDynArray; overload; + +/// deprecated function - please call AlgoSynLZ.Decompress() method +function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload; + +/// deprecated function - please call AlgoSynLZ.Decompress() method +function SynLZDecompress(const Data: RawByteString; out Len: integer; + var tmp: RawByteString): pointer; overload; + +/// deprecated function - please call AlgoSynLZ.Decompress() method +function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; + var tmp: RawByteString): pointer; overload; + +/// deprecated function - please call AlgoSynLZ.DecompressHeader() method +function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; + +/// deprecated function - please call AlgoSynLZ.DecompressBody() method +function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; + SafeDecompression: boolean=false): boolean; + +/// deprecated function - please call AlgoSynLZ.DecompressPartial() method +function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; + + + +implementation + +{$ifdef FPC} +uses + {$ifdef FPC_X64MM} + {$ifdef CPUX64} + SynFPCx64MM, + {$else} + {$undef FPC_X64MM} + {$endif CPUX64} + {$endif FPC_X64MM} + {$ifdef LINUX} + Unix, + dynlibs, + {$ifdef BSD} + sysctl, + {$else} + Linux, + {$endif BSD} + {$ifdef FPCUSEVERSIONINFO} // to be enabled in Synopse.inc + fileinfo, // FPC 3.0 and up + {$ifdef DARWIN} + machoreader, // MACH-O executables + {$else} + elfreader, // ELF executables + {$endif DARWIN} + {$endif FPCUSEVERSIONINFO} + {$ifdef ISFPC271} + unixcp, // for GetSystemCodePage + {$endif} + SynFPCLinux, + {$endif LINUX} + SynFPCTypInfo; // small wrapper unit around FPC's TypInfo.pp +{$endif FPC} + + +{ ************ some fast UTF-8 / Unicode / Ansi conversion routines } + +var + // internal list of TSynAnsiConvert instances + SynAnsiConvertList: TSynObjectList = nil; + +{$ifdef HASINLINE} +{$ifdef USE_VTYPE_STATIC} // circumvent weird bug on BSD + ARM (Alfred) +procedure VarClear(var v: variant); // defined here for proper inlining +const VTYPE_STATIC = $BFE8; // bitmask to avoid remote VarClearProc call +var p: PInteger; // more efficient generated asm with an explicit temp variable +begin + p := @v; + if p^ and VTYPE_STATIC=0 then + p^ := 0 else + VarClearProc(PVarData(p)^); +end; +{$else} +procedure VarClear(var v: variant); // defined here for proper inlining +begin + VarClearProc(PVarData(@v)^); +end; +{$endif USE_VTYPE_STATIC} +{$endif HASINLINE} + +procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); +var c: AnsiChar; // better FPC inlining +begin + inc(PtrUInt(Source),Count); + inc(PtrUInt(Dest),Count); + PtrInt(Count) := -PtrInt(Count); + repeat + c := PAnsiChar(Source)[Count]; + PAnsiChar(Dest)[Count] := c; + inc(Count); + until Count=0; +end; + + +{ TSynTempBuffer } + +procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt); +begin + len := SourceLen; + if len<=0 then + buf := nil else begin + if len<=SizeOf(tmp)-16 then + buf := @tmp else + GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing + if Source<>nil then begin + MoveFast(Source^,buf^,len); + PPtrInt(PAnsiChar(buf)+len)^ := 0; // init last 4/8 bytes (makes valgrid happy) + end; + end; +end; + +function TSynTempBuffer.InitOnStack: pointer; +begin + buf := @tmp; + len := SizeOf(tmp); + result := @tmp; +end; + +procedure TSynTempBuffer.Init(const Source: RawByteString); +begin + Init(pointer(Source),length(Source)); +end; + +function TSynTempBuffer.Init(Source: PUTF8Char): PUTF8Char; +begin + Init(Source,StrLen(Source)); + result := buf; +end; + +function TSynTempBuffer.Init(SourceLen: PtrInt): pointer; +begin + len := SourceLen; + if len<=0 then + buf := nil else begin + if len<=SizeOf(tmp)-16 then + buf := @tmp else + GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing + end; + result := buf; +end; + +function TSynTempBuffer.Init: integer; +begin + buf := @tmp; + result := SizeOf(tmp)-16; + len := result; +end; + +function TSynTempBuffer.InitRandom(RandomLen: integer; forcegsl: boolean): pointer; +begin + Init(RandomLen); + if RandomLen>0 then + FillRandom(buf,(RandomLen shr 2)+1,forcegsl); + result := buf; +end; + +function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray; +begin + Init((Count-Start)*4); + FillIncreasing(buf,Start,Count); + result := buf; +end; + +function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer; +begin + Init(ZeroLen-16); + FillCharFast(buf^,ZeroLen,0); + result := buf; +end; + +procedure TSynTempBuffer.Done; +begin + if (buf<>@tmp) and (buf<>nil) then + FreeMem(buf); +end; + +procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8); +begin + if EndBuf=nil then + Dest := '' else + FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf)); + if (buf<>@tmp) and (buf<>nil) then + FreeMem(buf); +end; + + +{ TSynAnsiConvert } + +{$ifdef MSWINDOWS} +const + DefaultCharVar: AnsiChar = '?'; +{$endif} + +function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar; + Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; +var c: cardinal; +{$ifndef MSWINDOWS} +{$ifdef KYLIX3} + ic: iconv_t; + DestBegin: PAnsiChar; + SourceCharsBegin: integer; +{$endif} +{$endif} +begin + {$ifdef KYLIX3} + SourceCharsBegin := SourceChars; + DestBegin := pointer(Dest); + {$endif} + // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) + if SourceChars>=4 then + repeat + c := PCardinal(Source)^; + if c and $80808080<>0 then + break; // break on first non ASCII quad + dec(SourceChars,4); + inc(Source,4); + PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; + c := c shr 16; + PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff; + inc(Dest,4); + until SourceChars<4; + if (SourceChars>0) and (ord(Source^)<=127) then + repeat + dec(SourceChars); + PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC + inc(Source); + inc(Dest); + until (SourceChars=0) or (ord(Source^)>=128); + // rely on the Operating System for all remaining ASCII characters + if SourceChars=0 then + result := Dest else begin + {$ifdef MSWINDOWS} + result := Dest+MultiByteToWideChar( + fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); + {$else} + {$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar() + result := Dest+UnicodeFromLocaleChars( + fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); + {$else} + {$ifdef FPC} + // uses our SynFPCLinux ICU API helper + result := Dest+AnsiToWideICU(fCodePage,Source,Dest,SourceChars); + {$else} + {$ifdef KYLIX3} + result := Dest; // makes compiler happy + ic := LibC.iconv_open('UTF-16LE',Pointer(fIConvCodeName)); + if PtrInt(ic)>=0 then + try + result := IconvBufConvert(ic,Source,SourceChars,1, + Dest,SourceCharsBegin*2-(PAnsiChar(Dest)-DestBegin),2); + finally + LibC.iconv_close(ic); + end else + {$else} + raise ESynException.CreateUTF8('%.AnsiBufferToUnicode() not supported yet for CP=%', + [self,CodePage]); + {$endif KYLIX3} + {$endif FPC} + {$endif ISDELPHIXE} + {$endif MSWINDOWS} + end; + if not NoTrailingZero then + result^ := #0; +end; + +function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char; + Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; +var tmp: TSynTempBuffer; + c: cardinal; + U: PWideChar; +begin + // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) + if SourceChars>=4 then + repeat + c := PCardinal(Source)^; + if c and $80808080<>0 then + break; // break on first non ASCII quad + PCardinal(Dest)^ := c; + dec(SourceChars,4); + inc(Source,4); + inc(Dest,4); + until SourceChars<4; + if (SourceChars>0) and (ord(Source^)<=127) then + repeat + Dest^ := Source^; + dec(SourceChars); + inc(Source); + inc(Dest); + until (SourceChars=0) or (ord(Source^)>=128); + // rely on the Operating System for all remaining ASCII characters + if SourceChars=0 then + result := Dest else begin + U := AnsiBufferToUnicode(tmp.Init(SourceChars*3),Source,SourceChars); + result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,tmp.buf, + (PtrUInt(U)-PtrUInt(tmp.buf))shr 1,[ccfNoTrailingZero]); + tmp.Done; + end; + if not NoTrailingZero then + result^ := #0; +end; + +// UTF-8 is AT MOST 50% bigger than UTF-16 in bytes in range U+0800..U+FFFF +// see http://stackoverflow.com/a/7008095 -> bytes=WideCharCount*3 below + +procedure TSynAnsiConvert.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; + DestTextWriter: TObject; Escape: TTextWriterKind); +var W: TTextWriter absolute DestTextWriter; + tmp: TSynTempBuffer; +begin // rely on explicit conversion + SourceChars := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars)-PUTF8Char(tmp.buf); + W.Add(tmp.buf,SourceChars,Escape); + tmp.Done; +end; + +function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; +begin + result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText)); +end; + +function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; +var U: PWideChar; + tmp: TSynTempBuffer; +begin + if SourceChars=0 then + result := '' else begin + U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); + U^ := #0; + SetString(result,PAnsiChar(tmp.buf),PtrUInt(U)-PtrUInt(tmp.buf)+1); + tmp.Done; + end; +end; + +function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; +var tmp: TSynTempBuffer; + U: PWideChar; +begin + if SourceChars=0 then + result := '' else begin + U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); + SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); + tmp.Done; + end; +end; + +function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode; +var tmp: TSynTempBuffer; + U: PWideChar; +begin + if Source='' then + result := '' else begin + tmp.Init(length(Source)*2); // max dest size in bytes + U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source)); + SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); + tmp.Done; + end; +end; + +function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; +begin + result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText)); +end; + +function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; +var tmp: TSynTempBuffer; + endchar: pointer; // try circumvent Delphi 10.4 optimization issue +begin + if (Source=nil) or (SourceChars=0) then + result := '' else begin + endchar := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars,true); + tmp.Done(endchar,result); + end; +end; + +constructor TSynAnsiConvert.Create(aCodePage: cardinal); +begin + fCodePage := aCodePage; + fAnsiCharShift := 1; // default is safe + {$ifdef KYLIX3} + fIConvCodeName := 'CP'+UInt32ToUTF8(aCodePage); + {$endif} +end; + +function IsFixedWidthCodePage(aCodePage: cardinal): boolean; +begin + result := ((aCodePage>=1250) and (aCodePage<=1258)) or + (aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING); +end; + +class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert; +var i: PtrInt; +begin + if SynAnsiConvertList=nil then begin + GarbageCollectorFreeAndNil(SynAnsiConvertList,TSynObjectList.Create); + CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP); + WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth; + UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8; + end; + if aCodePage<=0 then begin + result := CurrentAnsiConvert; + exit; + end; + with SynAnsiConvertList do + for i := 0 to Count-1 do begin + result := List[i]; + if result.CodePage=aCodePage then + exit; + end; + if aCodePage=CP_UTF8 then + result := TSynAnsiUTF8.Create(CP_UTF8) else + if aCodePage=CP_UTF16 then + result := TSynAnsiUTF16.Create(CP_UTF16) else + if IsFixedWidthCodePage(aCodePage) then + result := TSynAnsiFixedWidth.Create(aCodePage) else + result := TSynAnsiConvert.Create(aCodePage); + SynAnsiConvertList.Add(result); +end; + +function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; +var c: cardinal; +{$ifndef MSWINDOWS} +{$ifdef KYLIX3} + ic: iconv_t; + DestBegin: PAnsiChar; + SourceCharsBegin: integer; +{$endif} +{$endif MSWINDOWS} +begin + {$ifdef KYLIX3} + SourceCharsBegin := SourceChars; + DestBegin := Dest; + {$endif} + // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) + if SourceChars>=2 then + repeat + c := PCardinal(Source)^; + if c and $ff80ff80<>0 then + break; // break on first non ASCII pair + dec(SourceChars,2); + inc(Source,2); + c := c shr 8 or c; + PWord(Dest)^ := c; + inc(Dest,2); + until SourceChars<2; + if (SourceChars>0) and (ord(Source^)<=127) then + repeat + Dest^ := AnsiChar(ord(Source^)); + dec(SourceChars); + inc(Source); + inc(Dest); + until (SourceChars=0) or (ord(Source^)>=128); + // rely on the Operating System for all remaining ASCII characters + if SourceChars=0 then + result := Dest else begin + {$ifdef MSWINDOWS} + result := Dest+WideCharToMultiByte( + fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); + {$else} + {$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte() + result := Dest+System.LocaleCharsFromUnicode( + fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); + {$else} + {$ifdef FPC} + // uses our SynFPCLinux ICU API helper + result := Dest+WideToAnsiICU(fCodePage,Source,Dest,SourceChars); + {$else} + {$ifdef KYLIX3} + result := Dest; // makes compiler happy + ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE'); + if PtrInt(ic)>=0 then + try + result := IconvBufConvert(ic,Source,SourceChars,2, + Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1); + finally + LibC.iconv_close(ic); + end else + {$else} + raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%', + [self,CodePage]); {$endif KYLIX3} + {$endif FPC} + {$endif ISDELPHIXE} + {$endif MSWINDOWS} + end; +end; + +function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar; + Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; +var tmp: TSynTempBuffer; +begin + if (Source=nil) or (SourceChars=0) then + result := Dest else begin + tmp.Init((SourceChars+1) shl fAnsiCharShift); + result := UnicodeBufferToAnsi(Dest,tmp.buf,UTF8ToWideChar(tmp.buf,Source,SourceChars) shr 1); + tmp.Done; + end; +end; + +function TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; + SourceChars: Cardinal): RawByteString; +begin + UTF8BufferToAnsi(Source,SourceChars,result); +end; + +procedure TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; + var result: RawByteString); +var tmp: TSynTempBuffer; +begin + if (Source=nil) or (SourceChars=0) then + result := '' else begin + tmp.Init((SourceChars+1) shl fAnsiCharShift); + FastSetStringCP(result,tmp.buf, + Utf8BufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); + tmp.Done; + end; +end; + +function TSynAnsiConvert.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; +begin + UTF8BufferToAnsi(pointer(UTF8),length(UTF8),result); +end; + +function TSynAnsiConvert.Utf8ToAnsiBuffer(const S: RawUTF8; + Dest: PAnsiChar; DestSize: integer): integer; +var tmp: array[0..2047] of AnsiChar; // truncated to 2KB as documented +begin + if (DestSize<=0) or (Dest=nil) then begin + result := 0; + exit; + end; + result := length(s); + if result>0 then begin + if result>SizeOf(tmp) then + result := SizeOf(tmp); + result := UTF8BufferToAnsi(tmp,pointer(s),result)-tmp; + if result>=DestSize then + result := DestSize-1; + MoveFast(tmp,Dest^,result); + end; + Dest[result] := #0; +end; + +function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; +var tmp: TSynTempBuffer; +begin + if (Source=nil) or (SourceChars=0) then + result := '' else begin + tmp.Init((SourceChars+1) shl fAnsiCharShift); + FastSetStringCP(result,tmp.buf, + UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); + tmp.Done; + end; +end; + +function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; +begin + result := UnicodeBufferToAnsi(pointer(Source),length(Source) shr 1); +end; + +function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; +begin + if From=self then + result := Source else + result := AnsiToAnsi(From,pointer(Source),length(Source)); +end; + +function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; +var tmpU: array[byte] of WideChar; + U: PWideChar; +begin + if From=self then + FastSetStringCP(result,Source,SourceChars,fCodePage) else + if (Source=nil) or (SourceChars=0) then + result := '' else + if SourceCharsnil) and (SourceChars>0) then begin + // handle 7 bit ASCII WideChars, by quads (Sha optimization) + EndSource := Source+SourceChars; + EndSourceBy4 := EndSource-4; + if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then + repeat +By4: c := PCardinal(Source)^; + if c and $80808080<>0 then + goto By1; // break on first non ASCII quad + inc(Source,4); + PCardinal(Dest)^ := c; + inc(Dest,4); + until Source>EndSourceBy4; + // generic loop, handling one WideChar per iteration + if Source$7ff then begin + Dest[0] := AnsiChar($E0 or (c shr 12)); + Dest[1] := AnsiChar($80 or ((c shr 6) and $3F)); + Dest[2] := AnsiChar($80 or (c and $3F)); + Inc(Dest,3); + if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4; + if Source 255 + // - values taken from MultiByteToWideChar(1252,0,@Tmp,256,@WinAnsiTable,256) + // so these values are available outside the Windows platforms (e.g. Linux/BSD) + // and even if registry has been tweaked as such: + // http://www.fas.harvard.edu/~chgis/data/chgis/downloads/v4/howto/cyrillic.html + WinAnsiUnicodeChars: packed array[128..159] of word = + (8364, 129, 8218, 402, 8222, 8230, 8224, 8225, 710, 8240, 352, 8249, 338, + 141, 381, 143, 144, 8216, 8217, 8220, 8221, 8226, 8211, 8212, 732, 8482, + 353, 8250, 339, 157, 382, 376); + +constructor TSynAnsiFixedWidth.Create(aCodePage: cardinal); +var i: PtrInt; + A256: array[0..256] of AnsiChar; + U256: array[0..256] of WideChar; // AnsiBufferToUnicode() write a last #0 +begin + inherited; + if not IsFixedWidthCodePage(aCodePage) then + // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here + raise ESynException.CreateFmt('%s.Create - Invalid code page %d', + [ClassName,fCodePage]); + // create internal look-up tables + SetLength(fAnsiToWide,256); + if (aCodePage=CODEPAGE_US) or (aCodePage=CODEPAGE_LATIN1) or + (aCodePage=CP_RAWBYTESTRING) then begin + for i := 0 to 255 do + fAnsiToWide[i] := i; + if aCodePage=CODEPAGE_US then // do not trust the Windows API :( + for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do + fAnsiToWide[i] := WinAnsiUnicodeChars[i]; + end else begin // from Operating System returned values + for i := 0 to 255 do + A256[i] := AnsiChar(i); + FillcharFast(U256,SizeOf(U256),0); + if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then + // warning: CreateUTF8() uses UTF8ToString() -> use CreateFmt() now + raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]); + MoveFast(U256[0],fAnsiToWide[0],512); + end; + SetLength(fWideToAnsi,65536); + for i := 1 to 126 do + fWideToAnsi[i] := i; + FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char + for i := 127 to 255 do + if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then + fWideToAnsi[fAnsiToWide[i]] := i; + // fixed width Ansi will never be bigger than UTF-8 + fAnsiCharShift := 0; +end; + +function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; +var i: PtrInt; + wc: PtrUInt; +begin + result := false; + if WideText<>nil then + for i := 0 to Length-1 do begin + wc := PtrUInt(WideText[i]); + if wc=0 then + break else + if wc<256 then + if fAnsiToWide[wc]<256 then + continue else + exit else + if fWideToAnsi[wc]=ord('?') then + exit else + continue; + end; + result := true; +end; + +function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean; +var wc: PtrUInt; +begin + result := false; + if WideText<>nil then + repeat + wc := PtrUInt(WideText^); + inc(WideText); + if wc=0 then + break else + if wc<256 then + if fAnsiToWide[wc]<256 then + continue else + exit else + if fWideToAnsi[wc]=ord('?') then + exit else + continue; + until false; + result := true; +end; + +function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean; +var c: PtrUInt; + i, extra: PtrInt; +begin + result := false; + if UTF8Text<>nil then + repeat + c := byte(UTF8Text^); + inc(UTF8Text); + if c=0 then break else + if c<=127 then + continue else begin + extra := UTF8_EXTRABYTES[c]; + if UTF8_EXTRA[extra].minimum>$ffff then + exit; + for i := 1 to extra do begin + if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content + c := c shl 6+byte(UTF8Text^); + inc(UTF8Text); + end; + dec(c,UTF8_EXTRA[extra].offset); + if (c>$ffff) or (fWideToAnsi[c]=ord('?')) then + exit; // invalid char in the WinAnsi code page + end; + until false; + result := true; +end; + +function TSynAnsiFixedWidth.IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; +var c: PtrUInt; + i, extra: PtrInt; +begin + result := false; + if UTF8Text<>nil then + repeat + c := byte(UTF8Text^); + inc(UTF8Text); + if c=0 then break else + if c<=127 then + continue else begin + extra := UTF8_EXTRABYTES[c]; + if UTF8_EXTRA[extra].minimum>$ffff then + exit; + for i := 1 to extra do begin + if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content + c := c shl 6+byte(UTF8Text^); + inc(UTF8Text); + end; + dec(c,UTF8_EXTRA[extra].offset); + if (c>255) or (fAnsiToWide[c]>255) then + exit; // not 8 bit char (like "tm" or such) is marked invalid + end; + until false; + result := true; +end; + +function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; +var c: cardinal; + tab: PAnsiChar; +begin + // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) + if SourceChars>=2 then + repeat + c := PCardinal(Source)^; + if c and $ff80ff80<>0 then + break; // break on first non ASCII pair + dec(SourceChars,2); + inc(Source,2); + c := c shr 8 or c; + PWord(Dest)^ := c; + inc(Dest,2); + until SourceChars<2; + // use internal lookup tables for fast process of remaining chars + tab := pointer(fWideToAnsi); + for c := 1 to SourceChars shr 2 do begin + Dest[0] := tab[Ord(Source[0])]; + Dest[1] := tab[Ord(Source[1])]; + Dest[2] := tab[Ord(Source[2])]; + Dest[3] := tab[Ord(Source[3])]; + inc(Source,4); + inc(Dest,4); + end; + for c := 1 to SourceChars and 3 do begin + Dest^ := tab[Ord(Source^)]; + inc(Dest); + inc(Source); + end; + result := Dest; +end; + +function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar; + Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; +var c: cardinal; + endSource, endSourceBy4: PUTF8Char; + i,extra: integer; +label By1, By4, Quit; // ugly but faster +begin + // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) + endSource := Source+SourceChars; + endSourceBy4 := endSource-4; + if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then + repeat +By4: c := PCardinal(Source)^; + if c and $80808080<>0 then + goto By1; // break on first non ASCII quad + PCardinal(Dest)^ := c; + inc(Source,4); + inc(Dest,4); + until Source>endSourceBy4; + // generic loop, handling one UTF-8 code per iteration + if SourceendSource) then break; + for i := 1 to extra do begin + if byte(Source^) and $c0<>$80 then + goto Quit; // invalid UTF-8 content + c := c shl 6+byte(Source^); + inc(Source); + end; + dec(c,UTF8_EXTRA[extra].offset); + if c>$ffff then + Dest^ := '?' else // '?' as in unknown fWideToAnsi[] items + Dest^ := AnsiChar(fWideToAnsi[c]); + inc(Dest); + if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then goto By4; + if SourceCP_UTF8 then + raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); + inherited Create(aCodePage); +end; + +function TSynAnsiUTF8.UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; +begin + result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),DestChars,Source,SourceChars, + [ccfNoTrailingZero]); +end; + +function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; +begin + result := UnicodeBufferToUTF8(Dest,SourceChars,Source,SourceChars); +end; + +function TSynAnsiUTF8.UnicodeBufferToAnsi(Source: PWideChar; + SourceChars: Cardinal): RawByteString; +var tmp: TSynTempBuffer; +begin + if (Source=nil) or (SourceChars=0) then + result := '' else begin + tmp.Init(SourceChars*3); + FastSetStringCP(result,tmp.buf,UnicodeBufferToUTF8(tmp.buf, + SourceChars*3,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); + tmp.Done; + end; +end; + +function TSynAnsiUTF8.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; +begin + MoveFast(Source^,Dest^,SourceChars); + result := Dest+SourceChars; +end; + +procedure TSynAnsiUTF8.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; + var result: RawByteString); +begin + FastSetString(RawUTF8(result),Source,SourceChars); +end; + +function TSynAnsiUTF8.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; +begin + result := UTF8; + {$ifdef HASCODEPAGE} + SetCodePage(result,CP_UTF8,false); + {$endif} +end; + +function TSynAnsiUTF8.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; +begin + result := AnsiText; + {$ifdef HASCODEPAGE} + SetCodePage(RawByteString(result),CP_UTF8,false); + {$endif} +end; + +function TSynAnsiUTF8.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; +begin + FastSetString(Result,Source,SourceChars); +end; + + +{ TSynAnsiUTF16 } + +function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar; + Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; +begin + MoveFast(Source^,Dest^,SourceChars); + result := Pointer(PtrUInt(Dest)+SourceChars); + if not NoTrailingZero then + result^ := #0; +end; + +const + NOTRAILING: array[boolean] of TCharConversionFlags = + ([],[ccfNoTrailingZero]); + +function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; + SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; +begin + SourceChars := SourceChars shr 1; // from byte count to WideChar count + result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3, + PWideChar(Source),SourceChars,NOTRAILING[NoTrailingZero]); +end; + +function TSynAnsiUTF16.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; +begin + SetString(result,Source,SourceChars); // byte count +end; + +constructor TSynAnsiUTF16.Create(aCodePage: cardinal); +begin + if aCodePage<>CP_UTF16 then + raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); + inherited Create(aCodePage); +end; + +function TSynAnsiUTF16.UnicodeBufferToAnsi(Dest: PAnsiChar; + Source: PWideChar; SourceChars: Cardinal): PAnsiChar; +begin + SourceChars := SourceChars shl 1; // from WideChar count to byte count + MoveFast(Source^,Dest^,SourceChars); + result := Dest+SourceChars; +end; + +function TSynAnsiUTF16.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; + SourceChars: Cardinal): PAnsiChar; +begin + result := Dest+UTF8ToWideChar(PWideChar(Dest),Source,SourceChars,true); +end; + + +function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; +begin + if aWideChar<=$7F then begin + Dest^ := AnsiChar(aWideChar); + result := 1; + end else + if aWideChar>$7ff then begin + Dest[0] := AnsiChar($E0 or (aWideChar shr 12)); + Dest[1] := AnsiChar($80 or ((aWideChar shr 6) and $3F)); + Dest[2] := AnsiChar($80 or (aWideChar and $3F)); + result := 3; + end else begin + Dest[0] := AnsiChar($C0 or (aWideChar shr 6)); + Dest[1] := AnsiChar($80 or (aWideChar and $3F)); + result := 2; + end; +end; + +function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; +var c: cardinal; + j: integer; +begin + c := Source^; + inc(Source); + case c of + 0..$7f: begin + Dest^ := AnsiChar(c); + result := 1; + exit; + end; + UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin + c := ((c-$D7C0)shl 10)+(Source^ xor UTF16_LOSURROGATE_MIN); + inc(Source); + end; + UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin + c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); + inc(Source); + end; + end; // now c is the UTF-32/UCS4 code point + case c of + 0..$7ff: result := 2; + $800..$ffff: result := 3; + $10000..$1FFFFF: result := 4; + $200000..$3FFFFFF: result := 5; + else result := 6; + end; + for j := result-1 downto 1 do begin + Dest[j] := AnsiChar((c and $3f)+$80); + c := c shr 6; + end; + Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[result]); +end; + +function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; +var j: integer; +begin + case ucs4 of + 0..$7f: begin + Dest^ := AnsiChar(ucs4); + result := 1; + exit; + end; + $80..$7ff: result := 2; + $800..$ffff: result := 3; + $10000..$1FFFFF: result := 4; + $200000..$3FFFFFF: result := 5; + else result := 6; + end; + for j := result-1 downto 1 do begin + Dest[j] := AnsiChar((ucs4 and $3f)+$80); + ucs4 := ucs4 shr 6; + end; + Dest^ := AnsiChar(Byte(ucs4) or UTF8_FIRSTBYTE[result]); +end; + +procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); +{$ifdef HASCODEPAGE}var CodePage: Cardinal;{$endif} +begin + if s='' then + result := '' else begin + {$ifdef HASCODEPAGE} + CodePage := StringCodePage(s); + if (CodePage=CP_UTF8) or (CodePage=CP_RAWBYTESTRING) then + result := s else + result := TSynAnsiConvert.Engine(CodePage). + {$else} + result := CurrentAnsiConvert. + {$endif} + AnsiBufferToRawUTF8(pointer(s),length(s)); + end; +end; + +function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; +begin + AnyAnsiToUTF8(s,result); +end; + +function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; +begin + result := WinAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); +end; + +function ShortStringToUTF8(const source: ShortString): RawUTF8; +begin + result := WinAnsiConvert.AnsiBufferToRawUTF8(@source[1],ord(source[0])); +end; + +procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); +var L: PtrInt; +begin + L := length(S); + if L<>0 then begin + if L>=DestLen then + L := DestLen-1; // truncate to avoid buffer overflow + WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0 + end else + Dest^[0] := 0; +end; + +function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; +begin + result := WinAnsiConvert.AnsiToRawUnicode(S); +end; + +function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; +begin + result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s)); +end; + +function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; +begin + result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen); +end; + +function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; +begin + wc := WinAnsiConvert.WideCharToAnsiChar(wc); + if integer(wc)=-1 then + result := '?' else + result := AnsiChar(wc); +end; + +function WideCharToWinAnsi(wc: cardinal): integer; +begin + result := WinAnsiConvert.WideCharToAnsiChar(wc); +end; + +function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; +begin + result := WinAnsiConvert.IsValidAnsi(WideText,Length); +end; + +function IsAnsiCompatible(PC: PAnsiChar): boolean; +begin + result := false; + if PC<>nil then + while true do + if PC^=#0 then + break else + if PC^<=#127 then + inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used + exit; + result := true; +end; + +function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; +begin + if PC<>nil then begin + result := false; + Len := PtrUInt(@PC[Len-4]); + if Len>=PtrUInt(PC) then + repeat + if PCardinal(PC)^ and $80808080<>0 then + exit; + inc(PC,4); + until LenPtrUInt(PC) then + repeat + if PC^>=#127 then + exit; + inc(PC); + until Len<=PtrUInt(PC); + end; + result := true; +end; + +function IsAnsiCompatible(const Text: RawByteString): boolean; +begin + result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text)); +end; + +function IsAnsiCompatibleW(PW: PWideChar): boolean; +begin + result := false; + if PW<>nil then + while true do + if ord(PW^)=0 then + break else + if ord(PW^)<=127 then + inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used + exit; + result := true; +end; + +function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; +var i: PtrInt; +begin + result := false; + if PW<>nil then + for i := 0 to Len-1 do + if ord(PW[i])>127 then + exit; + result := true; +end; + +function IsWinAnsi(WideText: PWideChar): boolean; +begin + result := WinAnsiConvert.IsValidAnsi(WideText); +end; + +function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; +begin + result := WinAnsiConvert.IsValidAnsiU(UTF8Text); +end; + +function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; +begin + result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text); +end; + +function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; +begin + result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest; +end; + +function ShortStringToAnsi7String(const source: shortstring): RawByteString; +begin + FastSetString(RawUTF8(result),@source[1],ord(source[0])); +end; + +procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); +begin + FastSetString(result,@source[1],ord(source[0])); +end; + +procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); +var c: cardinal; + len,extra,i: integer; +begin + len := 0; + if source<>nil then + repeat + c := byte(source^); inc(source); + if c=0 then break else + if c<=127 then begin + inc(len); dest[len] := AnsiChar(c); + if len<253 then continue else break; + end else begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then break; // invalid leading byte + for i := 1 to extra do begin + if byte(source^) and $c0<>$80 then begin + dest[0] := AnsiChar(len); + exit; // invalid UTF-8 content + end; + c := c shl 6+byte(source^); + inc(Source); + end; + dec(c,UTF8_EXTRA[extra].offset); + // #256.. -> slower but accurate conversion + inc(len); + if c>$ffff then + dest[len] := '?' else + dest[len] := AnsiChar(WinAnsiConvert.fWideToAnsi[c]); + if len<253 then continue else break; + end; + until false; + dest[0] := AnsiChar(len); +end; + +function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; +begin + result := WinAnsiConvert.UTF8ToAnsi(S); +end; + +function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; +begin + result := WinAnsiConvert.UTF8ToAnsi(P); +end; + +procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); +begin // fast and Delphi 2009+ ready + FastSetString(result,P,StrLen(P)); +end; + +function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; + MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt; +// faster than System.Utf8ToUnicode() +var c: cardinal; + begd: PWideChar; + endSource: PUTF8Char; + endDest: PWideChar; + i,extra: integer; +label Quit, NoSource; +begin + result := 0; + if dest=nil then + exit; + if source=nil then + goto NoSource; + if sourceBytes=0 then begin + if source^=#0 then + goto NoSource; + sourceBytes := StrLen(source); + end; + endSource := source+sourceBytes; + endDest := dest+MaxDestChars; + begd := dest; + repeat + c := byte(source^); + inc(source); + if c<=127 then begin + PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC + inc(dest); + if (sourceendSource) then break; + for i := 1 to extra do begin + if byte(Source^) and $c0<>$80 then + goto Quit; // invalid input content + c := c shl 6+byte(Source^); + inc(Source); + end; + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if c=endsource) or (dest>=endDest) then + break; + until false; +Quit: + result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return byte length +NoSource: + if not NoTrailingZero then + dest^ := #0; // always append a WideChar(0) to the end of the buffer +end; + +function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt; + NoTrailingZero: boolean): PtrInt; +// faster than System.UTF8Decode() +var c: cardinal; + begd: PWideChar; + endSource, endSourceBy4: PUTF8Char; + i,extra: PtrInt; +label Quit, NoSource, By1, By4; +begin + result := 0; + if dest=nil then + exit; + if source=nil then + goto NoSource; + if sourceBytes=0 then begin + if source^=#0 then + goto NoSource; + sourceBytes := StrLen(source); + end; + begd := dest; + endSource := Source+SourceBytes; + endSourceBy4 := endSource-4; + if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then + repeat // handle 7 bit ASCII chars, by quad (Sha optimization) +By4: c := PCardinal(Source)^; + if c and $80808080<>0 then + goto By1; // break on first non ASCII quad + inc(Source,4); + PCardinal(dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; + c := c shr 16; + PCardinal(dest+2)^ := (c shl 8 or c) and $00ff00ff; + inc(dest,4); + until Source>EndSourceBy4; + if SourceendSource) then break; + for i := 1 to extra do begin + if byte(Source^) and $c0<>$80 then + goto Quit; // invalid input content + c := c shl 6+byte(Source^); + inc(Source); + end; + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if c=endSource then break; + until false; +Quit: + result := PtrUInt(dest)-PtrUInt(begd); // dest-begd returns bytes length +NoSource: + if not NoTrailingZero then + dest^ := #0; // always append a WideChar(0) to the end of the buffer +end; + +function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; +var extra, i: integer; + c: cardinal; +begin + result := false; + if source<>nil then + repeat + c := byte(source^); + inc(source); + if c=0 then break else + if c<32 then exit else // disallow #1..#31 control char + if c and $80<>0 then begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + for i := 1 to extra do + if byte(source^) and $c0<>$80 then // invalid UTF-8 encoding + exit else + inc(source); + end; + until false; + result := true; +end; + +function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; +var s, extra, i, len: integer; + c: cardinal; +begin + result := false; + s := 1; + len := length(source); + while s<=len do begin + c := byte(source[s]); + inc(s); + if c<32 then exit else // disallow #0..#31 control char + if c and $80<>0 then begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + for i := 1 to extra do + if byte(source[s]) and $c0<>$80 then // reached #0 or invalid UTF-8 + exit else + inc(s); + end; + end; + result := true; +end; + + +function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; +var c: PtrUInt; + extra,i: integer; +begin + result := 0; + if source<>nil then + repeat + c := byte(source^); + inc(source); + if c=0 then break else + if c<=127 then + inc(result) else begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + if extra>=UTF8_EXTRA_SURROGATE then + inc(result,2) else + inc(result); + for i := 1 to extra do // inc(source,extra) is faster but not safe + if byte(source^) and $c0<>$80 then + exit else + inc(source); // check valid UTF-8 content + end; + until false; +end; + +function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUTF16: integer): boolean; +var c: PtrUInt; + extra,i: integer; + source: PUTF8Char; +begin + source := pointer(text); + if (source<>nil) and (cardinal(maxUtf16)=UTF8_EXTRA_SURROGATE then + dec(maxUTF16,2) else + dec(maxUTF16); + for i := 1 to extra do // inc(source,extra) is faster but not safe + if byte(source^) and $c0<>$80 then + break else + inc(source); // check valid UTF-8 content + end; + until false; + result := false; +end; + +function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; +begin + if PtrUInt(length(text))0) and (ord(text[maxBytes]) and $c0=$80) do dec(maxBytes); + if (maxBytes>0) and (ord(text[maxBytes]) and $80<>0) then dec(maxBytes); + SetLength(text,maxBytes); + result := true; +end; + +function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; +begin + result := length(text); + if PtrUInt(result)0) and (ord(text[result]) and $c0=$80) do dec(result); + if (result>0) and (ord(text[result]) and $80<>0) then dec(result); +end; + +function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; +begin + if textlen0) and (ord(text[result]) and $c0=$80) do dec(result); + if (result>0) and (ord(text[result]) and $80<>0) then dec(result); +end; + +function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; +var c,extra: PtrUInt; +begin + result := 0; + if source<>nil then + repeat + c := byte(source^); + inc(source); + if c in [0,10,13] then break else // #0, #10 or #13 stop the count + if c<=127 then + inc(result) else begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + if extra>=UTF8_EXTRA_SURROGATE then + inc(result,2) else + inc(result); + inc(source,extra); // a bit less safe, but faster + end; + until false; +end; + +function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; +var tmp: TSynTempBuffer; +begin + result := ''; // somewhat faster if result is freed before any SetLength() + if L=0 then + L := StrLen(P); + if L=0 then + exit; + // +1 below is for #0 ending -> true WideChar(#0) ending + tmp.Init(L*3); // maximum posible unicode size (if all <#128) + SetString(result,PAnsiChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L)+1); + tmp.Done; +end; + +function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; +begin + if S='' then + result := '' else + result := Utf8DecodeToRawUnicode(pointer(S),length(S)); +end; + +function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger): RawUnicode; +var L: integer; +begin + L := Utf8DecodeToRawUnicodeUI(S,result); + if DestLen<>nil then + DestLen^ := L; +end; + +function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; +begin + Dest := ''; // somewhat faster if Dest is freed before any SetLength() + if S='' then begin + result := 0; + exit; + end; + result := length(S); + SetLength(Dest,result*2+2); + result := UTF8ToWideChar(pointer(Dest),Pointer(S),result); +end; + +function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; + SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; +var c: Cardinal; + Tail: PWideChar; + i,j: integer; +label unmatch; +begin + result := PtrInt(Dest); + inc(DestLen,PtrInt(Dest)); + if (Source<>nil) and (Dest<>nil) then begin + // first handle 7 bit ASCII WideChars, by pairs (Sha optimization) + SourceLen := SourceLen*2+PtrInt(PtrUInt(Source)); + Tail := PWideChar(SourceLen)-2; + if (PtrInt(PtrUInt(Dest))0 then + break; // break on first non ASCII pair + inc(Source,2); + c := c shr 8 or c; + PWord(Dest)^ := c; + inc(Dest,2); + until (Source>Tail) or (PtrInt(PtrUInt(Dest))>=DestLen); + // generic loop, handling one UCS4 char per iteration + if (PtrInt(PtrUInt(Dest))=SourceLen) or + ((cardinal(Source^)UTF16_LOSURROGATE_MAX)) then begin +unmatch: if (PtrInt(PtrUInt(@Dest[3]))>DestLen) or + not (ccfReplacementCharacterForUnmatchedSurrogate in Flags) then + break; + PWord(Dest)^ := $BFEF; + Dest[2] := AnsiChar($BD); + inc(Dest,3); + if (PtrInt(PtrUInt(Dest))=SourceLen) or + ((cardinal(Source^)UTF16_HISURROGATE_MAX)) then + goto unmatch else begin + c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); + inc(Source); + end; + end; // now c is the UTF-32/UCS4 code point + case c of + 0..$7ff: i := 2; + $800..$ffff: i := 3; + $10000..$1FFFFF: i := 4; + $200000..$3FFFFFF: i := 5; + else i := 6; + end; + if PtrInt(PtrUInt(Dest))+i>DestLen then + break; + for j := i-1 downto 1 do begin + Dest[j] := AnsiChar((c and $3f)+$80); + c := c shr 6; + end; + Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[i]); + inc(Dest,i); + if (PtrInt(PtrUInt(Dest)) direct assign +end; +{$endif} + +function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; +begin + {$ifdef UNICODE} + Ansi7ToString(Text,Len,result); + {$else} + SetString(result,PAnsiChar(Text),Len); + {$endif} +end; + +procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); +{$ifdef UNICODE} +var i: PtrInt; +begin + SetString(result,nil,Len); + for i := 0 to Len-1 do + PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi +end; +{$else} +begin + SetString(result,PAnsiChar(Text),Len); +end; +{$endif} + +function StringToAnsi7(const Text: string): RawByteString; +{$ifdef UNICODE} +var i: PtrInt; +begin + SetString(result,nil,length(Text)); + for i := 0 to length(Text)-1 do + PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi +end; +{$else} +begin + result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign +end; +{$endif} + +function StringToWinAnsi(const Text: string): WinAnsiString; +begin + {$ifdef UNICODE} + result := RawUnicodeToWinAnsi(Pointer(Text),length(Text)); + {$else} + result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text); + {$endif} +end; + +function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; +begin + {$ifdef UNICODE} + result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars,[]); + {$else} + result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); + {$endif} +end; + +procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; +begin + {$ifdef UNICODE} + RawUnicodeToUtf8(Source,StrLenW(Source),result); + {$else} + result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Source,StrLen(Source)); + {$endif} +end; + +function StringToUTF8(const Text: string): RawUTF8; +begin + {$ifdef UNICODE} + RawUnicodeToUtf8(pointer(Text),length(Text),result); + {$else} + result := CurrentAnsiConvert.AnsiToUTF8(Text); + {$endif} +end; + +procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); +begin + {$ifdef UNICODE} + RawUnicodeToUtf8(Text,TextLen,result); + {$else} + result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Text, TextLen); + {$endif} +end; + +procedure StringToUTF8(const Text: string; var result: RawUTF8); +begin + {$ifdef UNICODE} + RawUnicodeToUtf8(pointer(Text),length(Text),result); + {$else} + result := CurrentAnsiConvert.AnsiToUTF8(Text); + {$endif} +end; + +function ToUTF8(const Text: string): RawUTF8; +begin + {$ifdef UNICODE} + RawUnicodeToUtf8(pointer(Text),length(Text),result); + {$else} + result := CurrentAnsiConvert.AnsiToUTF8(Text); + {$endif} +end; + +function ToUTF8(const Ansi7Text: ShortString): RawUTF8; +begin + FastSetString(result,@Ansi7Text[1],ord(Ansi7Text[0])); +end; + +function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; +begin + FastSetString(result,nil,36); + GUIDToText(pointer(result),@guid); +end; + + +{$ifdef HASVARUSTRING} // some UnicodeString dedicated functions +function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; +begin + RawUnicodeToUtf8(pointer(S),length(S),result); +end; + +function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; +begin + UTF8DecodeToUnicodeString(pointer(S),length(S),result); +end; + +procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); +var tmp: TSynTempBuffer; +begin + if (P=nil) or (L=0) then + result := '' else begin + tmp.Init(L*3); // maximum posible unicode size (if all <#128) + SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L) shr 1); + tmp.Done; + end; +end; + +function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; +begin + result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(S),length(S)); +end; + +function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; +begin + UTF8DecodeToUnicodeString(P,L,result); +end; + +function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; +begin + SetString(result,nil,WinAnsiLen); + WinAnsiConvert.AnsiBufferToUnicode(pointer(result),WinAnsi,WinAnsiLen); +end; + +function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; +begin + result := WinAnsiToUnicodeString(pointer(WinAnsi),length(WinAnsi)); +end; +{$endif HASVARUSTRING} + + +function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; +{$ifdef ABSOLUTEPASCALORNOTINTEL} +begin // fallback to pure pascal version for ARM or PIC + if val<0 then begin + result := StrUInt32(P,PtrUInt(-val))-1; + result^ := '-'; + end else + result := StrUInt32(P,val); +end; +{$else} +{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 +{$endif FPC} + {$ifndef win64} + mov rcx, rdi + mov rdx, rsi + {$endif win64} + mov r10, rdx + sar r10, 63 // r10=0 if val>=0 or -1 if val<0 + xor rdx, r10 + sub rdx, r10 // rdx=abs(val) + cmp rdx, 10 + jb @3 // direct process of common val<10 + mov rax, rdx + lea r8, [rip + TwoDigitLookup] +@s: lea rcx, [rcx - 2] + cmp rax, 100 + jb @2 + lea r9, [rax * 2] + shr rax, 2 + mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division + mul rdx + shr rdx, 2 + mov rax, rdx + imul rdx, -200 + lea rdx, [rdx + r8] + movzx rdx, word ptr[rdx + r9] + mov [rcx], dx + cmp rax, 10 + jae @s +@1: or al, '0' + mov byte ptr[rcx - 2], '-' + mov [rcx - 1], al + lea rax, [rcx + r10 - 1] // includes '-' if val<0 + ret +@2: movzx eax, word ptr[r8 + rax * 2] + mov byte ptr[rcx - 1], '-' + mov [rcx], ax + lea rax, [rcx + r10] // includes '-' if val<0 + ret +@3: or dl, '0' + mov byte ptr[rcx - 2], '-' + mov [rcx - 1], dl + lea rax, [rcx + r10 - 1] // includes '-' if val<0 +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=P, edx=val + mov ecx, edx + sar ecx, 31 // 0 if val>=0 or -1 if val<0 + push ecx + xor edx, ecx + sub edx, ecx // edx=abs(val) + cmp edx, 10 + jb @3 // direct process of common val<10 + push edi + mov edi, eax + mov eax, edx +@s: sub edi, 2 + cmp eax, 100 + jb @2 + mov ecx, eax + mov edx, 1374389535 // use power of two reciprocal to avoid division + mul edx + shr edx, 5 // now edx=eax div 100 + mov eax, edx + imul edx, -200 + movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] + mov [edi], dx + cmp eax, 10 + jae @s +@1: dec edi + or al, '0' + mov byte ptr[edi - 1], '-' + mov [edi], al + mov eax, edi + pop edi + pop ecx + add eax, ecx // includes '-' if val<0 + ret +@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] + mov byte ptr[edi - 1], '-' + mov [edi], ax + mov eax, edi + pop edi + pop ecx + add eax, ecx // includes '-' if val<0 + ret +@3: dec eax + pop ecx + or dl, '0' + mov byte ptr[eax - 1], '-' + mov [eax], dl + add eax, ecx // includes '-' if val<0 +end; +{$endif CPUX64} +{$endif ABSOLUTEPASCALORNOTINTEL} + +function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; +{$ifdef ABSOLUTEPASCALORNOTINTEL} // fallback to pure pascal version for ARM or PIC +var c100: PtrUInt; // val/c100 are QWord on 64-bit CPU + tab: PWordArray; +begin // this code is faster than Borland's original str() or IntToStr() + tab := @TwoDigitLookupW; + repeat + if val<10 then begin + dec(P); + P^ := AnsiChar(val+ord('0')); + break; + end else + if val<100 then begin + dec(P,2); + PWord(P)^ := tab[val]; + break; + end; + dec(P,2); + c100 := val div 100; + dec(val,c100*100); + PWord(P)^ := tab[val]; + val := c100; + if c100=0 then + break; + until false; + result := P; +end; +{$else} +{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 +{$endif FPC} + {$ifndef win64} + mov rcx, rdi + mov rdx, rsi + {$endif win64} + cmp rdx, 10 + jb @3 // direct process of common val<10 + mov rax, rdx + lea r8, [rip + TwoDigitLookup] +@s: lea rcx, [rcx - 2] + cmp rax, 100 + jb @2 + lea r9, [rax * 2] + shr rax, 2 + mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division + mul rdx + shr rdx, 2 + mov rax, rdx + imul rdx, -200 + add rdx, r8 + movzx rdx, word ptr[rdx + r9] + mov [rcx], dx + cmp rax, 10 + jae @s +@1: dec rcx + or al, '0' + mov [rcx], al +@0: mov rax, rcx + ret +@2: movzx eax, word ptr[r8 + rax * 2] + mov [rcx], ax + mov rax, rcx + ret +@3: lea rax, [rcx - 1] + or dl, '0' + mov [rax], dl +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=P, edx=val + cmp edx, 10 + jb @3 // direct process of common val=0 (or val<10) + push edi + mov edi, eax + mov eax, edx + nop + nop // @s loop alignment +@s: sub edi, 2 + cmp eax, 100 + jb @2 + mov ecx, eax + mov edx, 1374389535 // use power of two reciprocal to avoid division + mul edx + shr edx, 5 // now edx=eax div 100 + mov eax, edx + imul edx, -200 + movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] + mov [edi], dx + cmp eax, 10 + jae @s +@1: dec edi + or al, '0' + mov [edi], al + mov eax, edi + pop edi + ret +@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] + mov [edi], ax + mov eax, edi + pop edi + ret +@3: dec eax + or dl, '0' + mov [eax], dl +end; +{$endif CPU64} +{$endif ABSOLUTEPASCALORNOTINTEL} + +function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; +{$ifdef CPU64} +begin + result := StrUInt32(P,val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU +end; +{$else} +var c,c100: QWord; + tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin + if PInt64Rec(@val)^.Hi=0 then + P := StrUInt32(P,PCardinal(@val)^) else begin + {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} + c := val; + repeat + {$ifdef PUREPASCAL} + c100 := c div 100; // one div by two digits + dec(c,c100*100); // fast c := c mod 100 + {$else} + asm // by-passing the RTL is a good idea here + push ebx + mov edx, dword ptr[c + 4] + mov eax, dword ptr[c] + mov ebx, 100 + mov ecx, eax + mov eax, edx + xor edx, edx + div ebx + mov dword ptr[c100 + 4], eax + xchg eax, ecx + div ebx + mov dword ptr[c100], eax + imul ebx, ecx + mov ecx, 100 + mul ecx + add edx, ebx + pop ebx + sub dword ptr[c + 4], edx + sbb dword ptr[c], eax + end; + {$endif} + dec(P,2); + PWord(P)^ := tab[c]; + c := c100; + if PInt64Rec(@c)^.Hi=0 then begin + if PCardinal(@c)^<>0 then + P := StrUInt32(P,PCardinal(@c)^); + break; + end; + until false; + end; + result := P; +end; +{$endif} + +function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; +begin + {$ifdef CPU64} + result := StrInt32(P,val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU + {$else} + if val<0 then begin + P := StrUInt64(P,-val)-1; + P^ := '-'; + end else + P := StrUInt64(P,val); + result := P; + {$endif CPU64} +end; + +procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + if PtrUInt(Value)<=high(SmallUInt32UTF8) then + result := SmallUInt32UTF8[Value] else begin + P := StrInt32(@tmp[23],Value); + FastSetString(result,P,@tmp[23]-P); + end; +end; + +procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + {$ifdef CPU64} + if PtrUInt(Value)<=high(SmallUInt32UTF8) then + {$else} // Int64Rec gives compiler internal error C4963 + if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and + (PCardinalArray(@Value)^[1]=0) then + {$endif CPU64} + result := SmallUInt32UTF8[Value] else begin + P := {$ifdef CPU64}StrInt32{$else}StrInt64{$endif}(@tmp[23],Value); + FastSetString(result,P,@tmp[23]-P); + end; +end; + +procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + {$ifdef CPU64} + if Value<=high(SmallUInt32UTF8) then + {$else} // Int64Rec gives compiler internal error C4963 + if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and + (PCardinalArray(@Value)^[1]=0) then + {$endif CPU64} + result := SmallUInt32UTF8[Value] else begin + P := {$ifdef CPU64}StrUInt32{$else}StrUInt64{$endif}(@tmp[23],Value); + FastSetString(result,P,@tmp[23]-P); + end; +end; + +function ClassNameShort(C: TClass): PShortString; +// new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code +// with vmtClassName = UTF-8 encoded text stored in a shortstring = -44 +begin + result := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; +end; + +function ClassNameShort(Instance: TObject): PShortString; +begin + result := PPointer(PPtrInt(Instance)^+vmtClassName)^; +end; + +function ToText(C: TClass): RawUTF8; +var P: PShortString; +begin + if C=nil then + result := '' else begin + P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; + FastSetString(result,@P^[1],ord(P^[0])); + end; +end; + +procedure ToText(C: TClass; var result: RawUTF8); +var P: PShortString; +begin + if C=nil then + result := '' else begin + P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; + FastSetString(result,@P^[1],ord(P^[0])); + end; +end; + +function GetClassParent(C: TClass): TClass; +begin + result := PPointer(PtrInt(PtrUInt(C))+vmtParent)^; + {$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC + if result<>nil then + result := PPointer(result)^; + {$endif HASDIRECTTYPEINFO} +end; + +function VarRecAsChar(const V: TVarRec): integer; +begin + case V.VType of + vtChar: result := ord(V.VChar); + vtWideChar: result := ord(V.VWideChar); + else result := 0; + end; +end; + +function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; +begin + case V.VType of + vtInteger: value := V.VInteger; + vtInt64 {$ifdef FPC}, vtQWord{$endif}: value := V.VInt64^; + vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize + {$ifndef NOVARIANTS} + vtVariant: value := V.VVariant^; + {$endif} + else begin + result := false; + exit; + end; + end; + result := true; +end; + +function VarRecToDouble(const V: TVarRec; out value: double): boolean; +begin + case V.VType of + vtInteger: value := V.VInteger; + vtInt64: value := V.VInt64^; + {$ifdef FPC} + vtQWord: value := V.VQWord^; + {$endif} + vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize + vtExtended: value := V.VExtended^; + vtCurrency: value := V.VCurrency^; + {$ifndef NOVARIANTS} + vtVariant: value := V.VVariant^; + {$endif} + else begin + result := false; + exit; + end; + end; + result := true; +end; + +function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; +{$ifndef NOVARIANTS} +var v64: Int64; + isString: boolean; +{$endif} +label smlu32; +begin + Res.TempRawUTF8 := nil; // avoid GPF + case V.VType of + vtString: begin + Res.Text := @V.VString^[1]; + Res.Len := ord(V.VString^[0]); + result := Res.Len; + exit; + end; + vtAnsiString: begin // expect UTF-8 content + Res.Text := pointer(V.VAnsiString); + Res.Len := length(RawUTF8(V.VAnsiString)); + result := Res.Len; + exit; + end; + {$ifdef HASVARUSTRING} + vtUnicodeString: + RawUnicodeToUtf8(V.VPWideChar,length(UnicodeString(V.VUnicodeString)),RawUTF8(Res.TempRawUTF8)); + {$endif} + vtWideString: + RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),RawUTF8(Res.TempRawUTF8)); + vtPChar: begin // expect UTF-8 content + Res.Text := V.VPointer; + Res.Len := StrLen(V.VPointer); + result := Res.Len; + exit; + end; + vtChar: begin + Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC) + Res.Text := @Res.Temp; + Res.Len := 1; + result := 1; + exit; + end; + vtPWideChar: + RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),RawUTF8(Res.TempRawUTF8)); + vtWideChar: + RawUnicodeToUtf8(@V.VWideChar,1,RawUTF8(Res.TempRawUTF8)); + vtBoolean: begin + if V.VBoolean then // normalize + Res.Text := pointer(SmallUInt32UTF8[1]) else + Res.Text := pointer(SmallUInt32UTF8[0]); + Res.Len := 1; + result := 1; + exit; + end; + vtInteger: begin + result := V.VInteger; + if cardinal(result)<=high(SmallUInt32UTF8) then begin +smlu32: Res.Text := pointer(SmallUInt32UTF8[result]); + Res.Len := PStrLen(Res.Text-_STRLEN)^; + end else begin + Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],result)); + Res.Len := @Res.Temp[23]-Res.Text; + end; + result := Res.Len; + exit; + end; + vtInt64: + if (PCardinalArray(V.VInt64)^[0]<=high(SmallUInt32UTF8)) and + (PCardinalArray(V.VInt64)^[1]=0) then begin + result := V.VInt64^; + goto smlu32; + end else begin + Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^)); + Res.Len := @Res.Temp[23]-Res.Text; + result := Res.Len; + exit; + end; + {$ifdef FPC} + vtQWord: + if V.VQWord^<=high(SmallUInt32UTF8) then begin + result := V.VQWord^; + goto smlu32; + end else begin + Res.Text := PUTF8Char(StrUInt64(@Res.Temp[23],V.VQWord^)); + Res.Len := @Res.Temp[23]-Res.Text; + result := Res.Len; + exit; + end; + {$endif} + vtCurrency: begin + Res.Text := @Res.Temp; + Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp); + result := Res.Len; + exit; + end; + vtExtended: + DoubleToStr(V.VExtended^,RawUTF8(Res.TempRawUTF8)); + vtPointer,vtInterface: begin + Res.Text := @Res.Temp; + Res.Len := SizeOf(pointer)*2; + BinToHexDisplayLower(@V.VPointer,@Res.Temp,SizeOf(Pointer)); + result := SizeOf(pointer)*2; + exit; + end; + vtClass: begin + if V.VClass<>nil then begin + Res.Text := PPUTF8Char(PtrInt(PtrUInt(V.VClass))+vmtClassName)^+1; + Res.Len := ord(Res.Text[-1]); + end else + Res.Len := 0; + result := Res.Len; + exit; + end; + vtObject: begin + if V.VObject<>nil then begin + Res.Text := PPUTF8Char(PPtrInt(V.VObject)^+vmtClassName)^+1; + Res.Len := ord(Res.Text[-1]); + end else + Res.Len := 0; + result := Res.Len; + exit; + end; + {$ifndef NOVARIANTS} + vtVariant: + if VariantToInt64(V.VVariant^,v64) then + if (PCardinalArray(@v64)^[0]<=high(SmallUInt32UTF8)) and + (PCardinalArray(@v64)^[1]=0) then begin + result := v64; + goto smlu32; + end else begin + Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],v64)); + Res.Len := @Res.Temp[23]-Res.Text; + result := Res.Len; + exit; + end else + VariantToUTF8(V.VVariant^,RawUTF8(Res.TempRawUTF8),isString); + {$endif} + else begin + Res.Len := 0; + result := 0; + exit; + end; + end; + Res.Text := Res.TempRawUTF8; + Res.Len := length(RawUTF8(Res.TempRawUTF8)); + result := Res.Len; +end; + +procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean); +var isString: boolean; +begin + isString := not (V.VType in [ + vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended]); + with V do + case V.VType of + vtString: + FastSetString(result,@VString^[1],ord(VString^[0])); + vtAnsiString: + result := RawUTF8(VAnsiString); // expect UTF-8 content + {$ifdef HASVARUSTRING} + vtUnicodeString: + RawUnicodeToUtf8(VUnicodeString,length(UnicodeString(VUnicodeString)),result); + {$endif} + vtWideString: + RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result); + vtPChar: + FastSetString(result,VPChar,StrLen(VPChar)); + vtChar: + FastSetString(result,PAnsiChar(@VChar),1); + vtPWideChar: + RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result); + vtWideChar: + RawUnicodeToUtf8(@VWideChar,1,result); + vtBoolean: + if VBoolean then // normalize + result := SmallUInt32UTF8[1] else + result := SmallUInt32UTF8[0]; + vtInteger: + Int32ToUtf8(VInteger,result); + vtInt64: + Int64ToUtf8(VInt64^,result); + {$ifdef FPC} + vtQWord: + UInt64ToUtf8(VQWord^,result); + {$endif} + vtCurrency: + Curr64ToStr(VInt64^,result); + vtExtended: + DoubleToStr(VExtended^,result); + vtPointer: + PointerToHex(VPointer,result); + vtClass: + if VClass<>nil then + ToText(VClass,result) else + result := ''; + vtObject: + if VObject<>nil then + ToText(PClass(VObject)^,result) else + result := ''; + vtInterface: + {$ifdef HASINTERFACEASTOBJECT} + if VInterface<>nil then + ToText((IInterface(VInterface) as TObject).ClassType,result) else + result := ''; + {$else} + PointerToHex(VInterface,result); + {$endif} + {$ifndef NOVARIANTS} + vtVariant: + VariantToUTF8(VVariant^,result,isString); + {$endif} + else begin + isString := false; + result := ''; + end; + end; + if wasString<>nil then + wasString^ := isString; +end; + +function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; +begin + VarRecToUTF8(V,value,@result); +end; + +procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); +var wasString: boolean; + tmp: RawUTF8; +begin + VarRecToUTF8(V,tmp,@wasString); + if wasString then + QuotedStr(tmp,'"',result) else + result := tmp; +end; + +{$ifdef UNICODE} +function StringToRawUnicode(const S: string): RawUnicode; +begin + SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0 +end; +function StringToSynUnicode(const S: string): SynUnicode; +begin + result := S; +end; +procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; +begin + result := S; +end; +function StringToRawUnicode(P: PChar; L: integer): RawUnicode; +begin + SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0 +end; +function RawUnicodeToString(P: PWideChar; L: integer): string; +begin + SetString(result,P,L); +end; +procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); +begin + SetString(result,P,L); +end; +function RawUnicodeToString(const U: RawUnicode): string; +begin // uses StrLenW() and not length(U) to handle case when was used as buffer + SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U))); +end; +function SynUnicodeToString(const U: SynUnicode): string; +begin + result := U; +end; +function UTF8DecodeToString(P: PUTF8Char; L: integer): string; +begin + UTF8DecodeToUnicodeString(P,L,result); +end; +procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); +begin + UTF8DecodeToUnicodeString(P,L,result); +end; +function UTF8ToString(const Text: RawUTF8): string; +begin + UTF8DecodeToUnicodeString(pointer(Text),length(Text),result); +end; +{$else} +function StringToRawUnicode(const S: string): RawUnicode; +begin + result := CurrentAnsiConvert.AnsiToRawUnicode(S); +end; +function StringToSynUnicode(const S: string): SynUnicode; +begin + result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); +end; +procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; +begin + result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); +end; +function StringToRawUnicode(P: PChar; L: integer): RawUnicode; +begin + result := CurrentAnsiConvert.AnsiToRawUnicode(P,L); +end; +function RawUnicodeToString(P: PWideChar; L: integer): string; +begin + result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); +end; +procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); +begin + result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); +end; +function RawUnicodeToString(const U: RawUnicode): string; +begin // uses StrLenW() and not length(U) to handle case when was used as buffer + result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U))); +end; +function SynUnicodeToString(const U: SynUnicode): string; +begin + result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U)); +end; +function UTF8DecodeToString(P: PUTF8Char; L: integer): string; +begin + CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); +end; +procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); +begin + CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); +end; +function UTF8ToString(const Text: RawUTF8): string; +begin + CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result)); +end; +{$endif UNICODE} + +procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); +begin + UTF8ToWideString(pointer(Text),Length(Text),result); +end; + +function UTF8ToWideString(const Text: RawUTF8): WideString; +begin + {$ifdef FPC} + Finalize(result); + {$endif FPC} + UTF8ToWideString(pointer(Text),Length(Text),result); +end; + +procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); +var tmp: TSynTempBuffer; +begin + if (Text=nil) or (Len=0) then + result := '' else begin + tmp.Init(Len*3); // maximum posible unicode size (if all <#128) + SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); + tmp.Done; + end; +end; + +function WideStringToUTF8(const aText: WideString): RawUTF8; +begin + RawUnicodeToUtf8(pointer(aText),length(aText),result); +end; + +function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; +begin + UTF8ToSynUnicode(pointer(Text),length(Text),result); +end; + +procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); +begin + UTF8ToSynUnicode(pointer(Text),length(Text),result); +end; + +procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); +var tmp: TSynTempBuffer; +begin + if (Text=nil) or (Len=0) then + result := '' else begin + tmp.Init(Len*3); // maximum posible unicode size (if all <#128) + SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); + tmp.Done; + end; +end; + + + +{ TRawUTF8InterningSlot } + +procedure TRawUTF8InterningSlot.Init; +begin + Safe.Init; + {$ifndef NOVARIANTS} + Safe.LockedInt64[0] := 0; + {$endif} + Values.Init(TypeInfo(TRawUTF8DynArray),Value,HashAnsiString, + SortDynArrayAnsiString,InterningHasher,@Safe.Padding[0].VInteger,false); +end; + +procedure TRawUTF8InterningSlot.Done; +begin + Safe.Done; +end; + +function TRawUTF8InterningSlot.Count: integer; +begin + {$ifdef NOVARIANTS} + result := Safe.Padding[0].VInteger; + {$else} + result := Safe.LockedInt64[0]; + {$endif} +end; + +procedure TRawUTF8InterningSlot.Unique(var aResult: RawUTF8; + const aText: RawUTF8; aTextHash: cardinal); +var i: PtrInt; + added: boolean; +begin + EnterCriticalSection(Safe.fSection); + try + i := Values.FindHashedForAdding(aText,added,aTextHash); + if added then begin + Value[i] := aText; // copy new value to the pool + aResult := aText; + end else + aResult := Value[i]; // return unified string instance + finally + LeaveCriticalSection(Safe.fSection); + end; +end; + +procedure TRawUTF8InterningSlot.UniqueText(var aText: RawUTF8; aTextHash: cardinal); +var i: PtrInt; + added: boolean; +begin + EnterCriticalSection(Safe.fSection); + try + i := Values.FindHashedForAdding(aText,added,aTextHash); + if added then + Value[i] := aText else // copy new value to the pool + aText := Value[i]; // return unified string instance + finally + LeaveCriticalSection(Safe.fSection); + end; +end; + +procedure TRawUTF8InterningSlot.Clear; +begin + EnterCriticalSection(Safe.fSection); + try + Values.SetCount(0); // Values.Clear + Values.Hasher.Clear; + finally + LeaveCriticalSection(Safe.fSection); + end; +end; + +function TRawUTF8InterningSlot.Clean(aMaxRefCount: integer): integer; +var i: integer; + s,d: PPtrUInt; // points to RawUTF8 values (bypass COW assignments) +begin + result := 0; + EnterCriticalSection(Safe.fSection); + try + if Safe.Padding[0].VInteger=0 then + exit; + s := pointer(Value); + d := s; + for i := 1 to Safe.Padding[0].VInteger do begin + if PStrCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin + {$ifdef FPC} + Finalize(PRawUTF8(s)^); + {$else} + PRawUTF8(s)^ := ''; + {$endif FPC} + inc(result); + end else begin + if s<>d then begin + d^ := s^; + s^ := 0; // avoid GPF + end; + inc(d); + end; + inc(s); + end; + if result>0 then begin + Values.SetCount((PtrUInt(d)-PtrUInt(Value))div SizeOf(d^)); + Values.ReHash; + end; + finally + LeaveCriticalSection(Safe.fSection); + end; +end; + + +{ TRawUTF8Interning } + +constructor TRawUTF8Interning.Create(aHashTables: integer); +var p: integer; + i: PtrInt; +begin + for p := 0 to 9 do + if aHashTables=1 shl p then begin + SetLength(fPool,aHashTables); + fPoolLast := aHashTables-1; + for i := 0 to fPoolLast do + fPool[i].Init; + exit; + end; + raise ESynException.CreateUTF8('%.Create(%) not allowed: should be a power of 2', + [self,aHashTables]); +end; + +destructor TRawUTF8Interning.Destroy; +var i: PtrInt; +begin + for i := 0 to fPoolLast do + fPool[i].Done; + inherited Destroy; +end; + +procedure TRawUTF8Interning.Clear; +var i: PtrInt; +begin + if self<>nil then + for i := 0 to fPoolLast do + fPool[i].Clear; +end; + +function TRawUTF8Interning.Clean(aMaxRefCount: integer): integer; +var i: PtrInt; +begin + result := 0; + if self<>nil then + for i := 0 to fPoolLast do + inc(result,fPool[i].Clean(aMaxRefCount)); +end; + +function TRawUTF8Interning.Count: integer; +var i: PtrInt; +begin + result := 0; + if self<>nil then + for i := 0 to fPoolLast do + inc(result,fPool[i].Count); +end; + +procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; const aText: RawUTF8); +var hash: cardinal; +begin + if aText='' then + aResult := '' else + if self=nil then + aResult := aText else begin + hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement + fPool[hash and fPoolLast].Unique(aResult,aText,hash); + end; +end; + +procedure TRawUTF8Interning.UniqueText(var aText: RawUTF8); +var hash: cardinal; +begin + if (self<>nil) and (aText<>'') then begin + hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement + fPool[hash and fPoolLast].UniqueText(aText,hash); + end; +end; + +function TRawUTF8Interning.Unique(const aText: RawUTF8): RawUTF8; +var hash: cardinal; +begin + if aText='' then + result := '' else + if self=nil then + result := aText else begin + hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement + fPool[hash and fPoolLast].Unique(result,aText,hash); + end; +end; + +function TRawUTF8Interning.Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; +begin + FastSetString(result,aText,aTextLen); + UniqueText(result); +end; + +procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; aText: PUTF8Char; + aTextLen: PtrInt); +begin + FastSetString(aResult,aText,aTextLen); + UniqueText(aResult); +end; + +procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline; {$endif} +var v: TVarData absolute Value; +begin + if cardinal(v.VType) = varString then + Finalize(RawByteString(v.VString)) + else + begin + VarClear(Value); + PInteger(@v.VType)^ := varString; + v.VString := nil; // to avoid GPF when assign a RawByteString + end; +end; + +{$ifndef NOVARIANTS} + +procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8); +begin + ClearVariantForString(aResult); + Unique(RawUTF8(TVarData(aResult).VAny),aText); +end; + +procedure TRawUTF8Interning.UniqueVariantString(var aResult: variant; const aText: string); +var tmp: RawUTF8; +begin + StringToUTF8(aText,tmp); + UniqueVariant(aResult,tmp); +end; + +procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; + aText: PUTF8Char; aTextLen: PtrInt; aAllowVarDouble: boolean); +var tmp: RawUTF8; +begin + if not GetNumericVariantFromJSON(aText,TVarData(aResult),aAllowVarDouble) then begin + FastSetString(tmp,aText,aTextLen); + UniqueVariant(aResult,tmp); + end; +end; + +procedure TRawUTF8Interning.UniqueVariant(var aResult: variant); +var vt: cardinal; +begin + vt := TVarData(aResult).VType; + with TVarData(aResult) do + if vt=varString then + UniqueText(RawUTF8(VString)) else + if vt=varVariant or varByRef then + UniqueVariant(PVariant(VPointer)^) else + if vt=varString or varByRef then + UniqueText(PRawUTF8(VPointer)^); +end; + +{$endif NOVARIANTS} + +const + // see https://en.wikipedia.org/wiki/Baudot_code + Baudot2Char: array[0..63] of AnsiChar = + #0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+ + #0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255; +var + Char2Baudot: array[AnsiChar] of byte; + +function AsciiToBaudot(const Text: RawUTF8): RawByteString; +begin + result := AsciiToBaudot(pointer(Text),length(Text)); +end; + +function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; +var i: PtrInt; + c,d,bits: integer; + shift: boolean; + dest: PByte; + tmp: TSynTempBuffer; +begin + result := ''; + if (P=nil) or (len=0) then + exit; + shift := false; + dest := tmp.Init((len*10)shr 3); + d := 0; + bits := 0; + for i := 0 to len-1 do begin + c := Char2Baudot[P[i]]; + if c>32 then begin + if not shift then begin + d := (d shl 5) or 27; + inc(bits,5); + shift := true; + end; + d := (d shl 5) or (c-32); + inc(bits,5); + end else + if c>0 then begin + if shift and (P[i]>=' ') then begin + d := (d shl 5) or 31; + inc(bits,5); + shift := false; + end; + d := (d shl 5) or c; + inc(bits,5); + end; + while bits>=8 do begin + dec(bits,8); + dest^ := d shr bits; + inc(dest); + end; + end; + if bits>0 then begin + dest^ := d shl (8-bits); + inc(dest); + end; + SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf)); + tmp.Done; +end; + +function BaudotToAscii(const Baudot: RawByteString): RawUTF8; +begin + result := BaudotToAscii(pointer(Baudot),length(Baudot)); +end; + +function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; +var i: PtrInt; + c,b,bits,shift: integer; + tmp: TSynTempBuffer; + dest: PAnsiChar; +begin + result := ''; + if (Baudot=nil) or (len<=0) then + exit; + dest := tmp.Init((len shl 3)div 5); + try + shift := 0; + b := 0; + bits := 0; + for i := 0 to len-1 do begin + b := (b shl 8) or Baudot[i]; + inc(bits,8); + while bits>=5 do begin + dec(bits,5); + c := (b shr bits) and 31; + case c of + 27: if shift<>0 then + exit else + shift := 32; + 31: if shift<>0 then + shift := 0 else + exit; + else begin + c := ord(Baudot2Char[c+shift]); + if c=0 then + if Baudot[i+1]=0 then // allow triming of last 5 bits + break else + exit; + dest^ := AnsiChar(c); + inc(dest); + end; + end; + end; + end; + finally + tmp.Done(dest,result); + end; +end; + +function IsVoid(const text: RawUTF8): boolean; +var i: PtrInt; +begin + result := false; + for i := 1 to length(text) do + if text[i]>' ' then + exit; + result := true; +end; + +function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet): RawUTF8; +var len,i,j,n: PtrInt; + P: PAnsiChar; +begin + len := length(text); + for i := 1 to len do + if text[i] in controls then begin + n := i-1; + FastSetString(result,nil,len); + P := pointer(result); + if n>0 then + MoveFast(pointer(text)^,P^,n); + for j := i+1 to len do + if not(text[j] in controls) then begin + P[n] := text[j]; + inc(n); + end; + SetLength(result,n); // truncate + exit; + end; + result := text; // no control char found +end; + +procedure ExchgPointer(n1,n2: PPointer); {$ifdef HASINLINE}inline;{$endif} +var n: pointer; +begin + n := n2^; + n2^ := n1^; + n1^ := n; +end; + +procedure ExchgVariant(v1,v2: PPtrIntArray); {$ifdef CPU64}inline;{$endif} +var c: PtrInt; // 32-bit:16bytes=4ptr 64-bit:24bytes=3ptr +begin + c := v2[0]; + v2[0] := v1[0]; + v1[0] := c; + c := v2[1]; + v2[1] := v1[1]; + v1[1] := c; + c := v2[2]; + v2[2] := v1[2]; + v1[2] := c; + {$ifdef CPU32} + c := v2[3]; + v2[3] := v1[3]; + v1[3] := c; + {$endif} +end; + +{$ifdef CPU64} +procedure Exchg16(P1,P2: PPtrIntArray); inline; +var c: PtrInt; +begin + c := P1[0]; + P1[0] := P2[0]; + P2[0] := c; + c := P1[1]; + P1[1] := P2[1]; + P2[1] := c; +end; +{$endif} + +procedure Exchg(P1,P2: PAnsiChar; count: PtrInt); + {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} +var i, c: PtrInt; + u: AnsiChar; +begin + for i := 1 to count shr POINTERSHR do begin + c := PPtrInt(P1)^; + PPtrInt(P1)^ := PPtrInt(P2)^; + PPtrInt(P2)^ := c; + inc(P1,SizeOf(c)); + inc(P2,SizeOf(c)); + end; + for i := 0 to (count and POINTERAND)-1 do begin + u := P1[i]; + P1[i] := P2[i]; + P2[i] := u; + end; +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=P1, edx=P2, ecx=count + push ebx + push esi + push ecx + shr ecx, 2 + jz @2 +@4: mov ebx, [eax] + mov esi, [edx] + mov [eax], esi + mov [edx], ebx + add eax, 4 + add edx, 4 + dec ecx + jnz @4 +@2: pop ecx + and ecx, 3 + jz @0 +@1: mov bl, [eax] + mov bh, [edx] + mov [eax], bh + mov [edx], bl + inc eax + inc edx + dec ecx + jnz @1 +@0: pop esi + pop ebx +end; +{$endif} + +function GetAllBits(Bits, BitCount: Cardinal): boolean; +begin + if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then begin + BitCount := ALLBITS_CARDINAL[BitCount]; + result := (Bits and BitCount)=BitCount; + end else + result := false; +end; + +// naive code gives the best performance - bts [Bits] has an overhead +function GetBit(const Bits; aIndex: PtrInt): boolean; +begin + result := PByteArray(@Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; +end; + +procedure SetBit(var Bits; aIndex: PtrInt); +begin + TByteArray(Bits)[aIndex shr 3] := TByteArray(Bits)[aIndex shr 3] + or (1 shl (aIndex and 7)); +end; + +procedure UnSetBit(var Bits; aIndex: PtrInt); +begin + PByteArray(@Bits)[aIndex shr 3] := PByteArray(@Bits)[aIndex shr 3] + and not (1 shl (aIndex and 7)); +end; + +function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; +begin + result := PByteArray(Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; +end; + +procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); +begin + PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] + or (1 shl (aIndex and 7)); +end; + +procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); +begin + PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] + and not (1 shl (aIndex and 7)); +end; + +function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; +begin + result := aIndex in TBits64(Bits); +end; + +procedure SetBit64(var Bits: Int64; aIndex: PtrInt); +begin + include(PBits64(@Bits)^,aIndex); +end; + +procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); +begin + exclude(PBits64(@Bits)^,aIndex); +end; + +function GetBitsCount(const Bits; Count: PtrInt): PtrInt; +var P: PPtrInt; + popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop +begin + P := @Bits; + result := 0; + popcnt := @GetBitsCountPtrInt; + if Count>=POINTERBITS then + repeat + dec(Count,POINTERBITS); + inc(result,popcnt(P^)); // use SSE4.2 if available + inc(P); + until Count0 then + inc(result,popcnt(P^ and ((PtrInt(1) shl Count)-1))); +end; + +{ FPC x86_64 Linux: + 1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s + 1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s + 1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s + 1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s + FPC i386 Windows: + 1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s + 1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s + 1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s + 1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s + notes: + 1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf + 2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm + whereas FPC RTL's popcnt() is much slower } + +{$ifdef CPUX86} +function GetBitsCountSSE42(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} +asm + {$ifdef FPC_X86ASM} + popcnt eax, eax + {$else} // oldest Delphi don't support this opcode + db $f3,$0f,$B8,$c0 + {$endif} +end; +function GetBitsCountPas(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // branchless Wilkes-Wheeler-Gill i386 asm implementation + mov edx, eax + shr eax, 1 + and eax, $55555555 + sub edx, eax + mov eax, edx + shr edx, 2 + and eax, $33333333 + and edx, $33333333 + add eax, edx + mov edx, eax + shr eax, 4 + add eax, edx + and eax, $0f0f0f0f + mov edx, eax + shr edx, 8 + add eax, edx + mov edx, eax + shr edx, 16 + add eax, edx + and eax, $3f +end; +{$else} +{$ifdef CPUX64} +function GetBitsCountSSE42(value: PtrInt): PtrInt; +{$ifdef FPC} assembler; nostackframe; +asm + popcnt rax, value +{$else} // oldest Delphi don't support this opcode +asm .noframe + {$ifdef win64} db $f3,$48,$0f,$B8,$c1 + {$else} db $f3,$48,$0f,$B8,$c7 {$endif} +{$endif FPC} +end; +function GetBitsCountPas(value: PtrInt): PtrInt; +{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} + mov rax, value + mov rdx, value + shr rax, 1 + mov rcx, $5555555555555555 + mov r8, $3333333333333333 + mov r10, $0f0f0f0f0f0f0f0f + mov r11, $0101010101010101 + and rax, rcx + sub rdx, rax + mov rax, rdx + shr rdx, 2 + and rax, r8 + and rdx, r8 + add rax, rdx + mov rdx, rax + shr rax, 4 + add rax, rdx + and rax, r10 + imul rax, r11 + shr rax, 56 +end; +{$else} +function GetBitsCountPas(value: PtrInt): PtrInt; +begin // generic branchless Wilkes-Wheeler-Gill pure pascal version + result := value; + {$ifdef CPU64} + result := result-((result shr 1) and $5555555555555555); + result := (result and $3333333333333333)+((result shr 2) and $3333333333333333); + result := (result+(result shr 4)) and $0f0f0f0f0f0f0f0f; + inc(result,result shr 8); // avoid slow multiplication on ARM + inc(result,result shr 16); + inc(result,result shr 32); + result := result and $7f; + {$else} + result := result-((result shr 1) and $55555555); + result := (result and $33333333)+((result shr 2) and $33333333); + result := (result+(result shr 4)) and $0f0f0f0f; + inc(result,result shr 8); + inc(result,result shr 16); + result := result and $3f; + {$endif CPU64} +end; +{$endif CPUX64} +{$endif CPUX86} + +type +{$ifdef FPC} + {$packrecords c} // as expected by FPC's RTTI record definitions + TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc + {$ifdef ISFPC27} + codePage: TSystemCodePage; // =Word + elemSize: Word; + {$ifndef STRCNT32} + {$ifdef CPU64} + _PaddingToQWord: DWord; + {$endif} {$endif} {$endif} + refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4 + length: SizeInt; + end; +{$else FPC} + /// map the Delphi/FPC dynamic array header (stored before each instance) + TDynArrayRec = packed record + {$ifdef CPUX64} + /// padding bytes for 16 byte alignment of the header + _Padding: LongInt; + {$endif} + /// dynamic array reference count (basic garbage memory mechanism) + refCnt: TDACnt; + /// length in element count + // - size in bytes = length*ElemSize + length: PtrInt; + end; + PDynArrayRec = ^TDynArrayRec; + + /// map the Delphi/FPC string header (stored before each instance) + TStrRec = packed record + {$ifdef UNICODE} + {$ifdef CPU64} + /// padding bytes for 16 bytes alignment of the header + _Padding: LongInt; + {$endif} + /// the associated code page used for this string + // - exist only since Delphi/FPC 2009 + // - 0 or 65535 for RawByteString + // - 1200=CP_UTF16 for UnicodeString + // - 65001=CP_UTF8 for RawUTF8 + // - the current code page for AnsiString + codePage: Word; + /// either 1 (for AnsiString) or 2 (for UnicodeString) + // - exist only since Delphi/FPC 2009 + elemSize: Word; + {$endif UNICODE} + /// COW string reference count (basic garbage memory mechanism) + refCnt: TStrCnt; + /// length in characters + // - size in bytes = length*elemSize + length: Longint; + end; +{$endif FPC} + PStrRec = ^TStrRec; + + PTypeInfo = ^TTypeInfo; + {$ifdef HASDIRECTTYPEINFO} // for old FPC (<=3.0) + PTypeInfoStored = PTypeInfo; + {$else} // e.g. for Delphi and newer FPC + PTypeInfoStored = ^PTypeInfo; // = TypeInfoPtr macro in FPC typinfo.pp + {$endif} + + // note: FPC TRecInitData is taken from typinfo.pp via SynFPCTypInfo + // since this information is evolving/breaking a lot in the current FPC trunk + + /// map the Delphi/FPC record field RTTI + TFieldInfo = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + TypeInfo: PTypeInfoStored; + {$ifdef FPC} + Offset: sizeint; + {$else} + Offset: PtrUInt; + {$endif FPC} + end; + PFieldInfo = ^TFieldInfo; + {$ifdef ISDELPHI2010_OR_FPC_NEWRTTI} + /// map the Delphi record field enhanced RTTI (available since Delphi 2010) + TEnhancedFieldInfo = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + TypeInfo: PTypeInfoStored; + {$ifdef FPC} + Offset: sizeint; // match TInitManagedField/TManagedField in FPC typinfo.pp + {$else} + Offset: PtrUInt; + {$endif FPC} + {$ifdef ISDELPHI2010} + Flags: Byte; + NameLen: byte; // = Name[0] = length(Name) + {$ENDIF} + end; + PEnhancedFieldInfo = ^TEnhancedFieldInfo; + {$endif} + + TTypeInfo = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + kind: TTypeKind; + NameLen: byte; + case TTypeKind of + tkUnknown: ( + NameFirst: AnsiChar; + ); + tkDynArray: ( + {$ifdef FPC} + elSize: SizeUInt; // and $7FFFFFFF = item/record size + elType2: PTypeInfoStored; + varType: LongInt; + elType: PTypeInfoStored; + //DynUnitName: ShortStringBase; + {$else} + // storage byte count for this field + elSize: Longint; + // nil for unmanaged field + elType: PTypeInfoStored; + // OleAuto compatible type + varType: Integer; + // also unmanaged field + elType2: PTypeInfoStored; + {$endif FPC} + ); + tkArray: ( + {$ifdef FPC} + // warning: in VER2_6, this is the element size, not full array size + arraySize: SizeInt; + // product of lengths of all dimensions + elCount: SizeInt; + {$else} + arraySize: Integer; + // product of lengths of all dimensions + elCount: Integer; + {$endif FPC} + arrayType: PTypeInfoStored; + dimCount: Byte; + dims: array[0..255 {DimCount-1}] of PTypeInfoStored; + ); + {$ifdef FPC} + tkRecord, tkObject:( + {$ifdef FPC_NEWRTTI} + RecInitInfo: Pointer; // call GetManagedFields() to use FPC's TypInfo.pp + recSize: longint; + {$else} + ManagedCount: longint; + ManagedFields: array[0..0] of TFieldInfo; + // note: FPC for 3.0.x and previous generates RTTI for unmanaged fields (as in TEnhancedFieldInfo) + {$endif FPC_NEWRTTI} + {$else} + tkRecord: ( + recSize: cardinal; + ManagedCount: integer; + ManagedFields: array[0..0] of TFieldInfo; + {$ifdef ISDELPHI2010} // enhanced RTTI containing info about all fields + NumOps: Byte; + //RecOps: array[0..0] of Pointer; + AllCount: Integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic]) + AllFields: array[0..0] of TEnhancedFieldInfo; + {$endif ISDELPHI2010} + {$endif FPC} + ); + tkEnumeration: ( + EnumType: TOrdType; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + EnumDummy: DWORD; // needed on ARM for correct alignment + {$endif} + {$ifdef FPC_ENUMHASINNER} inner: + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record + {$endif FPC_ENUMHASINNER} + MinValue: longint; + MaxValue: longint; + EnumBaseType: PTypeInfoStored; // BaseTypeRef in FPC TypInfo.pp + {$ifdef FPC_ENUMHASINNER} end; {$endif FPC_ENUMHASINNER} + NameList: string[255]; + ); + tkInteger: ( + IntegerType: TOrdType; + ); + tkInt64: ( + MinInt64Value, MaxInt64Value: Int64; + ); + tkSet: ( + SetType: TOrdType; + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + SetDummy: DWORD; // needed on ARM for correct alignment + {$endif} + {$ifdef FPC} + {$ifndef VER3_0} + SetSize: SizeInt; + {$endif VER3_0} + {$endif FPC} + SetBaseType: PTypeInfoStored; // CompTypeRef in FPC TypInfo.pp + ); + tkFloat: ( + FloatType: TFloatType; + ); + tkClass: ( + ClassType: TClass; + ParentInfo: PTypeInfoStored; // ParentInfoRef in FPC TypInfo.pp + PropCount: SmallInt; + UnitNameLen: byte; + ); + end; + + {$ifdef FPC} + {$push} + {$PACKRECORDS 1} + {$endif} + TPropInfo = packed record + PropType: PTypeInfoStored; + GetProc: PtrInt; + SetProc: PtrInt; + StoredProc: PtrInt; + Index: Integer; + Default: Longint; + NameIndex: SmallInt; + {$ifdef FPC} + PropProcs : Byte; + {$ifdef FPC_PROVIDE_ATTR_TABLE} + /// property attributes, introduced since FPC SVN 42356-42411 (2019/07) + AttributeTable: Pointer; + {$endif FPC_PROVIDE_ATTR_TABLE} + {$endif} + NameLen: byte; + end; + PPropInfo = ^TPropInfo; + {$ifdef FPC} + {$pop} + {$endif} + +{$ifdef HASDIRECTTYPEINFO} +type + Deref = PTypeInfo; +{$else} +function Deref(Info: PTypeInfoStored): PTypeInfo; // for Delphi and newer FPC +{$ifdef HASINLINE} inline; +begin + result := pointer(Info); + if Info<>nil then + result := Info^; +end; +{$else} +asm // Delphi is so bad at compiling above code... + or eax, eax + jz @z + mov eax, [eax] + ret +@z: db $f3 // rep ret +end; +{$endif HASINLINE} +{$endif HASDIRECTTYPEINFO} + +const + /// codePage offset = string header size + // - used to calc the beginning of memory allocation of a string + STRRECSIZE = SizeOf(TStrRec); + +{$ifdef HASCODEPAGE} +function FastNewString(len: PtrInt; cp: cardinal): PAnsiChar; inline; +begin + if len>0 then begin + {$ifdef FPC_X64MM}result := _Getmem({$else}GetMem(result,{$endif}len+(STRRECSIZE+4)); + PStrRec(result)^.codePage := cp; + PStrRec(result)^.elemSize := 1; + PStrRec(result)^.refCnt := 1; + PStrRec(result)^.length := len; + PCardinal(result+len+STRRECSIZE)^ := 0; // ensure ends with four #0 + inc(PStrRec(result)); + end else + result := nil; +end; +{$endif HASCODEPAGE} + +{$ifdef FPC_X64} +procedure fpc_ansistr_decr_ref; external name 'FPC_ANSISTR_DECR_REF'; +procedure fpc_ansistr_incr_ref; external name 'FPC_ANSISTR_INCR_REF'; +procedure fpc_ansistr_assign; external name 'FPC_ANSISTR_ASSIGN'; +procedure fpc_ansistr_setlength; external name 'FPC_ANSISTR_SETLENGTH'; +procedure fpc_ansistr_compare; external name 'FPC_ANSISTR_COMPARE'; +procedure fpc_ansistr_compare_equal; external name 'FPC_ANSISTR_COMPARE_EQUAL'; +procedure fpc_unicodestr_decr_ref; external name 'FPC_UNICODESTR_DECR_REF'; +procedure fpc_unicodestr_incr_ref; external name 'FPC_UNICODESTR_INCR_REF'; +procedure fpc_unicodestr_assign; external name 'FPC_UNICODESTR_ASSIGN'; +procedure fpc_dynarray_incr_ref; external name 'FPC_DYNARRAY_INCR_REF'; +procedure fpc_dynarray_decr_ref; external name 'FPC_DYNARRAY_DECR_REF'; +procedure fpc_dynarray_clear; external name 'FPC_DYNARRAY_CLEAR'; +{$ifdef FPC_X64MM} +procedure fpc_getmem; external name 'FPC_GETMEM'; +procedure fpc_freemem; external name 'FPC_FREEMEM'; +{$else} +procedure _Getmem; external name 'FPC_GETMEM'; +procedure _Freemem; external name 'FPC_FREEMEM'; +{$endif FPC_X64MM} + +procedure PatchJmp(old, new: PByteArray; size: PtrInt; jmp: PtrUInt=0); +var + rel: PCardinal; +begin + PatchCode(old, new, size, nil, {unprotected=}true); + if jmp = 0 then + jmp := PtrUInt(@_Freemem); + repeat // search and fix "jmp rel fpc_freemem/_dynarray_decr_ref_free" + dec(size); + if size = 0 then + exit; + rel := @old[size + 1]; + until (old[size] = $e9) and + (rel^ = cardinal(jmp - PtrUInt(@new[size]) - 5)); + rel^ := jmp - PtrUInt(rel) - 4; +end; + +procedure _ansistr_decr_ref(var p: Pointer); nostackframe; assembler; +asm + mov rax, qword ptr[p] + xor edx, edx + test rax, rax + jz @z + mov qword ptr[p], rdx + mov p, rax + {$ifdef STRCNT32} + cmp dword ptr[rax - _STRREFCNT], rdx + jl @z +lock dec dword ptr[rax - _STRREFCNT] + {$else} + cmp qword ptr[rax - _STRREFCNT], rdx + jl @z +lock dec qword ptr[rax - _STRREFCNT] + {$endif STRCNT32} + jbe @free +@z: ret +@free: sub p, STRRECSIZE + jmp _Freemem +end; + +procedure _ansistr_incr_ref(p: pointer); nostackframe; assembler; +asm + test p, p + jz @z + {$ifdef STRCNT32} + cmp dword ptr[p - _STRREFCNT], 0 + jl @z +lock inc dword ptr[p - _STRREFCNT] + {$else} + cmp qword ptr[p - _STRREFCNT], 0 + jl @z +lock inc qword ptr[p - _STRREFCNT] + {$endif STRCNT32} +@z: +end; + +procedure _ansistr_assign(var d: pointer; s: pointer); nostackframe; assembler; +asm + mov rax, qword ptr[d] + cmp rax, s + jz @eq + test s, s + jz @ns + {$ifdef STRCNT32} + cmp dword ptr[s - _STRREFCNT], 0 + jl @ns +lock inc dword ptr[s - _STRREFCNT] +@ns: mov qword ptr[d], s + test rax, rax + jnz @z +@eq: ret +@z: mov d, rax + cmp dword ptr[rax - _STRREFCNT], 0 + jl @n + lock dec dword ptr[rax - _STRREFCNT] + {$else} + cmp qword ptr[s - _STRREFCNT], 0 + jl @ns +lock inc qword ptr[s - _STRREFCNT] +@ns: mov qword ptr[d], s + test rax, rax + jnz @z +@eq: ret +@z: mov d, rax + cmp qword ptr[rax - _STRREFCNT], 0 + jl @n + lock dec qword ptr[rax - _STRREFCNT] + {$endif STRCNT32} + ja @n +@free: sub d, STRRECSIZE + jmp _Freemem +@n: +end; + +{ note: fpc_ansistr_compare/_equal do check the codepage and make a UTF-8 + conversion if necessary, whereas Delphi _LStrCmp/_LStrEqual don't; + involving codepage is safer, but paranoid, and 1. is (much) slower, and + 2. is not Delphi compatible -> we rather follow the Delphi/Lazy's way } + +function _ansistr_compare(s1, s2: pointer): SizeInt; nostackframe; assembler; +asm + xor eax, eax + cmp s1, s2 + je @0 + test s1, s2 + jz @maybe0 +@first: mov al, byte ptr[s1] // we can check the first char (for quicksort) + sub al, byte ptr[s2] + jne @ne + mov r8, qword ptr[s1 - _STRLEN] + mov r11, r8 + sub r8, qword ptr[s2 - _STRLEN] // r8 = length(s1)-length(s2) + adc rax, -1 + and rax, r8 // rax = -min(length(s1),length(s2)) + sub rax, r11 + sub s1, rax + sub s2, rax + align 8 +@s: mov r10, qword ptr[s1 + rax] // compare by 8 bytes (may include len) + xor r10, qword ptr[s2 + rax] + jnz @d + add rax, 8 + js @s +@e: mov rax, r8 // all equal -> return difflen +@0: ret +@ne: movsx rax, al + ret +@d: bsf r10, r10 // compute s1^-s2^ + shr r10, 3 + add rax, r10 + jns @e + movzx edx, byte ptr[s2 + rax] + movzx eax, byte ptr[s1 + rax] + sub rax, rdx + ret +@maybe0:test s2, s2 + jz @1 + test s1, s1 + jnz @first + dec rax + ret +@1: inc eax +end; + +function _ansistr_compare_equal(s1, s2: pointer): SizeInt; nostackframe; assembler; +asm + xor eax, eax + cmp s1, s2 + je @q + test s1, s2 + jz @maybe0 +@ok: mov rax, qword ptr[s1 - _STRLEN] // len must match + cmp rax, qword ptr[s2 - _STRLEN] + jne @q + lea s1, qword ptr[s1 + rax - 8] + lea s2, qword ptr[s2 + rax - 8] + neg rax + mov r8, qword ptr[s1] // compare last 8 bytes (may include len) + cmp r8, qword ptr[s2] + jne @q + align 16 +@s: add rax, 8 // compare remaining 8 bytes per iteration + jns @0 + mov r8, qword ptr[s1 + rax] + cmp r8, qword ptr[s2 + rax] + je @s + mov eax, 1 + ret +@0: xor eax, eax +@q: ret +@maybe0:test s2, s2 + jz @1 + test s1, s1 + jnz @ok +@1: inc eax // not zero is enough +end; + +procedure _dynarray_incr_ref(p: pointer); nostackframe; assembler; +asm + test p, p + jz @z + cmp qword ptr[p - _DAREFCNT], 0 + jle @z +lock inc qword ptr[p - _DAREFCNT] +@z: +end; + +procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); forward; + +procedure _dynarray_decr_ref(var p: Pointer; info: pointer); nostackframe; assembler; +asm + mov rax, qword ptr[p] + test rax, rax + jz @z + mov qword ptr[p], 0 + mov p, rax + sub p, SizeOf(TDynArrayRec) + cmp qword ptr[rax - _DAREFCNT], 0 + jle @z +lock dec qword ptr[p] + jbe @free +@z: ret +@free: jmp _dynarray_decr_ref_free +end; + +procedure FastAssignNew(var d; s: pointer); nostackframe; assembler; +asm + mov rax, qword ptr[d] + mov qword ptr[d], s + test rax, rax + jz @z + mov d, rax + {$ifdef STRCNT32} + cmp dword ptr[rax - _STRREFCNT], 0 + jl @z +lock dec dword ptr[rax - _STRREFCNT] + {$else} + cmp qword ptr[rax - _STRREFCNT], 0 + jl @z +lock dec qword ptr[rax - _STRREFCNT] + {$endif STRCNT32} + jbe @free +@z: ret +@free: sub d, STRRECSIZE + jmp _Freemem +end; + +{$ifdef FPC_HAS_CPSTRING} + +{$ifdef FPC_X64MM} +procedure _ansistr_setlength_new(var s: RawByteString; len: PtrInt; cp: cardinal); +var p, new: PAnsiChar; + l: PtrInt; +begin + if cp<=CP_OEMCP then begin // TranslatePlaceholderCP logic + cp := DefaultSystemCodePage; + if cp=0 then + cp := CP_NONE; + end; + new := FastNewString(len,cp); + p := pointer(s); + if p<>nil then begin + l := PStrLen(p-_STRLEN)^+1; + if l>len then + l := len; + MoveFast(p^,new^,l); + end; + FastAssignNew(s,new); +end; + +procedure _ansistr_setlength(var s: RawByteString; len: PtrInt; cp: cardinal); + nostackframe; assembler; +asm + mov rax, qword ptr[s] + test len, len + jle _ansistr_decr_ref + test rax, rax + jz _ansistr_setlength_new + {$ifdef STRCNT32} + cmp dword ptr[rax - _STRREFCNT], 1 + {$else} + cmp qword ptr[rax - _STRREFCNT], 1 + {$endif STRCNT32} + jne _ansistr_setlength_new + push len + push s + sub qword ptr[s], STRRECSIZE + add len, STRRECSIZE + 1 + call _reallocmem // rely on MM in-place detection + pop s + pop len + add qword ptr[s], STRRECSIZE + mov qword ptr[rax].TStrRec.length, len + mov byte ptr[rax + len + STRRECSIZE], 0 +end; +{$endif FPC_X64MM} + +// _ansistr_concat_convert* optimized for systemcodepage=CP_UTF8 + +function ToTempUTF8(var temp: TSynTempBuffer; p: pointer; len, cp: cardinal): pointer; +begin + if (len=0) or (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or IsAnsiCompatible(p,len) then begin + temp.buf := nil; + temp.len := len; + result := p; + end else begin + temp.Init(len*3); + p := TSynAnsiConvert.Engine(cp).AnsiBufferToUTF8(temp.buf,p,len); + temp.len := PAnsiChar(p)-PAnsiChar(temp.buf); + result := temp.buf; + end; +end; + +procedure _ansistr_concat_convert(var dest: RawByteString; const s1,s2: RawByteString; + cp,cp1,cp2: cardinal); +var t1, t2, t: TSynTempBuffer; // avoid most memory allocation + p1, p2, p: PAnsiChar; + eng: TSynAnsiConvert; +begin + p1 := ToTempUTF8(t1,pointer(s1),length(s1),cp1); + p2 := ToTempUTF8(t2,pointer(s2),length(s2),cp2); + if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or ((t1.buf=nil) and (t2.buf=nil)) then begin + p := FastNewString(t1.len+t2.len,cp); + MoveFast(p1^,p[0],t1.len); + MoveFast(p2^,p[t1.len],t2.len); + FastAssignNew(dest,p); + end else begin + eng := TSynAnsiConvert.Engine(cp); + t.Init((t1.len+t2.len) shl eng.fAnsiCharShift); + p := eng.UTF8BufferToAnsi(eng.UTF8BufferToAnsi(t.buf,p1,t1.len),p2,t2.len); + FastSetStringCP(dest,t.buf,p-t.buf,cp); + t.Done; + end; + t2.Done; + t1.Done; +end; + +function _lstrlen(const s: RawByteString): TStrLen; inline; +begin + result := PStrLen(PtrUInt(s)-_STRLEN)^; +end; + +function _lstrcp(const s: RawByteString; cp: integer): integer; inline; +begin + result := cp; + if s<>'' then begin + result := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; + if result<=CP_OEMCP then + result := CP_UTF8; + end; +end; + +procedure _ansistr_concat_utf8(var dest: RawByteString; + const s1,s2: RawByteString; cp: cardinal); +var cp1, cp2: cardinal; + new: PAnsiChar; + l1: PtrInt; +begin + if cp<=CP_OEMCP then // TranslatePlaceholderCP logic + cp := CP_UTF8; + cp1 := _lstrcp(s1,cp); + cp2 := _lstrcp(s2,cp1); + if (cp1=cp2) and ((cp>=CP_SQLRAWBLOB) or (cp=cp1)) then + cp := cp1 else + if ((cp1<>cp) and (cp1cp) and (cp2 self-resize dest + SetLength(dest,l1+_lstrlen(s2)); + PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; + MoveFast(pointer(s2)^,PByteArray(dest)[l1],_lstrlen(s2)); + end else begin + new := FastNewString(l1+_lstrlen(s2),cp); + MoveFast(pointer(s1)^,new[0],l1); + MoveFast(pointer(s2)^,new[l1],_lstrlen(s2)); + FastAssignNew(dest,new); + end; + end; +end; + +procedure _ansistr_concat_multi_convert(var dest: RawByteString; + s: PRawByteString; scount, cp: cardinal); +var t: TTextWriter; + u: RawUTF8; + tmp: TTextWriterStackBuffer; +begin + t := TTextWriter.CreateOwnedStream(tmp); + try + repeat + if s^<>'' then + t.AddAnyAnsiBuffer(pointer(s^),_lstrlen(s^),twNone,_lstrcp(s^,cp)); + inc(s); + dec(scount); + until scount=0; + t.SetText(u); + finally + t.Free; + end; + if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) then + dest := u else + TSynAnsiConvert.Engine(cp).UTF8BufferToAnsi(pointer(u),length(u),dest); +end; + +procedure _ansistr_concat_multi_utf8(var dest: RawByteString; + const s: array of RawByteString; cp: cardinal); +var first,len,i,l: integer; // should NOT be PtrInt/SizeInt to avoid FPC bug with high(s) :( + cpf,cpi: cardinal; + p: pointer; + new: PAnsiChar; +begin + if cp<=CP_OEMCP then + cp := CP_UTF8; + first := 0; + repeat + if first>high(s) then begin + _ansistr_decr_ref(pointer(dest)); + exit; + end; + p := pointer(s[first]); + if p<>nil then + break; + inc(first); + until false; + len := _lstrlen(RawByteString(p)); + cpf := _lstrcp(RawByteString(p),cp); + if (cpf<>cp) and (cpfnil then begin + inc(len,_lstrlen(RawByteString(p))); + cpi := PStrRec(PtrUInt(p)-STRRECSIZE)^.codePage; + if cpi<=CP_OEMCP then + cpi := CP_UTF8; + if (cpi<>cpf) and (cpi self-resize + SetLength(dest,len); + new := pointer(dest); + PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; + cp := 0; + end else begin + new := FastNewString(len,cp); + MoveFast(p^,new[0],l); + end; + for i := first+1 to high(s) do begin + p := pointer(s[i]); + if p<>nil then begin + MoveFast(p^,new[l],_lstrlen(RawByteString(p))); + inc(l,_lstrlen(RawByteString(p))); + end; + end; + if cp<>0 then + FastAssignNew(dest,new); + end; +end; + +procedure _fpc_ansistr_concat(var a: RawUTF8); +begin + a := a+a; // to generate "call fpc_ansistr_concat" opcode +end; + +procedure _fpc_ansistr_concat_multi(var a: RawUTF8); +begin + a := a+a+a; // to generate "call fpc_ansistr_concat_multi" opcode +end; + +procedure RedirectRtl(dummy, dest: PByteArray); +begin + repeat + if (dummy[0]=$b9) and (PCardinal(@dummy[1])^=CP_UTF8) then + case dummy[5] of + $e8: begin + // found "mov ecx,65001; call fpc_ansistr_concat" opcodes + RedirectCode(@dummy[PInteger(@dummy[6])^+10],dest); + exit; + end; + $ba: if (PCardinal(@dummy[6])^=2) and (dummy[10]=$e8) then + begin + // found "mov ecx,65001; mov edx,2; call fpc_ansistr_concat_multi" + RedirectCode(@dummy[PInteger(@dummy[11])^+15],dest); + exit; + end; + end; + inc(PByte(dummy)); + until PInt64(dummy)^=0; +end; + +{$endif FPC_HAS_CPSTRING} + +{$else} + +procedure FastAssignNew(var d; s: pointer); {$ifdef HASINLINE} inline; {$endif} +var + sr: PStrRec; // local copy to use register +begin + sr := Pointer(d); + Pointer(d) := s; + if sr = nil then + exit; + dec(sr); + if (sr^.refcnt >= 0) and StrCntDecFree(sr^.refcnt) then + FreeMem(sr); +end; +{$endif FPC_X64} + +{$ifdef HASCODEPAGE} +procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); +var r: pointer; +begin + r := FastNewString(len,codepage); + if p<>nil then + MoveFast(p^,r^,len); + FastAssignNew(s,r); +end; + +procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); +var r: pointer; +begin + r := FastNewString(len,CP_UTF8); + if p<>nil then + MoveFast(p^,r^,len); + FastAssignNew(s,r); +end; +{$else not HASCODEPAGE} +procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); +begin + SetString(RawByteString(s),PAnsiChar(p),len); +end; +procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); +begin + SetString(RawByteString(s),PAnsiChar(p),len); +end; +{$endif HASCODEPAGE} + +procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; + out aligned: pointer); +begin + SetString(s,nil,len+16); + aligned := pointer(s); + inc(PByte(aligned),PtrUInt(aligned) and 15); + if p<>nil then + MoveFast(p^,aligned^,len); +end; + +function ToText(k: TTypeKind): PShortString; +begin + result := GetEnumName(TypeInfo(TTypeKind),ord(k)); +end; + +function ToText(k: TDynArrayKind): PShortString; +begin + result := GetEnumName(TypeInfo(TDynArrayKind),ord(k)); +end; + +function UniqueRawUTF8(var UTF8: RawUTF8): pointer; +begin + {$ifdef FPC} + UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :( + {$endif} + result := @UTF8[1]; +end; + +procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer); +var i: integer; +begin + i := length(UTF8); + if i>MaxSize then + PByteArray(UTF8)[MaxSize] := 0 else + MaxSize := i; + for i := 0 to MaxSize-1 do + if PByteArray(UTF8)[i]=0 then + PByteArray(UTF8)[i] := ord('~'); +end; + +{$ifdef FPC} +function TDynArrayRec.GetLength: sizeint; +begin + result := high+1; +end; + +procedure TDynArrayRec.SetLength(len: sizeint); +begin + high := len-1; +end; +{$endif FPC} + +function DynArrayLength(Value: Pointer): PtrInt; + {$ifdef HASINLINE}inline;{$endif} +begin + result := PtrInt(Value); + if result<>0 then + result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; +end; + +{$ifdef HASALIGNTYPEDATA} +function FPCTypeInfoOverName(P: pointer): pointer; inline; +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} {$ifdef CPUARM3264} +const diff=SizeOf(QWord);// always on these two CPU's +{$else} var diff: PtrUInt; {$endif} {$endif} +begin + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + {$ifndef CPUARM3264} + diff := PtrUInt(@PTypeInfo(P)^.NameFirst)-PtrUInt(@PTypeInfo(P)^.Kind); + {$endif} + result := AlignTypeData(P+2+PByte(P+1)^); + dec(PByte(result),diff); + {$else} + result := AlignTypeData(P+PByte(P+1)^); + {$endif} +end; +{$endif HASALIGNTYPEDATA} + +function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload; +{$ifdef HASINLINE} inline; +begin + result := aTypeInfo; + if result<>nil then + if result^.Kind=aExpectedKind then + {$ifdef HASALIGNTYPEDATA} + result := FPCTypeInfoOverName(result) + {$else} + inc(PByte(result),result^.NameLen) + {$endif} + else + result := nil; +end; +{$else} +asm + test eax, eax + jz @n + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + cmp dl, [eax] + jne @n + add eax, ecx + ret +@n: xor eax, eax +end; +{$endif HASINLINE} + +function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload; +{$ifdef HASINLINE} inline; +begin + result := aTypeInfo; + if result<>nil then + if result^.Kind in aExpectedKind then + {$ifdef HASALIGNTYPEDATA} + result := FPCTypeInfoOverName(result) + {$else} + inc(PByte(result),result^.NameLen) + {$endif} + else + result := nil; +end; +{$else} +asm // eax=aTypeInfo edx=aExpectedKind + test eax, eax + jz @n + movzx ecx, byte ptr[eax] + bt edx, ecx + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + jnb @n + add eax, ecx + ret +@n: xor eax, eax +end; +{$endif HASINLINE} + +function GetTypeInfo(aTypeInfo: pointer): PTypeInfo; overload; +{$ifdef HASINLINE} inline; +begin + {$ifdef HASALIGNTYPEDATA} + result := FPCTypeInfoOverName(aTypeInfo); + {$else} + result := @PAnsiChar(aTypeInfo)[PTypeInfo(aTypeInfo)^.NameLen]; + {$endif} +end; +{$else} +asm + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + add eax, ecx +end; +{$endif HASINLINE} + +function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; + aDataSize: PInteger): pointer; +var info: PTypeInfo; +begin + result := nil; + info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray); + if info=nil then + exit; + if info^.elType<>nil then + result := Deref(info^.elType); + if aDataSize<>nil then + aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; +end; + +procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; + const default: RawUTF8); +begin + if aTypeInfo<>nil then + FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, + PTypeInfo(aTypeInfo)^.NameLen) else + result := default; +end; + +function TypeInfoToShortString(aTypeInfo: pointer): PShortString; +begin + if aTypeInfo<>nil then + result := @PTypeInfo(aTypeInfo)^.NameLen else + result := nil; +end; + +procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; + const default: RawUTF8); +var unitname: RawUTF8; +begin + if aTypeInfo<>nil then begin + FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, + PTypeInfo(aTypeInfo)^.NameLen); + if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin + with GetTypeInfo(aTypeInfo)^ do + FastSetString(unitname,PAnsiChar(@UnitNameLen)+1,UnitNameLen); + result := unitname+'.'+result; + end; + end else result := default; +end; + +function TypeInfoToName(aTypeInfo: pointer): RawUTF8; +begin + TypeInfoToName(aTypeInfo,Result,''); +end; + +function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; +var info: PTypeInfo; +begin + info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); + if info=nil then + result := 0 else + result := info^.recSize; +end; + +function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer): PShortString; +{$ifdef HASINLINE} inline; +var info: PTypeInfo; + base: PTypeInfoStored; +begin + if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=tkEnumeration) then begin + info := GetTypeInfo(aTypeInfo); + base := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType; + {$ifdef FPC} // no redirection if aTypeInfo is already the base type + if (base<>nil) and (base{$ifndef HASDIRECTTYPEINFO}^{$endif}<>aTypeInfo) then + {$endif} + info := GetTypeInfo(base{$ifndef HASDIRECTTYPEINFO}^{$endif}); + MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue; + result := @info^.NameList; + end else + result := nil; +end; +{$else} +asm // eax=aTypeInfo edx=@MaxValue + test eax, eax + jz @n + cmp byte ptr[eax], tkEnumeration + jnz @n + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + mov eax, [eax + ecx + TTypeInfo.EnumBaseType] + mov eax, [eax] + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + add eax, ecx + mov ecx, [eax + TTypeInfo.MaxValue] + mov [edx], ecx + lea eax, [eax + TTypeInfo.NameList] + ret +@n: xor eax, eax +end; +{$endif HASINLINE} + +function GetSetBaseEnum(aTypeInfo: pointer): pointer; +begin + result := GetTypeInfo(aTypeInfo,tkSet); + if result<>nil then + result := Deref(PTypeInfo(result)^.SetBaseType); +end; + +function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer; + out Names: PShortString): boolean; {$ifdef HASINLINE}inline;{$endif} +var info: PTypeInfo; +begin + info := GetTypeInfo(aTypeInfo,tkSet); + if info<>nil then begin + Names := GetEnumInfo(Deref(info^.SetBaseType),MaxValue); + result := Names<>nil; + end else + result := false; +end; + +const + NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; + FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24; + FALSE_LOW2 = ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24; + TRUE_LOW = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24; + + NULL_SHORTSTRING: string[1] = ''; + +procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); +var MaxValue, i: integer; + res: PShortString; +begin + res := GetEnumInfo(aTypeInfo,MaxValue); + if res<>nil then + for i := 0 to MaxValue do begin + aDest^ := res; + inc(PByte(res),PByte(res)^+1); // next + inc(aDest); + end; +end; + +procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); +var MaxValue, i: integer; + res: PShortString; +begin + res := GetEnumInfo(aTypeInfo,MaxValue); + if res<>nil then + for i := 0 to MaxValue do begin + aDest^ := TrimLeftLowerCaseShort(res); + inc(PByte(res),PByte(res)^+1); // next + inc(aDest); + end; +end; + +function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; +var MaxValue, i: integer; + res: PShortString; +begin + Finalize(result); + res := GetEnumInfo(aTypeInfo,MaxValue); + if res=nil then + exit; + SetLength(result,MaxValue+1); + for i := 0 to MaxValue do begin + result[i] := TrimLeftLowerCaseShort(res); + inc(PByte(res),PByte(res)^+1); // next + end; +end; + +procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); +var tmp: array[byte] of AnsiChar; + L: integer; +begin + L := ord(PS^[0]); + inc(PByte(PS)); + while (L>0) and (PS^[0] in ['a'..'z']) do begin inc(PByte(PS)); dec(L); end; + tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase + if L>0 then + MoveSmall(PS,@tmp,L); + GetCaptionFromPCharLen(tmp,result); +end; + +procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); +var MaxValue, i: integer; + res: PShortString; +begin + res := GetEnumInfo(aTypeInfo,MaxValue); + if res<>nil then + for i := 0 to MaxValue do begin + GetCaptionFromTrimmed(res,aDest^); + inc(PByte(res),PByte(res)^+1); // next + inc(aDest); + end; +end; + +function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; +{$ifdef HASINLINENOTX86} +var MaxValue: integer; +begin + result := GetEnumInfo(aTypeInfo,MaxValue); + if (result<>nil) and (cardinal(aIndex)<=cardinal(MaxValue)) then begin + if aIndex>0 then + repeat + inc(PByte(result),PByte(result)^+1); // next + dec(aIndex); + if aIndex=0 then + break; + inc(PByte(result),PByte(result)^+1); // loop unrolled twice + dec(aIndex); + until aIndex=0; + end else + result := @NULL_SHORTSTRING; +end; +{$else} +asm // eax=aTypeInfo edx=aIndex + test eax, eax + jz @0 + cmp byte ptr[eax], tkEnumeration + jnz @0 + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + mov eax, [eax + ecx + TTypeInfo.EnumBaseType] + mov eax, [eax] + movzx ecx, byte ptr[eax + TTypeInfo.NameLen] + cmp edx, [eax + ecx + TTypeInfo.MaxValue] + ja @0 + lea eax, [eax + ecx + TTypeInfo.NameList] + test edx, edx + jz @z + push edx + shr edx, 2 // fast by-four scanning + jz @1 +@4: dec edx + movzx ecx, byte ptr[eax] + lea eax, [eax + ecx + 1] + movzx ecx, byte ptr[eax] + lea eax, [eax + ecx + 1] + movzx ecx, byte ptr[eax] + lea eax, [eax + ecx + 1] + movzx ecx, byte ptr[eax] + lea eax, [eax + ecx + 1] + jnz @4 + pop edx + and edx, 3 + jnz @s + ret +@1: pop edx +@s: movzx ecx, byte ptr[eax] + dec edx + lea eax, [eax + ecx + 1] // next + jnz @s + ret +@z: rep ret +@0: lea eax, NULL_SHORTSTRING +end; +{$endif HASINLINENOTX86} + +{$ifdef PUREPASCAL} // for proper inlining +function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; +label zero; +begin + P1P2Len := PtrInt(@PAnsiChar(P1)[P1P2Len-SizeOf(cardinal)]); + if P1P2Len>=PtrInt(PtrUInt(P1)) then + repeat // case-insensitive compare 4 bytes per loop + if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf<>0 then + goto zero; + inc(P1,SizeOf(cardinal)); + inc(P2,SizeOf(cardinal)); + until P1P2Len0 then + goto zero; + inc(P1); + until PtrInt(PtrUInt(P1))>=P1P2Len; + result := true; + exit; +zero: + result := false; +end; +{$endif PUREPASCAL} + +function IdemPropNameUSmallNotVoid(P1,P2,P1P2Len: PtrInt): boolean; + {$ifdef HASINLINE}inline;{$endif} +label zero; +begin + inc(P1P2Len,P1); + dec(P2,P1); + repeat + if (PByte(P1)^ xor ord(PAnsiChar(P1)[P2])) and $df<>0 then + goto zero; + inc(P1); + until P1>=P1P2Len; + result := true; + exit; +zero: + result := false; +end; + +function FindShortStringListExact(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; +var PLen: PtrInt; +begin + if aValueLen<>0 then + for result := 0 to MaxValue do begin + PLen := PByte(List)^; + if (PLen=aValuelen) and + IdemPropNameUSmallNotVoid(PtrInt(@List^[1]),PtrInt(aValue),PLen) then + exit; + List := pointer(@PAnsiChar(PLen)[PtrUInt(List)+1]); // next + end; + result := -1; +end; + +function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; +var PLen: PtrInt; +begin + if aValueLen<>0 then + for result := 0 to MaxValue do begin + PLen := ord(List^[0]); + inc(PUTF8Char(List)); + repeat // trim lower case + if not(PUTF8Char(List)^ in ['a'..'z']) then + break; + inc(PUTF8Char(List)); + dec(PLen); + until PLen=0; + if (PLen=aValueLen) and IdemPropNameUSmallNotVoid(PtrInt(aValue),PtrInt(List),PLen) then + exit; + inc(PUTF8Char(List),PLen); // next + end; + result := -1; +end; + +{$ifdef HASINLINE} +function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; +label zero; +begin // cut-down version of our pure pascal CompareMem() function + {$ifndef CPUX86} result := false; {$endif} + Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)]); + if Length>=PtrInt(PtrUInt(P1)) then + repeat // compare one PtrInt per loop + if PPtrInt(P1)^<>PPtrInt(P2)^ then + goto zero; + inc(PPtrInt(P1)); + inc(PPtrInt(P2)); + until LengthPByteArray(P2)[PtrUInt(P1)] then + goto zero; + inc(PByte(P1)); + until PtrInt(PtrUInt(P1))>=Length; + result := true; + exit; +zero: + {$ifdef CPUX86} result := false; {$endif} +end; +{$endif HASINLINE} + +function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; + aValue: PUTF8Char; aValueLen: PtrInt): integer; +var PLen: PtrInt; +begin + if aValueLen<>0 then + for result := 0 to MaxValue do begin + PLen := ord(List^[0]); + inc(PUTF8Char(List)); + repeat + if not(PUTF8Char(List)^ in ['a'..'z']) then + break; + inc(PUTF8Char(List)); + dec(PLen); + until PLen=0; + if (PLen=aValueLen) and CompareMemFixed(aValue,List,PLen) then + exit; + inc(PUTF8Char(List),PLen); + end; + result := -1; +end; + +function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; + AlsoTrimLowerCase: boolean): Integer; +var List: PShortString; + MaxValue: integer; +begin + List := GetEnumInfo(aTypeInfo,MaxValue); + if (aValueLen<>0) and (List<>nil) then begin + result := FindShortStringListExact(List,MaxValue,aValue,aValueLen); + if (result<0) and AlsoTrimLowerCase then + result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen); + end else + result := -1; +end; + +function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; +var List: PShortString; + MaxValue: integer; +begin + List := GetEnumInfo(aTypeInfo,MaxValue); + if (aValueLen<>0) and (List<>nil) then + result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else + result := -1; +end; + +function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; +var List: PShortString; + MaxValue: integer; +begin + List := GetEnumInfo(aTypeInfo,MaxValue); + if (aValueLen<>0) and (List<>nil) then + result := FindShortStringListTrimLowerCaseExact(List,MaxValue,aValue,aValueLen) else + result := -1; +end; + +function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; + AlsoTrimLowerCase: boolean): Integer; +begin + result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue), + AlsoTrimLowerCase); +end; + +function GetSetName(aTypeInfo: pointer; const value): RawUTF8; +var PS: PShortString; + i,max: integer; +begin + result := ''; + if GetSetInfo(aTypeInfo,max,PS) then begin + for i := 0 to max do begin + if GetBitPtr(@value,i) then + result := FormatUTF8('%%,',[result,PS^]); + inc(PByte(PS),PByte(PS)^+1); // next + end; + end; + if result<>'' then + SetLength(result,length(result)-1); // trim last comma +end; + +procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; + trimlowercase: boolean); +begin + if trimlowercase then + while text^ in ['a'..'z'] do + if len=1 then + exit else begin + inc(text); + dec(len); + end; + if integer(ord(result[0]))+len>=255 then + exit; + if len>0 then + MoveSmall(text,@result[ord(result[0])+1],len); + inc(result[0],len+1); + result[ord(result[0])] := ','; +end; + +procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; + trimlowercase: boolean); +var PS: PShortString; + i,max: integer; +begin + result := ''; + if GetSetInfo(aTypeInfo,max,PS) then begin + for i := 0 to max do begin + if GetBitPtr(@value,i) then + AppendShortComma(@PS^[1],ord(PS^[0]),result,trimlowercase); + inc(PByte(PS),PByte(PS)^+1); // next + end; + end; + if result[ord(result[0])]=',' then + dec(result[0]); +end; + +function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; + out EndOfObject: AnsiChar): cardinal; +var names: PShortString; + Text: PUTF8Char; + wasString: boolean; + MaxValue, TextLen, i: integer; +begin + result := 0; + if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,names) then begin + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='[' then begin + repeat inc(P) until (P^>' ') or (P^=#0); + if P^=']' then + inc(P) else begin + repeat + Text := GetJSONField(P,P,@wasString,@EndOfObject,@TextLen); + if (Text=nil) or not wasString then begin + P := nil; // invalid input (expects a JSON array of strings) + exit; + end; + if Text^='*' then begin + if MaxValue<32 then + result := ALLBITS_CARDINAL[MaxValue+1] else + result := cardinal(-1); + break; + end; + if Text^ in ['a'..'z'] then + i := FindShortStringListExact(names,MaxValue,Text,TextLen) else + i := -1; + if i<0 then + i := FindShortStringListTrimLowerCase(names,MaxValue,Text,TextLen); + if i>=0 then + SetBitPtr(@result,i); + // unknown enum names (i=-1) would just be ignored + until EndOfObject=']'; + if P=nil then + exit; // avoid GPF below if already reached the input end + end; + while not (jcEndOfJSONField in JSON_CHARS[P^]) do begin // mimics GetJSONField() + if P^=#0 then begin + P := nil; + exit; // unexpected end + end; + inc(P); + end; + EndOfObject := P^; + repeat inc(P) until (P^>' ') or (P^=#0); + end else + result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject)); + end; +end; + + +{ note: those low-level VariantTo*() functions are expected to be there + even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) } + +function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; +var typ: cardinal; +begin + result := false; + typ := TVarData(Source).VType; + if typ and varByRef=0 then + exit; + typ := typ and not varByRef; + case typ of + varVariant: + if integer(PVarData(TVarData(Source).VPointer)^.VType) in + [varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin + Dest := PVarData(TVarData(Source).VPointer)^; + result := true; + end; + varEmpty..varDate,varBoolean,varShortInt..varWord64: begin + Dest.VType := typ; + Dest.VInt64 := PInt64(TVarData(Source).VAny)^; + result := true; + end; + end; +end; + +function VariantToInteger(const V: Variant; var Value: integer): boolean; +var tmp: TVarData; + vt: cardinal; +begin + result := false; + vt := TVarData(V).VType; + case vt of + varNull, + varEmpty: Value := 0; + varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize + varSmallint: Value := TVarData(V).VSmallInt; + {$ifndef DELPHI5OROLDER} + varShortInt: Value := TVarData(V).VShortInt; + varWord: Value := TVarData(V).VWord; + varLongWord: + if TVarData(V).VLongWord<=cardinal(High(integer)) then + Value := TVarData(V).VLongWord else + exit; + {$endif} + varByte: Value := TVarData(V).VByte; + varInteger: Value := TVarData(V).VInteger; + varWord64: + if (TVarData(V).VInt64>=0) and (TVarData(V).VInt64<=High(integer)) then + Value := TVarData(V).VInt64 else + exit; + varInt64: + if (TVarData(V).VInt64>=Low(integer)) and (TVarData(V).VInt64<=High(integer)) then + Value := TVarData(V).VInt64 else + exit; + else + if SetVariantUnRefSimpleValue(V,tmp) then begin + result := VariantToInteger(variant(tmp),Value); + exit; + end else + exit; + end; + result := true; +end; + +function VariantToDouble(const V: Variant; var Value: double): boolean; +var tmp: TVarData; + vt: cardinal; +begin + vt := TVarData(V).VType; + if vt=varVariant or varByRef then + result := VariantToDouble(PVariant(TVarData(V).VPointer)^,Value) else begin + result := true; + if VariantToInt64(V,tmp.VInt64) then // also handle varEmpty,varNull + Value := tmp.VInt64 else + case vt of + varDouble,varDate: + Value := TVarData(V).VDouble; + varSingle: + Value := TVarData(V).VSingle; + varCurrency: + Value := TVarData(V).VCurrency; + else begin + if SetVariantUnRefSimpleValue(V,tmp) then + result := VariantToDouble(variant(tmp),Value) else + result := false; + end; + end; + end; +end; + +function VariantToDoubleDef(const V: Variant; const default: double=0): double; +begin + if not VariantToDouble(V,result) then + result := default; +end; + +function VariantToCurrency(const V: Variant; var Value: currency): boolean; +var tmp: TVarData; + vt: cardinal; +begin + vt := TVarData(V).VType; + if vt=varVariant or varByRef then + result := VariantToCurrency(PVariant(TVarData(V).VPointer)^,Value) else begin + result := true; + if VariantToInt64(V,tmp.VInt64) then + Value := tmp.VInt64 else + case vt of + varDouble,varDate: + Value := TVarData(V).VDouble; + varSingle: + Value := TVarData(V).VSingle; + varCurrency: + Value := TVarData(V).VCurrency; + else + if SetVariantUnRefSimpleValue(V,tmp) then + result := VariantToCurrency(variant(tmp),Value) else + result := false; + end; + end; +end; + +function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; +var tmp: TVarData; + vt: cardinal; +begin + vt := TVarData(V).VType; + case vt of + varEmpty, varNull: begin + result := false; + exit; + end; + varBoolean: + Value := TVarData(V).VBoolean; + varInteger: // coming e.g. from GetJsonField() + Value := TVarData(V).VInteger=1; + varString: + Value := IdemPropNameU(RawUTF8(TVarData(V).VAny),BOOL_UTF8[true]); + {$ifndef DELPHI5OROLDER} // WideCompareText() not defined on this old RTL + varOleStr: + Value := WideCompareText(WideString(TVarData(V).VAny),'true')=0; + {$endif DELPHI5OROLDER} + {$ifdef HASVARUSTRING} + varUString: Value := {$ifdef FPC}UnicodeCompareText{$else}CompareText{$endif}( + UnicodeString(TVarData(V).VAny),'true')=0; + {$endif HASVARUSTRING} + else + if SetVariantUnRefSimpleValue(V,tmp) then + if tmp.VType=varBoolean then + Value := tmp.VBoolean else begin + result := false; + exit; + end else begin + result := false; + exit; + end; + end; + result := true; +end; + +function VariantToInt64(const V: Variant; var Value: Int64): boolean; +var tmp: TVarData; + vt: cardinal; +begin + vt := TVarData(V).VType; + case vt of + varNull, + varEmpty: Value := 0; + varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize + varSmallint: Value := TVarData(V).VSmallInt; + {$ifndef DELPHI5OROLDER} + varShortInt: Value := TVarData(V).VShortInt; + varWord: Value := TVarData(V).VWord; + varLongWord: Value := TVarData(V).VLongWord; + {$endif} + varByte: Value := TVarData(V).VByte; + varInteger: Value := TVarData(V).VInteger; + varWord64: if TVarData(V).VInt64>=0 then + Value := TVarData(V).VInt64 else begin + result := false; + exit; + end; + varInt64: Value := TVarData(V).VInt64; + else + if SetVariantUnRefSimpleValue(V,tmp) then begin + result := VariantToInt64(variant(tmp),Value); + exit; + end else begin + result := false; + exit; + end; + end; + result := true; +end; + +function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; +begin + if not VariantToInt64(V,result) then + result := DefaultValue; +end; + +function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; +begin + if not VariantToInteger(V,result) then + result := DefaultValue; +end; + +{$ifndef NOVARIANTS} + +function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; +begin + RawUTF8ToVariant(BinToHexDisplayLower(Bin,BinBytes),result); +end; + +function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; +var tmp: RawUTF8; + wasString: boolean; +begin + VariantToUTF8(hex,tmp,wasString); + result := wasstring and HexDisplayToBin(pointer(tmp),Bin,BinBytes); +end; + +function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; +var tmp: RawUTF8; + vd: TVarData; + vt: cardinal; +begin + vt := TVarData(V).VType; + if vt=varVariant or varByRef then + result := VariantToDateTime(PVariant(TVarData(V).VPointer)^,Value) else begin + result := true; + case vt of + varDouble,varDate: + Value := TVarData(V).VDouble; + varSingle: + Value := TVarData(V).VSingle; + varCurrency: + Value := TVarData(V).VCurrency; + else + if SetVariantUnRefSimpleValue(V,vd) then + result := VariantToDateTime(variant(vd),Value) else begin + VariantToUTF8(V,tmp); + Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value); + result := Value<>0; + end; + end; + end; +end; + +procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); +var tmp: RawUTF8; + wasString: boolean; +begin + VariantToUTF8(V,tmp,wasString); + if wasString then + QuotedStr(tmp,'"',result) else + result := tmp; +end; + +function VariantToVariantUTF8(const V: Variant): variant; +var tmp: RawUTF8; + wasString: boolean; +begin + VariantToUTF8(V,tmp,wasString); + if wasString then + result := V else + RawUTF8ToVariant(tmp,result); +end; + +procedure VariantToUTF8(const V: Variant; var result: RawUTF8; + var wasString: boolean); +var tmp: TVarData; + vt: cardinal; +begin + wasString := false; + vt := TVarData(V).VType; + with TVarData(V) do + case vt of + varEmpty, + varNull: + result := NULL_STR_VAR; + varSmallint: + Int32ToUTF8(VSmallInt,result); + {$ifndef DELPHI5OROLDER} + varShortInt: + Int32ToUTF8(VShortInt,result); + varWord: + UInt32ToUTF8(VWord,result); + varLongWord: + UInt32ToUTF8(VLongWord,result); + {$endif} + varByte: + result := SmallUInt32UTF8[VByte]; + varBoolean: + if VBoolean then + result := SmallUInt32UTF8[1] else + result := SmallUInt32UTF8[0]; + varInteger: + Int32ToUTF8(VInteger,result); + varInt64: + Int64ToUTF8(VInt64,result); + varWord64: + UInt64ToUTF8(VInt64,result); + varSingle: + ExtendedToStr(VSingle,SINGLE_PRECISION,result); + varDouble: + DoubleToStr(VDouble,result); + varCurrency: + Curr64ToStr(VInt64,result); + varDate: begin + wasString := true; + DateTimeToIso8601TextVar(VDate,'T',result); + end; + varString: begin + wasString := true; + {$ifdef HASCODEPAGE} + AnyAnsiToUTF8(RawByteString(VString),result); + {$else} + result := RawUTF8(VString); + {$endif} + end; + {$ifdef HASVARUSTRING} + varUString: begin + wasString := true; + RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result); + end; + {$endif} + varOleStr: begin + wasString := true; + RawUnicodeToUtf8(VAny,length(WideString(VAny)),result); + end; + else + if SetVariantUnRefSimpleValue(V,tmp) then + VariantToUTF8(Variant(tmp),result,wasString) else + if vt=varVariant or varByRef then // complex varByRef + VariantToUTF8(PVariant(VPointer)^,result,wasString) else + if vt=varByRef or varString then begin + wasString := true; + {$ifdef HASCODEPAGE} + AnyAnsiToUTF8(PRawByteString(VString)^,result); + {$else} + result := PRawUTF8(VString)^; + {$endif} + end else + if vt=varByRef or varOleStr then begin + wasString := true; + RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result); + end else + {$ifdef HASVARUSTRING} + if vt=varByRef or varUString then begin + wasString := true; + RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result); + end else + {$endif} + VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types + end; +end; + +function VariantToUTF8(const V: Variant): RawUTF8; +var wasString: boolean; +begin + VariantToUTF8(V,result,wasString); +end; + +function ToUTF8(const V: Variant): RawUTF8; +var wasString: boolean; +begin + VariantToUTF8(V,result,wasString); +end; + +function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; +begin + VariantToUTF8(V,Text,result); +end; + +function VariantEquals(const V: Variant; const Str: RawUTF8; + CaseSensitive: boolean): boolean; + function Complex: boolean; + var wasString: boolean; + tmp: RawUTF8; + begin + VariantToUTF8(V,tmp,wasString); + if CaseSensitive then + result := (tmp=Str) else + result := IdemPropNameU(tmp,Str); + end; +var v1,v2: Int64; + vt: cardinal; +begin + vt := TVarData(V).VType; + with TVarData(V) do + case vt of + varEmpty,varNull: + result := Str=''; + varBoolean: + result := VBoolean=(Str<>''); + varString: + if CaseSensitive then + result := RawUTF8(VString)=Str else + result := IdemPropNameU(RawUTF8(VString),Str); + else if VariantToInt64(V,v1) then begin + SetInt64(pointer(Str),v2); + result := v1=v2; + end else + result := Complex; + end; +end; + +function VariantToString(const V: Variant): string; +var wasString: boolean; + tmp: RawUTF8; + vt: cardinal; +begin + vt := TVarData(V).VType; + with TVarData(V) do + case vt of + varEmpty,varNull: + result := ''; // default VariantToUTF8(null)='null' + {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString + varUString: + result := UnicodeString(VAny); + else + if vt=varByRef or varUString then + result := PUnicodeString(VAny)^ + {$endif} + else begin + VariantToUTF8(V,tmp,wasString); + if tmp='' then + result := '' else + UTF8DecodeToString(pointer(tmp),length(tmp),result); + end; + end; +end; + +procedure RawVariantDynArrayClear(V: PVarData; n: integer); +var vt,docv: integer; + handler: TCustomVariantType; +begin + handler := nil; + docv := DocVariantVType; + repeat + vt := V^.VType; + case vt of + varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ; + varString: {$ifdef FPC}Finalize(RawUTF8(V^.VAny)){$else}RawUTF8(V^.VAny) := ''{$endif}; + varOleStr: WideString(V^.VAny) := ''; + {$ifdef HASVARUSTRING} + varUString: UnicodeString(V^.VAny) := ''; + {$endif} + else + if vt=docv then + DocVariantType.Clear(V^) else + if vt=varVariant or varByRef then + VarClear(PVariant(V^.VPointer)^) else + if handler=nil then + if (vt and varByRef=0) and FindCustomVariantType(vt,handler) then + handler.Clear(V^) else + VarClear(variant(V^)) else + if vt=handler.VarType then + handler.Clear(V^) else + VarClear(variant(V^)); + end; + inc(V); + dec(n); + until n=0; +end; + +procedure VariantDynArrayClear(var Value: TVariantDynArray); +begin + FastDynArrayClear(@Value,TypeInfo(variant)); +end; + +{$endif NOVARIANTS} + +{$ifdef UNICODE} +// this Pos() is seldom used, it was decided to only define it under +// Delphi 2009+ (which expect such a RawUTF8 specific overloaded version) + +function Pos(const substr, str: RawUTF8): Integer; overload; +begin + Result := PosEx(substr,str,1); +end; + +function IntToString(Value: integer): string; +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + P := StrInt32(@tmp[23],Value); + Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); +end; + +function IntToString(Value: cardinal): string; +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + P := StrUInt32(@tmp[23],Value); + Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); +end; + +function IntToString(Value: Int64): string; +var tmp: array[0..31] of AnsiChar; + P: PAnsiChar; +begin + P := StrInt64(@tmp[31],Value); + Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result); +end; + +function DoubleToString(Value: Double): string; +var tmp: ShortString; +begin + if Value=0 then + result := '0' else + Ansi7ToString(PWinAnsiChar(@tmp[1]),DoubleToShort(tmp,Value),result); +end; + +function Curr64ToString(Value: Int64): string; +var tmp: array[0..31] of AnsiChar; +begin + Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result); +end; + +{$else UNICODE} + +{$ifdef PUREPASCAL} +function IntToString(Value: integer): string; +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + if cardinal(Value)<=high(SmallUInt32UTF8) then + result := SmallUInt32UTF8[Value] else begin + P := StrInt32(@tmp[23],Value); + SetString(result,P,@tmp[23]-P); + end; +end; +{$else} +function IntToString(Value: integer): string; {$ifdef FPC} nostackframe; assembler; {$endif} +asm + jmp Int32ToUTF8 +end; +{$endif PUREPASCAL} + +function IntToString(Value: cardinal): string; +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + if Value<=high(SmallUInt32UTF8) then + result := SmallUInt32UTF8[Value] else begin + P := StrUInt32(@tmp[23],Value); + SetString(result,P,@tmp[23]-P); + end; +end; + +function IntToString(Value: Int64): string; +var tmp: array[0..31] of AnsiChar; + P: PAnsiChar; +begin + if (Value>=0) and (Value<=high(SmallUInt32UTF8)) then + result := SmallUInt32UTF8[Value] else begin + P := StrInt64(@tmp[31],Value); + SetString(result,P,@tmp[31]-P); + end; +end; + +function DoubleToString(Value: Double): string; +var tmp: ShortString; +begin + if Value=0 then + result := '0' else + SetString(result,PAnsiChar(@tmp[1]),DoubleToShort(tmp,Value)); +end; + +function Curr64ToString(Value: Int64): string; +begin + result := Curr64ToStr(Value); +end; + +{$endif UNICODE} + +procedure bswap64array(a,b: PQWordArray; n: PtrInt); +{$ifdef CPUX86} {$ifdef FPC}nostackframe; assembler;{$endif} +asm + push ebx + push esi +@1: mov ebx, dword ptr[eax] + mov esi, dword ptr[eax + 4] + bswap ebx + bswap esi + mov dword ptr[edx + 4], ebx + mov dword ptr[edx], esi + add eax, 8 + add edx, 8 + dec ecx + jnz @1 + pop esi + pop ebx +end; +{$else} +{$ifdef CPUX64} +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} +@1: mov rax, qword ptr[a] + bswap rax + mov qword ptr[b], rax + add a, 8 + add b, 8 + dec n + jnz @1 +end; +{$else} +var i: PtrInt; +begin + for i := 0 to n-1 do + b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]); +end; +{$endif CPUX64} +{$endif CPUX86} + +{$ifdef CPUX64} +function bswap32(a: cardinal): cardinal; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov eax, a + bswap eax +end; + +function bswap64(const a: QWord): QWord; {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=a (Linux: rdi) +{$endif FPC} + mov rax, a + bswap rax +end; +{$else} +{$ifdef CPUX86} +function bswap32(a: cardinal): cardinal; {$ifdef FPC} nostackframe; assembler; {$endif} +asm + bswap eax +end; + +function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; +{$ifdef FPC} nostackframe; assembler; {$endif} asm + {$ifdef FPC_X86} + mov edx, dword ptr[eax] + mov eax, dword ptr[eax + 4] + {$else} + mov edx, a.TQWordRec.L + mov eax, a.TQWordRec.H + {$endif FPC_X86} + bswap edx + bswap eax +end; +{$else} +{$ifdef FPC} +function bswap32(a: cardinal): cardinal; +begin + result := SwapEndian(a); // use fast platform-specific function +end; + +function bswap64(const a: QWord): QWord; +begin + result := SwapEndian(a); // use fast platform-specific function +end; +{$else} +function bswap32(a: cardinal): cardinal; +begin + result := ((a and $ff)shl 24)or((a and $ff00)shl 8)or + ((a and $ff0000)shr 8)or((a and $ff000000)shr 24); +end; + +function bswap64(const a: QWord): QWord; +begin + TQWordRec(result).L := bswap32(TQWordRec(a).H); + TQWordRec(result).H := bswap32(TQWordRec(a).L); +end; +{$endif FPC} +{$endif CPUX86} +{$endif CPUX64} + +{$ifndef PUREPASCAL} { these functions are implemented in asm } +{$ifndef LVCL} { don't define these functions twice } +{$ifndef FPC} { some asm functions use some low-level system.pas calls } + +{$define DEFINED_INT32TOUTF8} + +function Int32ToUTF8(Value : PtrInt): RawUtf8; // 3x faster than SysUtils.IntToStr +// from IntToStr32_JOH_IA32_6_a, adapted for Delphi 2009+ +asm // eax=Value, edx=@result + push ebx + push edi + push esi + mov ebx, eax // value + sar ebx, 31 // 0 for +ve value or -1 for -ve value + xor eax, ebx + sub eax, ebx // abs(value) + mov esi, 10 // max dig in result + mov edi, edx // @result + cmp eax, 10 + sbb esi, 0 + cmp eax, 100 + sbb esi, 0 + cmp eax, 1000 + sbb esi, 0 + cmp eax, 10000 + sbb esi, 0 + cmp eax, 100000 + sbb esi, 0 + cmp eax, 1000000 + sbb esi, 0 + cmp eax, 10000000 + sbb esi, 0 + cmp eax, 100000000 + sbb esi, 0 + cmp eax, 1000000000 + sbb esi, ebx // esi=dig (including sign character) + mov ecx, [edx] // result + test ecx, ecx + je @newstr // create new string for result + cmp dword ptr[ecx - 8], 1 + jne @chgstr // reference count <> 1 + cmp esi, [ecx - 4] + je @lenok // existing length = required length + sub ecx, STRRECSIZE // allocation address + push eax // abs(value) + push ecx + mov eax, esp + lea edx, [esi + STRRECSIZE + 1] // new allocation size + call System.@ReallocMem // reallocate result string + pop ecx + pop eax // abs(value) + add ecx, STRRECSIZE // result + mov [ecx - 4], esi // set new length + mov byte ptr[ecx + esi], 0 // add null terminator + mov [edi], ecx // set result address + jmp @lenok +@chgstr:mov edx, dword ptr[ecx - 8] // reference count + add edx, 1 + jz @newstr // refcount = -1 (string constant) +lock dec dword ptr[ecx - 8] // decrement existing reference count +@newstr:push eax // abs(value) + mov eax, esi // length + {$ifdef UNICODE} + mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ + {$endif} + call System.@NewAnsiString + mov [edi], eax // set result address + mov ecx, eax // result + pop eax // abs(value) +@lenok: mov byte ptr[ecx], '-' // store '-' character (may be overwritten) + add esi, ebx // dig (excluding sign character) + sub ecx, ebx // destination of 1st dig + sub esi, 2 // dig (excluding sign character) - 2 + jle @findig // 1 or 2 dig value + cmp esi, 8 // 10 dig value? + jne @setres // not a 10 dig value + sub eax, 2000000000 // dig 10 must be either '1' or '2' + mov dl, '2' + jnc @set10 // dig 10 = '2' + mov dl, '1' // dig 10 = '1' + add eax, 1000000000 +@set10: mov [ecx], dl // save dig 10 + mov esi, 7 // 9 dig remaining + add ecx, 1 // destination of 2nd dig +@setres:mov edi, $28f5c29 // ((2^32)+100-1)/100 +@loop: mov ebx, eax // dividend + mul edi // edx = dividend div 100 + mov eax, edx // set next dividend + imul edx, -200 // -2 * (100 * dividend div 100) + movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii + mov [ecx + esi], dx + sub esi, 2 + jg @loop // loop until 1 or 2 dig remaining +@findig:pop esi + pop edi + pop ebx + jnz @last + movzx eax, word ptr[TwoDigitLookup + eax * 2] + mov [ecx], ax // save final 2 dig + ret +@last: or al, '0' // ascii adjustment + mov [ecx], al // save final dig +end; + +function Int64ToUTF8(Value: Int64): RawUtf8; +asm // from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+ + push ebx + mov ecx, [ebp + 8] // low integer of val + mov edx, [ebp + 12] // high integer of val + xor ebp, ebp // clear sign flag (ebp already pushed) + mov ebx, ecx // low integer of val + test edx, edx + jnl @absval + mov ebp, 1 // ebp = 1 for -ve val or 0 for +ve val + neg ecx + adc edx, 0 + neg edx +@absval:jnz @large // edx:ecx = abs(val) + test ecx, ecx + js @large + mov edx, eax // @result + mov eax, ebx // low integer of val + call Int32ToUtf8 // call fastest integer inttostr function + pop ebx +@exit: pop ebp // restore stack and exit + ret 8 +@large: push edi + push esi + mov edi, eax + xor ebx, ebx + xor eax, eax +@t15: cmp edx, $00005af3 // test for 15 or more dig + jne @chk15 // 100000000000000 div $100000000 + cmp ecx, $107a4000 // 100000000000000 mod $100000000 +@chk15: jb @t13 +@t17: cmp edx, $002386f2 // test for 17 or more dig + jne @chk17 // 10000000000000000 div $100000000 + cmp ecx, $6fc10000 // 10000000000000000 mod $100000000 +@chk17: jb @t1516 +@t19: cmp edx, $0de0b6b3 // test for 19 dig + jne @chk19 // 1000000000000000000 div $100000000 + cmp ecx, $a7640000 // 1000000000000000000 mod $100000000 +@chk19: jb @t1718 + mov al, 19 + jmp @setl2 +@t1718: mov bl, 18 // 17 or 18 dig + cmp edx, $01634578 // 100000000000000000 div $100000000 + jne @setlen + cmp ecx, $5d8a0000 // 100000000000000000 mod $100000000 + jmp @setlen +@t1516: mov bl, 16 // 15 or 16 dig + cmp edx, $00038d7e // 1000000000000000 div $100000000 + jne @setlen + cmp ecx, $a4c68000 // 1000000000000000 mod $100000000 + jmp @setlen +@t13: cmp edx, $000000e8 // test for 13 or more dig + jne @chk13 // 1000000000000 div $100000000 + cmp ecx, $d4a51000 // 1000000000000 mod $100000000 +@chk13: jb @t11 +@t1314: mov bl, 14 // 13 or 14 dig + cmp edx, $00000918 // 10000000000000 div $100000000 + jne @setlen + cmp ecx, $4e72a000 // 10000000000000 mod $100000000 + jmp @setlen +@t11: cmp edx, $02 // 10, 11 or 12 dig + jne @chk11 // 10000000000 div $100000000 + cmp ecx, $540be400 // 10000000000 mod $100000000 +@chk11: mov bl, 11 + jb @setlen // 10 dig +@t1112: mov bl, 12 // 11 or 12 dig + cmp edx, $17 // 100000000000 div $100000000 + jne @setlen + cmp ecx, $4876e800 // 100000000000 mod $100000000 +@setlen:sbb eax, 0 // adjust for odd/evem digit count + add eax, ebx +@setl2: push ecx // abs(val) in edx:ecx, dig in eax + push edx // save abs(val) + lea edx, [eax + ebp] // digit needed (including sign character) + mov ecx, [edi] // @result + mov esi, edx // digit needed (including sign character) + test ecx, ecx + je @newstr // create new ansistring for result + cmp dword ptr[ecx - 8], 1 + jne @chgstr // reference count <> 1 + cmp esi, [ecx - 4] + je @lenok // existing length = required length + sub ecx, STRRECSIZE // allocation address + push eax // abs(val) + push ecx + mov eax, esp + lea edx, [esi + STRRECSIZE + 1] // new allocation size + call System.@ReallocMem // reallocate result ansistring + pop ecx + pop eax // abs(val) + add ecx, STRRECSIZE // @result + mov [ecx - 4], esi // set new length + mov byte ptr[ecx + esi], 0 // add null terminator + mov [edi], ecx // set result address + jmp @lenok +@chgstr:mov edx, dword ptr[ecx - 8] // reference count + add edx, 1 + jz @newstr // refcount = -1 (ansistring constant) +lock dec dword ptr[ecx - 8] // decrement existing reference count +@newstr:push eax // abs(val) + mov eax, esi // length + {$ifdef UNICODE} + mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ + {$endif} + call System.@NewAnsiString + mov [edi], eax // set result address + mov ecx, eax // @result + pop eax // abs(val) +@lenok: mov edi, [edi] // @result + sub esi, ebp // digit needed (excluding sign character) + mov byte ptr[edi], '-' // store '-' character (may be overwritten) + add edi, ebp // destination of 1st digit + pop edx // restore abs(val) + pop eax + cmp esi, 17 + jl @less17 // dig < 17 + je @set17 // dig = 17 + cmp esi, 18 + je @set18 // dig = 18 + mov cl, '0' - 1 + mov ebx, $a7640000 // 1000000000000000000 mod $100000000 + mov ebp, $0de0b6b3 // 1000000000000000000 div $100000000 +@dig19: add ecx, 1 + sub eax, ebx + sbb edx, ebp + jnc @dig19 + add eax, ebx + adc edx, ebp + mov [edi], cl + add edi, 1 +@set18: mov cl, '0' - 1 + mov ebx, $5d8a0000 // 100000000000000000 mod $100000000 + mov ebp, $01634578 // 100000000000000000 div $100000000 +@dig18: add ecx, 1 + sub eax, ebx + sbb edx, ebp + jnc @dig18 + add eax, ebx + adc edx, ebp + mov [edi], cl + add edi, 1 +@set17: mov cl, '0' - 1 + mov ebx, $6fc10000 // 10000000000000000 mod $100000000 + mov ebp, $002386f2 // 10000000000000000 div $100000000 +@dig17: add ecx, 1 + sub eax, ebx + sbb edx, ebp + jnc @dig17 + add eax, ebx + adc edx, ebp + mov [edi], cl + add edi, 1 // update destination + mov esi, 16 // set 16 dig left +@less17:mov ecx, 100000000 // process next 8 dig + div ecx // edx:eax = abs(val) = dividend + mov ebp, eax // dividend div 100000000 + mov ebx, edx + mov eax, edx // dividend mod 100000000 + mov edx, $51eb851f + mul edx + shr edx, 5 // dividend div 100 + mov eax, edx // set next dividend + lea edx, [edx * 4 + edx] + lea edx, [edx * 4 + edx] + shl edx, 2 // dividend div 100 * 100 + sub ebx, edx // remainder (0..99) + movzx ebx, word ptr[TwoDigitLookup + ebx * 2] + shl ebx, 16 + mov edx, $51eb851f + mov ecx, eax // dividend + mul edx + shr edx, 5 // dividend div 100 + mov eax, edx + lea edx, [edx * 4 + edx] + lea edx, [edx * 4 + edx] + shl edx, 2 // dividend div 100 * 100 + sub ecx, edx // remainder (0..99) + or bx, word ptr[TwoDigitLookup + ecx * 2] + mov [edi + esi - 4], ebx // store 4 dig + mov ebx, eax + mov edx, $51eb851f + mul edx + shr edx, 5 // edx = dividend div 100 + lea eax, [edx * 4 + edx] + lea eax, [eax * 4 + eax] + shl eax, 2 // eax = dividend div 100 * 100 + sub ebx, eax // remainder (0..99) + movzx ebx, word ptr[TwoDigitLookup + ebx * 2] + movzx ecx, word ptr[TwoDigitLookup + edx * 2] + shl ebx, 16 + or ebx, ecx + mov [edi + esi - 8], ebx // store 4 dig + mov eax, ebp // remainder + sub esi, 10 // dig left - 2 + jz @last2 +@small: mov edx, $28f5c29 // ((2^32)+100-1)/100 + mov ebx, eax // dividend + mul edx + mov eax, edx // set next dividend + imul edx, -200 + movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii + mov [edi + esi], dx + sub esi, 2 + jg @small // repeat until less than 2 dig remaining + jz @last2 + or al, '0' // ascii adjustment + mov [edi], al // save final digit + jmp @done +@last2: movzx eax, word ptr[TwoDigitLookup + eax * 2] + mov [edi], ax // save final 2 dig +@done: pop esi + pop edi + pop ebx +end; + +function Trim(const S: RawUTF8): RawUTF8; +asm // fast implementation by John O'Harrow, modified for Delphi 2009+ + test eax, eax // S = nil? + xchg eax, edx + jz System.@LStrClr // Yes, Return Empty String + mov ecx, [edx - 4] // Length(S) + cmp byte ptr[edx], ' ' // S[1] <= ' '? + jbe @left // Yes, Trim Leading Spaces + cmp byte ptr[edx + ecx - 1], ' ' // S[Length(S)] <= ' '? + jbe @right // Yes, Trim Trailing Spaces + jmp System.@LStrLAsg // No, Result := S (which occurs most time) +@left: dec ecx // Strip Leading Whitespace + jle System.@LStrClr // All Whitespace + inc edx + cmp byte ptr[edx], ' ' + jbe @left +@done: cmp byte ptr[edx + ecx - 1], ' ' +{$ifdef UNICODE} + jbe @right + push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call System.@LStrFromPCharLen // we need a call, not a jmp here + rep ret +{$else} ja System.@LStrFromPCharLen +{$endif} +@right: dec ecx // Strip Trailing Whitespace + jmp @done +end; + +{$endif FPC} { above asm function had some low-level system.pas calls } + +{$endif LVCL} +{$endif PUREPASCAL} + +function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; +label zero; +var c: AnsiChar; // explicit temp variable for better FPC code generation +begin + {$ifndef CPUX86} result := false; {$endif} + inc(PtrUInt(P1),PtrUInt(Length)); + inc(PtrUInt(P2),PtrUInt(Length)); + Length := -Length; + if Length<>0 then + repeat + c := PAnsiChar(P1)[Length]; + if c<>PAnsiChar(P2)[Length] then + goto zero; + inc(Length); + until Length=0; + result := true; + {$ifdef CPUX86} exit; {$endif} +zero: + {$ifdef CPUX86} result := false; {$endif} +end; + +{$ifdef HASINLINE} +procedure FillZero(var dest; count: PtrInt); +begin + FillCharFast(dest,count,0); +end; +{$else} +procedure FillZero(var dest; count: PtrInt); +asm + xor ecx, ecx + jmp dword ptr [FillCharFast] +end; +{$endif} + +function IsEqual(const A,B; count: PtrInt): boolean; +var perbyte: boolean; // ensure no optimization takes place +begin + result := true; + while count>0 do begin + dec(count); + perbyte := PByteArray(@A)[count]=PByteArray(@B)[count]; + result := result and perbyte; + end; +end; + +function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; +var s: PAnsiChar; + c: AnsiChar; +begin + if (Str<>nil) and (Characters<>nil) and (Characters^<>#0) then + repeat + c := Str^; + if c=#0 then + break; + s := Characters; + repeat + if s^=c then begin + result := Str; + exit; + end; + inc(s); + until s^=#0; + inc(Str); + until false; + result := nil; +end; + +function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; +var i,j,n: PtrInt; +begin + if (OldChar<>NewChar) and (Source<>'') then begin + n := length(Source); + for i := 0 to n-1 do + if PAnsiChar(pointer(Source))[i]=OldChar then begin + FastSetString(result,PAnsiChar(pointer(Source)),n); + for j := i to n-1 do + if PAnsiChar(pointer(result))[j]=OldChar then + PAnsiChar(pointer(result))[j] := NewChar; + exit; + end; + end; + result := Source; +end; + +function IdemPChar2(table: PNormTable; p: PUTF8Char; up: PAnsiChar): boolean; + {$ifdef HASINLINE}inline;{$endif} +var u: AnsiChar; +begin // here p and up are expected to be <> nil + result := false; + dec(PtrUInt(p),PtrUInt(up)); + repeat + u := up^; + if u=#0 then + break; + if table^[up[PtrUInt(p)]]<>u then + exit; + inc(up); + until false; + result := true; +end; + +function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; +var u: AnsiChar; + table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; +begin + if uppersubstr<>nil then begin + {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} + u := uppersubstr^; + for result := 1 to Length(str) do + if table[str[result]]=u then + if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} + @PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then + exit; + end; + result := 0; +end; + +function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; +var u: AnsiChar; + table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; +begin + if (uppersubstr<>nil) and (str<>nil) then begin + {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} + u := uppersubstr^; + inc(uppersubstr); + result := str; + while result^<>#0 do begin + if table[result^]=u then + if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} + result+1,PAnsiChar(uppersubstr)) then + exit; + inc(result); + end; + end; + result := nil; +end; + +function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; +var p: PUTF8Char; +begin + if (substr<>nil) and (str<>'') then begin + p := pointer(str); + repeat + if GetNextUTF8Upper(p)=ord(substr^) then + if IdemPCharU(p,substr+1) then begin + result := p-pointer(str); + exit; + end; + until p^=#0; + end; + result := 0; +end; + +// same as PosExPas() but using char/PChar for (unicode)string process +function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt; +var len, lenSub: PtrInt; + ch: char; + pStart, pStop: PChar; +label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, + AfterTestT, AfterTest0, Ret, Exit; +begin + result := 0; + if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then + goto Exit; + len := PStrLen(PtrUInt(p)-_STRLEN)^; + lenSub := PStrLen(PtrUInt(pSub)-_STRLEN)^-1; + if (len=pStop then goto Exit; + goto Loop2; +Test4: dec(p,2); +Test2: dec(p,2); + goto Test0; +Test3: dec(p,2); +Test1: dec(p,2); +TestT: len := lenSub; + if lenSub<>0 then + repeat + if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then + goto AfterTestT; + inc(len,2); + until len>=0; + inc(p,2); + if p<=pStop then goto Ret; + goto Exit; +Test0: len := lenSub; + if lenSub<>0 then + repeat + if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then + goto AfterTest0; + inc(len,2); + until len>=0; + inc(p); +Ret: + result := p-pStart; +Exit: +end; + +procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); +var L: PtrInt; +begin + L := length(Text); + SetLength(Text,L+1); // reallocate + PByteArray(Text)[L] := ord(Ch); +end; + +procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); +var L: PtrInt; +begin + if BufferLen<=0 then + exit; + L := length(Text); + SetLength(Text,L+BufferLen); + MoveFast(Buffer^,pointer(PtrInt(Text)+L)^,BufferLen); +end; + +procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); +var i,len,TextLen: PtrInt; + lens: array[0..63] of integer; + P: PUTF8Char; +begin + if high(Buffers)>high(lens) then + raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()'); + len := 0; + for i := 0 to high(Buffers) do begin + lens[i] := StrLen(Buffers[i]); + inc(len,lens[i]); + end; + TextLen := Length(Text); + SetLength(Text,TextLen+len); + P := pointer(Text); + inc(P,TextLen); + for i := 0 to high(Buffers) do + if Buffers[i]<>nil then begin + MoveFast(Buffers[i]^,P^,lens[i]); + inc(P,lens[i]); + end; +end; + +function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; +var L: PtrInt; +begin + L := length(Text); + if L<>0 then begin + MoveFast(Pointer(Text)^,Buffer^,L); + inc(Buffer,L); + end; + result := Buffer; +end; + +function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; +var L: PtrInt; + P: PAnsiChar; + tmp: array[0..23] of AnsiChar; +begin + if Value<=high(SmallUInt32UTF8) then begin + P := pointer(SmallUInt32UTF8[Value]); + L := PStrLen(P-_STRLEN)^; + end else begin + P := StrUInt32(@tmp[23],Value); + L := @tmp[23]-P; + end; + result := Buffer; + repeat + result^ := P^; + inc(result); + inc(P); + dec(L); + until L=0; +end; + +function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; +var L: PtrInt; + P: PAnsiChar; + c: cardinal; +begin + P := pointer(SmallUInt32UTF8[Value]); + L := PStrLen(P-_STRLEN)^; + c := PCardinal(P)^; + Buffer[0] := AnsiChar(c); // PCardinal() write = FastMM4 FullDebugMode errors + inc(Buffer); + if L>1 then begin + Buffer^ := AnsiChar(c shr 8); + inc(Buffer); + if L>2 then begin + Buffer^ := AnsiChar(c shr 16); + inc(Buffer); + end; + end; + result := pointer(Buffer); +end; + +function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8; +begin + QuotedStr(S,Quote,result); +end; + +procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); +var i,L,quote1,nquote: PtrInt; + P,R: PUTF8Char; + tmp: pointer; // will hold a RawUTF8 with no try..finally exception block + c: AnsiChar; +begin + tmp := nil; + L := length(S); + P := pointer(S); + if (P<>nil) and (P=pointer(result)) then begin + RawUTF8(tmp) := S; // make private ref-counted copy for QuotedStr(U,'"',U) + P := pointer(tmp); + end; + nquote := 0; + {$ifdef FPC} // will use fast FPC SSE version + quote1 := IndexByte(P^,L,byte(Quote)); + if quote1>=0 then + for i := quote1 to L-1 do + if P[i]=Quote then + inc(nquote); + {$else} + quote1 := 0; + for i := 0 to L-1 do + if P[i]=Quote then begin + if nquote=0 then + quote1 := i; + inc(nquote); + end; + {$endif} + FastSetString(result,nil,L+nquote+2); + R := pointer(result); + R^ := Quote; + inc(R); + if nquote=0 then begin + MoveFast(P^,R^,L); + R[L] := Quote; + end else begin + MoveFast(P^,R^,quote1); + inc(R,quote1); + inc(quote1,PtrInt(P)); // trick for reusing a register on FPC + repeat + c := PAnsiChar(quote1)^; + if c=#0 then + break; + inc(quote1); + R^ := c; + inc(R); + if c<>Quote then + continue; + R^ := c; + inc(R); + until false; + R^ := Quote; + end; + if tmp<>nil then + {$ifdef FPC}Finalize(RawUTF8(tmp)){$else}RawUTF8(tmp) := ''{$endif}; +end; + +function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; +var quote: AnsiChar; +begin // P^=" or P^=' at function call + quote := P^; + inc(P); + repeat + if P^=#0 then + break else + if P^<>quote then + inc(P) else + if P[1]=quote then // allow double quotes inside string + inc(P,2) else + break; // end quote + until false; + result := P; +end; // P^='"' at function return + +procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; + const aPrefix, aSuffix: RawUTF8); +var temp: TTextWriterStackBuffer; + Lp,Ls: PtrInt; + D: PUTF8Char; +begin + if (P=nil) or (PLen<=0) then + result := '""' else + if (pointer(result)=pointer(P)) or NeedsJsonEscape(P,PLen) then + with TTextWriter.CreateOwnedStream(temp) do + try + AddString(aPrefix); + Add('"'); + AddJSONEscape(P,PLen); + Add('"'); + AddString(aSuffix); + SetText(result); + exit; + finally + Free; + end else begin + Lp := length(aPrefix); + Ls := length(aSuffix); + FastSetString(result,nil,PLen+Lp+Ls+2); + D := pointer(result); // we checked dest result <> source P above + if Lp>0 then begin + MoveFast(pointer(aPrefix)^,D^,Lp); + inc(D,Lp); + end; + D^ := '"'; + MoveFast(P^,D[1],PLen); + inc(D,PLen); + D[1] := '"'; + if Ls>0 then + MoveFast(pointer(aSuffix)^,D[2],Ls); + end; +end; + +procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; + const aPrefix, aSuffix: RawUTF8); +begin + QuotedStrJSON(pointer(aText),Length(aText),result,aPrefix,aSuffix); +end; + +function QuotedStrJSON(const aText: RawUTF8): RawUTF8; +begin + QuotedStrJSON(pointer(aText),Length(aText),result,'',''); +end; + +function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; +var c: AnsiChar; +begin // P^='"' at function call + inc(P); + repeat + c := P^; + if c=#0 then + break else + if c<>'\' then + if c<>'"' then // ignore \" + inc(P) else + break else // found ending " + if P[1]=#0 then // avoid potential buffer overflow issue for \#0 + break else + inc(P,2); // ignore \? + until false; + result := P; +end; // P^='"' at function return + +function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; +begin + {$ifdef FPC} + while (P^<=' ') and (P^<>#0) do inc(P); + {$else} + if P^ in [#1..' '] then + repeat + inc(P) + until not(P^ in [#1..' ']); + {$endif} + result := P; +end; + +function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; +begin + while P^ in [#9,' '] do inc(P); + result := P; +end; + +function GotoNextSpace(P: PUTF8Char): PUTF8Char; +begin + if P^>' ' then + repeat + inc(P) + until P^<=' '; + result := P; +end; + +function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; +begin + while (P^<=' ') and (P^<>#0) do inc(P); + if P^=ch then begin + inc(P); + result := true; + end else + result := false; +end; + +function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; +var quote: AnsiChar; + PBeg, PS: PUTF8Char; + internalquote: PtrInt; +begin + if P=nil then begin + result := nil; + exit; + end; + quote := P^; // " or ' + inc(P); + // compute unquoted string length + PBeg := P; + internalquote := 0; + repeat + if P^=#0 then + break; + if P^<>quote then + inc(P) else + if P[1]=quote then begin + inc(P,2); // allow double quotes inside string + inc(internalquote); + end else + break; // end quote + until false; + if P^=#0 then begin + result := nil; // end of string before end quote -> incorrect + exit; + end; + // create unquoted string + if internalquote=0 then + // no quote within + FastSetString(Value,PBeg,P-PBeg) else begin + // unescape internal quotes + SetLength(Value,P-PBeg-internalquote); + P := PBeg; + PS := Pointer(Value); + repeat + if P^=quote then + if P[1]=quote then + inc(P) else // allow double quotes inside string + break; // end quote + PS^ := P^; + inc(PByte(PS)); + inc(P); + until false; + end; + result := P+1; +end; + +function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; +begin + UnQuoteSQLStringVar(pointer(Value),result); +end; + +function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; +begin + if (ExternalDBSymbol<>'') and + (ExternalDBSymbol[1] in ['[','"','''','(']) then // e.g. for ZDBC's GetFields() + result := copy(ExternalDBSymbol,2,length(ExternalDBSymbol)-2) else + result := ExternalDBSymbol; +end; + +function isSelect(P: PUTF8Char; SelectClause: PRawUTF8): boolean; +var from: PUTF8Char; +begin + if P<>nil then begin + P := SQLBegin(P); + case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH','EXECUTE']) of + 0: if P[6]<=' ' then begin + if SelectClause<>nil then begin + inc(P,7); + from := StrPosI(' FROM ',P); + if from=nil then + SelectClause^ := '' else + FastSetString(SelectClause^,P,from-P); + end; + result := true; + end else + result := false; + 1: result := true; + 2,3: result := P[6] in [#0..' ',';']; + 4: result := (P[4]<=' ') and not (StrPosI('INSERT',P+5)<>nil) or + (StrPosI('UPDATE',P+5)<>nil) or (StrPosI('DELETE',P+5)<>nil); + 5: begin // FireBird specific + P := GotoNextNotSpace(P+7); + result := IdemPChar(P,'BLOCK') and IdemPChar(GotoNextNotSpace(P+5),'RETURNS'); + end + else result := false; + end; + end else + result := true; // assume '' statement is SELECT command +end; + +function SQLBegin(P: PUTF8Char): PUTF8Char; +begin + if P<>nil then + repeat + if P^<=' ' then // ignore blanks + repeat + if P^=#0 then + break else + inc(P) + until P^>' '; + if PWord(P)^=ord('-')+ord('-')shl 8 then // SQL comments + repeat + inc(P) + until P^ in [#0,#10] + else + if PWord(P)^=ord('/')+ord('*')shl 8 then begin // C comments + inc(P); + repeat + inc(P); + if PWord(P)^=ord('*')+ord('/')shl 8 then begin + inc(P,2); + break; + end; + until P^=#0; + end + else break; + until false; + result := P; +end; + +procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); +begin + if where='' then + where := condition else + where := where+' and '+condition; +end; + +procedure Base64MagicDecode(var ParamValue: RawUTF8); +var + tmp: RawUTF8; +begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked) + tmp := ParamValue; + if not Base64ToBinSafe(PAnsiChar(pointer(tmp))+3,length(tmp)-3,RawByteString(ParamValue)) then + ParamValue := ''; +end; + +function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; +var ValueLen: integer; +begin // '\uFFF0base64encodedbinary' checked and decode into binary + if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or + (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then + result := false else begin + ValueLen := StrLen(Value)-3; + if ValueLen>0 then + result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen,Blob) else + result := false; + end; +end; + +function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; +var ValueLen: integer; +begin // '\uFFF0base64encodedbinary' checked and decode into binary + if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or + (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then + result := false else begin + ValueLen := StrLen(Value)-3; + if ValueLen>0 then + result := Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob) else + result := false; + end; +end; + +function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: integer; + var Blob: RawByteString): boolean; +begin // '\uFFF0base64encodedbinary' checked and decode into binary + if (ValueLen<4) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then + result := false else + result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen-3,Blob); +end; + +{$ifndef DEFINED_INT32TOUTF8} + +function Int32ToUtf8(Value: PtrInt): RawUTF8; // faster than SysUtils.IntToStr +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + if PtrUInt(Value)<=high(SmallUInt32UTF8) then + result := SmallUInt32UTF8[Value] else begin + P := StrInt32(@tmp[23],Value); + FastSetString(result,P,@tmp[23]-P); + end; +end; + +function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr +begin + Int64ToUtf8(Value,result); +end; + +function Trim(const S: RawUTF8): RawUTF8; +var I,L: PtrInt; +begin + L := Length(S); + I := 1; + while (I<=L) and (S[I]<=' ') do inc(I); + if I>L then // void string + result := '' else + if (I=1) and (S[L]>' ') then // nothing to trim + result := S else begin + while S[L]<=' ' do dec(L); // allocated trimmed + result := Copy(S,I,L-I+1); + end; +end; + +{$endif DEFINED_INT32TOUTF8} + +{$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below +function ToUTF8(Value: Int64): RawUTF8; +begin + Int64ToUTF8(Value,result); +end; +{$endif CPU64} + +function ToUTF8(Value: PtrInt): RawUTF8; +begin + Int32ToUTF8(Value,result); +end; + +procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; +begin + if Value<=high(SmallUInt32UTF8) then + result := SmallUInt32UTF8[Value] else begin + P := StrUInt32(@tmp[23],Value); + FastSetString(result,P,@tmp[23]-P); + end; +end; + +function UInt32ToUtf8(Value: PtrUInt): RawUTF8; +begin + UInt32ToUTF8(Value,result); +end; + +{$ifndef EXTENDEDTOSHORT_USESTR} +var // standard FormatSettings: force US decimal display (with '.' for floats) + SettingsUS: TFormatSettings; +{$endif EXTENDEDTOSHORT_USESTR} + +function FloatStringNoExp(S: PAnsiChar; Precision: PtrInt): PtrInt; +var i, prec: PtrInt; + c: AnsiChar; +begin + result := ord(S[0]); + prec := result; // if no decimal + if S[1]='-' then + dec(prec); + for i := 2 to result do begin // test if scientific format -> return as this + c := S[i]; + if c='E' then // should not appear + exit else + if c='.' then + if i>=precision then begin // return huge decimal number as is + result := i-1; + exit; + end else + dec(prec); + end; + if (prec>=Precision) and (prec<>result) then begin + dec(result,prec-Precision); + if S[result+1]>'5' then begin // manual rounding + prec := result; + repeat + c := S[prec]; + if c<>'.' then + if c='9' then begin + S[prec] := '0'; + if ((prec=2) and (S[1]='-')) or (prec=1) then begin + i := result; + inc(S,prec); + repeat // inlined Move(S[prec],S[prec+1],result); + S[i] := S[i-1]; + dec(i); + until i=0; + S^ := '1'; + dec(S,prec); + break; + end; + end else + if (c>='0') and (c<='8') then begin + inc(S[prec]); + break; + end else + break; + dec(prec); + until prec=0; + end; // note: this fixes http://stackoverflow.com/questions/2335162 + end; + if S[result]='0' then + repeat + dec(result); // trunc any trimming 0 + c := S[result]; + if c<>'.' then + if c<>'0' then + break else + continue else begin + dec(result); + if (result=2) and (S[1]='-') and (S[2]='0') then begin + result := 1; + S[1] := '0'; // '-0.000' -> '0' + end; + break; // if decimal are all '0' -> return only integer part + end; + until false; +end; + +function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; + Precision: integer): integer; +begin + {$ifdef DOUBLETOSHORT_USEGRISU} + if Precision=DOUBLE_PRECISION then + DoubleToAscii(0,Precision,Value,@S) else + {$endif DOUBLETOSHORT_USEGRISU} + str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000' + result := FloatStringNoExp(@S,Precision); + S[0] := AnsiChar(result); +end; + +const // range when to switch into scientific notation - minimal 6 digits + SINGLE_HI: TSynExtended = 1E3; // for proper Delphi 5 compilation + SINGLE_LO: TSynExtended = 1E-3; + DOUBLE_HI: TSynExtended = 1E9; + DOUBLE_LO: TSynExtended = 1E-9; + EXT_HI: TSynExtended = 1E12; + EXT_LO: TSynExtended = 1E-12; + +function ExtendedToShort(var S: ShortString; Value: TSynExtended; + Precision: integer): integer; +{$ifdef EXTENDEDTOSHORT_USESTR} +var scientificneeded: boolean; + valueabs: TSynExtended; +begin + {$ifdef DOUBLETOSHORT_USEGRISU} + if Precision=DOUBLE_PRECISION then begin + result := DoubleToShort(S,Value); + exit; + end; + {$endif DOUBLETOSHORT_USEGRISU} + if Value=0 then begin + PWord(@s)^ := 1 + ord('0') shl 8; + result := 1; + exit; + end; + scientificneeded := false; + valueabs := abs(Value); + if Precision<=SINGLE_PRECISION then begin + if (valueabs>SINGLE_HI) or (valueabsDOUBLE_PRECISION then begin + if (valueabs>EXT_HI) or (valueabsDOUBLE_HI) or (valueabs ' 0.0E+0000' + result := FloatStringNoExp(@S,Precision); + S[0] := AnsiChar(result); + end; +end; +{$else} +{$ifdef UNICODE} +var i: PtrInt; +{$endif} +begin + // use ffGeneral: see https://synopse.info/forum/viewtopic.php?pid=442#p442 + result := FloatToText(PChar(@S[1]), Value, fvExtended, ffGeneral, + Precision, 0, SettingsUS); + {$ifdef UNICODE} // FloatToText(PWideChar) is faster than FloatToText(PAnsiChar) + for i := 1 to result do + PByteArray(@S)[i] := PWordArray(PtrInt(@S)-1)[i]; + {$endif} + S[0] := AnsiChar(result); +end; +{$endif EXTENDEDTOSHORT_USESTR} + +function FloatToShortNan(const s: shortstring): TFloatNan; +begin + case PInteger(@s)^ and $ffdfdfdf of + 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: + result := fnNan; + 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, + 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: + result := fnInf; + 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: + result := fnNegInf; + else + result := fnNumber; + end; +end; + +function FloatToStrNan(const s: RawUTF8): TFloatNan; +begin + case length(s) of + 3: case PInteger(s)^ and $dfdfdf of + ord('N')+ord('A')shl 8+ord('N')shl 16: result := fnNan; + ord('I')+ord('N')shl 8+ord('F')shl 16: result := fnInf; + else result := fnNumber; + end; + 4: case PInteger(s)^ and $dfdfdfdf of + ord('+')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnInf; + ord('-')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnNegInf; + else result := fnNumber; + end; + else result := fnNumber; + end; +end; + +function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; +begin + ExtendedToStr(Value,Precision,result); +end; + +procedure ExtendedToStr(Value: TSynExtended; Precision: integer; + var result: RawUTF8); +var tmp: ShortString; +begin + if Value=0 then + result := SmallUInt32UTF8[0] else + FastSetString(result,@tmp[1],ExtendedToShort(tmp,Value,Precision)); +end; + +function FloatToJSONNan(const s: ShortString): PShortString; +begin + case PInteger(@s)^ and $ffdfdfdf of + 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: + result := @JSON_NAN[fnNan]; + 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, + 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: + result := @JSON_NAN[fnInf]; + 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: + result := @JSON_NAN[fnNegInf]; + else + result := @s; + end; +end; + +function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; + Precision: integer; NoExp: boolean): PShortString; +begin + if Value=0 then + result := @JSON_NAN[fnNumber] else begin + if noexp then + ExtendedToShortNoExp(tmp,Value,precision) else + ExtendedToShort(tmp,Value,precision); + result := FloatToJSONNan(tmp); + end; +end; + +procedure Div100(Y: cardinal; var res: TDiv100Rec); +{$ifdef FPC} +var Y100: cardinal; +begin + Y100 := Y div 100; // FPC will use fast reciprocal + res.D := Y100; + res.M := Y-Y100*100; // avoid div twice +end; +{$else} +{$ifdef CPUX64} +asm + .noframe + mov r8, res + mov edx, Y + mov dword ptr [r8].TDiv100Rec.M,edx + mov eax, 1374389535 + mul edx + shr edx, 5 + mov dword ptr [r8].TDiv100Rec.D, edx + imul eax, edx, 100 + sub dword ptr [r8].TDiv100Rec.M, eax +end; +{$else} +asm + mov dword ptr [edx].TDiv100Rec.M, eax + mov ecx, edx + mov edx, eax + mov eax, 1374389535 + mul edx + shr edx, 5 + mov dword ptr [ecx].TDiv100Rec.D, edx + imul eax, edx, 100 + sub dword ptr [ecx].TDiv100Rec.M, eax +end; +{$endif CPUX64} +{$endif FPC} + +{$ifdef DOUBLETOSHORT_USEGRISU} + +// includes Fabian Loitsch's Grisu algorithm especially compiled for double +{$I SynDoubleToText.inc} // implements DoubleToAscii() + +function DoubleToShort(var S: ShortString; const Value: double): integer; +var valueabs: double; +begin + valueabs := abs(Value); + if (valueabs>DOUBLE_HI) or (valueabs=high(blocks) then + raise ESynException.Create('FormatUTF8: too many args (max=32)!'); + L := 0; + argN := 0; + b := @blocks; + F := pointer(Format); + repeat + if F^=#0 then + break; + if F^<>'%' then begin + FDeb := F; + repeat + inc(F); + until (F^='%') or (F^=#0); + b^.Text := FDeb; + b^.Len := F-FDeb; + b^.TempRawUTF8 := nil; + inc(L,b^.Len); + inc(b); + if F^=#0 then + break; + end; + inc(F); // jump '%' + if argN<=high(Args) then begin + inc(L,VarRecToTempUTF8(Args[argN],b^)); + if b.Len>0 then + inc(b); + inc(argN); + if F^=#0 then + break; + end else // no more available Args -> add all remaining text + if F^=#0 then + break else begin + b^.Len := length(Format)-(F-pointer(Format)); + b^.Text := F; + b^.TempRawUTF8 := nil; + inc(L,b^.Len); + inc(b); + break; + end; + until false; +end; + +procedure TFormatUTF8.Write(Dest: PUTF8Char); +var d: PTempUTF8; +begin + d := @blocks; + repeat + {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); + inc(Dest,d^.Len); + if d^.TempRawUTF8<>nil then + {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; + inc(d); + until d=b; +end; + +function TFormatUTF8.WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char; +var d: PTempUTF8; +begin + if Max>0 then begin + inc(Max,PtrUInt(Dest)); + d := @blocks; + if Dest<>nil then + repeat + if PtrUInt(Dest)+PtrUInt(d^.Len)>Max then begin // avoid buffer overflow + {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},Max-PtrUInt(Dest)); + repeat + if d^.TempRawUTF8<>nil then + {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; + inc(d); + until d=b; // avoid memory leak + result := PUTF8Char(Max); + exit; + end; + {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); + inc(Dest,d^.Len); + if d^.TempRawUTF8<>nil then + {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; + inc(d); + until d=b; + end; + result := Dest; +end; + +procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; + out result: RawUTF8); +var process: TFormatUTF8; +begin + if (Format='') or (high(Args)<0) then // no formatting needed + result := Format else + if PWord(Format)^=ord('%') then // optimize raw conversion + VarRecToUTF8(Args[0],result) else begin + process.Parse(Format,Args); + if process.L<>0 then begin + FastSetString(result,nil,process.L); + process.Write(pointer(result)); + end; + end; +end; + +procedure FormatShort(const Format: RawUTF8; const Args: array of const; + var result: shortstring); +var process: TFormatUTF8; +begin + if (Format='') or (high(Args)<0) then // no formatting needed + SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin + process.Parse(Format,Args); + result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); + end; +end; + +function FormatBuffer(const Format: RawUTF8; const Args: array of const; + Dest: pointer; DestLen: PtrInt): PtrInt; +var process: TFormatUTF8; +begin + if (Dest=nil) or (DestLen<=0) then begin + result := 0; + exit; // avoid buffer overflow + end; + process.Parse(Format,Args); + result := PtrInt(process.WriteMax(Dest,DestLen))-PtrInt(Dest); +end; + +function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; +var process: TFormatUTF8; +begin // Delphi 5 has troubles compiling overloaded FormatShort() + process.Parse(Format,Args); + result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); +end; + +procedure FormatShort16(const Format: RawUTF8; const Args: array of const; + var result: TShort16); +var process: TFormatUTF8; +begin + if (Format='') or (high(Args)<0) then // no formatting needed + SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin + process.Parse(Format,Args); + result[0] := AnsiChar(process.WriteMax(@result[1],16)-@result[1]); + end; +end; + +procedure FormatString(const Format: RawUTF8; const Args: array of const; + out result: string); +var process: TFormatUTF8; + temp: TSynTempBuffer; // will avoid most memory allocations +begin + if (Format='') or (high(Args)<0) then begin // no formatting needed + UTF8DecodeToString(pointer(Format),length(Format),result); + exit; + end; + process.Parse(Format,Args); + temp.Init(process.L); + process.Write(temp.buf); + UTF8DecodeToString(temp.buf,process.L,result); + temp.Done; +end; + +function FormatString(const Format: RawUTF8; const Args: array of const): string; +begin + FormatString(Format,Args,result); +end; + +function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8; +var i, tmpN, L, A, P, len: PtrInt; + isParam: AnsiChar; + tmp: TRawUTF8DynArray; + inlin: set of 0..255; + F,FDeb: PUTF8Char; + wasString: Boolean; +const NOTTOQUOTE: array[boolean] of set of 0..31 = ( + [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended], + [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended,vtVariant]); +label Txt; +begin + if Format='' then begin + result := ''; + exit; + end; + if (high(Args)<0) and (high(Params)<0) then begin + // no formatting to process, but may be a const -> make unique + FastSetString(result,pointer(Format),length(Format)); + exit; // e.g. _JsonFmt() will parse it in-place + end; + if high(Params)<0 then begin + FormatUTF8(Format,Args,result); // slightly faster overloaded function + exit; + end; + if Format='%' then begin + VarRecToUTF8(Args[0],result); // optimize raw conversion + exit; + end; + result := ''; + tmpN := 0; + FillCharFast(inlin,SizeOf(inlin),0); + L := 0; + A := 0; + P := 0; + F := pointer(Format); + while F^<>#0 do begin + if F^<>'%' then begin + FDeb := F; + while not (F^ in [#0,'%','?']) do inc(F); +Txt: len := F-FDeb; + if len>0 then begin + inc(L,len); + if tmpN=length(tmp) then + SetLength(tmp,tmpN+8); + FastSetString(tmp[tmpN],FDeb,len); // add inbetween text + inc(tmpN); + end; + end; + if F^=#0 then + break; + isParam := F^; + inc(F); // jump '%' or '?' + if (isParam='%') and (A<=high(Args)) then begin // handle % substitution + if tmpN=length(tmp) then + SetLength(tmp,tmpN+8); + VarRecToUTF8(Args[A],tmp[tmpN]); + inc(A); + if tmp[tmpN]<>'' then begin + inc(L,length(tmp[tmpN])); + inc(tmpN); + end; + end else + if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution + if tmpN=length(tmp) then + SetLength(tmp,tmpN+8); + {$ifndef NOVARIANTS} + if JSONFormat and (Params[P].VType=vtVariant) then + VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else + {$endif} + begin + VarRecToUTF8(Params[P],tmp[tmpN]); + wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]); + if wasString then + if JSONFormat then + QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else + tmp[tmpN] := QuotedStr(tmp[tmpN],''''); + if not JSONFormat then begin + inc(L,4); // space for :(): + include(inlin,tmpN); + end; + end; + inc(P); + inc(L,length(tmp[tmpN])); + inc(tmpN); + end else + if F^<>#0 then begin // no more available Args -> add all remaining text + FDeb := F; + repeat inc(F) until (F^=#0); + goto Txt; + end; + end; + if L=0 then + exit; + if not JSONFormat and (tmpN>SizeOf(inlin)shl 3) then + raise ESynException.CreateUTF8( + 'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]); + FastSetString(result,nil,L); + F := pointer(result); + for i := 0 to tmpN-1 do + if tmp[i]<>'' then begin + if byte(i) in inlin then begin + PWord(F)^ := ord(':')+ord('(')shl 8; + inc(F,2); + end; + L := PStrLen(PtrUInt(tmp[i])-_STRLEN)^; + MoveFast(pointer(tmp[i])^,F^,L); + inc(F,L); + if byte(i) in inlin then begin + PWord(F)^ := ord(')')+ord(':')shl 8; + inc(F,2); + end; + end; +end; + +function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; + const values: array of pointer; ident: PRawUTF8DynArray): integer; +var + v,w: PtrInt; + F,FEnd,PEnd: PUTF8Char; + tab: PTextCharSet; +label next; +begin + result := 0; + if (fmt='') or (P=nil) or (PLen<=0) or (high(values)<0) then + exit; + if ident<>nil then + SetLength(ident^,length(values)); + F := pointer(fmt); + FEnd := F+length(fmt); + PEnd := P+PLen; + for v := 0 to high(values) do + repeat + if (P^<=' ') and (P^<>#0) then // ignore any whitespace char in text + repeat + inc(P); + if P=PEnd then + exit; + until (P^>' ') or (P^=#0); + while (F^<=' ') and (F^<>#0) do begin // ignore any whitespace char in fmt + inc(F); + if F=FEnd then + exit; + end; + if F^='%' then begin // format specifier + inc(F); + if F=FEnd then + exit; + case F^ of + 'd': PInteger(values[v])^ := GetNextItemInteger(P,#0); + 'D': PInt64(values[v])^ := GetNextItemInt64(P,#0); + 'u': PCardinal(values[v])^ := GetNextItemCardinal(P,#0); + 'U': PQword(values[v])^ := GetNextItemQword(P,#0); + 'f': unaligned(PDouble(values[v])^) := GetNextItemDouble(P,#0); + 'F': GetNextItemCurrency(P,PCurrency(values[v])^,#0); + 'x': if not GetNextItemHexDisplayToBin(P,values[v],4,#0) then + exit; + 'X': if not GetNextItemHexDisplayToBin(P,values[v],8,#0) then + exit; + 's','S': begin + w := 0; + while (P[w]>' ') and (P+w<=PEnd) do inc(w); + if F^='s' then + SetString(PShortString(values[v])^,PAnsiChar(P),w) else + FastSetString(PRawUTF8(values[v])^,P,w); + inc(P,w); + while (P^<=' ') and (P^<>#0) and (P<=PEnd) do inc(P); + end; + 'L': begin + w := 0; + tab := @TEXT_CHARS; + while (tcNot01013 in tab[P[w]]) and (P+w<=PEnd) do inc(w); + FastSetString(PRawUTF8(values[v])^,P,w); + inc(P,w); + end; + '%': goto next; + else raise ESynException.CreateUTF8('ScanUTF8: unknown ''%'' specifier [%]',[F^,fmt]); + end; + inc(result); + tab := @TEXT_CHARS; + if (tcIdentifier in tab[F[1]]) or (ident<>nil) then begin + w := 0; + repeat inc(w) until not(tcIdentifier in tab[F[w]]) or (F+w=FEnd); + if ident<>nil then + FastSetString(ident^[v],F,w); + inc(F,w); + end else + inc(F); + if (F>=FEnd) or (P>=PEnd) then + exit; + break; + end else begin +next: while (P^<>F^) and (P<=PEnd) do inc(P); + inc(F); + inc(P); + if (F>=FEnd) or (P>=PEnd) then + exit; + end; + until false; +end; + +function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; + ident: PRawUTF8DynArray): integer; +begin + result := ScanUTF8(pointer(text),length(text),fmt,values,ident); +end; + +function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; +var i, L: PtrInt; + P: PAnsiChar; +begin + L := 0; + for i := 0 to high(Values) do + inc(L,length(Values[i])); + SetString(Result,nil,L); + P := pointer(Result); + for i := 0 to high(Values) do begin + L := length(Values[i]); + MoveFast(pointer(Values[i])^,P^,L); + inc(P,L); + end; +end; + +procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); +var L: Integer; +begin + L := Length(buf); + if L<>0 then begin + SetLength(bytes,L); + MoveFast(pointer(buf)^,pointer(bytes)^,L); + end; +end; + +procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); +begin + SetString(buf,PAnsiChar(pointer(bytes)),Length(bytes)); +end; + +procedure ResourceToRawByteString(const ResName: string; ResType: PChar; + out buf: RawByteString; Instance: THandle); +var HResInfo: THandle; + HGlobal: THandle; +begin + if Instance=0 then + Instance := HInstance; + HResInfo := FindResource(Instance,PChar(ResName),ResType); + if HResInfo=0 then + exit; + HGlobal := LoadResource(Instance,HResInfo); + if HGlobal<>0 then begin + SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(Instance,HResInfo)); + UnlockResource(HGlobal); // only needed outside of Windows + FreeResource(HGlobal); + end; +end; + +procedure ResourceSynLZToRawByteString(const ResName: string; + out buf: RawByteString; Instance: THandle); +var HResInfo: THandle; + HGlobal: THandle; +begin + if Instance=0 then + Instance := HInstance; + HResInfo := FindResource(Instance,PChar(ResName),PChar(10)); + if HResInfo=0 then + exit; + HGlobal := LoadResource(Instance,HResInfo); + if HGlobal<>0 then // direct decompression from memory mapped .exe content + try + AlgoSynLZ.Decompress(LockResource(HGlobal),SizeofResource(Instance,HResInfo),buf); + finally + UnlockResource(HGlobal); // only needed outside of Windows + FreeResource(HGlobal); + end; +end; + +function StrLenW(S: PWideChar): PtrInt; +begin + result := 0; + if S<>nil then + while true do + if S[result+0]<>#0 then + if S[result+1]<>#0 then + if S[result+2]<>#0 then + if S[result+3]<>#0 then + inc(result,4) else begin + inc(result,3); + exit; + end else begin + inc(result,2); + exit; + end else begin + inc(result); + exit; + end else + exit; +end; + +function StrCompW(Str1, Str2: PWideChar): PtrInt; +begin + if Str1<>Str2 then + if Str1<>nil then + if Str2<>nil then begin + if Str1^=Str2^ then + repeat + if (Str1^=#0) or (Str2^=#0) then break; + inc(Str1); + inc(Str2); + until Str1^<>Str2^; + result := PWord(Str1)^-PWord(Str2)^; + exit; + end else + result := 1 else // Str2='' + result := -1 else // Str1='' + result := 0; // Str1=Str2 +end; + +{$ifdef PUREPASCAL} + +function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; +// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) +var table: PNormTable; + u: AnsiChar; +begin + result := false; + if p=nil then + exit; + if up<>nil then begin + dec(PtrUInt(p),PtrUInt(up)); + table := @NormToUpperAnsi7; + repeat + u := up^; + if u=#0 then + break; + if u<>table^[up[PtrUInt(p)]] then + exit; + inc(up); + until false; + end; + result := true; +end; + +function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; +begin + result := 0; + dec(Count,4); + if P<>nil then begin + repeat + if result>Count then + break; + if P^[result]<>Value then + if P^[result+1]<>Value then + if P^[result+2]<>Value then + if P^[result+3]<>Value then begin + inc(result,4); + continue; + end else + inc(result,3) else + inc(result,2) else + inc(result); + exit; + until false; + inc(Count,4); + repeat + if result>=Count then + break; + if P^[result]=Value then + exit else + inc(result); + until false; + end; + result := -1; +end; + +function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; +begin + result := nil; + if P=nil then + exit; + Count := PtrInt(@P[Count-4]); + repeat + if PtrUInt(P)>PtrUInt(Count) then + break; + if P^[0]<>Value then + if P^[1]<>Value then + if P^[2]<>Value then + if P^[3]<>Value then begin + P := @P[4]; + continue; + end else + result := @P[3] else + result := @P[2] else + result := @P[1] else + result := pointer(P); + exit; + until false; + inc(Count,4*SizeOf(Value)); + result := pointer(P); + repeat + if PtrUInt(result)>=PtrUInt(Count) then + break; + if result^=Value then + exit else + inc(result); + until false; + result := nil; +end; + +function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; +begin + if P<>nil then begin + result := true; + Count := PtrInt(@P[Count-4]); + repeat + if PtrUInt(P)>PtrUInt(Count) then + break; + if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then + exit; + P := @P[4]; + until false; + inc(Count,4*SizeOf(Value)); + repeat + if PtrUInt(P)>=PtrUInt(Count) then + break; + if P^[0]=Value then + exit else + P := @P[1]; + until false; + end; + result := false; +end; + +function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; +var c: cardinal; +begin // FPC is efficient at compiling this code + result := nil; + if Str<>nil then begin + repeat + c := PCardinal(str)^; + if ToByte(c)=0 then + exit else + if ToByte(c)=byte(Chr) then + break; + c := c shr 8; + inc(Str); + if ToByte(c)=0 then + exit else + if ToByte(c)=byte(Chr) then + break; + c := c shr 8; + inc(Str); + if ToByte(c)=0 then + exit else + if ToByte(c)=byte(Chr) then + break; + c := c shr 8; + inc(Str); + if ToByte(c)=0 then + exit else + if ToByte(c)=byte(Chr) then + break; + inc(Str); + until false; + result := Str; + end; +end; + +function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; +label zero; +begin // this code compiles well under FPC and Delphi on both 32-bit and 64-bit + Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)*2]); // = 2*PtrInt end + if Length>=PtrInt(PtrUInt(P1)) then begin + if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then // compare first PtrInt bytes + goto zero; + inc(PPtrInt(P1)); + inc(PPtrInt(P2)); + dec(PtrInt(P2),PtrInt(PtrUInt(P1))); + PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and -SizeOf(PtrInt); // align + inc(PtrInt(P2),PtrInt(PtrUInt(P1))); + if Length>=PtrInt(PtrUInt(P1)) then + repeat // compare 4 aligned PtrInt per loop + if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then + goto zero; + inc(PByte(P1),SizeOf(PtrInt)*2); + inc(PByte(P2),SizeOf(PtrInt)*2); + if LengthPPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then + goto zero; + inc(PByte(P1),SizeOf(PtrInt)*2); + inc(PByte(P2),SizeOf(PtrInt)*2); + until Length=SizeOf(PtrInt) then begin + if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then + goto zero; + inc(PPtrInt(P1)); + inc(PPtrInt(P2)); + dec(Length,SizeOf(PtrInt)); + end; + {$ifdef CPU64} + if Length>=4 then begin + if PCardinal(P1)^<>PCardinal(P2)^ then + goto zero; + inc(PCardinal(P1)); + inc(PCardinal(P2)); + dec(Length,4); + end; + {$endif} + if Length>=2 then begin + if PWord(P1)^<>PWord(P2)^ then + goto zero; + inc(PWord(P1)); + inc(PWord(P2)); + dec(Length,2); + end; + if Length>=1 then + if PByte(P1)^<>PByte(P2)^ then + goto zero; + result := true; + exit; +zero: + result := false; +end; + +{$ifdef HASINLINE} // to use directly the SubStr/S arguments registers +function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): PtrInt; +begin + result := PosExPas(pointer(SubStr),pointer(S),Offset); +end; +{$endif HASINLINE} + +// from Aleksandr Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform +function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; +var len, lenSub: PtrInt; + ch: AnsiChar; + pStart, pStop: PUTF8Char; +label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, + AfterTestT, AfterTest0, Ret, Exit; +begin + result := 0; + if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then + goto Exit; + len := PStrLen(p-_STRLEN)^; + lenSub := PStrLen(pSub-_STRLEN)^-1; + if (len=pStop then goto Exit; + goto Loop2; +Test4: dec(p,2); +Test2: dec(p,2); + goto Test0; +Test3: dec(p,2); +Test1: dec(p,2); +TestT: len := lenSub; + if lenSub<>0 then + repeat + if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then + goto AfterTestT; + inc(len,2); + until len>=0; + inc(p,2); + if p<=pStop then goto Ret; + goto Exit; +Test0: len := lenSub; + if lenSub<>0 then + repeat + if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then + goto AfterTest0; + inc(len,2); + until len>=0; + inc(p); +Ret: + result := p-pStart; +Exit: +end; + +function IdemPropNameU(const P1,P2: RawUTF8): boolean; +var L: PtrInt; +begin + L := length(P1); + if length(P2)=L then + result := IdemPropNameUSameLen(pointer(P1),pointer(P2),L) else + result := false; +end; + +function StrIComp(Str1, Str2: pointer): PtrInt; +var C1,C2: byte; // integer/PtrInt are actually slower on FPC + lookupper: PByteArray; // better x86-64 / PIC asm generation +begin + result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); + if result<>0 then + if Str1<>nil then + if Str2<>nil then begin + lookupper := @NormToUpperAnsi7Byte; + repeat + C1 := lookupper[PByteArray(Str1)[0]]; + C2 := lookupper[PByteArray(Str1)[result]]; + inc(PByte(Str1)); + until (C1=0) or (C1<>C2); + result := C1-C2; + end else + result := 1 else // Str2='' + result := -1; // Str1='' +end; + +function StrLenPas(S: pointer): PtrInt; +label + _0, _1, _2, _3; // ugly but faster +begin + result := PtrUInt(S); + if S<>nil then begin + while true do + if PAnsiChar(result)[0]=#0 then + goto _0 + else if PAnsiChar(result)[1]=#0 then + goto _1 + else if PAnsiChar(result)[2]=#0 then + goto _2 + else if PAnsiChar(result)[3]=#0 then + goto _3 + else + inc(result, 4); +_3: inc(result); +_2: inc(result); +_1: inc(result); +_0: dec(result,PtrUInt(S)); // return length + end; +end; + +function StrCompFast(Str1, Str2: pointer): PtrInt; +var c: byte; +begin + if Str1<>Str2 then + if Str1<>nil then + if Str2<>nil then begin + c := PByte(Str1)^; + if c=PByte(Str2)^ then + repeat + if c=0 then break; + inc(PByte(Str1)); + inc(PByte(Str2)); + c := PByte(Str1)^; + until c<>PByte(Str2)^; + result := c-PByte(Str2)^; + exit; + end else + result := 1 else // Str2='' + result := -1 else // Str1='' + result := 0; // Str1=Str2 +end; + +procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); +var d100: PtrUInt; + tab: PWordArray; +begin + tab := @TwoDigitLookupW; + d100 := Y div 100; + PWordArray(P)[0] := tab[d100]; + PWordArray(P)[1] := tab[Y-(d100*100)]; +end; + +procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUTF8Char); {$ifdef HASINLINE}inline;{$endif} +var d100: PtrUInt; +begin + d100 := Y div 100; + PWordArray(P)[0] := tab[d100]; + PWordArray(P)[1] := tab[Y-(d100*100)]; +end; + +function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; +begin + result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); +end; + +function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; +var s: PAnsiChar; + c: byte; + lookupper: PByteArray; // better x86-64 / PIC asm generation +begin + s := pointer(source); + if s<>nil then begin + lookupper := @NormToUpperAnsi7Byte; + repeat + c := lookupper[ord(s^)]; + if c=0 then + break; + dest^ := AnsiChar(c); + inc(s); + inc(dest); + until false; + end; + result := dest; +end; + +function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; +var s: PByteArray; + i: PtrInt; + lookupper: PByteArray; // better x86-64 / PIC asm generation +begin + s := @source; + lookupper := @NormToUpperAnsi7Byte; + for i := 1 to s[0] do begin + dest^ := AnsiChar(lookupper[s[i]]); + inc(dest); + end; + result := dest; +end; + +function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; +begin + if source=nil then + result := false else begin + result := IdemPChar(source,searchUp); + source := GotoNextLine(source); + end; +end; + +function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; +var i: PtrInt; +begin + if buf<>nil then + for i := 0 to len-1 do + crc := (crc xor ord(buf[i]))*16777619; + result := crc; +end; + +function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; +var i: PtrInt; +begin + if buf<>nil then + for i := 0 to len-1 do begin + crc := crc*31; + inc(crc,ord(buf[i])); + end; + result := crc; +end; + +procedure crcblockNoSSE42(crc128, data128: PBlock128); +var c: cardinal; + tab: PCrc32tab; +begin + tab := @crc32ctab; + c := crc128^[0] xor data128^[0]; + crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[1] xor data128^[1]; + crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[2] xor data128^[2]; + crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[3] xor data128^[3]; + crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; +end; + +function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$ifdef ABSOLUTEPASCALORNOTINTEL} +var tab: PCrc32tab; +begin // on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache + tab := @crc32ctab; + result := not crc; + if (buf<>nil) and (len>0) then begin + repeat + if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary + break; + result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); + dec(len); + inc(buf); + until len=0; + if len>=4 then + repeat + result := result xor PCardinal(buf)^; + inc(buf,4); + dec(len,4); + result := tab[3,ToByte(result)] xor + tab[2,ToByte(result shr 8)] xor + tab[1,ToByte(result shr 16)] xor + tab[0,ToByte(result shr 24)]; + until len<4; + while len>0 do begin + result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); + dec(len); + inc(buf); + end; + end; + result := not result; +end; +{$else} +{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + {$ifndef win64} + mov r8d, len + {$endif} + mov eax, crc + xor ecx, ecx + test buf, buf // buf=rdx/rsi len=r8 + jz @z + neg r8 + jz @z + not eax + lea r9, [rip + crc32ctab] + cmp r8, -8 + jb @head +@sml: mov cl, byte ptr[buf] + inc buf + xor cl, al + shr eax, 8 + xor eax, dword ptr[rcx * 4 + r9] + inc r8 + jnz @sml +@0: not eax +@z: ret +@head: test buf, 7 + jz @align + mov cl, byte ptr[buf] + inc buf + xor cl, al + shr eax, 8 + xor eax, dword ptr[rcx * 4 + r9] + inc r8 + jnz @head + not eax + ret +@align: sub buf, r8 + add r8, 8 + jg @done + xor r11, r11 +@by8: mov r10d, eax + mov rcx, qword ptr[buf + r8 - 8] + xor r10d, ecx + shr rcx, 32 + mov r11b, cl + shr ecx, 8 + mov eax, dword ptr[r11 * 4 + r9 + 1024 * 3] + mov r11b, cl + shr ecx, 8 + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 2] + mov r11b, cl + shr ecx, 8 + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 1] + mov r11b, cl + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 0] + mov ecx, r10d + mov r11b, cl + shr ecx, 8 + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 7] + mov r11b, cl + shr ecx, 8 + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 6] + mov r11b, cl + shr ecx, 8 + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 5] + mov r11b, cl + xor eax, dword ptr[r11 * 4 + r9 + 1024 * 4] + add r8, 8 + jle @by8 +@done: sub r8, 8 + jge @e +@tail: mov cl, byte ptr[buf + r8] + xor cl, al + shr eax, 8 + xor eax, dword ptr[rcx * 4 + r9] + inc r8 + jnz @tail +@e: not eax +end; +{$endif ABSOLUTEPASCALORNOTINTEL} + +function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; +begin // 0=0,1=1,2=-1,3=2,4=-2... + if Value<0 then + // -1->2, -2->4.. + Value := (-Value) shl 1 else + if Value>0 then + // 1->1, 2->3.. + Value := (Value shl 1)-1; + // 0->0 + result := ToVarUInt32(Value,Dest); +end; + +function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; +label _1,_2,_3; // ugly but fast +begin + if Value>$7f then begin + if Value<$80 shl 7 then goto _1 else + if Value<$80 shl 14 then goto _2 else + if Value<$80 shl 21 then goto _3; + Dest^ := (Value and $7F) or $80; + Value := Value shr 7; + inc(Dest); +_3: Dest^ := (Value and $7F) or $80; + Value := Value shr 7; + inc(Dest); +_2: Dest^ := (Value and $7F) or $80; + Value := Value shr 7; + inc(Dest); +_1: Dest^ := (Value and $7F) or $80; + Value := Value shr 7; + inc(Dest); + end; + Dest^ := Value; + inc(Dest); + result := Dest; +end; + +{$ifdef CPUX64} // very efficient branchless asm - rcx/rdi=A rdx/rsi=B +function SortDynArrayInteger(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov r8d, dword ptr[A] + mov edx, dword ptr[B] + xor eax, eax + xor ecx, ecx + cmp r8d, edx + setl cl + setg al + sub eax, ecx +end; +function SortDynArrayCardinal(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov ecx, dword ptr[A] + mov edx, dword ptr[B] + xor eax, eax + cmp ecx, edx + seta al + sbb eax, 0 +end; +function SortDynArrayInt64(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov r8, qword ptr[A] + mov rdx, qword ptr[B] + xor eax, eax + xor ecx, ecx + cmp r8, rdx + setl cl + setg al + sub eax, ecx +end; +function SortDynArrayQWord(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov rcx, qword ptr[A] + mov rdx, qword ptr[B] + xor eax, eax + cmp rcx, rdx + seta al + sbb eax, 0 +end; +function SortDynArrayPointer(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov rcx, qword ptr[A] + mov rdx, qword ptr[B] + xor eax, eax + cmp rcx, rdx + seta al + sbb eax, 0 +end; +function SortDynArrayDouble(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + movsd xmm0, qword ptr[A] + movsd xmm1, qword ptr[B] + xor eax, eax + xor edx, edx + comisd xmm0, xmm1 + seta al + setb dl + sub eax, edx +end; +function SortDynArraySingle(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + movss xmm0, dword ptr[A] + movss xmm1, dword ptr[B] + xor eax, eax + xor edx, edx + comiss xmm0, xmm1 + seta al + setb dl + sub eax, edx +end; +function SortDynArrayAnsiString(const A,B): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + mov rcx, qword ptr[A] + mov rdx, qword ptr[B] + cmp rcx, rdx // A=B (happens with string refcounting) + je @0 + test rcx, rdx // A^ or B^ may be nil i.e. '' + jz @n1 +@s: mov al, byte ptr[rcx] // by char comparison + cmp al, byte ptr[rdx] + jne @ne + inc rcx + inc rdx + test al, al + jnz @s +@0: xor eax, eax + ret +@n1: test rcx, rcx + jz @less // A='' -> -1 + test rdx, rdx + jnz @s // B='' -> 1 +@1: mov eax, 1 + ret +@ne: jnc @1 +@less: mov eax, -1 +end; // note: SSE4.2 read up to 16 bytes after buffer, this version won't +{$else} +function SortDynArrayInteger(const A,B): integer; +begin + result := ord(integer(A)>integer(B))-ord(integer(A)cardinal(B))-ord(cardinal(A)Int64(B))-ord(Int64(A)QWord(B))-ord(QWord(A)PtrUInt(B))-ord(PtrUInt(A)double(B))-ord(double(A)single(B))-ord(single(A)B)-ord(Ap2 then + if p1<>nil then + if p2<>nil then begin + l1 := PStrLen(PtrUInt(p1)-_STRLEN)^; + l2 := PStrLen(PtrUInt(p2)-_STRLEN)^; + l := l1; + if l20 then + exit; + inc(i); + until i>=l; + result := l1-l2; + end else + result := 1 else // p2='' + result := -1 else // p1='' + result := 0; // p1=p2 +end; + +function SortDynArrayPUTF8Char(const A,B): integer; +begin + result := StrCompFast(pointer(A),pointer(B)); +end; + +{$else PUREPASCAL} + +function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm + test eax, eax + jz @e // P=nil -> false + test edx, edx + push ebx + jz @t // up=nil -> true + xor ebx, ebx +@1: mov ecx, [edx] // optimized for DWORD aligned read up^ + test cl, cl + mov bl, [eax] + jz @t // up^[0]=#0 -> OK + cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[0]] + jne @f + mov bl, [eax + 1] + test ch, ch + jz @t // up^[1]=#0 -> OK + cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[1]] + jne @f + shr ecx, 16 // cl=up^[2] ch=up^[3] + mov bl, [eax + 2] + test cl, cl + jz @t // up^[2]=#0 -> OK + cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[2]] + jne @f + mov bl, [eax + 3] + add eax, 4 + add edx, 4 + test ch, ch + jz @t // up^[3]=#0 -> OK + cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[3]] + je @1 +@f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE +@e: xor eax, eax + ret +@t: pop ebx // up^=#0 -> TRUE + mov al, 1 +end; + +function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm + push eax + call IntegerScan + pop edx + test eax, eax + jnz @e + dec eax // returns -1 + ret +@e: sub eax, edx + shr eax, 2 +end; + +function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=P, edx=Count, Value=ecx + test eax, eax + jz @ok0 // avoid GPF + cmp edx, 8 + jb @s2 + nop + nop + nop // @s1 loop align +@s1: sub edx, 8 + cmp [eax], ecx + je @ok0 + cmp [eax + 4], ecx + je @ok4 + cmp [eax + 8], ecx + je @ok8 + cmp [eax + 12], ecx + je @ok12 + cmp [eax + 16], ecx + je @ok16 + cmp [eax + 20], ecx + je @ok20 + cmp [eax + 24], ecx + je @ok24 + cmp [eax + 28], ecx + je @ok28 + add eax, 32 + cmp edx, 8 + jae @s1 +@s2: test edx, edx + jz @z + cmp [eax], ecx + je @ok0 + dec edx + jz @z + cmp [eax + 4], ecx + je @ok4 + dec edx + jz @z + cmp [eax + 8], ecx + je @ok8 + dec edx + jz @z + cmp [eax + 12], ecx + je @ok12 + dec edx + jz @z + cmp [eax + 16], ecx + je @ok16 + dec edx + jz @z + cmp [eax + 20], ecx + je @ok20 + dec edx + jz @z + cmp [eax + 24], ecx + je @ok24 +@z: xor eax, eax // return nil if not found + ret +@ok0: rep ret +@ok28: add eax, 28 + ret +@ok24: add eax, 24 + ret +@ok20: add eax, 20 + ret +@ok16: add eax, 16 + ret +@ok12: add eax, 12 + ret +@ok8: add eax, 8 + ret +@ok4: add eax, 4 +end; + +function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=P, edx=Count, Value=ecx + test eax, eax + jz @z // avoid GPF + cmp edx, 8 + jae @s1 + jmp dword ptr[edx * 4 + @Table] +@Table: dd @z, @1, @2, @3, @4, @5, @6, @7 +@s1: // fast search by 8 integers (pipelined instructions) + sub edx, 8 + cmp [eax], ecx + je @ok + cmp [eax + 4], ecx + je @ok + cmp [eax + 8], ecx + je @ok + cmp [eax + 12], ecx + je @ok + cmp [eax + 16], ecx + je @ok + cmp [eax + 20], ecx + je @ok + cmp [eax + 24], ecx + je @ok + cmp [eax + 28], ecx + je @ok + add eax, 32 + cmp edx, 8 + jae @s1 + jmp dword ptr[edx * 4 + @Table] +@7: cmp [eax + 24], ecx + je @ok +@6: cmp [eax + 20], ecx + je @ok +@5: cmp [eax + 16], ecx + je @ok +@4: cmp [eax + 12], ecx + je @ok +@3: cmp [eax + 8], ecx + je @ok +@2: cmp [eax + 4], ecx + je @ok +@1: cmp [eax], ecx + je @ok +@z: xor eax, eax + ret +@ok: mov al, 1 +end; + +function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // faster version by AB - eax=Str dl=Chr + test eax, eax + jz @z +@1: mov ecx, dword ptr [eax] + cmp cl, dl + je @z + inc eax + test cl, cl + jz @e + cmp ch, dl + je @z + inc eax + test ch, ch + jz @e + shr ecx, 16 + cmp cl, dl + je @z + inc eax + test cl, cl + jz @e + cmp ch, dl + je @z + inc eax + test ch, ch + jnz @1 +@e: xor eax, eax + ret +@z: db $f3 // rep ret +end; + +function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=P1 edx=P2 ecx=Length + cmp eax, edx + je @0 // P1=P2 + sub ecx, 8 + jl @small + push ebx + mov ebx, [eax] // Compare First 4 Bytes + cmp ebx, [edx] + jne @setbig + lea ebx, [eax + ecx] // Compare Last 8 Bytes + add edx, ecx + mov eax, [ebx] + cmp eax, [edx] + jne @setbig + mov eax, [ebx + 4] + cmp eax, [edx + 4] + jne @setbig + sub ecx, 4 + jle @true // All Bytes already Compared + neg ecx // ecx=-(Length-12) + add ecx, ebx // DWORD Align Reads + and ecx, -4 + sub ecx, ebx +@loop: mov eax, [ebx + ecx] // Compare 8 Bytes per Loop + cmp eax, [edx + ecx] + jne @setbig + mov eax, [ebx + ecx + 4] + cmp eax, [edx + ecx + 4] + jne @setbig + add ecx, 8 + jl @loop +@true: pop ebx +@0: mov al, 1 + ret +@setbig:pop ebx + setz al + ret +@small: add ecx, 8 // ecx=0..7 + jle @0 // Length <= 0 + neg ecx // ecx=-1..-7 + lea ecx, [@1 + ecx * 8 + 8] // each @#: block below = 8 bytes + jmp ecx +@7: mov cl, [eax + 6] + cmp cl, [edx + 6] + jne @setsml +@6: mov ch, [eax + 5] + cmp ch, [edx + 5] + jne @setsml +@5: mov cl, [eax + 4] + cmp cl, [edx + 4] + jne @setsml +@4: mov ch, [eax + 3] + cmp ch, [edx + 3] + jne @setsml +@3: mov cl, [eax + 2] + cmp cl, [edx + 2] + jne @setsml +@2: mov ch, [eax + 1] + cmp ch, [edx + 1] + jne @setsml +@1: mov al, [eax] + cmp al, [edx] +@setsml:setz al +end; + +function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): integer; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=SubStr, edx=S, ecx=Offset + push ebx + push esi + push edx + test eax, eax + jz @notfnd // exit if SubStr='' + test edx, edx + jz @notfnd // exit if S='' + mov esi, ecx + mov ecx, [edx - 4] // length(S) + mov ebx, [eax - 4] // length(SubStr) + add ecx, edx + sub ecx, ebx // ecx = max start pos for full match + lea edx, [edx + esi - 1] // edx = start position + cmp edx, ecx + jg @notfnd // startpos > max start pos + cmp ebx, 1 + jle @onec // optimized loop for length(SubStr)<=1 + push edi + push ebp + lea edi, [ebx - 2] // edi = length(SubStr)-2 + mov esi, eax // esi = SubStr + movzx ebx, byte ptr[eax] // bl = search character + nop; nop +@l: cmp bl, [edx] // compare 2 characters per @l + je @c1fnd +@notc1: cmp bl, [edx + 1] + je @c2fnd +@notc2: add edx, 2 + cmp edx, ecx // next start position <= max start position + jle @l + pop ebp + pop edi +@notfnd:xor eax, eax // returns 0 if not fnd + pop edx + pop esi + pop ebx + ret +@c1fnd: mov ebp, edi // ebp = length(SubStr)-2 +@c1l: movzx eax, word ptr[esi + ebp] + cmp ax, [edx + ebp] // compare 2 chars per @c1l (may include #0) + jne @notc1 + sub ebp, 2 + jnc @c1l + pop ebp + pop edi + jmp @setres +@c2fnd: mov ebp, edi // ebp = length(SubStr)-2 +@c2l: movzx eax, word ptr[esi + ebp] + cmp ax, [edx + ebp + 1] // compare 2 chars per @c2l (may include #0) + jne @notc2 + sub ebp, 2 + jnc @c2l + pop ebp + pop edi + jmp @chkres +@onec: jl @notfnd // needed for zero-length non-nil strings + movzx eax, byte ptr[eax] // search character +@charl: cmp al, [edx] + je @setres + cmp al, [edx + 1] + je @chkres + add edx, 2 + cmp edx, ecx + jle @charl + jmp @notfnd +@chkres:cmp edx, ecx // check within ansistring + jge @notfnd + add edx, 1 +@setres:pop ecx // ecx = S + pop esi + pop ebx + neg ecx + lea eax, [edx + ecx + 1] +end; + +function IdemPropNameU(const P1,P2: RawUTF8): boolean; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=p1, edx=p2 + cmp eax, edx + je @out1 + test eax, edx + jz @maybenil +@notnil:mov ecx, [eax - 4] // compare lengths + cmp ecx, [edx - 4] + jne @out1 + push ebx + lea edx, [edx + ecx - 4] // may include the length for shortest strings + lea ebx, [eax + ecx - 4] + neg ecx + mov eax, [ebx] // compare last 4 chars + xor eax, [edx] + and eax, $dfdfdfdf // case insensitive + jne @out2 +@by4: add ecx, 4 + jns @match + mov eax, [ebx + ecx] + xor eax, [edx + ecx] + and eax, $dfdfdfdf // case insensitive + je @by4 +@out2: pop ebx +@out1: setz al + ret +@match: mov al, 1 + pop ebx + ret +@maybenil: // here we know that eax<>edx + test eax, eax + jz @nil0 // eax=nil and eax<>edx -> edx<>nil -> false + test edx, edx + jnz @notnil + mov al, dl // eax<>nil and edx=nil -> false +@nil0: +end; + +function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=p1, edx=p2, ecx=P1P2Len + cmp eax, edx + je @out2 + cmp ecx, 4 + jbe @sml + push ebx + lea edx, [edx + ecx - 4] + lea ebx, [eax + ecx - 4] + neg ecx + mov eax, [ebx] // compare last 4 chars + xor eax, [edx] + and eax, $dfdfdfdf // case insensitive + jne @out1 +@by4: add ecx, 4 + jns @match + mov eax, [ebx + ecx] + xor eax, [edx + ecx] + and eax, $dfdfdfdf // case insensitive + je @by4 +@out1: pop ebx +@out2: setz al + ret + nop + nop +@match: pop ebx + mov al, 1 + ret +@mask: dd 0, $df, $dfdf, $dfdfdf, $dfdfdfdf // compare 1..4 chars +@sml: test ecx, ecx + jz @smlo // p1p2len=0 + mov eax, [eax] + xor eax, [edx] + and eax, dword ptr[@mask + ecx * 4] +@smlo: setz al +end; + +function StrIComp(Str1, Str2: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // faster version by AB, from Agner Fog's original + mov ecx, eax + test eax, edx + jz @n +@ok: sub edx, eax + jz @0 +@10: mov al, [ecx] + cmp al, [ecx + edx] + jne @20 + inc ecx + test al, al + jnz @10 // continue with next byte + // terminating zero found. Strings are equal +@0: xor eax, eax + ret +@20: // bytes are different. check case + xor al, 20H // toggle case + cmp al, [ecx + edx] + jne @30 + // possibly differing only by case. Check if a-z + or al, 20H // upper case + sub al, 'a' + cmp al, 'z' - 'a' + ja @30 // not a-z + // a-z and differing only by case + inc ecx + jmp @10 // continue with next byte +@30: // bytes are different,even after changing case + movzx eax, byte[ecx] // get original value again + sub eax, 'A' + cmp eax, 'Z' - 'A' + ja @40 + add eax, 20H +@40: movzx edx, byte[ecx + edx] + sub edx, 'A' + cmp edx, 'Z' - 'A' + ja @50 + add edx, 20H +@50: sub eax, edx // subtract to get result + ret +@n: cmp eax, edx + je @0 + test eax, eax // Str1='' ? + jz @max + test edx, edx // Str2='' ? + jnz @ok + mov eax, 1 + ret +@max: dec eax +end; + +function StrLenPas(S: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string + mov edx, eax + test eax, eax + jz @0 + xor eax, eax +@s: cmp byte ptr[eax + edx + 0], 0 + je @0 + cmp byte ptr[eax + edx + 1], 0 + je @1 + cmp byte ptr[eax + edx + 2], 0 + je @2 + cmp byte ptr[eax + edx + 3], 0 + je @3 + add eax, 4 + jmp @s +@1: inc eax + ret +@0: rep ret +@2: add eax, 2 + ret +@3: add eax, 3 +end; + +function StrCompFast(Str1, Str2: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // no branch taken in case of not equal first char + cmp eax, edx + je @zero // same string or both nil + test eax, edx + jz @maynil +@1: mov cl, [eax] + mov ch, [edx] + inc eax + inc edx + test cl, cl + jz @exit + cmp cl, ch + je @1 +@exit: movzx eax, cl + movzx edx, ch + sub eax, edx + ret +@maynil:test eax, eax // Str1='' ? + jz @max + test edx, edx // Str2='' ? + jnz @1 + mov eax, 1 + ret +@max: dec eax + ret +@zero: xor eax, eax +end; + +const + EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 + NEGATIVE_POLARITY = 16; + +function StrCompSSE42(Str1, Str2: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // warning: may read up to 15 bytes beyond the string itself + test eax, edx + jz @n +@ok: sub eax, edx + {$ifdef HASAESNI} + movups xmm0, dqword [edx] + pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx + {$else} + db $F3,$0F,$6F,$02 + db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY + {$endif} + ja @1 + jc @2 + xor eax, eax + ret +@1: add edx, 16 + {$ifdef HASAESNI} + movups xmm0, dqword [edx] + pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx + {$else} + db $F3,$0F,$6F,$02 + db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY + {$endif} + ja @1 + jc @2 +@0: xor eax, eax // Str1=Str2 + ret +@n: cmp eax, edx + je @0 + test eax, eax // Str1='' ? + jz @max + test edx, edx // Str2='' ? + jnz @ok + mov eax, 1 + ret +@max: dec eax + ret +@2: add eax, edx + movzx eax, byte ptr [eax+ecx] + movzx edx, byte ptr [edx+ecx] + sub eax, edx +end; + +function SortDynArrayAnsiStringSSE42(const A,B): integer; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // warning: may read up to 15 bytes beyond the string itself + mov eax, [eax] + mov edx, [edx] + test eax, edx + jz @n +@ok: sub eax, edx + jz @0 + {$ifdef HASAESNI} + movups xmm0, dqword [edx] // result in ecx + pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY + {$else} + db $F3,$0F,$6F,$02 + db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY + {$endif} + ja @1 + jc @2 + xor eax, eax + ret +@1: add edx, 16 + {$ifdef HASAESNI} + movups xmm0, dqword [edx] // result in ecx + pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY + {$else} + db $F3,$0F,$6F,$02 + db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY + {$endif} + ja @1 + jc @2 +@0: xor eax, eax // Str1=Str2 + ret +@n: cmp eax, edx + je @0 + test eax, eax // Str1='' ? + jz @max + test edx, edx // Str2='' ? + jnz @ok + mov eax, -1 + ret +@max: inc eax + ret +@2: add eax, edx + movzx eax, byte ptr [eax+ecx] + movzx edx, byte ptr [edx+ecx] + sub eax, edx +end; + +function StrLenSSE42(S: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // warning: may read up to 15 bytes beyond the string itself + mov edx, eax // copy pointer + test eax, eax + jz @null // returns 0 if S=nil + xor eax, eax + {$ifdef HASAESNI} + pxor xmm0, xmm0 + pcmpistri xmm0, dqword[edx], EQUAL_EACH // comparison result in ecx + {$else} + db $66, $0F, $EF, $C0 + db $66, $0F, $3A, $63, $02, EQUAL_EACH + {$endif} + jnz @loop + mov eax, ecx + ret + nop // for @loop alignment +@loop: add eax, 16 + {$ifdef HASAESNI} + pcmpistri xmm0, dqword[edx + eax], EQUAL_EACH // comparison result in ecx + {$else} + db $66, $0F, $3A, $63, $04, $10, EQUAL_EACH + {$endif} + jnz @loop +@ok: add eax, ecx + ret +@null: db $f3 // rep ret +end; + +procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=Y, edx=P + push edx + mov ecx, eax + mov edx, 1374389535 // use power of two reciprocal to avoid division + mul edx + shr edx, 5 // now edx=Y div 100 + movzx eax, word ptr[TwoDigitLookup + edx * 2] + imul edx, -200 + movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] + pop ecx + shl edx, 16 + or eax, edx + mov [ecx], eax +end; + +function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; +{$ifdef FPC} nostackframe; assembler; {$endif} asm + xor ecx,ecx // ContainsNoTime=nil + test eax,eax // if s='' -> p=nil -> will return 0, whatever L value is + jz Iso8601ToTimeLogPUTF8Char + mov edx,[eax-4] // edx=L +@1: jmp Iso8601ToTimeLogPUTF8Char +end; + +function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=dest source=edx + test edx, edx + jz @z + push esi + mov esi, offset NormToUpperAnsi7 + xor ecx, ecx +@1: mov cl, [edx] + inc edx + test cl, cl + mov cl, [esi + ecx] + jz @2 + mov [eax], cl + inc eax + jmp @1 +@2: pop esi +@z: +end; + +function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=dest source=edx + push esi + push ebx + movzx ebx, byte ptr[edx] // ebx = length(source) + xor ecx, ecx + test ebx, ebx + mov esi, offset NormToUpperAnsi7 + jz @2 // source='' + inc edx +@1: mov cl, [edx] + inc edx + dec ebx + mov cl, [esi + ecx] + mov [eax], cl + lea eax, [eax + 1] + jnz @1 +@2: pop ebx + pop esi +@z: +end; + +function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=source edx=searchUp + push eax // save source var + mov eax, [eax] // eax=source + test eax, eax + jz @z + push eax + call IdemPChar + pop ecx // ecx=source + push eax // save result +@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) + inc ecx + cmp dl, 13 + ja @1 + je @e + or dl, dl + jz @0 + cmp dl, 10 + jne @1 + jmp @4 +@e: cmp byte ptr[ecx], 10 // jump #13#10 + jne @4 +@3: inc ecx +@4: pop eax // restore result + pop edx // restore source var + mov [edx], ecx // update source var + ret +@0: xor ecx, ecx // set source=nil + jmp @4 +@z: pop edx // ignore source var, result := false +end; + +procedure crcblockNoSSE42(crc128, data128: PBlock128); +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // Delphi is not efficient about compiling above pascal code + push ebp + push edi + push esi + mov ebp, eax // ebp=crc128 edi=data128 + mov edi, edx + mov edx, dword ptr[eax] + mov ecx, dword ptr[eax + 4] + xor edx, dword ptr[edi] + xor ecx, dword ptr[edi + 4] + movzx esi, dl + mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] + movzx esi, dh + shr edx, 16 + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] + movzx esi, dl + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] + movzx esi, dh + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] + mov edx, dword ptr[ebp + 8] + xor edx, dword ptr[edi + 8] + mov dword ptr[ebp], eax + movzx esi, cl + mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] + movzx esi, ch + shr ecx, 16 + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] + movzx esi, cl + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] + movzx esi, ch + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] + mov dword ptr[ebp + 4], eax + mov ecx, dword ptr[ebp + 12] + xor ecx, dword ptr[edi + 12] + movzx esi, dl + mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] + movzx esi, dh + shr edx, 16 + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] + movzx esi, dl + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] + movzx esi, dh + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] + mov dword ptr[ebp + 8], eax + movzx esi, cl + mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] + movzx esi, ch + shr ecx, 16 + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] + movzx esi, cl + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] + movzx esi, ch + xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] + mov dword ptr[ebp + 12], eax + pop esi + pop edi + pop ebp +end; + +function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // adapted from Aleksandr Sharahov code and Maxim Masiutin remarks + test edx, edx + jz @z + neg ecx + jz @z + not eax + push ebx + push ebp + lea ebp, [crc32ctab] +@head: test dl, 3 + jz @align + movzx ebx, byte ptr[edx] + inc edx + xor bl, al + shr eax, 8 + xor eax, dword ptr[ebx * 4 + ebp] + inc ecx + jnz @head + pop ebp + pop ebx + not eax +@z: ret +@align: sub edx, ecx + add ecx, 8 + jg @done + push esi + push edi + mov edi, edx +@by8: mov edx, eax + mov ebx, [edi + ecx - 4] + xor edx, [edi + ecx - 8] + movzx esi, bl + mov eax, dword ptr[esi * 4 + ebp + 1024 * 3] + movzx esi, bh + xor eax, dword ptr[esi * 4 + ebp + 1024 * 2] + shr ebx, 16 + movzx esi, bl + xor eax, dword ptr[esi * 4 + ebp + 1024 * 1] + movzx esi, bh + xor eax, dword ptr[esi * 4 + ebp + 1024 * 0] + movzx esi, dl + xor eax, dword ptr[esi * 4 + ebp + 1024 * 7] + movzx esi, dh + xor eax, dword ptr[esi * 4 + ebp + 1024 * 6] + shr edx, 16 + movzx esi, dl + xor eax, dword ptr[esi * 4 + ebp + 1024 * 5] + movzx esi, dh + xor eax, dword ptr[esi * 4 + ebp + 1024 * 4] + add ecx, 8 + jle @by8 + mov edx, edi + pop edi + pop esi +@done: sub ecx, 8 + jl @tail + pop ebp + pop ebx + not eax + ret +@tail: movzx ebx, byte[edx + ecx] + xor bl, al + shr eax, 8 + xor eax, dword ptr[ebx * 4 + ebp] + inc ecx + jnz @tail +@e: pop ebp + pop ebx + not eax +end; + +{$ifndef DELPHI5OROLDER} +const + CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 + +function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=dest edx=source ecx=sourceLen + test ecx,ecx + jz @z + movups xmm1, dqword ptr [@az] + movups xmm3, dqword ptr [@bits] + cmp ecx, 16 + ja @big + // optimize the common case of sourceLen<=16 + movups xmm2, [edx] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 + {$else} + db $66, $0F, $3A, $62, $CA, CMP_RANGES + {$endif} + pand xmm0, xmm3 + pxor xmm2, xmm0 + movups [eax], xmm2 + add eax, ecx +@z: ret +@big: push eax + cmp ecx, 240 + jb @ok + mov ecx, 239 +@ok: add [esp], ecx // save to return end position with the exact size + shr ecx, 4 + sub edx, eax + inc ecx +@s: movups xmm2, [edx+eax] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, CMP_RANGES + {$else} + db $66, $0F, $3A, $62, $CA, CMP_RANGES + {$endif} + pand xmm0, xmm3 + pxor xmm2, xmm0 + movups [eax], xmm2 + add eax, 16 + dec ecx + jnz @s + pop eax + ret +@az: db 'azazazazazazazaz' // define range for upper case conversion +@bits: db ' ' // $20 = bit to change when changing case +end; +{$endif DELPHI5OROLDER} + +function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=crc, edx=buf, ecx=len + push ebx + test edx, edx + jz @0 + neg ecx + jz @0 + sub edx, ecx +@1: movzx ebx, byte ptr[edx + ecx] + xor eax, ebx + imul eax, eax, 16777619 + inc ecx + jnz @1 +@0: pop ebx +end; // we tried an unrolled version, but it was slower on our Core i7! + +function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=crc, edx=buf, ecx=len + test ecx, ecx + push edi + push esi + push ebx + push ebp + jz @z + cmp ecx, 4 + jb @s +@8: mov ebx, [edx] // unrolled version reading per dword + add edx, 4 + mov esi, eax + movzx edi, bl + movzx ebp, bh + shr ebx, 16 + shl eax, 5 + sub eax, esi + add eax, edi + mov esi, eax + shl eax, 5 + sub eax, esi + lea esi, [eax + ebp] + add eax, ebp + movzx edi, bl + movzx ebx, bh + shl eax, 5 + sub eax, esi + lea ebp, [eax + edi] + add eax, edi + shl eax, 5 + sub eax, ebp + add eax, ebx + cmp ecx, 8 + lea ecx, [ecx - 4] + jae @8 + test ecx, ecx + jz @z +@s: mov esi, eax +@1: shl eax, 5 + movzx ebx, byte ptr[edx] + inc edx + sub eax, esi + lea esi, [eax + ebx] + add eax, ebx + dec ecx + jnz @1 +@z: pop ebp + pop ebx + pop esi + pop edi +end; + +function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm + test eax, eax + jnl @pos + neg eax + add eax, eax + jmp ToVarUInt32 +@pos: jz @zer + lea eax, [eax * 2 - 1] + jmp ToVarUInt32 +@zer: mov [edx], al + lea eax, [edx + 1] +end; + +function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm + cmp eax, $7f + jbe @0 + cmp eax, $00004000 + jb @1 + cmp eax, $00200000 + jb @2 + cmp eax, $10000000 + jb @3 + mov ecx, eax + shr eax, 7 + and cl, $7f + or cl, $80 + mov [edx], cl + inc edx +@3: mov ecx, eax + shr eax, 7 + and cl, $7f + or cl, $80 + mov [edx], cl + inc edx +@2: mov ecx, eax + shr eax, 7 + and cl, $7f + or cl, $80 + mov [edx], cl + inc edx +@1: mov ecx, eax + shr eax, 7 + and cl, $7f + or cl, $80 + mov [edx], cl + inc edx +@0: mov [edx], al + lea eax, [edx + 1] +end; + +function CompareQWord(A, B: QWord): integer; +begin + {$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code + result := ord(A>B)-ord(A returns length(a)-length(b) + pop ebx + ret +@d: bsf ebx, ebx // char differs -> returns pbyte(a)^-pbyte(b)^ + shr ebx, 3 + add ecx, ebx + jns @l + movzx eax, byte ptr[eax + ecx] + movzx edx, byte ptr[edx + ecx] + pop ebx + pop ebx + sub eax, edx + ret +@n1: test eax, eax // a or b may be '' + jz @n0 + test edx, edx + jnz @n2 + cmp [eax - 4], edx + je @0 +@no: jnc @1 + mov eax, -1 + ret +@n0: cmp eax, [edx - 4] + je @0 + jnc @1 + mov eax, -1 + ret +@0: xor eax, eax + ret +@1: mov eax, 1 +end; +function SortDynArrayAnsiStringI(const A,B): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // avoid a call on the stack on x86 platform + mov eax, [eax] + mov edx, [edx] + jmp StrIComp +end; +function SortDynArrayPUTF8Char(const A,B): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // avoid a call on the stack on x86 platform + mov eax, [eax] + mov edx, [edx] + jmp dword ptr[StrComp] +end; +function SortDynArrayDouble(const A,B): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} asm + fld qword ptr[eax] + fcomp qword ptr[edx] + fstsw ax + sahf + jz @0 +@nz: jnb @p + mov eax, -1 + ret +@0: xor eax, eax + ret +@p: mov eax, 1 +end; +function SortDynArraySingle(const A,B): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} asm + fld dword ptr[eax] + fcomp dword ptr[edx] + fstsw ax + sahf + jz @0 +@nz: jnb @p + mov eax, -1 + ret +@0: xor eax, eax + ret +@p: mov eax, 1 +end; +{$endif PUREPASCAL} + +function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; +begin + if Str<>'' then + {$ifdef FPC} // will use fast FPC SSE version + result := IndexByte(pointer(Str)^,PStrLen(PtrUInt(Str)-_STRLEN)^,byte(chr))+1 else + {$else} + for result := 1 to PInteger(PtrInt(Str)-sizeof(Integer))^ do + if Str[result]=Chr then + exit; + {$endif FPC} + result := 0; +end; + +function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8): RawUTF8; +var i: PtrInt; +begin + for i := length(Str) downto 1 do + if Str[i]=SepChar then begin + result := copy(Str,i+1,maxInt); + if LeftStr<>nil then + LeftStr^ := copy(Str,1,i-1); + exit; + end; + result := Str; + if LeftStr<>nil then + LeftStr^ := ''; +end; + +function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; +var i, j, sep: PtrInt; + c: AnsiChar; +begin + sep := length(SepChar); + if sep > 0 then + if sep = 1 then + result := SplitRight(Str,SepChar[1]) else begin + for i := length(Str) downto 1 do begin + c := Str[i]; + for j := 1 to sep do + if c=SepChar[j] then begin + result := copy(Str,i+1,maxInt); + exit; + end; + end; + end; + result := Str; +end; + +function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8; +var i: integer; +begin +{$ifdef FPC} // to use fast FPC SSE version + if (StartPos=1) and (length(SepStr)=1) then + i := PosExChar(SepStr[1],Str) else +{$endif FPC} + i := PosEx(SepStr,Str,StartPos); + if i>0 then + result := Copy(Str,StartPos,i-StartPos) else + if StartPos=1 then + result := Str else + result := Copy(Str,StartPos,maxInt); +end; + +procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean); +var i: integer; + tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr) +begin + {$ifdef FPC} // to use fast FPC SSE version + if length(SepStr)=1 then + i := PosExChar(SepStr[1],Str) else + {$endif FPC} + i := PosEx(SepStr,Str); + if i=0 then begin + LeftStr := Str; + RightStr := ''; + end else begin + tmp := copy(Str,1,i-1); + RightStr := copy(Str,i+length(SepStr),maxInt); + LeftStr := tmp; + end; + if ToUpperCase then begin + UpperCaseSelf(LeftStr); + UpperCaseSelf(RightStr); + end; +end; + +function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean): RawUTF8; +begin + Split(Str,SepStr,LeftStr,result,ToUpperCase); +end; + +function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; + const DestPtr: array of PRawUTF8): PtrInt; +var s,i,j: PtrInt; +begin + j := 1; + result := 0; + s := 0; + if high(SepStr)>=0 then + while result<=high(DestPtr) do begin + i := PosEx(SepStr[s],Str,j); + if i=0 then begin + if DestPtr[result]<>nil then + DestPtr[result]^ := copy(Str,j,MaxInt); + inc(result); + break; + end; + if DestPtr[result]<>nil then + DestPtr[result]^ := copy(Str,j,i-j); + inc(result); + if snil then + DestPtr[i]^ := ''; +end; + +function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; + found: integer): RawUTF8; +var oldlen,newlen,i,last,posCount,sharedlen: integer; + pos: TIntegerDynArray; + src,dst: PAnsiChar; +begin + oldlen := length(OldPattern); + newlen := length(NewPattern); + SetLength(pos,64); + pos[0] := found; + posCount := 1; + repeat + found := PosEx(OldPattern,S,found+oldlen); + if found=0 then + break; + AddInteger(pos,posCount,found); + until false; + FastSetString(result,nil,Length(S)+(newlen-oldlen)*posCount); + last := 1; + src := pointer(s); + dst := pointer(result); + for i := 0 to posCount-1 do begin + sharedlen := pos[i]-last; + MoveFast(src^,dst^,sharedlen); + inc(src,sharedlen+oldlen); + inc(dst,sharedlen); + if newlen>0 then begin + MoveSmall(pointer(NewPattern),dst,newlen); + inc(dst,newlen); + end; + last := pos[i]+oldlen; + end; + MoveFast(src^,dst^,length(S)-last+1); +end; + +function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; +var found: integer; +begin + if (S='') or (OldPattern='') or (OldPattern=NewPattern) then + result := S else begin + found := PosEx(OldPattern,S,1); // our PosEx() is faster than Pos() + if found=0 then + result := S else + result := StringReplaceAllProcess(S,OldPattern,NewPattern,found); + end; +end; + +function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; +var n,i: integer; +begin + result := S; + n := high(OldNewPatternPairs); + if (n>0) and (n and 1=1) then + for i := 0 to n shr 1 do + result := StringReplaceAll(result,OldNewPatternPairs[i*2],OldNewPatternPairs[i*2+1]); +end; + +function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; + + procedure Process(S,D,T: PAnsiChar; TLen: integer); + begin + repeat + if S^=#0 then + break else + if S^<>#9 then begin + D^ := S^; + inc(D); + inc(S); + end else begin + if TLen>0 then begin + MoveSmall(T,D,TLen); + inc(D,TLen); + end; + inc(S); + end; + until false; + end; + +var L,i,n,ttl: PtrInt; +begin + ttl := length(TabText); + L := Length(Source); + n := 0; + if ttl<>0 then + for i := 1 to L do + if Source[i]=#9 then + inc(n); + if n=0 then begin + result := Source; + exit; + end; + FastSetString(result,nil,L+n*pred(ttl)); + Process(pointer(Source),pointer(result),pointer(TabText),ttl); +end; + +function strspnpas(s,accept: pointer): integer; +var p: PCardinal; + c: AnsiChar; + d: cardinal; +begin // returns size of initial segment of s which are in accept + result := 0; + repeat + c := PAnsiChar(s)[result]; + if c=#0 then + break; + p := accept; + repeat // stop as soon as we find any character not from accept + d := p^; + inc(p); + if AnsiChar(d)=c then + break else + if AnsiChar(d)=#0 then + exit; + d := d shr 8; + if AnsiChar(d)=c then + break else + if AnsiChar(d)=#0 then + exit; + d := d shr 8; + if AnsiChar(d)=c then + break else + if AnsiChar(d)=#0 then + exit; + d := d shr 8; + if AnsiChar(d)=c then + break else + if AnsiChar(d)=#0 then + exit; + until false; + inc(result); + until false; +end; + +function strcspnpas(s,reject: pointer): integer; +var p: PCardinal; + c: AnsiChar; + d: cardinal; +begin // returns size of initial segment of s which are not in reject + result := 0; + repeat + c := PAnsiChar(s)[result]; + if c=#0 then + break; + p := reject; + repeat // stop as soon as we find any character from reject + d := p^; + inc(p); + if AnsiChar(d)=c then + exit else + if AnsiChar(d)=#0 then + break; + d := d shr 8; + if AnsiChar(d)=c then + exit else + if AnsiChar(d)=#0 then + break; + d := d shr 8; + if AnsiChar(d)=c then + exit else + if AnsiChar(d)=#0 then + break; + d := d shr 8; + if AnsiChar(d)=c then + exit else + if AnsiChar(d)=#0 then + break; + until false; + inc(result); + until false; +end; + +{$ifndef ABSOLUTEPASCAL} +{$ifdef CPUINTEL} +{$ifdef CPUX64} // inspired by Agner Fog's strspn64.asm +function strcspnsse42(s,reject: pointer): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=s, rdx=reject (Linux: rdi,rsi) +{$endif FPC} +{$ifdef win64} + push rdi + push rsi + mov rdi, rcx + mov rsi, rdx +{$endif}mov r8, rsi + xor ecx, ecx +@1: movups xmm2, [rdi] + movups xmm1, [rsi] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 + {$else} + db $66,$0F,$3A,$62,$CA,$30 + {$endif} + movd eax, xmm0 + jns @5 +@2: cmp eax, 65535 + jne @3 + add rdi, 16 // first 16 chars matched, continue with next 16 chars + add rcx, 16 + jmp @1 +@3: not eax + bsf eax, eax + add rax, rcx +{$ifdef win64} + pop rsi + pop rdi +{$endif}ret +@4: and eax, edx // accumulate matches +@5: add rsi, 16 // the set is more than 16 bytes + movups xmm1, [rsi] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, $30 + {$else} + db $66,$0F,$3A,$62,$CA,$30 + {$endif} + movd edx, xmm0 + jns @4 + mov rsi, r8 // restore set pointer + and eax, edx // accumulate matches + cmp eax, 65535 + jne @3 + add rdi, 16 + add rcx, 16 + jmp @1 +end; +function strspnsse42(s,accept: pointer): integer; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=s, rdx=accept (Linux: rdi,rsi) +{$endif FPC} +{$ifdef win64} + push rdi + push rsi + mov rdi, rcx + mov rsi, rdx +{$endif}mov r8, rsi + xor ecx, ecx +@1: movups xmm2, [rdi] + movups xmm1, [rsi] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 + {$else} + db $66,$0F,$3A,$62,$CA,$00 + {$endif} + movd eax, xmm0 + jns @5 +@2: cmp eax, 65535 + jne @3 + add rdi, 16 // first 16 chars matched, continue with next 16 chars + add rcx, 16 + jmp @1 +@3: not eax + bsf eax, eax + add rax, rcx +{$ifdef win64} + pop rsi + pop rdi +{$endif}ret +@4: or eax, edx // accumulate matches +@5: add rsi, 16 // the set is more than 16 bytes + movups xmm1, [rsi] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, $00 + {$else} + db $66,$0F,$3A,$62,$CA,$00 + {$endif} + movd edx, xmm0 + jns @4 + mov rsi, r8 // restore set pointer + or eax, edx // accumulate matches + cmp eax, 65535 + jne @3 + add rdi, 16 // first 16 chars matched, continue with next 16 chars + add rcx, 16 + jmp @1 +end; +{$endif CPUX64} +{$ifdef CPUX86} +function strcspnsse42(s,reject: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=s, edx=reject + push edi + push esi + push ebx + mov edi, eax + mov esi, edx + mov ebx, esi + xor ecx, ecx +@1: {$ifdef HASAESNI} + movups xmm2, dqword [edi] + movups xmm1, dqword [esi] + pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 + movd eax, xmm0 + {$else} + db $F3,$0F,$6F,$17 + db $F3,$0F,$6F,$0E + db $66,$0F,$3A,$62,$CA,$30 + db $66,$0F,$7E,$C0 + {$endif} + jns @5 +@2: cmp eax, 65535 + jne @3 + add edi, 16 // first 16 chars matched, continue with next 16 chars + add ecx, 16 + jmp @1 +@3: not eax + bsf eax, eax + add eax, ecx + pop ebx + pop esi + pop edi + ret +@4: and eax, edx // accumulate matches +@5: add esi, 16 // the set is more than 16 bytes + {$ifdef HASAESNI} + movups xmm1, [esi] + pcmpistrm xmm1, xmm2, $30 + movd edx, xmm0 + {$else} + db $F3,$0F,$6F,$0E + db $66,$0F,$3A,$62,$CA,$30 + db $66,$0F,$7E,$C2 + {$endif} + jns @4 + mov esi, ebx // restore set pointer + and eax, edx // accumulate matches + cmp eax, 65535 + jne @3 + add edi, 16 // first 16 chars matched, continue with next 16 chars + add ecx, 16 + jmp @1 +end; +function strspnsse42(s,accept: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=s, edx=accept + push edi + push esi + push ebx + mov edi, eax + mov esi, edx + mov ebx, esi + xor ecx, ecx +@1: {$ifdef HASAESNI} + movups xmm2, dqword [edi] + movups xmm1, dqword [esi] + pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 + movd eax, xmm0 + {$else} + db $F3,$0F,$6F,$17 + db $F3,$0F,$6F,$0E + db $66,$0F,$3A,$62,$CA,$00 + db $66,$0F,$7E,$C0 + {$endif} + jns @5 +@2: cmp eax, 65535 + jne @3 + add edi, 16 // first 16 chars matched, continue with next 16 chars + add ecx, 16 + jmp @1 +@3: not eax + bsf eax, eax + add eax, ecx + pop ebx + pop esi + pop edi + ret +@4: or eax, edx // accumulate matches +@5: add esi, 16 // the set is more than 16 bytes + {$ifdef HASAESNI} + movups xmm1, [esi] + pcmpistrm xmm1, xmm2, $00 + movd edx, xmm0 + {$else} + db $F3,$0F,$6F,$0E + db $66,$0F,$3A,$62,$CA,$00 + db $66,$0F,$7E,$C2 + {$endif} + jns @4 + mov esi, ebx // restore set pointer + or eax, edx // accumulate matches + cmp eax, 65535 + jne @3 + add edi, 16 // first 16 chars matched, continue with next 16 chars + add ecx, 16 + jmp @1 +end; +{$ifndef DELPHI5OROLDER} +function StrLenSSE2(S: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize + mov ecx, eax // copy pointer + test eax, eax + jz @null // returns 0 if S=nil + push eax // save start address + pxor xmm0, xmm0 // set to zero + and ecx, 15 // lower 4 bits indicate misalignment + and eax, -16 // align pointer by 16 + // will never read outside a memory page boundary, so won't trigger GPF + movaps xmm1, [eax] // read from nearest preceding boundary + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + shr edx, cl // shift out false bits + shl edx, cl // shift back again + bsf edx, edx // find first 1-bit + jnz @A200 // found + // Main loop, search 16 bytes at a time +@A100: add eax, 10H // increment pointer by 16 + movaps xmm1, [eax] // read 16 bytes aligned + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + bsf edx, edx // find first 1-bit + // (moving the bsf out of the loop and using test here would be faster + // for long strings on old processors, but we are assuming that most + // strings are short, and newer processors have higher priority) + jz @A100 // loop if not found +@A200: // Zero-byte found. Compute string length + pop ecx // restore start address + sub eax, ecx // subtract start address + add eax, edx // add byte index +@null: +end; +{$endif DELPHI5OROLDER} +{$endif CPUX86} +{$endif CPUINTEL} +{$endif ABSOLUTEPASCAL} + +function IdemPropName(const P1,P2: shortstring): boolean; +begin + if P1[0]=P2[0] then + result := IdemPropNameUSameLen(@P1[1],@P2[1],ord(P2[0])) else + result := false; +end; + +function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; +begin + if ord(P1[0])=P2Len then + result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else + result := false; +end; + +function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; +begin + if P1Len=P2Len then + result := IdemPropNameUSameLen(P1,P2,P2Len) else + result := false; +end; + +function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; +begin + if length(P1)=P2Len then + result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else + result := false; +end; + +function ToText(os: TOperatingSystem): PShortString; +begin + result := GetEnumName(TypeInfo(TOperatingSystem),ord(os)); +end; + +function ToText(const osv: TOperatingSystemVersion): ShortString; +begin + if osv.os=osWindows then + FormatShort('Windows %', [WINDOWS_NAME[osv.win]], result) else + TrimLeftLowerCaseToShort(ToText(osv.os),result); +end; + +function ToTextOS(osint32: integer): RawUTF8; +var osv: TOperatingSystemVersion absolute osint32; + ost: ShortString; +begin + ost := ToText(osv); + if (osv.os>=osLinux) and (osv.utsrelease[2]<>0) then + result := FormatUTF8('% %.%.%',[ost,osv.utsrelease[2],osv.utsrelease[1],osv.utsrelease[0]]) else + result := ShortStringToUTF8(ost); +end; + +{$ifdef MSWINDOWS} +procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); +begin + {$ifdef CPU64} + PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; + PInt64Rec(@I64)^.Hi := FT.dwHighDateTime; + {$else} + I64 := PInt64(@FT)^; + {$endif} +end; + +const + // lpMinimumApplicationAddress retrieved from Windows is very low $10000 + // - i.e. maximum number of ID per table would be 65536 in TSQLRecord.GetID + // - so we'll force an higher and almost "safe" value as 1,048,576 + // (real value from runnning Windows is greater than $400000) + MIN_PTR_VALUE = $100000; + + // see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx + VER_NT_WORKSTATION = 1; + VER_NT_DOMAIN_CONTROLLER = 2; + VER_NT_SERVER = 3; + SM_SERVERR2 = 89; + PROCESSOR_ARCHITECTURE_AMD64 = 9; + +{$ifndef UNICODE} +function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; + external kernel32 name 'GetVersionExA'; +{$endif} + +threadvar // mandatory: GetTickCount seems per-thread on XP :( + LastTickXP: TQWordRec; + +function GetTickCount64ForXP: Int64; stdcall; +var t32: cardinal; + p: PQWordRec; +begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! + t32 := Windows.GetTickCount; + p := @LastTickXP; + if t320) or not SwitchToThread then + Windows.Sleep(ms); +end; + +{ TWinRegistry } + +function TWinRegistry.ReadOpen(root: HKEY; const keyname: RawUTF8; + closefirst: boolean): boolean; +var tmp: TSynTempBuffer; +begin + if closefirst then + Close; + tmp.Init(length(keyname)*2); + UTF8ToWideChar(tmp.buf,pointer(keyname)); + key := 0; + result := RegOpenKeyExW(root,tmp.buf,0,KEY_READ,key)=0; + tmp.Done; +end; + +procedure TWinRegistry.Close; +begin + if key<>0 then + RegCloseKey(key); +end; + +function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUTF8; +var rtype, rsize: DWORD; + tmp: TSynTempBuffer; +begin + result := ''; + if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then + exit; + tmp.Init(rsize); + if RegQueryValueExW(key,pointer(entry),nil,nil,tmp.buf,@rsize)=0 then begin + case rtype of + REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ: + RawUnicodeToUtf8(tmp.buf,StrLenW(tmp.buf),result); + end; + if andtrim then + result := Trim(result); + end; + tmp.Done; +end; + +function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString; +var rtype, rsize: DWORD; +begin + result := ''; + if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then + exit; + SetLength(result,rsize); + if RegQueryValueExW(key,pointer(entry),nil,nil,pointer(result),@rsize)<>0 then + result := ''; +end; + +function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal; +var rsize: DWORD; +begin + rsize := 4; + if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then + result := 0; +end; + +function TWinRegistry.ReadQword(const entry: SynUnicode): QWord; +var rsize: DWORD; +begin + rsize := 8; + if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then + result := 0; +end; + +function TWinRegistry.ReadEnumEntries: TRawUTF8DynArray; +var count,maxlen,i,len: DWORD; + tmp: TSynTempBuffer; +begin + result := nil; + if (RegQueryInfoKeyW(key,nil,nil,nil,@count,@maxlen,nil,nil,nil,nil,nil,nil)<>0) or + (count=0) then + exit; + SetLength(result,count); + inc(maxlen); + tmp.Init(maxlen*3); + for i := 0 to count-1 do begin + len := maxlen; + if RegEnumKeyExW(key,i,tmp.buf,len,nil,nil,nil,nil)=0 then + RawUnicodeToUtf8(tmp.buf,len,result[i]); + end; + tmp.Done; +end; + + +procedure RetrieveSystemInfo; +var + IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall; + GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall; + wine_get_version: function: PAnsiChar; stdcall; + Res: BOOL; + h: THandle; + P: pointer; + Vers: TWindowsVersion; + cpu, manuf, prod, prodver: RawUTF8; + reg: TWinRegistry; +begin + h := GetModuleHandle(kernel32); + GetTickCount64 := GetProcAddress(h,'GetTickCount64'); + if not Assigned(GetTickCount64) then // WinXP+ + GetTickCount64 := @GetTickCount64ForXP; + GetSystemTimePreciseAsFileTime := GetProcAddress(h,'GetSystemTimePreciseAsFileTime'); + if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+ + GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime; + IsWow64Process := GetProcAddress(h,'IsWow64Process'); + Res := false; + IsWow64 := Assigned(IsWow64Process) and + IsWow64Process(GetCurrentProcess,Res) and Res; + FillcharFast(SystemInfo,SizeOf(SystemInfo),0); + if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx + GetNativeSystemInfo := GetProcAddress(h,'GetNativeSystemInfo') else + @GetNativeSystemInfo := nil; + if Assigned(GetNativeSystemInfo) then + GetNativeSystemInfo(SystemInfo) else + Windows.GetSystemInfo(SystemInfo); + GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything + if (PtrUInt(P)>MIN_PTR_VALUE) and + (PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then + PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE; + Freemem(P); + OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); + GetVersionEx(OSVersionInfo); + Vers := wUnknown; + with OSVersionInfo do + // see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833 + case dwMajorVersion of + 5: case dwMinorVersion of + 0: Vers := w2000; + 1: Vers := wXP; + 2: if (wProductType=VER_NT_WORKSTATION) and + (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then + Vers := wXP_64 else + if GetSystemMetrics(SM_SERVERR2)=0 then + Vers := wServer2003 else + Vers := wServer2003_R2; + end; + 6: case dwMinorVersion of + 0: Vers := wVista; + 1: Vers := wSeven; + 2: Vers := wEight; + 3: Vers := wEightOne; + 4: Vers := wTen; + end; + 10: Vers := wTen; + end; + if Vers>=wVista then begin + if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then begin // Server edition + inc(Vers,2); // e.g. wEight -> wServer2012 + if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then + Vers := wServer2019_64; // https://stackoverflow.com/q/53393150 + end else if (Vers=wTen) and (OSVersionInfo.dwBuildNumber>=22000) then + Vers := wEleven; // waiting for an official mean of Windows 11 identification + if (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) and + (Vers wEight64 + end; + OSVersion := Vers; + with OSVersionInfo do + if wServicePackMajor=0 then + FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers], + dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else + FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor, + dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText); + OSVersionInt32 := (integer(Vers) shl 8)+ord(osWindows); + if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\CentralProcessor\0') then begin + cpu := reg.ReadString('ProcessorNameString'); + if cpu='' then + cpu := reg.ReadString('Identifier'); + end; + if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\BIOS',true) then begin + manuf := reg.ReadString('SystemManufacturer'); + if manuf<>'' then + manuf := manuf+' '; + prod := reg.ReadString('SystemProductName'); + prodver := reg.ReadString('SystemVersion'); + if prodver='' then + prodver := reg.ReadString('BIOSVersion'); + end; + if (prod='') or (prodver='') then begin + if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System',true) then begin + if prod='' then + prod := reg.ReadString('SystemBiosVersion'); + if prodver='' then + prodver := reg.ReadString('VideoBiosVersion'); + end; + end; + reg.Close; + if prodver<>'' then + FormatUTF8('%% %',[manuf,prod,prodver],BiosInfoText) else + FormatUTF8('%%',[manuf,prod],BiosInfoText); + if cpu='' then + cpu := StringToUTF8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER')); + cpu := Trim(cpu); + FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,cpu],CpuInfoText); + h := LoadLibrary('ntdll.dll'); + if h>0 then begin + wine_get_version := GetProcAddress(h,'wine_get_version'); + if Assigned(wine_get_version) then + OSVersionInfoEx := trim('Wine '+trim(wine_get_version)); + FreeLibrary(h); + end; + if OSVersionInfoEx<>'' then + OSVersionText := FormatUTF8('% - %', [OSVersionText,OSVersionInfoEx]); +end; + +{$else} + +{$ifndef BSD} +procedure SetLinuxDistrib(const release: RawUTF8); +var + distrib: TOperatingSystem; + dist: RawUTF8; +begin + for distrib := osArch to high(distrib) do begin + dist := UpperCase(TrimLeftLowerCaseShort(ToText(distrib))); + if PosI(pointer(dist),release)>0 then begin + OS_KIND := distrib; + break; + end; + end; +end; +{$endif BSD} + +procedure RetrieveSystemInfo; +var modname, beg: PUTF8Char; + {$ifdef BSD} + temp: shortstring; + {$else} + cpuinfo: PUTF8Char; + proccpuinfo,prod,prodver,release,dist: RawUTF8; + SR: TSearchRec; + {$endif BSD} +begin + modname := nil; + {$ifdef BSD} + fpuname(SystemInfo.uts); + SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU); + Utf8ToRawUTF8(fpsysctlhwstr(HW_MACHINE,temp),BiosInfoText); + modname := fpsysctlhwstr(HW_MODEL,temp); + with SystemInfo.uts do + FormatUTF8('%-% %',[sysname,release,version],OSVersionText); + {$else} + {$ifdef KYLIX3} + uname(SystemInfo.uts); + {$else} + fpuname(SystemInfo.uts); + {$endif KYLIX3} + prod := Trim(StringFromFile('/sys/class/dmi/id/product_name',true)); + if prod<>'' then begin + prodver := Trim(StringFromFile('/sys/class/dmi/id/product_version',true)); + if prodver<>'' then + FormatUTF8('% %',[prod,prodver],BiosInfoText) else + BiosInfoText := prod; + end; + SystemInfo.dwNumberOfProcessors := 0; + proccpuinfo := StringFromFile('/proc/cpuinfo',true); + cpuinfo := pointer(proccpuinfo); + while cpuinfo<>nil do begin + beg := cpuinfo; + cpuinfo := GotoNextLine(cpuinfo); + if IdemPChar(beg,'PROCESSOR') then + if beg^='P' then + modname := beg else // Processor : ARMv7 + inc(SystemInfo.dwNumberOfProcessors) else // processor : 0 + if IdemPChar(beg,'MODEL NAME') then + modname := beg; + end; + modname := PosChar(modname,':'); + if modname<>nil then + modname := GotoNextNotSpace(modname+1); + FindNameValue(StringFromFile('/etc/os-release'),'PRETTY_NAME=',release); + if (release<>'') and (release[1]='"') then + release := copy(release,2,length(release)-2); + release := trim(release); + if release='' then + if FindNameValue(StringFromFile('/etc/lsb-release'),'DISTRIB_DESCRIPTION=',release) and + (release<>'') and (release[1]='"') then + release := copy(release,2,length(release)-2); + if (release='') and (FindFirst('/etc/*-release',faAnyFile,SR)=0) then begin + release := StringToUTF8(SR.Name); // 'redhat-release' 'SuSE-release' + if IdemPChar(pointer(release),'LSB-') and (FindNext(SR)=0) then + release := StringToUTF8(SR.Name); + release := split(release,'-'); + dist := split(trim(StringFromFile('/etc/'+SR.Name)),#10); + if (dist<>'') and (PosExChar('=',dist)=0) and (PosExChar(' ',dist)>0) then + SetLinuxDistrib(dist) // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)' + else + dist := ''; + FindClose(SR); + end; + if (release<>'') and (OS_KIND=osLinux) then begin + SetLinuxDistrib(release); + if (OS_KIND=osLinux) and (dist<>'') then begin + SetLinuxDistrib(dist); + release := dist; + end; + if (OS_KIND=osLinux) and ((PosEx('RH',release)>0) or (PosEx('Red Hat',release)>0)) then + OS_KIND := osRedHat; + end; + SystemInfo.release := release; + {$endif BSD} + OSVersionInt32 := {$ifdef FPC}integer(KernelRevision shl 8)+{$endif}ord(OS_KIND); + with SystemInfo.uts do + FormatUTF8('% %',[sysname,release],OSVersionText); + if SystemInfo.release<>'' then + OSVersionText := FormatUTF8('% - %',[SystemInfo.release,OSVersionText]); + {$ifdef Android} + OSVersionText := 'Android ('+OSVersionText+')'; + {$endif} + if (SystemInfo.dwNumberOfProcessors>0) and (modname<>nil) then begin + beg := modname; + while not (ord(modname^) in [0,10,13]) do begin + if modname^<' ' then + modname^ := ' '; + inc(modname); + end; + modname^ := #0; + FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,beg],CpuInfoText); + end; + if CpuInfoText='' then + CpuInfoText := CPU_ARCH_TEXT; +end; + +{$ifdef KYLIX3} +function FileOpen(const FileName: string; Mode: LongWord): Integer; +const + SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = ( + 0, // No share mode specified + F_WRLCK, // fmShareExclusive + F_RDLCK, // fmShareDenyWrite + 0); // fmShareDenyNone +var FileHandle, Tvar: Integer; + LockVar: TFlock; + smode: Byte; +begin + result := -1; + if FileExists(FileName) and + ((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin + FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights); + if FileHandle=-1 then + exit; + smode := Mode and $F0 shr 4; + if SHAREMODE[smode]<>0 then begin + with LockVar do begin + l_whence := SEEK_SET; + l_start := 0; + l_len := 0; + l_type := SHAREMODE[smode]; + end; + Tvar := fcntl(FileHandle,F_SETLK,LockVar); + if Tvar=-1 then begin + __close(FileHandle); + exit; + end; + end; + result := FileHandle; + end; +end; + +function GetTickCount64: Int64; +begin + result := SynKylix.GetTickCount64; +end; +{$endif KYLIX3} + +{$ifdef FPC} +function GetTickCount64: Int64; +begin + result := SynFPCLinux.GetTickCount64; +end; +{$endif FPC} + +{$endif MSWINDOWS} + +function FileOpenSequentialRead(const FileName: string): Integer; +begin + {$ifdef MSWINDOWS} + if OSVersion>=wVista then // don't use the flag on XP + result := CreateFile(pointer(FileName),GENERIC_READ, + FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone + OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0) else + result := FileOpen(FileName,fmOpenRead or fmShareDenyNone); + {$else} + // SysUtils.FileOpen = fpOpen + fpFlock - assuming FileName is UTF-8 + result := fpOpen(pointer(FileName), O_RDONLY); + {$endif MSWINDOWS} +end; + +type +{$ifdef DELPHI5ORFPC} // TFileStream doesn't have per-handle constructor like Delphi + TFileStreamFromHandle = class(THandleStream) + public + destructor Destroy; override; + end; + +destructor TFileStreamFromHandle.Destroy; +begin + FileClose(Handle); // otherwise file is still opened +end; +{$else} + TFileStreamFromHandle = TFileStream; +{$endif DELPHI5ORFPC} + +function FileStreamSequentialRead(const FileName: string): THandleStream; +begin + result := TFileStreamFromHandle.Create(FileOpenSequentialRead(FileName)); +end; + +function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; +var now: Int64; +begin + if Interval<=0 then + result := false else begin + now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; + if now-PreviousTix>Interval then begin + PreviousTix := now; + result := true; + end else + result := false; + end; +end; + +function StrCntDecFree(var refcnt: TStrCnt): boolean; +{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} +asm {$ifdef CPU64DELPHI} .noframe {$endif} + {$ifdef STRCNT32} + lock dec dword ptr[refcnt] + {$else} + lock dec qword ptr[refcnt] + {$endif STRCNT32} + setbe al +end; // we don't check for ismultithread global since lock is cheap on new CPUs +{$else} +begin // fallback to RTL asm e.g. for ARM + {$ifdef STRCNT32} + result := InterLockedDecrement(refcnt)<=0; + {$else} + result := InterLockedDecrement64(refcnt)<=0; + {$endif STRCNT32} +end; +{$endif CPUINTEL} + +function DACntDecFree(var refcnt: TDACnt): boolean; +{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} +asm {$ifdef CPU64DELPHI} .noframe {$endif} + {$ifdef DACNT32} + lock dec dword ptr[refcnt] + {$else} + lock dec qword ptr[refcnt] + {$endif DACNT32} + setbe al +end; // we don't check for ismultithread global since lock is cheap on new CPUs +{$else} +begin // fallback to RTL asm e.g. for ARM + {$ifdef DACNT32} + result := InterLockedDecrement(refcnt)<=0; + {$else} + result := InterLockedDecrement64(refcnt)<=0; + {$endif DACNT32} +end; +{$endif CPUINTEL} + +{$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement +{$ifdef PUREPASCAL} +function InterlockedIncrement(var I: Integer): Integer; +begin + {$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2 + result := Windows.InterlockedIncrement(I); + {$else} + result := AtomicIncrement(I); + {$endif} +end; + +function InterlockedDecrement(var I: Integer): Integer; +begin + {$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2 + result := Windows.InterlockedDecrement(I); + {$else} + result := AtomicDecrement(I); + {$endif} +end; +{$else} +function InterlockedIncrement(var I: Integer): Integer; +asm + mov edx, 1 + xchg eax, edx + lock xadd [edx], eax + inc eax +end; +function InterlockedDecrement(var I: Integer): Integer; +asm + mov edx, -1 + xchg eax, edx + lock xadd [edx], eax + dec eax +end; +{$endif} +{$endif FPC} + +function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; +var extra,i: PtrInt; + c: PtrUInt; +begin + result := 0; + c := byte(U^); // here U^>=#80 + inc(U); + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + for i := 1 to extra do begin + if byte(U^) and $c0<>$80 then + exit; // invalid input content + c := c shl 6+byte(U^); + inc(U); + end; + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if c=#80 + inc(U); + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + for i := 1 to extra do begin + if byte(U^) and $c0<>$80 then + exit; // invalid input content + c := c shl 6+byte(U^); + inc(U); + end; + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if c=127) or not(tcWord in TEXT_BYTES[c]); + repeat + V := U; + c := GetNextUTF8Upper(U); + if c=0 then + exit; + until (c<127) and (tcWord in TEXT_BYTES[c]); + result := V; +end; + +{$ifdef USENORMTOUPPER} + +function AnsiICompW(u1, u2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} +var C1,C2: PtrInt; + table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7Byte{$else}PNormTableByte{$endif}; +begin + if u1<>u2 then + if u1<>nil then + if u2<>nil then begin + {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7Byte;{$endif} + repeat + C1 := PtrInt(u1^); + C2 := PtrInt(u2^); + result := C1-C2; + if result<>0 then begin + if (C1>255) or (C2>255) then exit; + result := table[C1]-table[C2]; + if result<>0 then exit; + end; + if (C1=0) or (C2=0) then break; + inc(u1); + inc(u2); + until false; + end else + result := 1 else // u2='' + result := -1 else // u1='' + result := 0; // u1=u2 +end; + + +{$ifdef PUREPASCAL} +function AnsiIComp(Str1, Str2: pointer): PtrInt; +var C1,C2: byte; // integer/PtrInt are actually slower on FPC + lookupper: PByteArray; // better x86-64 / PIC asm generation +begin + result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); + if result<>0 then + if Str1<>nil then + if Str2<>nil then begin + lookupper := @NormToUpperByte; + repeat + C1 := lookupper[PByteArray(Str1)[0]]; + C2 := lookupper[PByteArray(Str1)[result]]; + inc(PByte(Str1)); + until (C1=0) or (C1<>C2); + result := C1-C2; + end else + result := 1 else // Str2='' + result := -1; // Str1='' +end; +{$else} +function AnsiIComp(Str1, Str2: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // fast 8 bits WinAnsi comparison using the NormToUpper[] array + cmp eax, edx + je @2 + test eax, edx // is either of the strings perhaps nil? + jz @3 +@0: push ebx // compare the first character (faster quicksort) + movzx ebx, byte ptr[eax] // ebx=S1[1] + movzx ecx, byte ptr[edx] // ecx=S2[1] + test ebx, ebx + jz @z + cmp ebx, ecx + je @s + mov bl, byte ptr[NormToUpper + ebx] + mov cl, byte ptr[NormToUpper + ecx] + cmp ebx, ecx + je @s + mov eax, ebx + pop ebx + sub eax, ecx // return S1[1]-S2[1] + ret +@2b: pop ebx +@2: xor eax, eax + ret +@3: test eax, eax // S1='' + jz @4 + test edx, edx // S2='' ? + jnz @0 + mov eax, 1 // return 1 (S1>S2) + ret +@s: inc eax + inc edx + mov bl, [eax] // ebx=S1[i] + mov cl, [edx] // ecx=S2[i] + test ebx, ebx + je @z // end of S1 + cmp ebx, ecx + je @s + mov bl, byte ptr[NormToUpper + ebx] + mov cl, byte ptr[NormToUpper + ecx] + cmp ebx, ecx + je @s + mov eax, ebx + pop ebx + sub eax, ecx // return S1[i]-S2[i] + ret +@z: cmp ebx, ecx // S1=S2? + jz @2b + pop ebx +@4: mov eax, -1 // return -1 (S1$80 then + exit else // invalid input content + c := c shl 6+byte(P[i]); + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if cLD then + SetLength(result,LD); +end; + +function LowerCaseU(const S: RawUTF8): RawUTF8; +var LS,LD: integer; +begin + LS := length(S); + FastSetString(result,pointer(S),LS); + LD := ConvertCaseUTF8(pointer(result),NormToLowerByte); + if LS<>LD then + SetLength(result,LD); +end; + +function UTF8IComp(u1, u2: PUTF8Char): PtrInt; +var c2: PtrInt; + table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; +begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values + {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} + if u1<>u2 then + if u1<>nil then + if u2<>nil then + repeat + result := ord(u1^); + c2 := ord(u2^); + if result<=127 then + if result<>0 then begin + inc(u1); + result := table[result]; + if c2<=127 then begin + if c2=0 then exit; // u1>u2 -> return u1^ + inc(u2); + dec(result,table[c2]); + if result<>0 then exit; + continue; + end; + end else begin // u1^=#0 -> end of u1 reached + if c2<>0 then // end of u2 reached -> u1=u2 -> return 0 + result := -1; // u1u2 -> return u1^ + inc(u2); + dec(result,table[c2]); + if result<>0 then exit; + continue; + end else begin + c2 := GetHighUTF8UCS4Inlined(u2); + if c2<=255 then + dec(result,table[c2]) else // 8 bits to upper + dec(result,c2); // 32-bit widechar returns diff + if result<>0 then exit; + end; + until false else + result := 1 else // u2='' + result := -1 else // u1='' + result := 0; // u1=u2 +end; + +function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; +var c2: PtrInt; + extra,i: integer; + table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; +label neg,pos; +begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values + {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} + if u1<>u2 then + if (u1<>nil) and (L1<>0) then + if (u2<>nil) and (L2<>0) then + repeat + result := ord(u1^); + c2 := ord(u2^); + inc(u1); + dec(L1); + if result<=127 then begin + result := table[result]; + if c2<=127 then begin + dec(result,table[c2]); + dec(L2); + inc(u2); + if result<>0 then + exit else + if L1<>0 then + if L2<>0 then + continue else // L1>0 and L2>0 -> next char + goto pos else // L1>0 and L2=0 -> u1>u2 + if L2<>0 then + goto neg else // L1=0 and L2>0 -> u1 u1=u2 + end; + end else begin + extra := UTF8_EXTRABYTES[result]; + if extra=0 then goto neg; // invalid leading byte + dec(L1,extra); + if Integer(L1)<0 then goto neg; + for i := 0 to extra-1 do + result := result shl 6+PByteArray(u1)[i]; + dec(result,UTF8_EXTRA[extra].offset); + inc(u1,extra); + if result and $ffffff00=0 then + result := table[result]; // 8 bits to upper, 32-bit as is + end; + // here result=NormToUpper[u1^] + inc(u2); + dec(L2); + if c2<=127 then begin + dec(result,table[c2]); + if result<>0 then exit; + end else begin + extra := UTF8_EXTRABYTES[c2]; + if extra=0 then goto pos; + dec(L2,extra); + if integer(L2)<0 then goto pos; + for i := 0 to extra-1 do + c2 := c2 shl 6+PByteArray(u2)[i]; + dec(c2,UTF8_EXTRA[extra].offset); + inc(u2,extra); + if c2 and $ffffff00=0 then + dec(result,table[c2]) else // 8 bits to upper + dec(result,c2); // returns 32-bit diff + if result<>0 then exit; + end; + // here we have result=NormToUpper[u2^]-NormToUpper[u1^]=0 + if L1=0 then // test if we reached end of u1 or end of u2 + if L2=0 then exit // u1=u2 + else goto neg else // u1u2 + until false else +pos: result := 1 else // u2='' or u1>u2 +neg: result := -1 else // u1='' or u1UpperValue^ then break; {$else} + if NormToUpperAnsi7[A^]<>UpperValue^ then break; +{$endif} + inc(UpperValue); + if UpperValue^=#0 then begin + result := true; // UpperValue found! + exit; + end; + inc(A); + if A^=#0 then exit; + until false; + // find beginning of next word + repeat + if A^=#0 then exit else +{$ifdef USENORMTOUPPER} + if not (tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A); +{$else} if not (tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif} + until false; + until false; +end; + +function FindUnicode(PW, Upper: PWideChar; UpperLen: PtrInt): boolean; +var Start: PWideChar; + w: PtrUInt; +begin + result := false; + if (PW=nil) or (Upper=nil) then exit; + repeat + // go to beginning of next word + repeat + w := ord(PW^); + if w=0 then exit else + if (w>126) or (tcWord in TEXT_BYTES[w]) then + Break; + inc(PW); + until false; + Start := PW; + // search end of word matching UpperLen characters + repeat + inc(PW); + w := ord(PW^); + until (PW-Start>=UpperLen) or + (w=0) or ((w<126) and (not(tcWord in TEXT_BYTES[w]))); + if PW-Start>=UpperLen then + if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin + result := true; // match found + exit; + end; + // not found: go to end of current word + repeat + w := ord(PW^); + if w=0 then exit else + if ((w<126) and (not(tcWord in TEXT_BYTES[w]))) then Break; + inc(PW); + until false; + until false; +end; + +function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; +var ValueStart: PAnsiChar; +{$ifdef USENORMTOUPPER} + c: PtrUInt; + FirstChar: AnsiChar; +label Next; +{$else} + ch: AnsiChar; +{$endif} +begin + result := false; + if (U=nil) or (UpperValue=nil) then exit; +{$ifdef USENORMTOUPPER} + // handles 8-bits WinAnsi chars inside UTF-8 encoded data + FirstChar := UpperValue^; + ValueStart := UpperValue+1; + repeat + // test beginning of word + repeat + c := byte(U^); + inc(U); + if c=0 then exit else + if c<=127 then begin + if tcWord in TEXT_BYTES[c] then + if PAnsiChar(@NormToUpper)[c]<>FirstChar then + goto Next else + break; + end else + if c and $20=0 then begin // fast direct process $0..$7ff + c := c shl 6+byte(U^)-$3080; + inc(U); + if c<=255 then begin + c := NormToUpperByte[c]; + if tcWord in TEXT_BYTES[c] then + if AnsiChar(c)<>FirstChar then + goto Next else + break; + end; + end else + if UTF8_EXTRABYTES[c]=0 then + exit else // invalid leading byte + inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex + until false; + // here we had the first char match -> check if this word match UpperValue + UpperValue := ValueStart; + repeat + if UpperValue^=#0 then begin + result := true; // UpperValue found! + exit; + end; + c := byte(U^); inc(U); // next chars + if c=0 then exit else + if c<=127 then begin + if PAnsiChar(@NormToUpper)[c]<>UpperValue^ then break; + end else + if c and $20=0 then begin + c := c shl 6+byte(U^)-$3080; + inc(U); + if (c>255) or (PAnsiChar(@NormToUpper)[c]<>UpperValue^) then break; + end else begin + if UTF8_EXTRABYTES[c]=0 then + exit else // invalid leading byte + inc(U,UTF8_EXTRABYTES[c]); + break; + end; + inc(UpperValue); + until false; +Next: // find beginning of next word + U := FindNextUTF8WordBegin(U); + until U=nil; +{$else} + // this tiny version only handles 7-bits ansi chars and ignore all UTF-8 chars + ValueStart := UpperValue; + repeat + // find beginning of word + repeat + if byte(U^)=0 then exit else + if byte(U^)<=127 then + if byte(U^) in IsWord then + break else + inc(U) else + if byte(U^) and $20=0 then + inc(U,2) else + inc(U,3); + until false; + // check if this word is the UpperValue + UpperValue := ValueStart; + repeat + ch := NormToUpperAnsi7[U^]; + if ch<>UpperValue^ then break; + inc(UpperValue); + if UpperValue^=#0 then begin + result := true; // UpperValue found! + exit; + end; + inc(U); + if byte(U^)=0 then exit else + if byte(U^) and $80<>0 then break; // 7 bits char check only + until false; + // find beginning of next word + U := FindNextUTF8WordBegin(U); + until U=nil; +{$endif} +end; + +function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; +var b,c: byte; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; +begin + result := false; // return false if any invalid char + if (Hex=nil) or (Bin=nil) then + exit; + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 + if BinBytes>0 then begin + inc(Bin,BinBytes-1); + repeat + b := tab[Ord(Hex[0])]; + c := tab[Ord(Hex[1])]; + if (b>15) or (c>15) then + exit; + b := b shl 4; // better FPC generation code in small explicit steps + b := b or c; + Bin^ := b; + dec(Bin); + inc(Hex,2); + dec(BinBytes); + until BinBytes=0; + end; + result := true; // correct content in Hex +end; + +function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; +begin + result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); + if not result then + aValue := 0; +end; + +function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; +begin + result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); + if not result then + aValue := 0; +end; + +function HexDisplayToInt64(const Hex: RawByteString): Int64; +begin + if not HexDisplayToBin(pointer(Hex),@result,SizeOf(result)) then + result := 0; +end; + +function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; +var b,c: byte; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; +begin + result := false; // return false if any invalid char + if Hex=nil then + exit; + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 + if BinBytes>0 then + if Bin<>nil then + repeat + b := tab[Ord(Hex[0])]; + c := tab[Ord(Hex[1])]; + if (b>15) or (c>15) then + exit; + inc(Hex,2); + b := b shl 4; + b := b or c; + Bin^ := b; + inc(Bin); + dec(BinBytes); + until BinBytes=0 else + repeat // Bin=nil -> validate Hex^ input + if (tab[Ord(Hex[0])]>15) or (tab[Ord(Hex[1])]>15) then + exit; + inc(Hex,2); + dec(BinBytes); + until BinBytes=0; + result := true; // conversion OK +end; + +procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); +var tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; + c: byte; +begin + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 + if BinBytes>0 then + repeat + c := tab[ord(Hex[0])]; + c := c shl 4; + c := tab[ord(Hex[1])] or c; + Bin^ := c; + inc(Hex,2); + inc(Bin); + dec(BinBytes); + until BinBytes=0; +end; + +function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; +var c, v: byte; +label _nxt; +begin + result := PtrInt(Bin); + if Oct <> nil then + repeat + c := ord(Oct^); + inc(Oct); + if c <> ord('\') then begin + if c = 0 then + break; +_nxt: Bin^ := c; + inc(Bin); + continue; + end; + c := ord(Oct^); + inc(Oct); + if c = ord('\') then + goto _nxt; + dec(c, ord('0')); + if c > 3 then + break; // stop at malformated input (includes #0) + c := c shl 6; + v := c; + c := ord(Oct[0]); + dec(c, ord('0')); + if c > 7 then + break; + c := c shl 3; + v := v or c; + c := ord(Oct[1]); + dec(c, ord('0')); + if c > 7 then + break; + c := c or v; + Bin^ := c; + inc(Bin); + inc(Oct, 2); + until false; + result := PtrInt(Bin)-result; +end; + +function OctToBin(const Oct: RawUTF8): RawByteString; +var tmp: TSynTempBuffer; + L: integer; +begin + tmp.Init(length(Oct)); + try + L := OctToBin(pointer(Oct), tmp.buf); + SetString(result, PAnsiChar(tmp.buf), L); + finally + tmp.Done; + end; +end; + +function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; +begin + result := (length(Hex)=BinBytes*2) and SynCommons.HexToBin(pointer(Hex),nil,BinBytes); +end; + +function HexToCharValid(Hex: PAnsiChar): boolean; +begin + result := (ConvertHexToBin[Ord(Hex[0])]<=15) and + (ConvertHexToBin[Ord(Hex[1])]<=15); +end; + +function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; +var B,C: PtrUInt; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; +begin + if Hex<>nil then begin + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 + B := tab[Ord(Hex[0])]; + C := tab[Ord(Hex[1])]; + if (B<=15) and (C<=15) then begin + if Bin<>nil then + Bin^ := AnsiChar(B shl 4+C); + result := true; + exit; + end; + end; + result := false; // return false if any invalid char +end; + +function HexToWideChar(Hex: PAnsiChar): cardinal; +var B: PtrUInt; +begin + result := ConvertHexToBin[Ord(Hex[0])]; + if result<=15 then begin + B := ConvertHexToBin[Ord(Hex[1])]; + if B<=15 then begin + result := result shl 4+B; + B := ConvertHexToBin[Ord(Hex[2])]; + if B<=15 then begin + result := result shl 4+B; + B := ConvertHexToBin[Ord(Hex[3])]; + if B<=15 then begin + result := result shl 4+B; + exit; + end; + end; + end; + end; + result := 0; +end; + +{ --------- Base64 encoding/decoding } + +type + TBase64Enc = array[0..63] of AnsiChar; + PBase64Enc = ^TBase64Enc; + TBase64Dec = array[AnsiChar] of shortint; + PBase64Dec = ^TBase64Dec; +const + b64enc: TBase64Enc = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + b64URIenc: TBase64Enc = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_'; +var + /// a conversion table from Base64 text into binary data + // - used by Base64ToBin/IsBase64 functions + // - contains -1 for invalid char, -2 for '=', 0..63 for b64enc[] chars + ConvertBase64ToBin, ConvertBase64URIToBin: TBase64Dec; + +function Base64AnyDecode(const decode: TBase64Dec; sp,rp: PAnsiChar; len: PtrInt): boolean; +var c, ch: PtrInt; +begin + result := false; + while len>=4 do begin + c := decode[sp[0]]; + if c<0 then + exit; + c := c shl 6; + ch := decode[sp[1]]; + if ch<0 then + exit; + c := (c or ch) shl 6; + ch := decode[sp[2]]; + if ch<0 then + exit; + c := (c or ch) shl 6; + ch := decode[sp[3]]; + if ch<0 then + exit; + c := c or ch; + rp[2] := AnsiChar(c); + c := c shr 8; + rp[1] := AnsiChar(c); + c := c shr 8; + rp[0] := AnsiChar(c); + dec(len,4); + inc(rp,3); + inc(sp,4); + end; + if len>=2 then begin + c := decode[sp[0]]; + if c<0 then + exit; + c := c shl 6; + ch := decode[sp[1]]; + if ch<0 then + exit; + if len=2 then + rp[0] := AnsiChar((c or ch) shr 4) else begin + c := (c or ch) shl 6; + ch := decode[sp[2]]; + if ch<0 then + exit; + c := (c or ch) shr 2; + rp[1] := AnsiChar(c); + rp[0] := AnsiChar(c shr 8); + end; + end; + result := true; +end; + +function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; {$ifdef FPC}inline;{$endif} +var tab: PBase64Dec; // use local register +begin + tab := @ConvertBase64ToBin; + len := len shl 2; // len was the number of 4 chars chunks in sp + if (len>0) and (tab[sp[len-2]]>=0) then + if tab[sp[len-1]]>=0 then else + dec(len) else + dec(len,2); // Base64AnyDecode() algorithm ignores the trailing '=' + result := Base64AnyDecode(tab^,sp,rp,len); +end; + +{$ifdef PUREPASCAL} +function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; +var c: cardinal; + enc: PBase64Enc; // use local register +begin + enc := @b64enc; + len := len div 3; + result := len; + if len<>0 then + repeat + c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); + rp[0] := enc[(c shr 18) and $3f]; + rp[1] := enc[(c shr 12) and $3f]; + rp[2] := enc[(c shr 6) and $3f]; + rp[3] := enc[c and $3f]; + inc(rp,4); + inc(sp,3); + dec(len); + until len=0; +end; +{$else PUREPASCAL} +function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB + push ebx + push esi + push edi + push ebp + mov ebx, edx + mov esi, eax + mov eax, ecx + mov edx, 1431655766 // faster eax=len div 3 using reciprocal + sar ecx, 31 + imul edx + mov eax, edx + sub eax, ecx + mov edi, offset b64enc + mov ebp, eax + push eax + jz @z + // edi=b64enc[] ebx=sp esi=rp ebp=len div 3 + xor eax, eax +@1: // read 3 bytes from sp + movzx edx, byte ptr[ebx] + shl edx, 16 + mov al, [ebx + 2] + mov ah, [ebx + 1] + add ebx, 3 + or eax, edx + // encode as Base64 + mov ecx, eax + mov edx, eax + shr ecx, 6 + and edx, $3f + and ecx, $3f + mov dh, [edi + edx] + mov dl, [edi + ecx] + mov ecx, eax + shr eax, 12 + shr ecx, 18 + shl edx, 16 + and ecx, $3f + and eax, $3f + mov cl, [edi + ecx] + mov ch, [edi + eax] + or ecx, edx + // write the 4 encoded bytes into rp + mov [esi], ecx + add esi, 4 + dec ebp + jnz @1 +@z: pop eax // result := len div 3 + pop ebp + pop edi + pop esi + pop ebx +end; +{$endif PUREPASCAL} + +procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal); + {$ifdef HASINLINE}inline;{$endif} +var c: cardinal; + enc: PBase64Enc; // use local register +begin + enc := @b64enc; + case len of + 1: begin + c := ord(sp[0]) shl 4; + rp[0] := enc[(c shr 6) and $3f]; + rp[1] := enc[c and $3f]; + PWord(rp+2)^ := ord('=')+ord('=') shl 8; + end; + 2: begin + c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); + rp[0] := enc[(c shr 12) and $3f]; + rp[1] := enc[(c shr 6) and $3f]; + rp[2] := enc[c and $3f]; + rp[3] := '='; + end; + end; +end; + +procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal); +var main: cardinal; +begin + main := Base64EncodeMain(rp,sp,len); + Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3); +end; + +function BinToBase64Length(len: PtrUInt): PtrUInt; +begin + result := ((len+2)div 3)*4; +end; + +function BinToBase64(const s: RawByteString): RawUTF8; +var len: integer; +begin + result := ''; + len := length(s); + if len=0 then + exit; + FastSetString(result,nil,BinToBase64Length(len)); + Base64Encode(pointer(result),pointer(s),len); +end; + +function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; +var destlen: integer; +begin + result := ''; + if BinBytes=0 then + exit; + destlen := BinToBase64Length(BinBytes); + if destlen>255 then + exit; // avoid buffer overflow + result[0] := AnsiChar(destlen); + Base64Encode(@result[1],Bin,BinBytes); +end; + +function BinToBase64Short(const s: RawByteString): shortstring; +begin + result := BinToBase64Short(pointer(s),length(s)); +end; + +function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + result := ''; + if BinBytes=0 then + exit; + FastSetString(result,nil,BinToBase64Length(BinBytes)); + Base64Encode(pointer(result),Bin,BinBytes); +end; + +function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; +var lendata,lenprefix,lensuffix,len: integer; + res: PByteArray absolute result; +begin + result := ''; + lendata := length(data); + lenprefix := length(Prefix); + lensuffix := length(Suffix); + if lendata+lenprefix+lensuffix=0 then + exit; + len := ((lendata+2) div 3)*4+lenprefix+lensuffix; + if WithMagic then + inc(len,3); + FastSetString(result,nil,len); + if lenprefix>0 then + MoveSmall(pointer(Prefix),res,lenprefix); + if WithMagic then begin + PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC; + inc(lenprefix,3); + end; + Base64Encode(@res[lenprefix],pointer(data),lendata); + if lensuffix>0 then + MoveSmall(pointer(Suffix),@res[len-lensuffix],lensuffix); +end; + +function BinToBase64WithMagic(const data: RawByteString): RawUTF8; +var len: integer; +begin + result := ''; + len := length(data); + if len=0 then + exit; + FastSetString(result,nil,((len+2) div 3)*4+3); + PInteger(pointer(result))^ := JSON_BASE64_MAGIC; + Base64Encode(PAnsiChar(pointer(result))+3,pointer(data),len); +end; + +function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; +begin + result := ''; + if DataLen<=0 then + exit; + FastSetString(result,nil,((DataLen+2) div 3)*4+3); + PInteger(pointer(result))^ := JSON_BASE64_MAGIC; + Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen); +end; + +function IsBase64Internal(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): boolean; +var i: PtrInt; +begin + result := false; + if (len=0) or (len and 3<>0) then + exit; + for i := 0 to len-5 do + if dec[sp[i]]<0 then + exit; + inc(sp,len-4); + if (dec[sp[0]]=-1) or (dec[sp[1]]=-1) or + (dec[sp[2]]=-1) or (dec[sp[3]]=-1) then + exit; + result := true; // layout seems correct +end; + +function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; +begin + result := IsBase64Internal(sp,len,@ConvertBase64ToBin); +end; + +function IsBase64(const s: RawByteString): boolean; +begin + result := IsBase64Internal(pointer(s),length(s),@ConvertBase64ToBin); +end; + +function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; +var dec: PBase64Dec; +begin + dec := @ConvertBase64ToBin; + if IsBase64Internal(sp,len,dec) then begin + if dec[sp[len-2]]>=0 then + if dec[sp[len-1]]>=0 then + result := 0 else + result := 1 else + result := 2; + result := (len shr 2)*3-result; + end else + result := 0; +end; + +function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; +var dec: PBase64Dec; +begin + result := 0; + if (len=0) or (len and 3<>0) then + exit; + dec := @ConvertBase64ToBin; + if dec[sp[len-2]]>=0 then + if dec[sp[len-1]]>=0 then + result := 0 else + result := 1 else + result := 2; + result := (len shr 2)*3-result; +end; + +function Base64ToBin(const s: RawByteString): RawByteString; +begin + Base64ToBinSafe(pointer(s),length(s),result); +end; + +function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; +begin + Base64ToBinSafe(sp,len,result); +end; + +function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; +begin + result := Base64ToBinSafe(sp,len,data); +end; + +function Base64ToBinSafe(const s: RawByteString): RawByteString; +begin + Base64ToBinSafe(pointer(s),length(s),result); +end; + +function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; +begin + Base64ToBinSafe(sp,len,result); +end; + +function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; +var resultLen: PtrInt; +begin + resultLen := Base64ToBinLength(sp,len); + if resultLen<>0 then begin + SetString(data,nil,resultLen); + if ConvertBase64ToBin[sp[len-2]]>=0 then + if ConvertBase64ToBin[sp[len-1]]>=0 then else + dec(len) else + dec(len,2); // adjust for Base64AnyDecode() algorithm + result := Base64AnyDecode(ConvertBase64ToBin,sp,pointer(data),len); + if not result then + data := ''; + end else begin + result := false; + data := ''; + end; +end; + +function Base64ToBin(sp: PAnsiChar; len: PtrInt; var blob: TSynTempBuffer): boolean; +begin + blob.Init(Base64ToBinLength(sp,len)); + result := (blob.len>0) and Base64Decode(sp,blob.buf,len shr 2); +end; + +function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; + nofullcheck: boolean): boolean; +begin // nofullcheck is just ignored and deprecated + result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and + Base64Decode(base64,bin,base64len shr 2); +end; + +function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; + nofullcheck: boolean): boolean; +begin + result := Base64ToBin(pointer(base64),bin,length(base64),binlen,nofullcheck); +end; + +{ --------- Base64 URI encoding/decoding } + +{$ifdef PUREPASCAL} +procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); +var main, c: cardinal; + enc: PBase64Enc; // faster especially on x86_64 and PIC +begin + enc := @b64URIenc; + main := len div 3; + if main<>0 then begin + dec(len,main*3); // fast modulo + repeat + c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); + rp[0] := enc[(c shr 18) and $3f]; + rp[1] := enc[(c shr 12) and $3f]; + rp[2] := enc[(c shr 6) and $3f]; + rp[3] := enc[c and $3f]; + inc(rp,4); + inc(sp,3); + dec(main) + until main=0; + end; + case len of + 1: begin + c := ord(sp[0]) shl 4; + rp[0] := enc[(c shr 6) and $3f]; + rp[1] := enc[c and $3f]; + end; + 2: begin + c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); + rp[0] := enc[(c shr 12) and $3f]; + rp[1] := enc[(c shr 6) and $3f]; + rp[2] := enc[c and $3f]; + end; + end; +end; +{$else PUREPASCAL} +function Base64uriEncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; +{$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB + push ebx + push esi + push edi + push ebp + mov ebx, edx + mov esi, eax + mov eax, ecx + mov edx, 1431655766 // faster eax=len div 3 using reciprocal + sar ecx, 31 + imul edx + mov eax, edx + sub eax, ecx + mov edi, offset b64urienc + mov ebp, eax + push eax + jz @z + // edi=b64urienc[] ebx=sp esi=rp ebp=len div 3 + xor eax, eax +@1: // read 3 bytes from sp + movzx edx, byte ptr[ebx] + shl edx, 16 + mov al, [ebx + 2] + mov ah, [ebx + 1] + add ebx, 3 + or eax, edx + // encode as Base64uri + mov ecx, eax + mov edx, eax + shr ecx, 6 + and edx, $3f + and ecx, $3f + mov dh, [edi + edx] + mov dl, [edi + ecx] + mov ecx, eax + shr eax, 12 + shr ecx, 18 + shl edx, 16 + and ecx, $3f + and eax, $3f + mov cl, [edi + ecx] + mov ch, [edi + eax] + or ecx, edx + // write the 4 encoded bytes into rp + mov [esi], ecx + add esi, 4 + dec ebp + jnz @1 +@z: pop eax // result := len div 3 + pop ebp + pop edi + pop esi + pop ebx +end; + +procedure Base64uriEncodeTrailing(rp, sp: PAnsiChar; len: cardinal); + {$ifdef HASINLINE}inline;{$endif} +var c: cardinal; +begin + case len of + 1: begin + c := ord(sp[0]) shl 4; + rp[0] := b64urienc[(c shr 6) and $3f]; + rp[1] := b64urienc[c and $3f]; + end; + 2: begin + c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; + rp[0] := b64urienc[(c shr 12) and $3f]; + rp[1] := b64urienc[(c shr 6) and $3f]; + rp[2] := b64urienc[c and $3f]; + end; + end; +end; + +procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); +var main: cardinal; +begin + main := Base64uriEncodeMain(rp,sp,len); + Base64uriEncodeTrailing(rp+main*4,sp+main*3,len-main*3); +end; +{$endif PUREPASCAL} + +function BinToBase64uriLength(len: PtrUInt): PtrUInt; +begin + result := (len div 3)*4; + case len-(result shr 2)*3 of // fast len mod 3 + 1: inc(result,2); + 2: inc(result,3); + end; +end; + +function BinToBase64uri(const s: RawByteString): RawUTF8; +var len: integer; +begin + result := ''; + len := length(s); + if len=0 then + exit; + FastSetString(result,nil,BinToBase64uriLength(len)); + Base64uriEncode(pointer(result),pointer(s),len); +end; + +function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + result := ''; + if BinBytes<=0 then + exit; + FastSetString(result,nil,BinToBase64uriLength(BinBytes)); + Base64uriEncode(pointer(result),Bin,BinBytes); +end; + +function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; +var len: integer; +begin + result := ''; + if BinBytes<=0 then + exit; + len := BinToBase64uriLength(BinBytes); + if len>255 then + exit; + byte(result[0]) := len; + Base64uriEncode(@result[1],Bin,BinBytes); +end; + +function Base64uriToBinLength(len: PtrInt): PtrInt; +begin + if len=0 then + result := 0 else begin + result := (len shr 2)*3; + case len and 3 of + 1: result := 0; + 2: inc(result,1); + 3: inc(result,2); + end; + end; +end; + +function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; +begin + result := Base64AnyDecode(ConvertBase64URIToBin,sp,rp,len); +end; + +function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; +begin + Base64uriToBin(sp,len,result); +end; + +function Base64uriToBin(const s: RawByteString): RawByteString; +begin + Base64uriToBin(pointer(s),length(s),result); +end; + +procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); +var resultLen: PtrInt; +begin + resultLen := Base64uriToBinLength(len); + if resultLen<>0 then begin + SetString(result,nil,resultLen); + if Base64AnyDecode(ConvertBase64URIToBin,sp,pointer(result),len) then + exit; + end; + result := ''; +end; + +function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; +begin + temp.Init(Base64uriToBinLength(len)); + result := (temp.len>0) and Base64AnyDecode(ConvertBase64URIToBin,sp,temp.buf,len); +end; + +function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; +begin + result := Base64uriToBin(pointer(base64),bin,length(base64),binlen); +end; + +function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; +var resultLen: PtrInt; +begin + resultLen := Base64uriToBinLength(base64len); + result := (resultLen=binlen) and + Base64AnyDecode(ConvertBase64URIToBin,base64,bin,base64len); +end; + +procedure Base64ToURI(var base64: RawUTF8); +var P: PUTF8Char; +begin + P := UniqueRawUTF8(base64); + if P<>nil then + repeat + case P^ of + #0: break; + '+': P^ := '-'; + '/': P^ := '_'; + '=': begin // trim unsignificant trailing '=' characters + SetLength(base64,P-pointer(base64)); + break; + end; + end; + inc(P); + until false; +end; + + +function BinToSource(const ConstName, Comment: RawUTF8; + Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + if (Data=nil) or (Len<=0) or (PerLine<=0) then + result := '' else begin + W := TTextWriter.CreateOwnedStream(temp,Len*5+50+length(Comment)+length(Suffix)); + try + BinToSource(W,ConstName,Comment,Data,Len,PerLine); + if Suffix<>'' then begin + W.AddString(Suffix); + W.AddCR; + end; + W.SetText(result); + finally + W.Free; + end; + end; +end; + +procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; + Data: pointer; Len, PerLine: integer); +var line,i: integer; + P: PByte; +begin + if (Dest=nil) or (Data=nil) or (Len<=0) or (PerLine<=0) then + exit; + Dest.AddShort('const'); + if Comment<>'' then + Dest.Add(#13#10' // %',[Comment]); + Dest.Add(#13#10' %: array[0..%] of byte = (',[ConstName,Len-1]); + P := pointer(Data); + repeat + if len>PerLine then + line := PerLine else + line := Len; + Dest.AddShort(#13#10' '); + for i := 0 to line-1 do begin + Dest.Add('$'); + Dest.AddByteToHex(P^); + inc(P); + Dest.Add(','); + end; + dec(Len,line); + until Len=0; + Dest.CancelLastComma; + Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]); +end; + +{$ifdef KYLIX3} +function UpperCaseUnicode(const S: RawUTF8): RawUTF8; +begin + result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S))); +end; + +function LowerCaseUnicode(const S: RawUTF8): RawUTF8; +begin + result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S))); +end; +{$else} +function UpperCaseUnicode(const S: RawUTF8): RawUTF8; +var tmp: TSynTempBuffer; + len: integer; +begin + if S='' then begin + result := ''; + exit; + end; + tmp.Init(length(s)*2); + len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; + RawUnicodeToUtf8(tmp.buf,CharUpperBuffW(tmp.buf,len),result); + tmp.Done; +end; + +function LowerCaseUnicode(const S: RawUTF8): RawUTF8; +var tmp: TSynTempBuffer; + len: integer; +begin + if S='' then begin + result := ''; + exit; + end; + tmp.Init(length(s)*2); + len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; + RawUnicodeToUtf8(tmp.buf,CharLowerBuffW(tmp.buf,len),result); + tmp.Done; +end; +{$endif KYLIX3} + +function IsCaseSensitive(const S: RawUTF8): boolean; +begin + result := IsCaseSensitive(pointer(S),length(S)); +end; + +function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; +begin + result := true; + if (P<>nil) and (PLen>0) then + repeat + if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then + exit; + inc(P); + dec(PLen); + until PLen=0; + result := false; +end; + +function UpperCase(const S: RawUTF8): RawUTF8; +var L, i: PtrInt; +begin + L := length(S); + FastSetString(Result,pointer(S),L); + for i := 0 to L-1 do + if PByteArray(result)[i] in [ord('a')..ord('z')] then + dec(PByteArray(result)[i],32); +end; + +procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); +var i: PtrInt; +begin + FastSetString(result,Text,Len); + for i := 0 to Len-1 do + if PByteArray(result)[i] in [ord('a')..ord('z')] then + dec(PByteArray(result)[i],32); +end; + +procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); +var L, i: PtrInt; +begin + L := length(Source); + FastSetString(Dest,pointer(Source),L); + for i := 0 to L-1 do + if PByteArray(Dest)[i] in [ord('a')..ord('z')] then + dec(PByteArray(Dest)[i],32); +end; + +procedure UpperCaseSelf(var S: RawUTF8); +var i: PtrInt; + P: PByteArray; +begin + P := UniqueRawUTF8(S); + for i := 0 to length(S)-1 do + if P[i] in [ord('a')..ord('z')] then + dec(P[i],32); +end; + +function LowerCase(const S: RawUTF8): RawUTF8; +var L, i: PtrInt; +begin + L := length(S); + FastSetString(result,pointer(S),L); + for i := 0 to L-1 do + if PByteArray(result)[i] in [ord('A')..ord('Z')] then + inc(PByteArray(result)[i],32); +end; + +procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); +var i: PtrInt; +begin + FastSetString(result,Text,Len); + for i := 0 to Len-1 do + if PByteArray(result)[i] in [ord('A')..ord('Z')] then + inc(PByteArray(result)[i],32); +end; + +procedure LowerCaseSelf(var S: RawUTF8); +var i: PtrInt; + P: PByteArray; +begin + P := UniqueRawUTF8(S); + for i := 0 to length(S)-1 do + if P[i] in [ord('A')..ord('Z')] then + inc(P[i],32); +end; + +function TrimLeft(const S: RawUTF8): RawUTF8; +var i, l: PtrInt; +begin + l := Length(S); + i := 1; + while (i <= l) and (S[i] <= ' ') do + Inc(i); + Result := Copy(S, i, Maxint); +end; + +function TrimRight(const S: RawUTF8): RawUTF8; +var i: PtrInt; +begin + i := Length(S); + while (i > 0) and (S[i] <= ' ') do + Dec(i); + FastSetString(result,pointer(S),i); +end; + +procedure TrimCopy(const S: RawUTF8; start, count: PtrInt; + var result: RawUTF8); +var L: PtrInt; +begin + if count>0 then begin + if start<=0 then + start := 1; + L := Length(S); + while (start<=L) and (S[start]<=' ') do begin + inc(start); dec(count); end; + dec(start); + dec(L,start); + if count0 do + if S[start+L]<=' ' then + dec(L) else + break; + if L>0 then begin + FastSetString(result,@PByteArray(S)[start],L); + exit; + end; + end; + result := ''; +end; + +type + TAnsiCharToWord = array[AnsiChar] of word; + TByteToWord = array[byte] of word; +var + /// fast lookup table for converting hexadecimal numbers from 0 to 15 + // into their ASCII equivalence + // - is local for better code generation + TwoDigitsHex: array[byte] of array[1..2] of AnsiChar; + TwoDigitsHexW: TAnsiCharToWord absolute TwoDigitsHex; + TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex; + /// lowercase hexadecimal lookup table + TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar; + TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower; + TwoDigitsHexWBLower: array[byte] of word absolute TwoDigitsHexLower; + +procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); +{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} +begin + {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} + if BinBytes>0 then + repeat + PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; + inc(Bin); + inc(Hex,2); + dec(BinBytes); + until BinBytes=0; +end; + +function BinToHex(const Bin: RawByteString): RawUTF8; +var L: integer; +begin + L := length(Bin); + FastSetString(result,nil,L*2); + SynCommons.BinToHex(pointer(Bin),pointer(Result),L); +end; + +function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + FastSetString(result,nil,BinBytes*2); + SynCommons.BinToHex(Bin,pointer(Result),BinBytes); +end; + +function HexToBin(const Hex: RawUTF8): RawByteString; +var L: integer; +begin + result := ''; + L := length(Hex); + if L and 1<>0 then + L := 0 else // hexadecimal should be in char pairs + L := L shr 1; + SetLength(result,L); + if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then + result := ''; +end; + +function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; +begin + PWord(P)^ := TwoDigitsHexWB[Value]; + result := P+2; +end; + +function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; +var i: integer; +begin + if len>max then + len := max; + for i := 1 to len do begin + if s^ in [' '..#126] then begin + d^ := s^; + inc(d); + end else begin + d^ := '$'; + inc(d); + PWord(d)^ := TwoDigitsHexWB[ord(s^)]; + inc(d,2); + end; + inc(s); + end; + if len=max then begin + PCardinal(d)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; + inc(d,3); + end else + d^ := #0; + result := d; +end; + +function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; + enabled: boolean): PAnsiChar; +begin + if enabled then begin + temp[0] := ' '; + EscapeBuffer(source,@temp[1],sourcelen,LOGESCAPELEN); + end else + temp[0] := #0; + result := @temp; +end; + +function LogEscapeFull(const source: RawByteString): RawUTF8; +begin + result := LogEscapeFull(pointer(source),length(source)); +end; + +function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; +begin + FastSetString(result,nil,sourcelen*3); // worse case + if sourcelen=0 then + exit; + sourcelen := EscapeBuffer(source,pointer(result),sourcelen,length(result))-pointer(result); + SetLength(result,sourcelen); +end; + +function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; +begin + result[0] := AnsiChar(EscapeBuffer(source,@result[1],sourcelen,80)-@result[1]); +end; + +function EscapeToShort(const source: RawByteString): shortstring; overload; +begin + result[0] := AnsiChar(EscapeBuffer(pointer(source),@result[1],length(source),80)-@result[1]); +end; + +procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); +{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} +begin + {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} + inc(Hex,BinBytes*2); + if BinBytes>0 then + repeat + dec(Hex,2); + PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; + inc(Bin); + dec(BinBytes); + until BinBytes=0; +end; + +function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + FastSetString(result,nil,BinBytes*2); + BinToHexDisplay(Bin,pointer(result),BinBytes); +end; + +procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); +{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} +begin + {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} + if BinBytes>0 then + repeat + PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^]; + inc(Bin); + inc(Hex,2); + dec(BinBytes); + until BinBytes=0; +end; + +function BinToHexLower(const Bin: RawByteString): RawUTF8; +begin + BinToHexLower(pointer(Bin),length(Bin),result); +end; + +procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); +begin + FastSetString(result,nil,BinBytes*2); + BinToHexLower(Bin,pointer(result),BinBytes); +end; + +function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + BinToHexLower(Bin,BinBytes,result); +end; + +procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); +{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} +begin + if (Bin=nil) or (Hex=nil) or (BinBytes<=0) then + exit; + {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} + inc(Hex,BinBytes*2); + repeat + dec(Hex,2); + PWord(Hex)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWLower{$endif}[Bin^]; + inc(Bin); + dec(BinBytes); + until BinBytes=0; +end; + +function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; +begin + FastSetString(result,nil,BinBytes*2); + BinToHexDisplayLower(Bin,pointer(result),BinBytes); +end; + +function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; +begin + if BinBytes>127 then + BinBytes := 127; + result[0] := AnsiChar(BinBytes * 2); + BinToHexDisplayLower(Bin,@result[1],BinBytes); +end; + +function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; +begin + if BinBytes>8 then + BinBytes := 8; + result[0] := AnsiChar(BinBytes * 2); + BinToHexDisplayLower(@Bin,@result[1],BinBytes); +end; + +function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; +{$ifdef UNICODE} +var temp: TSynTempBuffer; +begin + temp.Init(BinBytes*2); + BinToHexDisplayLower(Bin,temp.Buf,BinBytes); + Ansi7ToString(PWinAnsiChar(temp.buf),BinBytes*2,string(result)); + temp.Done; +end; +{$else} +begin + SetString(result,nil,BinBytes*2); + BinToHexDisplayLower(Bin,pointer(result),BinBytes); +end; +{$endif UNICODE} + +procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); +begin + FastSetString(result,nil,SizeOf(Pointer)*2); + BinToHexDisplay(@aPointer,pointer(result),SizeOf(Pointer)); +end; + +function PointerToHex(aPointer: Pointer): RawUTF8; +begin + FastSetString(result,nil,SizeOf(aPointer)*2); + BinToHexDisplay(@aPointer,pointer(result),SizeOf(aPointer)); +end; + +function CardinalToHex(aCardinal: Cardinal): RawUTF8; +begin + FastSetString(result,nil,SizeOf(aCardinal)*2); + BinToHexDisplay(@aCardinal,pointer(result),SizeOf(aCardinal)); +end; + +function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; +begin + FastSetString(result,nil,SizeOf(aCardinal)*2); + BinToHexDisplayLower(@aCardinal,pointer(result),SizeOf(aCardinal)); +end; + +function Int64ToHex(aInt64: Int64): RawUTF8; +begin + FastSetString(result,nil,SizeOf(Int64)*2); + BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); +end; + +procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); +begin + FastSetString(result,nil,SizeOf(Int64)*2); + BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); +end; + +function PointerToHexShort(aPointer: Pointer): TShort16; +begin + result[0] := AnsiChar(SizeOf(aPointer)*2); + BinToHexDisplay(@aPointer,@result[1],SizeOf(aPointer)); +end; + +function CardinalToHexShort(aCardinal: Cardinal): TShort16; +begin + result[0] := AnsiChar(SizeOf(aCardinal)*2); + BinToHexDisplay(@aCardinal,@result[1],SizeOf(aCardinal)); +end; + +function Int64ToHexShort(aInt64: Int64): TShort16; +begin + result[0] := AnsiChar(SizeOf(aInt64)*2); + BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); +end; + +procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); +begin + result[0] := AnsiChar(SizeOf(aInt64)*2); + BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); +end; + +function Int64ToHexString(aInt64: Int64): string; +var temp: TShort16; +begin + Int64ToHexShort(aInt64,temp); + Ansi7ToString(@temp[1],ord(temp[0]),result); +end; + +function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; +begin + FastSetString(result,nil,3); + PWordArray(result)[0] := TwoDigitLookupW[Value div 10]; + PByteArray(result)[2] := (Value mod 10)+48; +end; + +function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; +begin + FastSetString(result,nil,4); + if Value>9999 then + Value := 9999; + YearToPChar(Value,pointer(result)); +end; + +function UInt4DigitsToShort(Value: Cardinal): TShort4; +begin + result[0] := #4; + if Value>9999 then + Value := 9999; + YearToPChar(Value,@result[1]); +end; + +function UInt3DigitsToShort(Value: Cardinal): TShort4; +begin + if Value>999 then + Value := 999; + YearToPChar(Value,@result[0]); + result[0] := #3; // override first digit +end; + +function UInt2DigitsToShort(Value: byte): TShort4; +begin + result[0] := #2; + if Value>99 then + Value := 99; + PWord(@result[1])^ := TwoDigitLookupW[Value]; +end; + +function UInt2DigitsToShortFast(Value: byte): TShort4; +begin + result[0] := #2; + PWord(@result[1])^ := TwoDigitLookupW[Value]; +end; + +function SameValue(const A, B: Double; DoublePrec: double): Boolean; +var AbsA,AbsB,Res: double; +begin + if PInt64(@DoublePrec)^=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12) + AbsA := Abs(A); + AbsB := Abs(B); + Res := 1E-12; + if AbsAB)-ord(AB)-ord(AB)-ord(AB)-ord(A0) and + (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and + CompareMemFixed(pointer(PtrInt(Values^)),pointer(Value),ValueLen) then + exit else + inc(Values) else + for result := 0 to ValuesCount do + if (PtrUInt(Values^)<>0) and // StrIComp() won't change length + (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and + (StrIComp(pointer(Values^),pointer(Value))=0) then + exit else + inc(Values); + result := -1; +end; + +function FindPropName(Values: PRawUTF8; const Value: RawUTF8; + ValuesCount: integer): integer; +var ValueLen: TStrLen; +begin + dec(ValuesCount); + ValueLen := length(Value); + if ValueLen=0 then + for result := 0 to ValuesCount do + if Values^='' then + exit else + inc(Values) else + for result := 0 to ValuesCount do + if (PtrUInt(Values^)<>0) and + (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and + IdemPropNameUSameLen(pointer(Values^),pointer(Value),ValueLen) then + exit else + inc(Values); + result := -1; +end; + +function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; + CaseSensitive: boolean): integer; +begin + result := FindRawUTF8(pointer(Values),Value,length(Values),CaseSensitive); +end; + +function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; + CaseSensitive: boolean): integer; +begin + result := high(Values); + if result>=0 then + result := FindRawUTF8(@Values[0],Value,result+1,CaseSensitive); +end; + +function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; +begin + result := high(Names); + if result>=0 then + result := FindPropName(@Names[0],Name,result+1); +end; + +function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; + NoDuplicates, CaseSensitive: boolean): boolean; +var i: integer; +begin + if NoDuplicates then begin + i := FindRawUTF8(Values,Value,CaseSensitive); + if i>=0 then begin + result := false; + exit; + end; + end; + i := length(Values); + SetLength(Values,i+1); + Values[i] := Value; + result := true; +end; + +function NextGrow(capacity: integer): integer; +begin // algorithm similar to TFPList.Expand for the increasing ranges + result := capacity; + if result<128 shl 20 then + if result<8 shl 20 then + if result<=128 then + if result>8 then + inc(result,16) else + inc(result,4) else + inc(result,result shr 2) else + inc(result,result shr 3) else + inc(result,16 shl 20); +end; + +procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + const Value: RawUTF8); +var capacity: integer; +begin + capacity := Length(Values); + if ValuesCount=capacity then + SetLength(Values,NextGrow(capacity)); + Values[ValuesCount] := Value; + inc(ValuesCount); +end; + +function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; +var n,i: integer; +begin + result := false; + n := length(A); + if n<>length(B) then + exit; + for i := 0 to n-1 do + if A[i]<>B[i] then + exit; + result := true; +end; + +function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; +var i: integer; +begin + result := false; + for i := 0 to Count - 1 do + if A[i]<>B[i] then + exit; + result := true; +end; + +procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; + var Result: TRawUTF8DynArray); +var i: Integer; +begin + Finalize(result); + SetLength(Result,length(Source)); + for i := 0 to length(Source)-1 do + StringToUTF8(Source[i],Result[i]); +end; + +procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); +var i: Integer; +begin + Finalize(result); + SetLength(Result,Source.Count); + for i := 0 to Source.Count-1 do + StringToUTF8(Source[i],Result[i]); +end; + +function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; +{$ifdef PUREPASCAL} +var tab: PTextCharSet; +begin + result := false; + if source=nil then + exit; + repeat + if source^='[' then begin + inc(source); + result := IdemPChar(source,search); + end; + tab := @TEXT_CHARS; + while tcNot01013 in tab[source^] do inc(source); + while tc1013 in tab[source^] do inc(source); + if result then + exit; // found + until source^=#0; + source := nil; +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=source edx=search + push eax // save source var + mov eax, [eax] // eax=source + test eax, eax + jz @z + push ebx + mov ebx, edx // save search + cmp byte ptr[eax], '[' + lea eax, [eax + 1] + jne @s +@i: push eax + mov edx, ebx // edx=search + call IdemPChar + pop ecx // ecx=source + jmp @1 +@s: mov ecx, eax + xor eax, eax // result := false +@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source); + inc ecx + cmp dl, 13 + ja @1 + je @e + or dl, dl + jz @0 + cmp dl, 10 + jne @1 + cmp byte[ecx], 13 + jbe @1 + jmp @4 +@e: cmp byte ptr[ecx], 10 // jump #13#10 + jne @4 + inc ecx +@4: test al, al + jnz @x // exit if IdemPChar returned true + cmp byte ptr[ecx], '[' + lea ecx, [ecx + 1] + jne @1 + mov eax, ecx + jmp @i +@0: xor ecx, ecx // set source=nil +@x: pop ebx + pop edx // restore source var + mov [edx], ecx // update source var + ret +@z: pop edx // ignore source var, result := false +end; +{$endif PUREPASCAL} + +{$ifdef USENORMTOUPPER} +{$ifdef PUREPASCAL} +function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; +begin + result := false; + if (p=nil) or (up=nil) then + exit; + while up^<>#0 do begin + if (p^>#255) or (up^<>AnsiChar(NormToUpperByte[ord(p^)])) then + exit; + inc(up); + inc(p); + end; + result := true; +end; +{$else} +function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=p edx=up + test eax, eax + jz @e // P=nil -> false + test edx, edx + push ebx + push esi + jz @z // up=nil -> true + mov esi, offset NormToUpper + xor ebx, ebx + xor ecx, ecx +@1: mov bx, [eax] // bl=p^ + mov cl, [edx] // cl=up^ + test bh, bh // p^ > #255 -> FALSE + jnz @n + test cl, cl + mov bl, [ebx + esi] // bl=NormToUpper[p^] + jz @z // up^=#0 -> OK + inc edx + add eax, 2 + cmp bl, cl + je @1 +@n: pop esi + pop ebx +@e: xor eax, eax + ret +@z: mov al, 1 // up^=#0 -> OK + pop esi + pop ebx +end; +{$endif PUREPASCAL} +{$else} +function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; +// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) +begin + result := false; + if (p=nil) or (up=nil) then + exit; + while up^<>#0 do begin + if (p^>#255) or (up^<>AnsiChar(NormToUpperByteAnsi7[ord(p^)])) then + exit; + inc(up); + inc(p); + end; + result := true; +end; +{$endif USENORMTOUPPER} + +function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; +var + {$ifdef CPUX86NOTPIC} + table: TNormTable absolute NormToUpperAnsi7; + {$else} + table: PNormTable; + {$endif} + c: AnsiChar; + u: PAnsiChar; +label + _0; +begin + if (P = nil) or (UpperName = nil) then + goto _0; + {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} + repeat + c := UpperName^; + if table[P^] = c then + begin + inc(P); + u := UpperName + 1; + repeat + c := u^; + inc(u); + if c <> #0 then + begin + if table[P^] <> c then + break; + inc(P); + continue; + end; + result := P; // if found, points just after UpperName + exit; + until false; + end; + repeat + repeat + c := P^; + inc(P); + until c <= #13; + if c = #13 then // most common case is text ending with #13#10 + repeat + c := P^; + if (c <> #10) and (c <> #13) then + break; + inc(P); + until false + else if c <> #10 then + if c <> #0 then + continue // e.g. #9 + else + goto _0 + else + repeat + c := P^; + if c <> #10 then + break; + inc(P); + until false; + if c <> #0 then + break; // check if UpperName is at the begining of the new line +_0: result := nil; // reached P^=#0 -> not found + exit; + until false; + until false; +end; + +function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; + var Value: RawUTF8): boolean; +var + P: PUTF8Char; + L: PtrInt; +begin + P := FindNameValue(pointer(NameValuePairs), UpperName); + if P <> nil then + begin + while P^ in [#9, ' '] do // trim left + inc(P); + L := 0; + while P[L] > #13 do // end of line/value + inc(L); + while P[L - 1] = ' ' do // trim right + dec(L); + FastSetString(Value, P, L); + result := true; + end + else + begin + {$ifdef FPC} Finalize(Value); {$else} Value := ''; {$endif} + result := false; + end; +end; + +function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; +{$ifdef PUREPASCAL} +begin + result := false; + if source=nil then + exit; + repeat + if source^='[' then begin + inc(source); + result := IdemPCharW(source,search); + end; + while not (cardinal(source^) in [0,10,13]) do inc(source); + while cardinal(source^) in [10,13] do inc(source); + if result then + exit; // found + until source^=#0; + source := nil; +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=source edx=search + push eax // save source var + mov eax, [eax] // eax=source + test eax, eax + jz @z + push ebx + mov ebx, edx // save search + cmp word ptr[eax], '[' + lea eax, [eax + 2] + jne @s +@i: push eax + mov edx, ebx // edx=search + call IdemPCharW + pop ecx // ecx=source + jmp @1 +@s: mov ecx, eax + xor eax, eax // result := false +@1: mov dx, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) + add ecx, 2 + cmp dx, 13 + ja @1 + je @e + or dx, dx + jz @0 + cmp dx, 10 + jne @1 + jmp @4 +@e: cmp word ptr[ecx], 10 // jump #13#10 + jne @4 + add ecx, 2 +@4: test al, al + jnz @x // exit if IdemPChar returned true + cmp word ptr[ecx], '[' + lea ecx, [ecx + 2] + jne @1 + mov eax, ecx + jmp @i +@0: xor ecx, ecx // set source=nil +@x: pop ebx + pop edx // restore source var + mov [edx], ecx // update source var + ret +@z: pop edx // ignore source var, result := false +end; +{$endif PUREPASCAL} + +function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; +var u, PBeg: PUTF8Char; + by4: cardinal; + table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; +begin // expect UpperName as 'NAME=' + if (P<>nil) and (P^<>'[') and (UpperName<>nil) then begin + {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} + PBeg := nil; + u := P; + repeat + while u^=' ' do inc(u); // trim left ' ' + if u^=#0 then + break; + if table[u^]=UpperName[0] then + PBeg := u; + repeat + by4 := PCardinal(u)^; + if ToByte(by4)>13 then + if ToByte(by4 shr 8)>13 then + if ToByte(by4 shr 16)>13 then + if ToByte(by4 shr 24)>13 then begin + inc(u,4); + continue; + end else + inc(u,3) else + inc(u,2) else + inc(u); + if u^ in [#0,#10,#13] then + break else + inc(u); + until false; + if PBeg<>nil then begin + inc(PBeg); + P := u; + u := pointer(UpperName+1); + repeat + if u^<>#0 then + if table[PBeg^]<>u^ then + break else begin + inc(u); + inc(PBeg); + end else begin + FastSetString(result,PBeg,P-PBeg); + exit; + end; + until false; + PBeg := nil; + u := P; + end; + if u^=#13 then inc(u); + if u^=#10 then inc(u); + until u^ in [#0,'[']; + end; + result := ''; +end; + +function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; +var table: PNormTable; +begin + result := false; + table := @NormToUpperAnsi7; + if (P<>nil) and (P^<>'[') then + repeat + if P^=' ' then begin + repeat inc(P) until P^<>' '; // trim left ' ' + if P^=#0 then + break; + end; + if IdemPChar2(table,P,UpperName) then begin + result := true; + exit; + end; + repeat + if P[0]>#13 then + if P[1]>#13 then + if P[2]>#13 then + if P[3]>#13 then begin + inc(P,4); + continue; + end else + inc(P,3) else + inc(P,2) else + inc(P); + case P^ of + #0: exit; + #10: begin inc(P); break; end; + #13: begin if P[1]=#10 then inc(P,2) else inc(P); break; end; + else inc(P); + end; + until false; + until P^='['; +end; + +function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; + const UpperValues: array of PAnsiChar): boolean; +var PBeg: PUTF8Char; +begin + result := true; + if high(UpperValues)>=0 then + while (P<>nil) and (P^<>'[') do begin + if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' ' + PBeg := P; + if IdemPChar(PBeg,pointer(UpperName)) then begin + inc(PBeg,length(UpperName)); + if IdemPCharArray(PBeg,UpperValues)>=0 then + exit; // found one value + break; + end; + P := GotoNextLine(P); + end; + result := false; +end; + +function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; +var PBeg: PUTF8Char; +begin + PBeg := SectionFirstLine; + while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do + SectionFirstLine := GotoNextLine(SectionFirstLine); + if SectionFirstLine=nil then + result := PBeg else + FastSetString(result,PBeg,SectionFirstLine-PBeg); +end; + +function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; +var P: PUTF8Char; + UpperSection: array[byte] of AnsiChar; +begin + P := pointer(Content); + PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); + if FindSectionFirstLine(P,UpperSection) then + result := GetSectionContent(P) else + result := ''; +end; + +function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; + EraseSectionHeader: boolean): boolean; +var P: PUTF8Char; + UpperSection: array[byte] of AnsiChar; +begin + result := false; // no modification + P := pointer(Content); + PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); + if FindSectionFirstLine(P,UpperSection) then + result := DeleteSection(P,Content,EraseSectionHeader); +end; + +function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; + EraseSectionHeader: boolean): boolean; +var PEnd: PUTF8Char; + IndexBegin: PtrInt; +begin + result := false; + PEnd := SectionFirstLine; + if EraseSectionHeader then // erase [Section] header line + while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine); + while (PEnd<>nil) and (PEnd^<>'[') do + PEnd := GotoNextLine(PEnd); + IndexBegin := SectionFirstLine-pointer(Content); + if IndexBegin=0 then + exit; // no modification + if PEnd=nil then + SetLength(Content,IndexBegin) else + delete(Content,IndexBegin+1,PEnd-SectionFirstLine); + result := true; // Content was modified +end; + +procedure ReplaceSection(SectionFirstLine: PUTF8Char; + var Content: RawUTF8; const NewSectionContent: RawUTF8); +var PEnd: PUTF8Char; + IndexBegin: PtrInt; +begin + if SectionFirstLine=nil then + exit; + // delete existing [Section] content + PEnd := SectionFirstLine; + while (PEnd<>nil) and (PEnd^<>'[') do + PEnd := GotoNextLine(PEnd); + IndexBegin := SectionFirstLine-pointer(Content); + if PEnd=nil then + SetLength(Content,IndexBegin) else + delete(Content,IndexBegin+1,PEnd-SectionFirstLine); + // insert section content + insert(NewSectionContent,Content,IndexBegin+1); +end; + +procedure ReplaceSection(var Content: RawUTF8; const SectionName, + NewSectionContent: RawUTF8); +var UpperSection: array[byte] of AnsiChar; + P: PUTF8Char; +begin + P := pointer(Content); + PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); + if FindSectionFirstLine(P,UpperSection) then + ReplaceSection(P,Content,NewSectionContent) else + Content := Content+'['+SectionName+']'#13#10+NewSectionContent; +end; + +function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; +begin + result := GetInteger(pointer(FindIniNameValue(P,UpperName))); +end; + +function FindIniEntry(const Content, Section, Name: RawUTF8): RawUTF8; +var P: PUTF8Char; + UpperSection, UpperName: array[byte] of AnsiChar; + // possible GPF if length(Section/Name)>255, but should const in code +begin + result := ''; + P := pointer(Content); + if P=nil then exit; + // UpperName := UpperCase(Name)+'='; + PWord(UpperCopy255(UpperName,Name))^ := ord('='); + if Section='' then + // find the Name= entry before any [Section] + result := FindIniNameValue(P,UpperName) else begin + // find the Name= entry in the specified [Section] + PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); + if FindSectionFirstLine(P,UpperSection) then + result := FindIniNameValue(P,UpperName); + end; +end; + +function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; +begin + result := WinAnsiToUtf8(WinAnsiString(FindIniEntry(Content,Section,Name))); +end; + +function FindIniEntryInteger(const Content,Section,Name: RawUTF8): integer; +begin + result := GetInteger(pointer(FindIniEntry(Content,Section,Name))); +end; + +function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; +var Content: RawUTF8; +begin + Content := StringFromFile(FileName); + if Content='' then + result := '' else + result := FindIniEntry(Content,Section,Name); +end; + +function UpdateIniNameValueInternal(var Content: RawUTF8; + const NewValue, NewValueCRLF: RawUTF8; var P: PUTF8Char; + UpperName: PAnsiChar; UpperNameLength: integer): boolean; +var PBeg: PUTF8Char; + i: integer; +begin + while (P<>nil) and (P^<>'[') do begin + while P^=' ' do inc(P); // trim left ' ' + PBeg := P; + P := GotoNextLine(P); + if IdemPChar(PBeg,UpperName) then begin + // update Name=Value entry + result := true; + inc(PBeg,UpperNameLength); + i := (PBeg-pointer(Content))+1; + if (i=length(NewValue)) and CompareMem(PBeg,pointer(NewValue),i) then + exit; // new Value is identical to the old one -> no change + if P=nil then // avoid last line (P-PBeg) calculation error + SetLength(Content,i-1) else + delete(Content,i,P-PBeg); // delete old Value + insert(NewValueCRLF,Content,i); // set new value + exit; + end; + end; + result := false; +end; + +function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; +var P: PUTF8Char; +begin + if UpperName='' then + result := false else begin + P := pointer(Content); + result := UpdateIniNameValueInternal(Content,NewValue,NewValue+#13#10,P, + pointer(UpperName),length(UpperName)); + if result or (Name='') then + exit; + if Content<>'' then + Content := Content+#13#10; + Content := Content+Name+NewValue; + result := true; + end; +end; + +procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); +const CRLF = #13#10; +var P: PUTF8Char; + SectionFound: boolean; + i, UpperNameLength: PtrInt; + V: RawUTF8; + UpperSection, UpperName: array[byte] of AnsiChar; +label Sec; +begin + UpperNameLength := length(Name); + PWord(UpperCopy255Buf(UpperName,pointer(Name),UpperNameLength))^ := ord('='); + inc(UpperNameLength); + V := Value+CRLF; + P := pointer(Content); + // 1. find Section, and try update within it + if Section='' then + goto Sec; // find the Name= entry before any [Section] + SectionFound := false; + PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); + if FindSectionFirstLine(P,UpperSection) then begin +Sec:SectionFound := true; + if UpdateIniNameValueInternal(Content,Value,V,P,@UpperName,UpperNameLength) then + exit; + // we reached next [Section] without having found Name= + end; + // 2. section or Name= entry not found: add Name=Value + V := Name+'='+V; + if not SectionFound then + // create not existing [Section] + V := '['+Section+(']'+CRLF)+V; + // insert Name=Value at P^ (end of file or end of [Section]) + if P=nil then + // insert at end of file + Content := Content+V else begin + // insert at end of [Section] + i := (P-pointer(Content))+1; + insert(V,Content,i); + end; +end; + +procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); +var Content: RawUTF8; +begin + Content := StringFromFile(FileName); + UpdateIniEntry(Content,Section,Name,Value); + FileFromString(Content,FileName); +end; + +function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString; +var F: THandle; + Read, Size, Chunk: integer; + P: PUTF8Char; + tmp: array[0..$7fff] of AnsiChar; +begin + result := ''; + if FileName='' then + exit; + F := FileOpenSequentialRead(FileName); + if PtrInt(F)>=0 then begin + if HasNoSize then begin + Size := 0; + repeat + Read := FileRead(F,tmp,SizeOf(tmp)); + if Read<=0 then + break; + SetLength(result,Size+Read); // in-place resize + MoveFast(tmp,PByteArray(result)^[Size],Read); + inc(Size,Read); + until false; + end else begin + Size := GetFileSize(F,nil); + if Size>0 then begin + SetLength(result,Size); + P := pointer(result); + repeat + Chunk := Size; + {$ifdef MSWINDOWS} // FILE_FLAG_SEQUENTIAL_SCAN has limits on XP + if Chunk>32 shl 20 then + Chunk := 32 shl 20; // avoid e.g. ERROR_NO_SYSTEM_RESOURCES + {$endif} + Read := FileRead(F,P^,Chunk); + if Read<=0 then begin + result := ''; + break; + end; + inc(P,Read); + dec(Size,Read); + until Size=0; + end; + end; + FileClose(F); + end; +end; + +function FileFromString(const Content: RawByteString; const FileName: TFileName; + FlushOnDisk: boolean; FileDate: TDateTime): boolean; +var F: THandle; + P: PByte; + L,written: integer; +begin + result := false; + if FileName='' then + exit; + F := FileCreate(FileName); + if PtrInt(F)<0 then + exit; + L := length(Content); + P := pointer(Content); + while L>0 do begin + written := FileWrite(F,P^,L); + if written<0 then begin + FileClose(F); + exit; + end; + dec(L,written); + inc(P,written); + end; + if FlushOnDisk then + FlushFileBuffers(F); + {$ifdef MSWINDOWS} + if FileDate<>0 then + FileSetDate(F,DateTimeToFileDate(FileDate)); + FileClose(F); + {$else} + FileClose(F); + if FileDate<>0 then + FileSetDate(FileName,DateTimeToFileDate(FileDate)); + {$endif MSWINDOWS} + result := true; +end; + +type + TTextFileKind = (isUnicode, isUTF8, isAnsi); + +function TextFileKind(const Map: TMemoryMap): TTextFileKind; +begin + result := isAnsi; + if (Map.Buffer<>nil) and (Map.Size>3) then + if PWord(Map.Buffer)^=$FEFF then + result := isUnicode else + if (PWord(Map.Buffer)^=$BBEF) and (PByteArray(Map.Buffer)[2]=$BF) then + result := isUTF8; +end; + +function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean): SynUnicode; +var Map: TMemoryMap; +begin + result := ''; + if Map.Map(FileName) then + try + if ForceUTF8 then + UTF8ToSynUnicode(PUTF8Char(Map.Buffer),Map.Size,Result) else + case TextFileKind(Map) of + isUnicode: + SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); + isUTF8: + UTF8ToSynUnicode(PUTF8Char(pointer(PtrUInt(Map.Buffer)+3)),Map.Size-3,Result); + isAnsi: + result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer, Map.Size); + end; + finally + Map.UnMap; + end; +end; + +function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean): RawUTF8; +var Map: TMemoryMap; +begin + result := ''; + if Map.Map(FileName) then + try + case TextFileKind(Map) of + isUnicode: + RawUnicodeToUtf8(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result); + isUTF8: + FastSetString(result,pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); + isAnsi: + if AssumeUTF8IfNoBOM then + FastSetString(result,Map.Buffer,Map.Size) else + result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Map.Buffer, Map.Size); + end; + finally + Map.UnMap; + end; +end; + +function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean): string; +var Map: TMemoryMap; +begin + result := ''; + if Map.Map(FileName) then + try + if ForceUTF8 then +{$ifdef UNICODE} + UTF8DecodeToString(PUTF8Char(Map.Buffer),Map.Size,result) {$else} + result := CurrentAnsiConvert.UTF8BufferToAnsi(PUTF8Char(Map.Buffer),Map.Size) +{$endif} else + case TextFileKind(Map) of +{$ifdef UNICODE} + isUnicode: + SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); + isUTF8: + UTF8DecodeToString(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3,result); + isAnsi: + result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size); +{$else} + isUnicode: + result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); + isUTF8: + result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); + isAnsi: + SetString(result,PAnsiChar(Map.Buffer),Map.Size); +{$endif UNICODE} + end; + finally + Map.UnMap; + end; +end; + +function StreamToRawByteString(aStream: TStream): RawByteString; +var current, size: Int64; +begin + result := ''; + if aStream=nil then + exit; + current := aStream.Position; + if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin + result := TRawByteStringStream(aStream).DataString; // fast COW + exit; + end; + size := aStream.Size-current; + if (size=0) or (size>maxInt) then + exit; + SetLength(result,size); + aStream.Read(pointer(result)^,size); + aStream.Position := current; +end; + +function RawByteStringToStream(const aString: RawByteString): TStream; +begin + result := TRawByteStringStream.Create(aString); +end; + +function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8; +var L: integer; +begin + result := ''; + L := 0; + if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then + exit; + FastSetString(result,nil,L); + if S.Read(pointer(result)^,L)<>L then + result := ''; +end; + +function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; +var L: integer; +begin + L := length(Text); + if L=0 then + result := S.Write(L,4)=4 else + {$ifdef FPC} + result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L); + {$else} + result := S.Write(pointer(PtrInt(Text)-SizeOf(integer))^,L+4)=L+4; + {$endif FPC} +end; + +function GetFileNameWithoutExt(const FileName: TFileName; + Extension: PFileName): TFileName; +var i, max: PtrInt; +begin + i := length(FileName); + max := i-16; + while (i>0) and not(cardinal(FileName[i]) in [ord('\'),ord('/'),ord('.')]) + and (i>=max) do dec(i); + if (i=0) or (FileName[i]<>'.') then begin + result := FileName; + if Extension<>nil then + Extension^ := ''; + end else begin + result := copy(FileName,1,i-1); + if Extension<>nil then + Extension^ := copy(FileName,i,20); + end; +end; + +function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; +var Ext: TFileName; + P: PChar; +begin + result := -1; + P := pointer(CSVExt); + Ext := ExtractFileExt(FileName); + if (P=nil) or (Ext='') or (Ext[1]<>'.') then + exit; + delete(Ext,1,1); + repeat + inc(result); + if SameText(GetNextItemString(P),Ext) then + exit; + until P=nil; + result := -1; +end; + +function FileSize(const FileName: TFileName): Int64; +{$ifdef MSWINDOWS} +var FA: WIN32_FILE_ATTRIBUTE_DATA; +begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle + if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin + PInt64Rec(@result)^.Lo := FA.nFileSizeLow; + PInt64Rec(@result)^.Hi := FA.nFileSizeHigh; + end else + result := 0; +end; +{$else} +var f: THandle; + res: Int64Rec absolute result; +begin + result := 0; + f := FileOpen(FileName,fmOpenRead or fmShareDenyNone); + if PtrInt(f)>0 then begin + res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux + FileClose(f); + end; +end; +{$endif MSWINDOWS} + +function FileSize(F: THandle): Int64; +var res: Int64Rec absolute result; +begin + result := 0; + if PtrInt(F)>0 then + res.Lo := GetFileSize(F,@res.Hi); // from WinAPI or SynKylix/SynFPCLinux +end; + +function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, + LastWriteAccess, FileCreateDateTime: Int64): Boolean; +var + lastreadaccess: TUnixMSTime; + {$ifdef MSWINDOWS} + lp: TByHandleFileInformation; + {$else} + lp: {$ifdef FPC}stat{$else}TStatBuf64{$endif}; + r: integer; + {$endif MSWINDOWS} +begin +{$ifdef MSWINDOWS} + result := GetFileInformationByHandle(aFileHandle,lp); + if not result then + exit; + LastWriteAccess := FileTimeToUnixMSTime(lp.ftLastWriteTime); + FileCreateDateTime := FileTimeToUnixMSTime(lp.ftCreationTime); + lastreadaccess := FileTimeToUnixMSTime(lp.ftLastAccessTime); + PInt64Rec(@FileSize).lo := lp.nFileSizeLow; + PInt64Rec(@FileSize).hi := lp.nFileSizeHigh; + PInt64Rec(@FileId).lo := lp.nFileIndexLow; + PInt64Rec(@FileId).hi := lp.nFileIndexHigh; +{$else} + r := {$ifdef FPC}FpFStat{$else}fstat64{$endif}(aFileHandle, lp); + result := r >= 0; + if not result then + exit; + FileId := lp.st_ino; + FileSize := lp.st_size; + lastreadaccess := lp.st_atime * MSecsPerSec; + LastWriteAccess := lp.st_mtime * MSecsPerSec; + {$ifdef OPENBSD} + if (lp.st_birthtime <> 0) and (lp.st_birthtime < lp.st_ctime) then + lp.st_ctime:= lp.st_birthtime; + {$endif} + FileCreateDateTime := lp.st_ctime * MSecsPerSec; +{$endif MSWINDOWS} + if LastWriteAccess <> 0 then + if (FileCreateDateTime = 0) or (FileCreateDateTime > LastWriteAccess) then + FileCreateDateTime:= LastWriteAccess; + if lastreadaccess <> 0 then + if (FileCreateDateTime = 0) or (FileCreateDateTime > lastreadaccess) then + FileCreateDateTime:= lastreadaccess; +end; + +function FileAgeToDateTime(const FileName: TFileName): TDateTime; +{$ifdef MSWINDOWS} +var FA: WIN32_FILE_ATTRIBUTE_DATA; + ST,LT: TSystemTime; +begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle + if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) and + FileTimeToSystemTime(FA.ftLastWriteTime,ST) and + SystemTimeToTzSpecificLocalTime(nil,ST,LT) then + result := SystemTimeToDateTime(LT) else + result := 0; +end; +{$else} +{$ifdef HASNEWFILEAGE} +begin + if not FileAge(FileName,result) then +{$else} +var Age: integer; +begin + Age := FileAge(FileName); + if Age<>-1 then + result := FileDateToDateTime(Age) else +{$endif HASNEWFILEAGE} + result := 0; +end; +{$endif MSWINDOWS} + +function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; +{$ifdef MSWINDOWS} +begin + result := Windows.CopyFile(pointer(Source),pointer(Target),FailIfExists); +end; +{$else} +var SourceF, DestF: TFileStream; +begin + result := false; + if FailIfExists then + if FileExists(Target) then + exit else + DeleteFile(Target); + try + SourceF := TFileStream.Create(Source,fmOpenRead); + try + DestF := TFileStream.Create(Target,fmCreate); + try + DestF.CopyFrom(SourceF, SourceF.Size); + finally + DestF.Free; + end; + FileSetDateFrom(Target,SourceF.Handle); + finally + SourceF.Free; + end; + result := true; + except + result := false; + end; +end; +{$endif} + +function SearchRecToDateTime(const F: TSearchRec): TDateTime; +begin + {$ifdef ISDELPHIXE} + result := F.Timestamp; + {$else} + result := FileDateToDateTime(F.Time); + {$endif} +end; + +function SearchRecValidFile(const F: TSearchRec): boolean; +begin + {$ifndef DELPHI5OROLDER} + {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID + {$endif} + result := (F.Name<>'') and (F.Attr and (faDirectory + {$ifdef MSWINDOWS}+faVolumeID+faSysFile+faHidden)=0) and (F.Name[1]<>'.') + {$else})=0){$endif}; + {$ifndef DELPHI5OROLDER} + {$WARN SYMBOL_DEPRECATED ON} + {$endif} +end; + +function SearchRecValidFolder(const F: TSearchRec): boolean; +begin + result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faHidden{$endif})=faDirectory) and + (F.Name<>'') and (F.Name<>'.') and (F.Name<>'..'); +end; + +function DirectoryDelete(const Directory: TFileName; const Mask: TFileName; + DeleteOnlyFilesNotDirectory: Boolean; DeletedCount: PInteger): Boolean; +var F: TSearchRec; + Dir: TFileName; + n: integer; +begin + n := 0; + result := true; + if DirectoryExists(Directory) then begin + Dir := IncludeTrailingPathDelimiter(Directory); + if FindFirst(Dir+Mask,faAnyFile-faDirectory,F)=0 then begin + repeat + if SearchRecValidFile(F) then + if DeleteFile(Dir+F.Name) then + inc(n) else + result := false; + until FindNext(F)<>0; + FindClose(F); + end; + if not DeleteOnlyFilesNotDirectory and not RemoveDir(Dir) then + result := false; + end; + if DeletedCount<>nil then + DeletedCount^ := n; +end; + +function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; + const Mask: TFileName; Recursive: Boolean; TotalSize: PInt64): Boolean; +var F: TSearchRec; + Dir: TFileName; + old: TDateTime; +begin + if not Recursive and (TotalSize<>nil) then + TotalSize^ := 0; + result := true; + if (Directory='') or not DirectoryExists(Directory) then + exit; + Dir := IncludeTrailingPathDelimiter(Directory); + if FindFirst(Dir+Mask,faAnyFile,F)=0 then begin + old := Now - TimePeriod; + repeat + if F.Name[1]<>'.' then + if Recursive and (F.Attr and faDirectory<>0) then + DirectoryDeleteOlderFiles(Dir+F.Name,TimePeriod,Mask,true,TotalSize) else + if SearchRecValidFile(F) and (SearchRecToDateTime(F) < old) then + if not DeleteFile(Dir+F.Name) then + result := false else + if TotalSize<>nil then + inc(TotalSize^,F.Size); + until FindNext(F)<>0; + FindClose(F); + end; +end; + +procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec); +begin + Name := Directory+F.Name; + {$ifdef MSWINDOWS} + {$ifdef HASINLINE} // FPC or Delphi 2006+ + Size := F.Size; + {$else} // F.Size was limited to 32-bit on older Delphi + PInt64Rec(@Size)^.Lo := F.FindData.nFileSizeLow; + PInt64Rec(@Size)^.Hi := F.FindData.nFileSizeHigh; + {$endif} + {$else} + Size := F.Size; + {$endif} + Attr := F.Attr; + Timestamp := SearchRecToDateTime(F); +end; + +function TFindFiles.ToText: shortstring; +begin + FormatShort('% % %',[Name,KB(Size),DateTimeToFileShort(Timestamp)],result); +end; + +function FindFiles(const Directory,Mask,IgnoreFileName: TFileName; + SortByName,IncludesDir,SubFolder: boolean): TFindFilesDynArray; +var m,count: integer; + dir: TFileName; + da: TDynArray; + masks: TRawUTF8DynArray; + masked: TFindFilesDynArray; + procedure SearchFolder(const folder : TFileName); + var + F: TSearchRec; + ff: TFindFiles; + begin + if FindFirst(dir+folder+Mask,faAnyfile-faDirectory,F)=0 then begin + repeat + if SearchRecValidFile(F) and ((IgnoreFileName='') or + (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin + if IncludesDir then + ff.FromSearchRec(dir+folder,F) else + ff.FromSearchRec(folder,F); + da.Add(ff); + end; + until FindNext(F)<>0; + FindClose(F); + end; + if SubFolder and (FindFirst(dir+folder+'*',faDirectory,F)=0) then begin + repeat + if SearchRecValidFolder(F) and ((IgnoreFileName='') or + (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then + SearchFolder(IncludeTrailingPathDelimiter(folder+F.Name)); + until FindNext(F)<>0; + FindClose(F); + end; + end; +begin + result := nil; + da.Init(TypeInfo(TFindFilesDynArray),result,@count); + if Pos(';',Mask)>0 then + CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';'); + if masks<>nil then begin + if SortByName then + QuickSortRawUTF8(masks,length(masks),nil,{$ifdef MSWINDOWS}@StrIComp{$else}@StrComp{$endif}); + for m := 0 to length(masks)-1 do begin // masks[] recursion + masked := FindFiles(Directory,UTF8ToString(masks[m]), + IgnoreFileName,SortByName,IncludesDir,SubFolder); + da.AddArray(masked); + end; + end else begin + if Directory<>'' then + dir := IncludeTrailingPathDelimiter(Directory); + SearchFolder(''); + if SortByName and (da.Count>0) then + da.Sort(SortDynArrayFileName); + end; + da.Capacity := count; // trim result[] +end; + +function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; +var i,n: PtrInt; +begin + Finalize(result); + n := length(Files); + SetLength(result,n); + for i := 0 to n-1 do + result[i] := Files[i].Name; +end; + +function SynchFolders(const Reference, Dest: TFileName; + SubFolder,ByContent,WriteFileNameToConsole: boolean): integer; +var ref,dst: TFileName; + fref,fdst: TSearchRec; + reftime: TDateTime; + s: RawByteString; +begin + result := 0; + ref := IncludeTrailingPathDelimiter(Reference); + dst := IncludeTrailingPathDelimiter(Dest); + if DirectoryExists(ref) and (FindFirst(dst+FILES_ALL,faAnyFile,fdst)=0) then begin + repeat + if SearchRecValidFile(fdst) then begin + if ByContent then + reftime := FileAgeToDateTime(ref+fdst.Name) else + if FindFirst(ref+fdst.Name,faAnyFile,fref)=0 then begin + reftime := SearchRecToDateTime(fref); + if (fdst.Size=fref.Size) and (SearchRecToDateTime(fdst)=reftime) then + reftime := 0; + FindClose(fref); + end else + reftime := 0; // "continue" trigger unexpected warning on Delphi + if reftime=0 then + continue; // skip if no reference file to copy from + s := StringFromFile(ref+fdst.Name); + if (s='') or (ByContent and (length(s)=fdst.Size) and + (DefaultHasher(0,pointer(s),fdst.Size)=HashFile(dst+fdst.Name))) then + continue; + FileFromString(s,dst+fdst.Name,false,reftime); + inc(result); + if WriteFileNameToConsole then + {$I-} writeln('synched ',dst,fdst.name); {$I+} + end else if SubFolder and SearchRecValidFolder(fdst) then + inc(result,SynchFolders(ref+fdst.Name,dst+fdst.Name,SubFolder,ByContent,WriteFileNameToConsole)); + until FindNext(fdst)<>0; + FindClose(fdst); + end; +end; + +function EnsureDirectoryExists(const Directory: TFileName; + RaiseExceptionOnCreationFailure: boolean): TFileName; +begin + result := IncludeTrailingPathDelimiter(ExpandFileName(Directory)); + if not DirectoryExists(result) then + if not CreateDir(result) then + if not RaiseExceptionOnCreationFailure then + result := '' else + raise ESynException.CreateUTF8('Impossible to create folder %',[result]); +end; + +var + TemporaryFileNameRandom: integer; + +function TemporaryFileName: TFileName; +var folder: TFileName; +begin // fast cross-platform implementation + folder := GetSystemPath(spTempFolder); + if TemporaryFileNameRandom=0 then + TemporaryFileNameRandom := Random32gsl; + repeat // thread-safe unique file name generation + FormatString('%%_%.tmp',[folder,ExeVersion.ProgramName, + CardinalToHexShort(InterlockedIncrement(TemporaryFileNameRandom))],string(result)); + until not FileExists(result); +end; + +function IsDirectoryWritable(const Directory: TFileName): boolean; +var fn: TFileName; +begin + fn := ExcludeTrailingPathDelimiter(Directory); + result := {$ifndef DELPHI5OROLDER}not FileIsReadOnly{$else}DirectoryExists{$endif}(fn); + if not result then + exit; + fn := FormatString('%%.%%',[fn,PathDelim,CardinalToHexShort(integer(GetCurrentThreadID)), + BinToBase64uriShort(@ExeVersion.Hash,SizeOf(ExeVersion.Hash))]); + result := FileFromString('tobedeleted',fn); // actually try to write something + DeleteFile(fn); +end; + +{$ifdef DELPHI5OROLDER} + +function DirectoryExists(const Directory: string): boolean; +var Code: Integer; +begin + Code := GetFileAttributes(pointer(Directory)); + result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>0); +end; + +function SameFileName(const S1, S2: TFileName): Boolean; +begin + result := AnsiCompareFileName(S1,S2)=0; +end; + +function GetEnvironmentVariable(const Name: string): string; +var Len: Integer; + Buffer: array[0..1023] of Char; +begin + Result := ''; + Len := Windows.GetEnvironmentVariable(pointer(Name),@Buffer,SizeOf(Buffer)); + if Len 0 then + Error := EOSError.CreateFmt('System Error. Code: %d.'#13#10'%s', + [LastError,SysErrorMessage(LastError)]) else + Error := EOSError.Create('A call to an OS function failed'); + Error.ErrorCode := LastError; + raise Error; +end; + +{$endif DELPHI5OROLDER} + +{$ifdef DELPHI6OROLDER} +procedure VarCastError; +begin + raise EVariantError.Create('Variant Type Cast Error'); +end; +{$endif} + +{$ifdef MSWINDOWS} +function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; +var FileTime: TFileTime; + D: THandle; +begin + D := FileOpen(Dest,fmOpenWrite); + if D<>THandle(-1) then begin + result := GetFileTime(SourceHandle,nil,nil,@FileTime) and + SetFileTime(D,nil,nil,@FileTime); + FileClose(D); + end else + result := false; +end; +{$else} +function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; +begin + result := FileSetDate(Dest,FileGetDate(SourceHandle))=0; +end; +{$endif} + +{$IFDEF PUREPASCAL} +{$IFNDEF HASCODEPAGE} +function Pos(const substr, str: RawUTF8): Integer; overload; +begin // the RawByteString version is fast enough + Result := PosEx(substr,str,1); +end; +{$ENDIF} +{$ENDIF} + +function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; +var L: integer; +begin + result := Trim(FindIniEntry(Content,'',Name+' ')); // 'Name = Value' format + if (result<>'') and (result[1]='''') then begin + L := length(result); + if result[L]='''' then + result := copy(result,2,L-2); // 'testDI6322.IAS' -> testDI6322.IAS + end; +end; + +function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; +begin + result := RawUTF8(GetFileNameWithoutExt( + ExtractFileName(TFileName(FindObjectEntry(Content,Name))))); +end; + + +function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; +begin + if P<>nil then begin + result := true; + Count := PtrInt(@P[Count-4]); + repeat + if PtrUInt(P)>PtrUInt(Count) then + break; + if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then + exit; + P := @P[4]; + until false; + inc(Count,4*SizeOf(Value)); + repeat + if PtrUInt(P)>=PtrUInt(Count) then + break; + if P^[0]=Value then + exit else + P := @P[1]; + until false; + end; + result := false; +end; + +function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; +begin + result := nil; + if P=nil then + exit; + Count := PtrInt(@P[Count-4]); + repeat + if PtrUInt(P)>PtrUInt(Count) then + break; + if P^[0]<>Value then + if P^[1]<>Value then + if P^[2]<>Value then + if P^[3]<>Value then begin + P := @P[4]; + continue; + end else + result := @P[3] else + result := @P[2] else + result := @P[1] else + result := pointer(P); + exit; + until false; + inc(Count,4*SizeOf(Value)); + result := pointer(P); + repeat + if PtrUInt(result)>=PtrUInt(Count) then + break; + if result^=Value then + exit else + inc(result); + until false; + result := nil; +end; + +function AddInteger(var Values: TIntegerDynArray; Value: integer; + NoDuplicates: boolean): boolean; +var n: PtrInt; +begin + n := Length(Values); + if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin + result := false; + exit; + end; + SetLength(Values,n+1); + Values[n] := Value; + result := true +end; + +procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer); +begin + if ValuesCount=length(Values) then + SetLength(Values,NextGrow(ValuesCount)); + Values[ValuesCount] := Value; + inc(ValuesCount); +end; + +function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer; NoDuplicates: boolean): boolean; +begin + if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin + result := false; + exit; + end; + if ValuesCount=length(Values) then + SetLength(Values,NextGrow(ValuesCount)); + Values[ValuesCount] := Value; + inc(ValuesCount); + result := true; +end; + +function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; +var v,a: PtrInt; +begin + v := length(Values); + a := length(Another); + if a>0 then begin + SetLength(Values,v+a); + MoveFast(Another[0],Values[v],a*SizeOf(Integer)); + end; + result := v+a; +end; + +function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; +begin + result := ValuesCount; + if result=length(Values) then + SetLength(Values,NextGrow(result)); + Values[result] := Value; + inc(ValuesCount); +end; + +function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; +begin + result := ValuesCount; + if result=length(Values) then + SetLength(Values,NextGrow(result)); + Values[result] := Value; + inc(ValuesCount); +end; + +function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; +begin + result := length(Values); + SetLength(Values,result+1); + Values[result] := Value; +end; + +function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; +var v,a: PtrInt; +begin + v := length(Values); + a := length(Another); + if a>0 then begin + SetLength(Values,v+a); + MoveFast(Another[0],Values[v],a*SizeOf(Int64)); + end; + result := v+a; +end; + +procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); +var last: integer; +begin + last := high(Values); + if FastFindInt64Sorted(pointer(Values),last,Value)<0 then begin + inc(last); + SetLength(Values,last+1); + Values[last] := Value; + QuickSortInt64(pointer(Values),0,last); + end; +end; + +function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; +begin + result := Int64ScanIndex(pointer(Values),length(Values),Value); + if result<0 then + result := AddInt64(Values,Value); +end; + +procedure DynArrayMakeUnique(Values: PPointer; TypeInfo: pointer); +var da: TDynArray; + n: PtrInt; +begin // caller ensured that Values<>nil, Values^<>nil and RefCnt>1 + da.Init(TypeInfo,Values^); + n := PDALen(PPtrUInt(Values)^-_DALEN)^{$ifdef FPC}+1{$endif}; + da.InternalSetLength(n,n); // make copy +end; + +procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); +var n: PtrInt; +begin + n := Length(Values); + if PtrUInt(Index)>=PtrUInt(n) then + exit; // wrong Index + dec(n); + if n>Index then begin + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TWordDynArray)); + MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word)); + end; + SetLength(Values,n); +end; + +procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); +var n: PtrInt; +begin + n := Length(Values); + if PtrUInt(Index)>=PtrUInt(n) then + exit; // wrong Index + dec(n); + if n>Index then begin + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); + MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer)); + end; + SetLength(Values,n); +end; + +procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); +var n: PtrInt; +begin + n := ValuesCount; + if PtrUInt(Index)>=PtrUInt(n) then + exit; // wrong Index + dec(n,Index+1); + if n>0 then begin + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); + MoveFast(Values[Index+1],Values[Index],n*SizeOf(Integer)); + end; + dec(ValuesCount); +end; + +procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); +var n: PtrInt; +begin + n := Length(Values); + if PtrUInt(Index)>=PtrUInt(n) then + exit; // wrong Index + dec(n); + if n>Index then begin + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); + MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64)); + end; + SetLength(Values,n); +end; + +procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); +var n: PtrInt; +begin + n := ValuesCount; + if PtrUInt(Index)>=PtrUInt(n) then + exit; // wrong Index + dec(n,Index+1); + if n>0 then begin + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); + MoveFast(Values[Index+1],Values[Index],n*SizeOf(Int64)); + end; + dec(ValuesCount); +end; + +procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: integer); +var i,v,x,n: PtrInt; +begin + if (Values=nil) or (Excluded=nil) then + exit; // nothing to exclude + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); + if PDACnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Excluded,TypeInfo(TIntegerDynArray)); + v := length(Values); + n := 0; + x := Length(Excluded); + if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it + dec(x); + QuickSortInteger(pointer(Excluded),0,x); + for i := 0 to v-1 do + if FastFindIntegerSorted(pointer(Excluded),x,Values[i])<0 then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + end else + for i := 0 to v-1 do + if not IntegerScanExists(pointer(Excluded),x,Values[i]) then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + if n<>v then + SetLength(Values,n); +end; + +procedure IncludeInteger(var Values, Included: TIntegerDynArray; + IncludedSortSize: Integer); +var i,v,x,n: PtrInt; +begin + if (Values=nil) or (Included=nil) then begin + Values := nil; + exit; + end; + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); + if PDACnt(PtrUInt(Included)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Included,TypeInfo(TIntegerDynArray)); + v := length(Values); + n := 0; + x := Length(Included); + if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it + dec(x); + QuickSortInteger(pointer(Included),0,x); + for i := 0 to v-1 do + if FastFindIntegerSorted(pointer(Included),x,Values[i])>=0 then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + end else + for i := 0 to v-1 do + if IntegerScanExists(pointer(Included),x,Values[i]) then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + if n<>v then + SetLength(Values,n); +end; + +procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer); +var i,v,x,n: PtrInt; +begin + if (Values=nil) or (Excluded=nil) then + exit; // nothing to exclude + v := length(Values); + n := 0; + x := Length(Excluded); + if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it + dec(x); + QuickSortInt64(pointer(Excluded),0,x); + for i := 0 to v-1 do + if FastFindInt64Sorted(pointer(Excluded),x,Values[i])<0 then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + end else + for i := 0 to v-1 do + if not Int64ScanExists(pointer(Excluded),x,Values[i]) then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + if n<>v then + SetLength(Values,n); +end; + +procedure IncludeInt64(var Values, Included: TInt64DynArray; + IncludedSortSize: integer); +var i,v,x,n: PtrInt; +begin + if (Values=nil) or (Included=nil) then begin + Values := nil; + exit; + end; + v := length(Values); + n := 0; + x := Length(Included); + if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it + dec(x); + QuickSortInt64(pointer(Included),0,x); + for i := 0 to v-1 do + if FastFindInt64Sorted(pointer(Included),x,Values[i])>=0 then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + end else + for i := 0 to v-1 do + if Int64ScanExists(pointer(Included),x,Values[i]) then begin + if n<>i then + Values[n] := Values[i]; + inc(n); + end; + if n<>v then + SetLength(Values,n); +end; + +procedure DeduplicateInteger(var Values: TIntegerDynArray); +begin + DeduplicateInteger(Values, length(Values)); +end; + +function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; +var i: PtrInt; +begin // sub-function for better code generation + i := 0; + repeat // here last>0 so ilast then + continue; + result := i; + exit; + until false; + result := i; + inc(i); + if i<>last then begin + repeat + if val[i]<>val[i+1] then begin + val[result] := val[i]; + inc(result); + end; + inc(i); + until i=last; + val[result] := val[i]; + end; +end; + +function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; +begin + result := Count; + dec(Count); + if Count>0 then begin + QuickSortInteger(pointer(Values),0,Count); + result := DeduplicateIntegerSorted(pointer(Values),Count)+1; + end; + if result<>length(Values) then + SetLength(Values,result); +end; + +procedure DeduplicateInt64(var Values: TInt64DynArray); +begin + DeduplicateInt64(Values, length(Values)); +end; + +function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; +var i: PtrInt; +begin // sub-function for better code generation + i := 0; + repeat // here last>0 so ilast then + continue; + result := i; + exit; + until false; + result := i; + inc(i); + if i<>last then begin + repeat + if val[i]<>val[i+1] then begin + val[result] := val[i]; + inc(result); + end; + inc(i); + until i=last; + val[result] := val[i]; + end; +end; + +function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; +begin + result := Count; + dec(Count); + if Count>0 then begin + QuickSortInt64(pointer(Values),0,Count); + result := DeduplicateInt64Sorted(pointer(Values),Count)+1; + end; + if result<>length(Values) then + SetLength(Values,result); +end; + +procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); +var n: integer; +begin + n := length(Source); + SetLength(Dest,n); + MoveFast(Source[0],Dest[0],n*SizeOf(Integer)); +end; + +procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); +var n: integer; +begin + n := length(Source); + SetLength(Dest,n); + MoveFast(Source[0],Dest[0],n*SizeOf(Int64)); +end; + +function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; MaxStart: integer): Integer; +var i: PtrInt; + v: integer; +begin + result := MaxStart; + for i := 0 to ValuesCount-1 do begin + v := Values[i]; + if v>result then + result := v; // branchless opcode on FPC + end; +end; + +function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; +var i: PtrInt; +begin + result := 0; + for i := 0 to ValuesCount-1 do + inc(result,Values[i]); +end; + +procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; + Reversed: PIntegerArray); +var i: PtrInt; +begin + i := 0; + if ValuesCount>=4 then begin + dec(ValuesCount,4); + while i0 then + if StartValue=0 then + for i := 0 to Count-1 do + Values[i] := i else + for i := 0 to Count-1 do begin + Values[i] := StartValue; + inc(StartValue); + end; +end; + +procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); +var i: PtrInt; +begin + for i := 0 to Count-1 do + Values32[i] := Values64[i]; +end; + +procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar); +begin + while CSV<>nil do begin + SetLength(Result,length(Result)+1); + Result[high(Result)] := GetNextItemInteger(CSV,Sep); + end; +end; + +procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar); +begin + while CSV<>nil do begin + SetLength(Result,length(Result)+1); + Result[high(Result)] := GetNextItemInt64(CSV,Sep); + end; +end; + +function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar): TInt64DynArray; +begin + Finalize(result); + while CSV<>nil do begin + SetLength(Result,length(Result)+1); + Result[high(Result)] := GetNextItemInt64(CSV,Sep); + end; +end; + +function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; + const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; +type + TInts16 = packed array[word] of string[15]; // shortstring are faster (no heap allocation) +var i, L, Len: PtrInt; + tmp: array[0..15] of AnsiChar; + ints: ^TInts16; + P: PAnsiChar; + tmpbuf: TSynTempBuffer; +begin + result := ''; + if ValuesCount=0 then + exit; + if InlinedValue then + Len := 4*ValuesCount else + Len := 0; + tmpbuf.Init(ValuesCount*SizeOf(ints[0])+Len); // faster than a dynamic array + try + ints := tmpbuf.buf; + // compute whole result length at once + dec(ValuesCount); + inc(Len,length(Prefix)+length(Suffix)); + tmp[15] := ','; + for i := 0 to ValuesCount do begin + P := StrInt32(@tmp[15],Values[i]); + L := @tmp[15]-P; + if i'' then begin + L := length(Prefix); + MoveSmall(pointer(Prefix),P,L); + inc(P,L); + end; + for i := 0 to ValuesCount do begin + if InlinedValue then begin + PWord(P)^ := ord(':')+ord('(')shl 8; + inc(P,2); + end; + L := ord(ints[i][0]); + MoveSmall(@ints[i][1],P,L); + inc(P,L); + if InlinedValue then begin + PWord(P)^ := ord(')')+ord(':')shl 8; + inc(P,2); + end; + end; + if Suffix<>'' then + MoveSmall(pointer(Suffix),P,length(Suffix)); + finally + tmpbuf.Done; + end; +end; + +function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; + const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; +type + TInt = packed record + Len: byte; + Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign + end; +var i, L, Len: PtrInt; + int: ^TInt; + P: PAnsiChar; + tmp: TSynTempBuffer; +begin + result := ''; + if ValuesCount=0 then + exit; + if InlinedValue then + Len := 4*ValuesCount else + Len := 0; + int := tmp.Init(ValuesCount*SizeOf(TInt)+Len); // faster than a dynamic array + try + // compute whole result length at once + dec(ValuesCount); + inc(Len,length(Prefix)+length(Suffix)); + for i := 0 to ValuesCount do begin + P := StrInt64(PAnsiChar(int)+21,Values[i]); + L := PAnsiChar(int)+21-P; + int^.Len := L; + if i'' then begin + L := length(Prefix); + MoveSmall(pointer(Prefix),P,L); + inc(P,L); + end; + int := tmp.buf; + repeat + if InlinedValue then begin + PWord(P)^ := ord(':')+ord('(')shl 8; + inc(P,2); + end; + L := int^.Len; + MoveSmall(PAnsiChar(int)+21-L,P,L); + inc(P,L); + if InlinedValue then begin + PWord(P)^ := ord(')')+ord(':')shl 8; + inc(P,2); + end; + if ValuesCount=0 then + break; + inc(int); + P^ := ','; + inc(P); + dec(ValuesCount); + until false; + if Suffix<>'' then + MoveSmall(pointer(Suffix),P,length(Suffix)); + finally + tmp.Done; + end; +end; + +function IntegerDynArrayToCSV(const Values: TIntegerDynArray; + const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; +begin + result := IntegerDynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); +end; + +function Int64DynArrayToCSV(const Values: TInt64DynArray; + const Prefix: RawUTF8; const Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; +begin + result := Int64DynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); +end; + +function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; +begin + result := 0; + dec(Count,8); + if P<>nil then begin + repeat + if result>Count then + break; + if P^[result]<>Value then + if P^[result+1]<>Value then + if P^[result+2]<>Value then + if P^[result+3]<>Value then + if P^[result+4]<>Value then + if P^[result+5]<>Value then + if P^[result+6]<>Value then + if P^[result+7]<>Value then begin + inc(result,8); + continue; + end else + inc(result,7) else + inc(result,6) else + inc(result,5) else + inc(result,4) else + inc(result,3) else + inc(result,2) else + inc(result); + exit; + until false; + inc(Count,8); + repeat + if result>=Count then + break; + if P^[result]=Value then + exit else + inc(result); + until false; + end; + result := -1; +end; + +function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; +begin + result := Int64ScanIndex(pointer(P),Count,Value); // this is the very same code +end; + +function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; +{$ifdef HASINLINE} +begin + result := {$ifdef CPU64}Int64Scan{$else}IntegerScan{$endif}(pointer(P),Count,Value); +end; +{$else} +asm + jmp IntegerScan +end; +{$endif HASINLINE} + +function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; +{$ifdef HASINLINE} +begin + result := {$ifdef CPU64}Int64ScanExists{$else}IntegerScanExists{$endif}(pointer(P),Count,Value); +end; +{$else} +asm + jmp IntegerScanExists; +end; +{$endif HASINLINE} + +function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; +{$ifdef HASINLINE} +begin + result := {$ifdef CPU64}Int64ScanIndex{$else}IntegerScanIndex{$endif}(pointer(P),Count,Value); +end; +{$else} +asm // identical to IntegerScanIndex() asm stub + push eax + call IntegerScan + pop edx + test eax, eax + jnz @e + dec eax // returns -1 + ret +@e: sub eax, edx + shr eax, 2 +end; +{$endif HASINLINE} + +function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; +begin +{$ifdef FPC} + result := IndexByte(P^,Count,Value); // will use fast FPC SSE version +{$else} + result := 0; + if P<>nil then + repeat + if result>=Count then + break; + if P^[result]=Value then + exit else + inc(result); + until false; + result := -1; +{$endif FPC} +end; + +function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; +begin +{$ifdef FPC} + result := IndexWord(P^,Count,Value); // will use fast FPC SSE version +{$else} + result := 0; + if P<>nil then + repeat + if result>=Count then + break; + if P^[result]=Value then + exit else + inc(result); + until false; + result := -1; +{$endif FPC} +end; + +function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; +begin + case ElemSize of + // optimized versions for arrays of byte,word,integer,Int64,Currency,Double + 1: result := ByteScanIndex(P,Count,PByte(Elem)^); + 2: result := WordScanIndex(P,Count,PWord(Elem)^); + 4: result := IntegerScanIndex(P,Count,PInteger(Elem)^); + 8: result := Int64ScanIndex(P,Count,PInt64(Elem)^); + // small ElemSize version (=0; + 2: result := WordScanIndex(P,Count,PInteger(Elem)^)>=0; + 4: result := IntegerScanExists(P,Count,PInteger(Elem)^); + 8: result := Int64ScanExists(P,Count,PInt64(Elem)^); + // small ElemSize version (0 then + repeat + if CompareMemSmall(P,Elem,ElemSize) then + exit; + inc(PByte(P),ElemSize); + dec(Count); + until Count=0; + result := false; + end; + else begin // generic binary comparison (fast with leading 64-bit comparison) + result := true; + if Count>0 then + repeat + if (PInt64(P)^=PInt64(Elem)^) and + CompareMemSmall(PAnsiChar(P)+8,PAnsiChar(Elem)+8,ElemSize-8) then + exit; + inc(PByte(P),ElemSize); + dec(Count); + until Count=0; + result := false; + end; + end; +end; + + +procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt); +var I, J, P: PtrInt; + tmp: integer; +begin + if L=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortInteger(ID, L, J); + L := I; + end else begin + if I < R then + QuickSortInteger(ID, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortInteger(var ID: TIntegerDynArray); +begin + QuickSortInteger(pointer(ID),0,high(ID)); +end; + +procedure QuickSortInteger(ID,CoValues: PIntegerArray; L,R: PtrInt); +var I, J, P: PtrInt; + tmp: integer; +begin + if L=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortInteger(ID, CoValues, L, J); + L := I; + end else begin + if I < R then + QuickSortInteger(ID, CoValues, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); +var I, J, P: PtrInt; + tmp: word; +begin + if L=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortWord(ID, L, J); + L := I; + end else begin + if I < R then + QuickSortWord(ID, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); +var I, J, P: PtrInt; + tmp: Int64; +begin + if L=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + {$else} + while ID[I]ID[P] do dec(J); + {$endif} + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortInt64(ID, L, J); + L := I; + end else begin + if I < R then + QuickSortInt64(ID, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); +var I, J, P: PtrInt; + tmp: QWord; +begin + if L0 do dec(J); + {$else} + tmp := ID[P]; + if ID[I]=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + {$endif} + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortQWord(ID, L, J); + L := I; + end else begin + if I < R then + QuickSortQWord(ID, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); +var I, J, P: PtrInt; + tmp: Int64; +begin + if L=tmp; + if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; + {$else} + while ID[I]ID[P] do dec(J); + {$endif} + if I <= J then begin + tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; + tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortInt64(ID, CoValues, L, J); + L := I; + end else begin + if I < R then + QuickSortInt64(ID, CoValues, I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); +begin + {$ifdef CPU64} + QuickSortInt64(PInt64Array(P),L,R); + {$else} + QuickSortInteger(PIntegerArray(P),L,R); + {$endif} +end; + +function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; +begin + {$ifdef CPU64} + result := FastFindInt64Sorted(PInt64Array(P),R,Value); + {$else} + result := FastFindIntegerSorted(PIntegerArray(P),R,Value); + {$endif} +end; + +procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); +begin + {$ifdef CPU64} + QuickSortInt64(PInt64Array(P),L,R); + {$else} + QuickSortInteger(PIntegerArray(P),L,R); + {$endif} +end; + +function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt; +begin + {$ifdef CPU64} + result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value)); + {$else} + result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value)); + {$endif} +end; + +procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; + const added, deleted: TOnNotifySortedIntegerChange; const sender); +var o, n: PtrInt; +begin + o := 0; + n := 0; + repeat + while (n=newn) or (old[o]=oldn) or (new[n]=oldn) and (n>=newn); +end; + +procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; + var Dest: TIntegerDynArray); +begin + if ValuesCount>length(Dest) then + SetLength(Dest,ValuesCount); + MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Integer)); + QuickSortInteger(pointer(Dest),0,ValuesCount-1); +end; + +procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; + var Dest: TInt64DynArray); +begin + if ValuesCount>length(Dest) then + SetLength(Dest,ValuesCount); + MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Int64)); + QuickSortInt64(pointer(Dest),0,ValuesCount-1); +end; + +function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; +{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx +{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} + xor r9, r9 // r9=L rax=result + test R, R + jl @ko + lea rax, [r9 + R] +{$ifdef FPC} align 8 {$else} .align 8 {$endif} +@s: shr rax, 1 + lea r10, qword ptr[rax - 1] // efficient branchless binary search + lea r11, qword ptr[rax + 1] + cmp Value, dword ptr[P + rax * 4] + je @ok + cmovl R, r10 + cmovg r9, r11 + lea rax, [r9 + R] + cmp r9, R + jle @s +@ko: or rax, -1 +@ok: +end; +{$else} +var L: PtrInt; + cmp: integer; +begin + L := 0; + if 0<=R then + repeat + result := (L + R) shr 1; + cmp := P^[result]-Value; + if cmp=0 then + exit; + if cmp<0 then begin + L := result+1; + if L<=R then + continue; + break; + end; + R := result-1; + if L<=R then + continue; + break; + until false; + result := -1 +end; +{$endif CPUX64} + + +function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; +begin + result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value); +end; + +function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; +{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx +{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} + xor r9, r9 // r9=L rax=result + test R, R + jl @ko + lea rax, [r9 + R] +{$ifdef FPC} align 8 {$else} .align 8 {$endif} +@s: shr rax, 1 + lea r10, qword ptr[rax - 1] // efficient branchless binary search + lea r11, qword ptr[rax + 1] + cmp Value, qword ptr[P + rax * 8] + je @ok + cmovl R, r10 + cmovg r9, r11 + lea rax, [r9 + R] + cmp r9, R + jle @s +@ko: or rax, -1 +@ok: +end; +{$else} +var L: PtrInt; + {$ifdef CPUX86} + cmp: Integer; + {$endif} +begin + L := 0; + if 0<=R then + repeat + result := (L + R) shr 1; + {$ifndef CPUX86} + if P^[result]=Value then + exit else + if P^[result] R; + while (i>=0) and (P^[i]>=Value) do dec(i); + result := i+1; // return the index where to insert + end; +end; + +function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; + Value: integer; CoValues: PIntegerDynArray): PtrInt; +begin + result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); + if result>=0 then // if Value exists -> fails + result := InsertInteger(Values,ValuesCount,Value,result,CoValues); +end; + +function AddSortedInteger(var Values: TIntegerDynArray; + Value: integer; CoValues: PIntegerDynArray): PtrInt; +var ValuesCount: integer; +begin + ValuesCount := length(Values); + result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); + if result>=0 then begin // if Value exists -> fails + SetLength(Values,ValuesCount+1); // manual size increase + result := InsertInteger(Values,ValuesCount,Value,result,CoValues); + end; +end; + +function TSortedIntegerArray.Add(aValue: Integer): PtrInt; +begin + result := Count; // optimistic check of perfectly increasing aValue + if (result>0) and (aValue<=Values[result-1]) then + result := FastLocateIntegerSorted(pointer(Values),result-1,aValue); + if result<0 then // aValue already exists in Values[] -> fails + exit; + if Count=length(Values) then + SetLength(Values,NextGrow(Count)); + if resultnil then + SetLength(CoValues^,n); + end; + n := ValuesCount; + if PtrUInt(result)nil then + MoveFast(CoValues^[result],CoValues^[result+1],n); + end else + result := n; + Values[result] := Value; + inc(ValuesCount); +end; + +function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; +var i: PtrInt; +begin + Finalize(result); + SetLength(result,length(Values)); + for i := 0 to high(Values) do + result[i] := Values[i]; +end; + +function TIntegerDynArrayFrom64(const Values: TInt64DynArray; + raiseExceptionOnOverflow: boolean): TIntegerDynArray; +var i: PtrInt; +const MinInt = -MaxInt-1; +begin + Finalize(result); + SetLength(result,length(Values)); + for i := 0 to length(Values)-1 do + if Values[i]>MaxInt then + if raiseExceptionOnOverflow then + raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%>%', + [i,Values[i],MaxInt]) else + result[i] := MaxInt else + if Values[i]ord(' ') then + break; + inc(P); + c := byte(P^); + until false; + if c=ord('-') then begin + minus := true; + repeat inc(P); c := byte(P^); until c<>ord(' '); + end else begin + minus := false; + if c=ord('+') then + repeat inc(P); c := byte(P^); until c<>ord(' '); + end; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + c := byte(P^); + dec(c,48); + if c>9 then + break; + result := result*10+PtrInt(c); + until false; + if minus then + result := -result; +end; + +function GetInteger(P,PEnd: PUTF8Char): PtrInt; +var c: byte; + minus: boolean; +begin + result := 0; + if (P=nil) or (P>=PEnd) then + exit; + c := byte(P^); + repeat + if c=0 then + exit; + if c>ord(' ') then + break; + inc(P); + if P=PEnd then + exit; + c := byte(P^); + until false; + if c=ord('-') then begin + minus := true; + repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); + end else begin + minus := false; + if c=ord('+') then + repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); + end; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + if P=PEnd then + break; + c := byte(P^); + dec(c,48); + if c>9 then + break; + result := result*10+PtrInt(c); + until false; + if minus then + result := -result; +end; + +function GetInteger(P: PUTF8Char; var err: integer): PtrInt; +var c: byte; + minus: boolean; +begin + result := 0; + err := 1; // don't return the exact index, just 1 as error flag + if P=nil then + exit; + c := byte(P^); + repeat + if c=0 then + exit; + if c>ord(' ') then + break; + inc(P); + c := byte(P^); + until false; + if c=ord('-') then begin + minus := true; + repeat inc(P); c := byte(P^); until c<>ord(' '); + end else begin + minus := false; + if c=ord('+') then + repeat inc(P); c := byte(P^); until c<>ord(' '); + end; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + c := byte(P^); + dec(c,48); + if c<=9 then + result := result*10+PtrInt(c) else + if c<>256-48 then + exit else + break; + until false; + err := 0; // success + if minus then + result := -result; +end; + +function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; +var err: integer; +begin + result := GetInteger(P,err); + if err<>0 then + result := Default; +end; + +function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; +var err: integer; +begin + result := GetInteger(pointer(value),err); + if err<>0 then + result := Default; +end; + +function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; +var err: integer; +begin + result := GetInteger(pointer(value),err); + if (err<>0) or (resultmax) then + result := Default; +end; + +function ToInteger(const text: RawUTF8; out value: integer): boolean; +var err: integer; +begin + value := GetInteger(pointer(text),err); + result := err=0; +end; + +function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal): boolean; +begin + value := GetCardinalDef(pointer(text),cardinal(-1)); + result := (value<>cardinal(-1)) and (value>=minimal); +end; + +function ToInt64(const text: RawUTF8; out value: Int64): boolean; +var err: integer; +begin + value := GetInt64(pointer(text),err); + result := err=0; +end; + +function ToDouble(const text: RawUTF8; out value: double): boolean; +var err: integer; +begin + value := GetExtended(pointer(text),err); + result := err=0; +end; + +function UTF8ToInt64(const text: RawUTF8; const default: Int64): Int64; +var err: integer; +begin + result := GetInt64(pointer(text),err); + if err<>0 then + result := default; +end; + +function GetBoolean(P: PUTF8Char): boolean; +begin + if P<>nil then + case PInteger(P)^ of + TRUE_LOW: result := true; + FALSE_LOW: result := false; + else result := PWord(P)^<>ord('0'); + end else + result := false; +end; + +function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; +var c: byte; +begin + result := Default; + if P=nil then + exit; + c := byte(P^); + repeat + if c=0 then + exit; + if c>ord(' ') then + break; + inc(P); + c := byte(P^); + until false; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + c := byte(P^)-48; + if c>9 then + break; + result := result*10+PtrUInt(c); + until false; +end; + +function GetCardinal(P: PUTF8Char): PtrUInt; +var c: byte; +begin + result := 0; + if P=nil then + exit; + c := byte(P^); + repeat + if c=0 then + exit; + if c>ord(' ') then + break; + inc(P); + c := byte(P^); + until false; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + c := byte(P^); + dec(c,48); + if c>9 then + break; + result := result*10+PtrUInt(c); + until false; +end; + +function GetCardinalW(P: PWideChar): PtrUInt; +var c: PtrUInt; +begin + result := 0; + if P=nil then + exit; + c := ord(P^); + repeat + if c=0 then + exit; + if c>ord(' ') then + break; + inc(P); + c := ord(P^); + until false; + dec(c,48); + if c>9 then + exit; + result := c; + repeat + inc(P); + c := ord(P^); + dec(c,48); + if c>9 then + break; + result := result*10+c; + until false; +end; + +{$ifdef CPU64} +procedure SetInt64(P: PUTF8Char; var result: Int64); +begin // PtrInt is already int64 -> call PtrInt version + result := GetInteger(P); +end; +{$else} +procedure SetInt64(P: PUTF8Char; var result: Int64); +var c: cardinal; + minus: boolean; +begin + result := 0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='-' then begin + minus := true; + repeat inc(P) until P^<>' '; + end else begin + minus := false; + if P^='+' then + repeat inc(P) until P^<>' '; + end; + c := byte(P^)-48; + if c>9 then + exit; + PCardinal(@result)^ := c; + inc(P); + repeat // fast 32-bit loop + c := byte(P^)-48; + if c>9 then + break else + PCardinal(@result)^ := PCardinal(@result)^*10+c; + inc(P); + if PCardinal(@result)^>=high(cardinal)div 10 then begin + repeat // 64-bit loop + c := byte(P^)-48; + if c>9 then + break; + result := result shl 3+result+result; // fast result := result*10 + inc(result,c); + inc(P); + until false; + break; + end; + until false; + if minus then + result := -result; +end; +{$endif} + +{$ifdef CPU64} +procedure SetQWord(P: PUTF8Char; var result: QWord); +begin // PtrUInt is already QWord -> call PtrUInt version + result := GetCardinal(P); +end; +{$else} +procedure SetQWord(P: PUTF8Char; var result: QWord); +var c: cardinal; +begin + result := 0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='+' then + repeat inc(P) until P^<>' '; + c := byte(P^)-48; + if c>9 then + exit; + PCardinal(@result)^ := c; + inc(P); + repeat // fast 32-bit loop + c := byte(P^)-48; + if c>9 then + break else + PCardinal(@result)^ := PCardinal(@result)^*10+c; + inc(P); + if PCardinal(@result)^>=high(cardinal)div 10 then begin + repeat // 64-bit loop + c := byte(P^)-48; + if c>9 then + break; + result := result shl 3+result+result; // fast result := result*10 + inc(result,c); + inc(P); + until false; + break; + end; + until false; +end; +{$endif} + +{$ifdef CPU64} +function GetInt64(P: PUTF8Char): Int64; +begin // PtrInt is already int64 -> call previous version + result := GetInteger(P); +end; +{$else} +function GetInt64(P: PUTF8Char): Int64; +begin + SetInt64(P,result); +end; +{$endif} + +function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; +var err: integer; +begin + result := GetInt64(P,err); + if err>0 then + result := Default; +end; + +{$ifdef CPU64} +function GetInt64(P: PUTF8Char; var err: integer): Int64; +begin // PtrInt is already int64 -> call previous version + result := GetInteger(P,err); +end; +{$else} +function GetInt64(P: PUTF8Char; var err: integer): Int64; +var c: cardinal; + minus: boolean; +begin + err := 0; + result := 0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='-' then begin + minus := true; + repeat inc(P) until P^<>' '; + end else begin + minus := false; + if P^='+' then + repeat inc(P) until P^<>' '; + end; + inc(err); + c := byte(P^)-48; + if c>9 then + exit; + PCardinal(@result)^ := c; + inc(P); + repeat // fast 32-bit loop + c := byte(P^); + if c<>0 then begin + dec(c,48); + inc(err); + if c>9 then + exit; + PCardinal(@result)^ := PCardinal(@result)^*10+c; + inc(P); + if PCardinal(@result)^>=high(cardinal)div 10 then begin + repeat // 64-bit loop + c := byte(P^); + if c=0 then begin + err := 0; // conversion success without error + break; + end; + dec(c,48); + inc(err); + if c>9 then + exit else + {$ifdef CPU32DELPHI} + result := result shl 3+result+result; + {$else} + result := result*10; + {$endif} + inc(result,c); + if result<0 then + exit; // overflow (>$7FFFFFFFFFFFFFFF) + inc(P); + until false; + break; + end; + end else begin + err := 0; // reached P^=#0 -> conversion success without error + break; + end; + until false; + if minus then + result := -result; +end; +{$endif} + +function GetQWord(P: PUTF8Char; var err: integer): QWord; +var c: PtrUInt; +begin + err := 1; // error + result := 0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + c := byte(P^)-48; + if c>9 then + exit; + {$ifdef CPU64} + result := c; + inc(P); + repeat + c := byte(P^); + if c=0 then + break; + dec(c,48); + if c>9 then + exit; + result := result*10+c; + inc(P); + until false; + err := 0; // success + {$else} + PByte(@result)^ := c; + inc(P); + repeat // fast 32-bit loop + c := byte(P^); + if c<>0 then begin + dec(c,48); + inc(err); + if c>9 then + exit; + PCardinal(@result)^ := PCardinal(@result)^*10+c; + inc(P); + if PCardinal(@result)^>=high(cardinal)div 10 then begin + repeat // 64-bit loop + c := byte(P^); + if c=0 then begin + err := 0; // conversion success without error + break; + end; + dec(c,48); + inc(err); + if c>9 then + exit else + {$ifdef CPU32DELPHI} + result := result shl 3+result+result; + {$else} + result := result*10; + {$endif} + inc(result,c); + inc(P); + until false; + break; + end; + end else begin + err := 0; // reached P^=#0 -> conversion success without error + break; + end; + until false; + {$endif CPU64} +end; + +function GetExtended(P: PUTF8Char): TSynExtended; +var err: integer; +begin + result := GetExtended(P,err); + if err<>0 then + result := 0; +end; + +const POW10: array[-31..33] of TSynExtended = ( + 1E-31,1E-30,1E-29,1E-28,1E-27,1E-26,1E-25,1E-24,1E-23,1E-22,1E-21,1E-20, + 1E-19,1E-18,1E-17,1E-16,1E-15,1E-14,1E-13,1E-12,1E-11,1E-10,1E-9,1E-8,1E-7, + 1E-6,1E-5,1E-4,1E-3,1E-2,1E-1,1E0,1E1,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9,1E10, + 1E11,1E12,1E13,1E14,1E15,1E16,1E17,1E18,1E19,1E20,1E21,1E22,1E23,1E24,1E25, + 1E26,1E27,1E28,1E29,1E30,1E31,0,-1); + +function HugePower10(exponent: integer): TSynExtended; {$ifdef HASINLINE}inline;{$endif} +var e: TSynExtended; +begin + result := POW10[0]; + if exponent<0 then begin + e := POW10[-1]; + exponent := -exponent; + end else + e := POW10[1]; + repeat + while exponent and 1=0 do begin + exponent := exponent shr 1; + e := sqr(e); + end; + result := result*e; + dec(exponent); + until exponent=0; +end; + +function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; +{$ifndef CPU32DELPHI} +var digit: byte; + frac, exp: PtrInt; + c: AnsiChar; + flags: set of (fNeg, fNegExp, fValid); + v: Int64; // allows 64-bit resolution for the digits +label e; +begin + byte(flags) := 0; + v := 0; + frac := 0; + if P=nil then + goto e; + c := P^; + if c=' ' then + repeat + inc(P); + c := P^; + until c<>' '; // trailing spaces + if c='+' then begin + inc(P); + c := P^; + end else + if c='-' then begin + inc(P); + c := P^; + include(flags,fNeg); + end; + digit := 18; // max Int64 resolution + repeat + inc(P); + if (c>='0') and (c<='9') then begin + if digit <> 0 then begin + dec(c,ord('0')); + {$ifdef CPU64} + v := v*10; + {$else} + v := v shl 3+v+v; + {$endif} + inc(v,byte(c)); + dec(digit); // over-required digits are just ignored + include(flags,fValid); + if frac<>0 then + dec(frac); + end else + if frac>=0 then + inc(frac); // handle #############00000 + c := P^; + continue; + end; + if c<>'.' then + break; + if frac>0 then + goto e; + dec(frac); + c := P^; + until false; + if frac<0 then + inc(frac); + if (c='E') or (c='e') then begin + exp := 0; + exclude(flags,fValid); + c := P^; + if c='+' then + inc(P) else + if c='-' then begin + inc(P); + include(flags,fNegExp); + end; + repeat + c := P^; + inc(P); + if (c<'0') or (c>'9') then + break; + dec(c,ord('0')); + exp := (exp*10)+byte(c); + include(flags,fValid); + until false; + if fNegExp in flags then + dec(frac,exp) else + inc(frac,exp); + end; + if (fValid in flags) and (c=#0) then + err := 0 else +e: err := 1; // return the (partial) value even if not ended with #0 + if (frac>=-31) and (frac<=31) then + result := POW10[frac] else + result := HugePower10(frac); + if fNeg in flags then + result := result*POW10[33]; // *-1 + result := result*v; +end; +{$else} +const Ten: double = 10.0; +asm // in: eax=text, edx=@err out: st(0)=result + push ebx // save used registers + push esi + push edi + mov esi, eax // string pointer + push eax // save for error condition + xor ebx, ebx + push eax // allocate local storage for loading fpu + test esi, esi + jz @nil // nil string +@trim: movzx ebx, byte ptr[esi] // strip leading spaces + inc esi + cmp bl, ' ' + je @trim + xor ecx, ecx // clear sign flag + fld qword[Ten] // load 10 into fpu + xor eax, eax // zero number of decimal places + fldz // zero result in fpu + cmp bl, '0' + jl @chksig // check for sign character +@dig1: xor edi, edi // zero exponent value +@digl: sub bl, '0' + cmp bl, 9 + ja @frac // non-digit + mov cl, 1 // set digit found flag + mov [esp], ebx // store for fpu use + fmul st(0), st(1) // multply by 10 + fiadd dword ptr[esp] // add next digit + movzx ebx, byte ptr[esi] // get next char + inc esi + test bl, bl // end reached? + jnz @digl // no,get next digit + jmp @finish // yes,finished +@chksig:cmp bl, '-' + je @minus + cmp bl, '+' + je @sigset +@gdig1: test bl, bl + jz @error // no digits found + jmp @dig1 +@minus: mov ch, 1 // set sign flag +@sigset:movzx ebx, byte ptr[esi] // get next char + inc esi + jmp @gdig1 +@frac: cmp bl, '.' - '0' + jne @exp // no decimal point + movzx ebx, byte ptr[esi] // get next char + test bl, bl + jz @dotend // string ends with '.' + inc esi +@fracl: sub bl, '0' + cmp bl, 9 + ja @exp // non-digit + mov [esp], ebx + dec eax // -(number of decimal places) + fmul st(0), st(1) // multply by 10 + fiadd dword ptr[esp] // add next digit + movzx ebx, byte ptr[esi] // get next char + inc esi + test bl, bl // end reached? + jnz @fracl // no, get next digit + jmp @finish // yes, finished (no exponent) +@dotend:test cl, cl // any digits found before '.'? + jnz @finish // yes, valid + jmp @error // no,invalid +@exp: or bl, $20 + cmp bl, 'e' - '0' + jne @error // not 'e' or 'e' + movzx ebx, byte ptr[esi] // get next char + inc esi + mov cl, 0 // clear exponent sign flag + cmp bl, '-' + je @minexp + cmp bl, '+' + je @expset + jmp @expl +@minexp:mov cl, 1 // set exponent sign flag +@expset:movzx ebx, byte ptr[esi] // get next char + inc esi +@expl: sub bl, '0' + cmp bl, 9 + ja @error // non-digit + lea edi, [edi + edi * 4]// multiply by 10 + add edi, edi + add edi, ebx // add next digit + movzx ebx, byte ptr[esi] // get next char + inc esi + test bl, bl // end reached? + jnz @expl // no, get next digit +@endexp:test cl, cl // positive exponent? + jz @finish // yes, keep exponent value + neg edi // no, negate exponent value +@finish:add eax, edi // exponent value - number of decimal places + mov [edx], ebx // result code = 0 + jz @pow // no call to _pow10 needed + mov edi, ecx // save decimal sign flag + call System.@Pow10 // raise to power of 10 + mov ecx, edi // restore decimal sign flag +@pow: test ch, ch // decimal sign flag set? + jnz @negate // yes, negate value +@ok: add esp, 8 // dump local storage and string pointer +@exit: ffree st(1) // remove ten value from fpu + pop edi // restore used registers + pop esi + pop ebx + ret // finished +@negate:fchs // negate result in fpu + jmp @ok +@nil: inc esi // force result code = 1 + fldz // result value = 0 +@error: pop ebx // dump local storage + pop eax // string pointer + sub esi, eax // error offset + mov [edx], esi // set result code + test ch, ch // decimal sign flag set? + jz @exit // no,exit + fchs // yes. negate result in fpu + jmp @exit // exit setting result code +end; +{$endif CPU32DELPHI} + +function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; +var c: AnsiChar; +begin + while s^=' ' do inc(s); + c := s^; + if (c='+') or (c='-') then begin + inc(s); + d^ := c; + inc(d); + c := s^; + end; + if c='.' then begin + PCardinal(d)^ := ord('0')+ord('.')shl 8; // '.5' -> '0.5' + inc(d,2); + inc(s); + c := s^; + end; + if (c>='0') and (c<='9') then + repeat + inc(s); + d^ := c; + inc(d); + c := s^; + if ((c>='0') and (c<='9')) or (c='.') then + continue; + if (c<>'e') and (c<>'E') then + break; + inc(s); + d^ := c; // 1.23e120 or 1.23e-45 + inc(d); + c := s^; + if c='-' then begin + inc(s); + d^ := c; + inc(d); + c := s^; + end; + while (c>='0') and (c<='9') do begin + inc(s); + d^ := c; + inc(d); + c := s^; + end; + break; + until false; + result := d; +end; + +function GetUTF8Char(P: PUTF8Char): cardinal; +begin + if P<>nil then begin + result := ord(P[0]); + if result and $80<>0 then begin + result := GetHighUTF8UCS4(P); + if result>$ffff then + result := ord('?'); // do not handle surrogates now + end; + end else + result := PtrUInt(P); +end; + +function NextUTF8UCS4(var P: PUTF8Char): cardinal; +begin + if P<>nil then begin + result := byte(P[0]); + if result<=127 then + inc(P) else begin + if result and $20=0 then begin + result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff + inc(P,2); + end else + result := GetHighUTF8UCS4(P); // handle even surrogates + end; + end else + result := 0; +end; + +function ContainsUTF8(p, up: PUTF8Char): boolean; +var u: PByte; +begin + if (p<>nil) and (up<>nil) and (up^<>#0) then begin + result := true; + repeat + u := pointer(up); + repeat + if GetNextUTF8Upper(p)<>u^ then + break else + inc(u); + if u^=0 then + exit; // up^ was found inside p^ + until false; + p := FindNextUTF8WordBegin(p); + until p=nil; + end; + result := false; +end; + +function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean; +var ext: PUTF8Char; +begin + if (p<>nil) and (extup<>nil) then begin + ext := nil; + repeat + if p^=sepChar then + ext := p; // get last '.' position from p into ext + inc(p); + until p^=#0; + result := IdemPChar(ext,extup); + end else + result := false; +end; + +function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; + sepChar: AnsiChar): integer; +var ext: PUTF8Char; +begin + result := -1; + if (p<>nil) and (high(extup)>0) then begin + ext := nil; + repeat + if p^=sepChar then + ext := p; // get last '.' position from p into ext + inc(p); + until p^=#0; + if ext<>nil then + result := IdemPCharArray(ext,extup); + end; +end; + +function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; +begin + result := False; + if p=nil then + exit; + if up<>nil then + while up^<>#0 do begin + while p^<=' ' do // trim white space + if p^=#0 then + exit else + inc(p); + if up^<>NormToUpperAnsi7[p^] then + exit; + inc(up); + inc(p); + end; + result := true; +end; + +function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; +var w: word; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7{$else}PNormTableByte{$endif}; + up: ^PAnsiChar; +begin + if p<>nil then begin + {$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64 + w := tab[ord(p[0])]+tab[ord(p[1])]shl 8; + up := @upArray[0]; + for result := 0 to high(upArray) do + if (PWord(up^)^=w) and + {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(pointer(tab),{$endif}p+2,up^+2) then + exit else + inc(up); + end; + result := -1; +end; + +function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; +var w: word; +begin + if p<>nil then begin + w := NormToUpperAnsi7Byte[ord(p[0])]+NormToUpperAnsi7Byte[ord(p[1])]shl 8; + for result := 0 to pred(length(upArrayBy2Chars) shr 1) do + if PWordArray(upArrayBy2Chars)[result]=w then + exit; + end; + result := -1; +end; + +function IdemPCharU(p, up: PUTF8Char): boolean; +begin + result := false; + if (p=nil) or (up=nil) then + exit; + while up^<>#0 do begin + if GetNextUTF8Upper(p)<>ord(up^) then + exit; + inc(up); + end; + result := true; +end; + +function EndWith(const text, upText: RawUTF8): boolean; +var o: PtrInt; +begin + o := length(text)-length(upText); + result := (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upText)); +end; + +function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; +var t,o: PtrInt; +begin + t := length(text); + if t>0 then + for result := 0 to high(upArray) do begin + o := t-length(UpArray[result]); + if (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upArray[result])) then + exit; + end; + result := -1; +end; + +function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; +begin + if source<>'' then + result := UpperCopy255Buf(dest,pointer(source),PStrLen(PtrUInt(source)-_STRLEN)^) else + result := dest; +end; + +function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; +var i,c,d{$ifdef CPU64},_80,_61,_7b{$endif}: PtrUInt; +begin + if sourceLen>0 then begin + if sourceLen>248 then + sourceLen := 248; // avoid buffer overflow + // we allow to copy up to 3/7 more chars in Dest^ since its size is 255 + {$ifdef CPU64} // unbranched uppercase conversion of 8 chars blocks + _80 := PtrUInt($8080808080808080); // use registers for constants + _61 := $6161616161616161; + _7b := $7b7b7b7b7b7b7b7b; + for i := 0 to (sourceLen-1) shr 3 do begin + c := PPtrUIntArray(source)^[i]; + d := c or _80; + PPtrUIntArray(dest)^[i] := c-((d-PtrUInt(_61)) and not(d-_7b)) and + ((not c) and _80)shr 2; + end; + {$else} // unbranched uppercase conversion of 4 chars blocks + for i := 0 to (sourceLen-1) shr 2 do begin + c := PPtrUIntArray(source)^[i]; + d := c or PtrUInt($80808080); + PPtrUIntArray(dest)^[i] := c-((d-PtrUInt($61616161)) and not(d-PtrUInt($7b7b7b7b))) and + ((not c) and PtrUInt($80808080))shr 2; + end; + {$endif} + result := dest+sourceLen; // but we always return the exact size + end else + result := dest; +end; + +function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; +var i, L: PtrInt; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; +begin + if source='' then + result := dest else begin + L := PStrLen(PtrUInt(source)-_STRLEN)^; + if L>250 then + L := 250; // avoid buffer overflow + result := dest+L; + {$ifndef CPUX86NOTPIC}tab := @NormToUpperByte;{$endif} // faster on PIC and x86_64 + for i := 0 to L-1 do + dest[i] := AnsiChar(tab[PByteArray(source)[i]]); + end; +end; + +function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; +var c: cardinal; + endSource, endSourceBy4, up: PUTF8Char; + extra,i: PtrInt; +label By1, By4, set1; // ugly but faster +begin + if (Source<>nil) and (Dest<>nil) then begin + // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) + endSource := Source+SourceChars; + endSourceBy4 := endSource-4; + up := @NormToUpper; + if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then + repeat + By4:c := PCardinal(Source)^; + if c and $80808080<>0 then + goto By1; // break on first non ASCII quad + inc(Source,4); + Dest[0] := up[ToByte(c)]; + Dest[1] := up[ToByte(c shr 8)]; + Dest[2] := up[ToByte(c shr 16)]; + Dest[3] := up[ToByte(c shr 24)]; + inc(Dest,4); + until Source>endSourceBy4; + // generic loop, handling one UCS4 char per iteration + if SourceendSource) then break; + for i := 0 to extra-1 do + c := c shl 6+byte(Source[i]); + with UTF8_EXTRA[extra] do begin + dec(c,offset); + if c0 - just copy UTF-8 input untouched + inc(Dest); + Dest^ := Source^; + inc(Source); + dec(extra); + if extra=0 then + goto Set1; + until false; + end; + until false; + end; + result := Dest; +end; + +function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; +var L: integer; +begin + L := length(source); + if L>0 then begin + if L>250 then + L := 250; // avoid buffer overflow + result := UTF8UpperCopy(pointer(dest),pointer(source),L); + end else + result := pointer(dest); +end; + +function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; +var c: cardinal; + i,L: integer; +begin + L := length(source); + if L>0 then begin + if L>250 then + L := 250; // avoid buffer overflow + result := dest+L; + for i := 0 to L-1 do begin + c := PWordArray(source)[i]; + if c<255 then + dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else + dest[i] := '?'; + end; + end else + result := dest; +end; + +function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; +var c: cardinal; + i: integer; +begin + if L>0 then begin + if L>250 then + L := 250; // avoid buffer overflow + result := dest+L; + for i := 0 to L-1 do begin + c := PWordArray(source)[i]; + if c<255 then + dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else + dest[i] := '?'; + end; + end else + result := dest; +end; + +function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean): RawUTF8; +var beg: PUTF8Char; +begin + if source=nil then begin + {$ifdef FPC}Finalize(result){$else}result := ''{$endif}; + next := source; + exit; + end; + if andtrim then // optional trim left + while source^ in [#9,' '] do inc(source); + beg := source; + repeat // just here to avoid a goto + if source[0]>#13 then + if source[1]>#13 then + if source[2]>#13 then + if source[3]>#13 then begin + inc(source,4); // fast process 4 chars per loop + continue; + end else + inc(source,3) else + inc(source,2) else + inc(source); + case source^ of + #0: next := nil; + #10: next := source+1; + #13: if source[1]=#10 then next := source+2 else next := source+1; + else begin + inc(source); + continue; + end; + end; + if andtrim then // optional trim right + while (source>beg) and (source[-1] in [#9,' ']) do dec(source); + FastSetString(result,beg,source-beg); + exit; + until false; +end; + +{$ifdef UNICODE} +function GetNextLineW(source: PWideChar; out next: PWideChar): string; +begin + next := source; + if source=nil then begin + result := ''; + exit; + end; + while not (cardinal(source^) in [0,10,13]) do inc(source); + SetString(result,PChar(next),source-next); + if source^=#13 then inc(source); + if source^=#10 then inc(source); + if source^=#0 then + next := nil else + next := source; +end; + +function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; +var PBeg: PWideChar; + L: PtrInt; +begin + while (P<>nil) and (P^<>'[') do begin + PBeg := P; + while not (cardinal(P^) in [0,10,13]) do inc(P); + while cardinal(P^) in [10,13] do inc(P); + if P^=#0 then P := nil; + if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' '; // trim left ' ' + if IdemPCharW(PBeg,UpperName) then begin + inc(PBeg,StrLen(UpperName)); + L := 0; while PBeg[L]>=' ' do inc(L); // get line length + SetString(result,PBeg,L); + exit; + end; + end; + result := ''; +end; + +function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; +var P: PWideChar; + UpperSection, UpperName: array[byte] of AnsiChar; + // possible GPF if length(Section/Name)>255, but should const in code +begin + result := ''; + P := pointer(Content); + if P=nil then exit; + // UpperName := UpperCase(Name)+'='; + PWord(UpperCopy255(UpperName,Name))^ := ord('='); + if Section='' then + // find the Name= entry before any [Section] + result := FindIniNameValueW(P,UpperName) else begin + // find the Name= entry in the specified [Section] + PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); + if FindSectionFirstLineW(P,UpperSection) then + result := FindIniNameValueW(P,UpperName); + end; +end; +{$endif UNICODE} + +function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; + var Item: RawUTF8; Sep: AnsiChar): boolean; +begin + if source=nil then + result := false else begin + result := IdemPChar(source,Pointer(searchUp)); + if result then begin + inc(source,Length(searchUp)); + GetNextItem(source,Sep,Item); + end; + end; +end; + +function GotoNextLine(source: PUTF8Char): PUTF8Char; +label + _z, _0, _1, _2, _3; // ugly but faster +var + c: AnsiChar; +begin + if source<>nil then + repeat + if source[0]<#13 then + goto _0 + else if source[1]<#13 then + goto _1 + else if source[2]<#13 then + goto _2 + else if source[3]<#13 then + goto _3 + else begin + inc(source, 4); + continue; + end; +_3: inc(source); +_2: inc(source); +_1: inc(source); +_0: c := source^; + if c=#13 then begin + if source[1]=#10 then begin + result := source+2; // most common case is text ending with #13#10 + exit; + end; + end else + if c=#0 then + goto _z else + if c<>#10 then begin + inc(source); + continue; // e.g. #9 + end; + result := source+1; + exit; + until false; +_z: result := nil; +end; + +function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; +{$ifdef CPUX64} +{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif} +{$ifdef MSWINDOWS} // Win64 ABI to System-V ABI + push rsi + push rdi + mov rdi, rcx + mov rsi, rdx +{$endif}mov r8, rsi + sub r8, rdi // rdi=Text, rsi=TextEnd, r8=TextLen + jz @fail + mov ecx, edi + movaps xmm0, [rip + @for10] + movaps xmm1, [rip + @for13] + and rdi, -16 // check first aligned 16 bytes + and ecx, 15 // lower cl 4 bits indicate misalignment + movaps xmm2, [rdi] + movaps xmm3, xmm2 + pcmpeqb xmm2, xmm0 + pcmpeqb xmm3, xmm1 + por xmm3, xmm2 + pmovmskb eax, xmm3 + shr eax, cl // shift out unaligned bytes + test eax, eax + jz @main + bsf eax, eax + add rax, rcx + add rax, rdi + sub rax, rsi + jae @fail // don't exceed TextEnd + add rax, r8 // rax = TextFound - TextEnd + (TextEnd - Text) = offset +{$ifdef MSWINDOWS} + pop rdi + pop rsi +{$endif}ret +@main: add rdi, 16 + sub rdi, rsi + jae @fail + jmp @by16 +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@for10: dq $0a0a0a0a0a0a0a0a + dq $0a0a0a0a0a0a0a0a +@for13: dq $0d0d0d0d0d0d0d0d + dq $0d0d0d0d0d0d0d0d +@by16: movaps xmm2, [rdi + rsi] // check 16 bytes per loop + movaps xmm3, xmm2 + pcmpeqb xmm2, xmm0 + pcmpeqb xmm3, xmm1 + por xmm3, xmm2 + pmovmskb eax, xmm3 + test eax, eax + jnz @found + add rdi, 16 + jnc @by16 +@fail: mov rax, r8 // returns TextLen if no CR/LF found +{$ifdef MSWINDOWS} + pop rdi + pop rsi +{$endif}ret +@found: bsf eax, eax + add rax, rdi + jc @fail + add rax, r8 +{$ifdef MSWINDOWS} + pop rdi + pop rsi +{$endif} +end; +{$else} +begin + result := PtrUInt(Text)-1; + repeat + inc(result); + if PtrUInt(result)13) or ((PByte(result)^<>10) and (PByte(result)^<>13)) then + continue; + break; + until false; + dec(result,PtrInt(Text)); // returns length +end; +{$endif CPUX64} + +function GetLineSize(P, PEnd: PUTF8Char): PtrUInt; +var c: byte; +begin + {$ifdef CPUX64} + if PEnd <> nil then begin + result := BufferLineLength(P,PEnd); // use branchless SSE2 on x86_64 + exit; + end; + result := PtrUInt(P)-1; + {$else} + result := PtrUInt(P)-1; + if PEnd<>nil then + repeat // inlined BufferLineLength() + inc(result); + if PtrUInt(result)13) or ((c<>10) and (c<>13)) then + continue; + end; + break; + until false else + {$endif CPUX64} + repeat // inlined BufferLineLength() ending at #0 for PEnd=nil + inc(result); + c := PByte(result)^; + if (c>13) or ((c<>0) and (c<>10) and (c<>13)) then + continue; + break; + until false; + dec(result,PtrUInt(P)); // returns length +end; + +function GetNextItem(var P: PUTF8Char; Sep: AnsiChar): RawUTF8; +begin + GetNextItem(P,Sep,result); +end; + +procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); +var S: PUTF8Char; +begin + if P=nil then + result := '' else begin + S := P; + while (S^<>#0) and (S^<>Sep) do + inc(S); + FastSetString(result,P,S-P); + if S^<>#0 then + P := S+1 else + P := nil; + end; +end; + +procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); +begin + if P=nil then + result := '' + else if P^=Quote then begin + P := UnQuoteSQLStringVar(P,result); + if P=nil then + result := '' + else if P^<>#0 then + inc(P); + end else + GetNextItem(P,Sep,result); +end; + +procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); +var S,E: PUTF8Char; +begin + if (P=nil) or (Sep<=' ') then + result := '' else begin + while (P^<=' ') and (P^<>#0) do inc(P); // trim left + S := P; + while (S^<>#0) and (S^<>Sep) do + inc(S); + E := S; + while (E>P) and (E[-1] in [#1..' ']) do dec(E); // trim right + FastSetString(result,P,E-P); + if S^<>#0 then + P := S+1 else + P := nil; + end; +end; + +procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); +var S,E: PUTF8Char; +begin + if P=nil then + result := '' else begin + S := P; + while (S^<>#0) and (S^<>#10) do + inc(S); + E := S; + if (E>P) and (E[-1]=#13) then + dec(E); + FastSetString(result,P,E-P); + if S^<>#0 then + P := S+1 else + P := nil; + end; +end; + +function GetNextItemString(var P: PChar; Sep: Char): string; +// this function will compile into AnsiString or UnicodeString, depending +// of the compiler version +var S: PChar; +begin + if P=nil then + result := '' else begin + S := P; + while (S^<>#0) and (S^<>Sep) do + inc(S); + SetString(result,P,S-P); + if S^<>#0 then + P := S+1 else + P := nil; + end; +end; + +function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; +var S: PChar; +begin + if P=nil then + result := '' else begin + S := P; + while S^>=' ' do + inc(S); + result := StringToRawUnicode(P,S-P); + while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 + if S^<>#0 then + P := S else + P := nil; + end; +end; + +procedure AppendCSVValues(const CSV: string; const Values: array of string; + var Result: string; const AppendBefore: string); +var Caption: string; + i, bool: integer; + P: PChar; + first: Boolean; +begin + P := pointer(CSV); + if P=nil then + exit; + first := True; + for i := 0 to high(Values) do begin + Caption := GetNextItemString(P); + if Values[i]<>'' then begin + if first then begin + Result := Result+#13#10; + first := false; + end else + Result := Result+AppendBefore; + bool := FindCSVIndex('0,-1',RawUTF8(Values[i])); + Result := Result+Caption+': '; + if bool<0 then + Result := Result+Values[i] else + Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/'); + end; + end; +end; + +procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar); +var S: PUTF8Char; + len: PtrInt; +begin + S := P; + if S<>nil then begin + while (S^<=' ') and (S^<>#0) do inc(S); + P := S; + if (S^<>#0) and (S^<>Sep) then + repeat + inc(S); + until (S^=#0) or (S^=Sep); + len := S-P; + repeat + dec(len); + until (len<0) or not(P[len] in [#1..' ']); // trim right spaces + if len>=255 then + len := 255 else + inc(len); + Dest[0] := AnsiChar(len); + MoveSmall(P,@Dest[1],Len); + if S^<>#0 then + P := S+1 else + P := nil; + end else + Dest[0] := #0; +end; + +function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; + Sep: AnsiChar): boolean; +var S: PUTF8Char; + len: integer; +begin + result := false; + FillCharFast(Bin^,BinBytes,0); + if P=nil then + exit; + if P^=' ' then repeat inc(P) until P^<>' '; + S := P; + if Sep=#0 then + while S^>' ' do + inc(S) else + while (S^<>#0) and (S^<>Sep) do + inc(S); + len := S-P; + while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces + if len<>BinBytes*2 then + exit; + if not HexDisplayToBin(PAnsiChar(P),Bin,BinBytes) then + FillCharFast(Bin^,BinBytes,0) else begin + if S^=#0 then + P := nil else + if Sep<>#0 then + P := S+1 else + P := S; + result := true; + end; +end; + +function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar): PtrUInt; +var c: PtrUInt; +begin + if P=nil then begin + result := 0; + exit; + end; + if P^=' ' then repeat inc(P) until P^<>' '; + c := byte(P^)-48; + if c>9 then + result := 0 else begin + result := c; + inc(P); + repeat + c := byte(P^)-48; + if c>9 then + break else + result := result*10+c; + inc(P); + until false; + end; + if Sep<>#0 then + while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) + inc(P); + if P^=#0 then + P := nil else + if Sep<>#0 then + inc(P); +end; + +function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; +var c: PtrUInt; +begin + if P=nil then begin + result := 0; + exit; + end; + c := byte(P^)-48; + if c>9 then + result := 0 else begin + result := c; + inc(P); + repeat + c := byte(P^)-48; + if c>9 then + break else + result := result*10+c; + inc(P); + until false; + end; + if P^=#0 then + P := nil; +end; + +function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8): RawUTF8; +var ValueLen, SepLen: cardinal; + i: cardinal; + P: PAnsiChar; +begin // CSVOfValue('?',3)='?,?,?' + result := ''; + if Count=0 then + exit; + ValueLen := length(Value); + SepLen := Length(Sep); + FastSetString(result,nil,ValueLen*Count+SepLen*pred(Count)); + P := pointer(result); + i := 1; + repeat + if ValueLen>0 then begin + MoveSmall(Pointer(Value),P,ValueLen); + inc(P,ValueLen); + end; + if i=Count then + break; + if SepLen>0 then begin + MoveSmall(Pointer(Sep),P,SepLen); + inc(P,SepLen); + end; + inc(i); + until false; +// assert(P-pointer(result)=length(result)); +end; + +procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); +var bit,last: cardinal; +begin + while P<>nil do begin + bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list + if bit>=cardinal(BitsCount) then + break; // avoid GPF + if (P=nil) or (P^=',') then + SetBitPtr(@Bits,bit) else + if P^='-' then begin + inc(P); + last := GetNextItemCardinalStrict(P)-1; // '0' marks end of list + if last>=Cardinal(BitsCount) then + exit; + while bit<=last do begin + SetBitPtr(@Bits,bit); + inc(bit); + end; + end; + if (P<>nil) and (P^=',') then + inc(P); + end; + if (P<>nil) and (P^=',') then + inc(P); +end; + +function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; +var i,j: integer; +begin + result := ''; + i := 0; + while i9 then + result := 0 else begin + result := c; + inc(P); + repeat + c := word(P^)-48; + if c>9 then + break else + result := result*10+c; + inc(P); + until false; + end; + while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) + inc(P); + if P^=#0 then + P := nil else + inc(P); +end; + +function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar): PtrInt; +var minus: boolean; +begin + if P=nil then begin + result := 0; + exit; + end; + if P^=' ' then repeat inc(P) until P^<>' '; + if (P^ in ['+','-']) then begin + minus := P^='-'; + inc(P); + end else + minus := false; + result := PtrInt(GetNextItemCardinal(P,Sep)); + if minus then + result := -result; +end; + +function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; +var S: PUTF8Char; + c: AnsiChar; +begin + result := 0; + S := P; + if S=nil then + exit; + if Sep=#0 then + repeat // store up to next whitespace + c := S[result]; + if c<=' ' then break; + Buf[result] := c; + inc(result); + if result>=SizeOf(Buf) then + exit; // avoid buffer overflow + until false else + repeat // store up to Sep or end of string + c := S[result]; + if (c=#0) or (c=Sep) then break; + Buf[result] := c; + inc(result); + if result>=SizeOf(Buf) then + exit; // avoid buffer overflow + until false; + Buf[result] := #0; // make asciiz + inc(S,result); // S[result]=Sep or #0 + if S^=#0 then + P := nil else + if Sep=#0 then + P := S else + P := S+1; +end; + +function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar): Int64; +{$ifdef CPU64} +begin + result := GetNextItemInteger(P,Sep); // PtrInt=Int64 +end; +{$else} +var tmp: TChar64; +begin + if GetNextTChar64(P,Sep,tmp)>0 then + SetInt64(tmp,result) else + result := 0; +end; +{$endif} + +function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar): QWord; +{$ifdef CPU64} +begin + result := GetNextItemCardinal(P,Sep); // PtrUInt=QWord +end; +{$else} +var tmp: TChar64; +begin + if GetNextTChar64(P,Sep,tmp)>0 then + SetQWord(tmp,result) else + result := 0; +end; +{$endif} + +function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar): QWord; +var tmp: TChar64; + L: integer; +begin + result := 0; + L := GetNextTChar64(P,Sep,tmp); + if (L>0) and (L and 1=0) then + if not HexDisplayToBin(@tmp,@result,L shr 1) then + result := 0; +end; + +function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar): double; +var tmp: TChar64; + err: integer; +begin + if GetNextTChar64(P,Sep,tmp)>0 then begin + result := GetExtended(tmp,err); + if err<>0 then + result := 0; + end else + result := 0; +end; + +function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar): currency; +begin + GetNextItemCurrency(P,result,Sep); +end; + +procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar); +var tmp: TChar64; +begin + if GetNextTChar64(P,Sep,tmp)>0 then + PInt64(@result)^ := StrToCurr64(tmp) else + result := 0; +end; + +function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar): RawUTF8; +var i: PtrUInt; +begin + if P=nil then + result := '' else + for i := 0 to Index do + GetNextItem(P,Sep,result); +end; + +function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep, Quote: AnsiChar): RawUTF8; +var i: PtrUInt; +begin + if P=nil then + result := '' else + for i := 0 to Index do + GetNextItem(P,Sep,Quote,result); +end; + +function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar): RawUTF8; +var i: integer; +begin + for i := length(CSV) downto 1 do + if CSV[i]=Sep then begin + result := copy(CSV,i+1,maxInt); + exit; + end; + result := CSV; +end; + +function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char): string; +var i: PtrUInt; +begin + if P=nil then + result := '' else + for i := 0 to Index do + result := GetNextItemString(P,Sep); +end; + +function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar; + CaseSensitive,TrimValue: boolean): integer; +var s: RawUTF8; +begin + result := 0; + while CSV<>nil do begin + GetNextItem(CSV,Sep,s); + if TrimValue then + s := trim(s); + if CaseSensitive then begin + if s=Value then + exit; + end else + if SameTextU(s,Value) then + exit; + inc(result); + end; + result := -1; // not found +end; + +procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; + Sep: AnsiChar; TrimItems, AddVoidItems: boolean); +var s: RawUTF8; + n: integer; +begin + n := length(Result); + while CSV<>nil do begin + if TrimItems then + GetNextItemTrimed(CSV,Sep,s) else + GetNextItem(CSV,Sep,s); + if (s<>'') or AddVoidItems then + AddRawUTF8(Result,n,s); + end; + if n<>length(Result) then + SetLength(Result,n); +end; + +procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); +var offs,i: integer; +begin + offs := 1; + while offs<=length(CSV) do begin + SetLength(Result,length(Result)+1); + i := PosEx(Sep,CSV,offs); + if i=0 then begin + i := PosEx(SepEnd,CSV,offs); + if i=0 then + i := MaxInt else + dec(i,offs); + Result[high(Result)] := Copy(CSV,offs,i); + exit; + end; + Result[high(Result)] := Copy(CSV,offs,i-offs); + offs := i+length(sep); + end; +end; + +function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; Sep: AnsiChar): RawUTF8; +var s: RawUTF8; +begin + GetNextItem(CSV,Sep,result); + if result='' then + exit; + result := Prefix+result; + while CSV<>nil do begin + GetNextItem(CSV,Sep,s); + if s<>'' then + result := result+','+Prefix+s; + end; +end; + +procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8); +begin + if CSV='' then + CSV := Value else + CSV := CSV+Sep+Value; +end; + +function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; + const Sep: RawUTF8): boolean; +var pattern: RawUTF8; + i,j: integer; +begin + result := OldValue=NewValue; + i := length(OldValue); + if result or (length(Sep)<>1) or (length(CSV)0) or (PosEx(Sep,NewValue)>0) then + exit; + if CompareMem(pointer(OldValue),pointer(CSV),i) and // first (or unique) item + ((CSV[i+1]=Sep[1]) or (CSV[i+1]=#0)) then + i := 1 else begin + j := 1; + pattern := Sep+OldValue; + repeat + i := PosEx(pattern,CSV,j); + if i=0 then + exit; + j := i+length(pattern); + until (CSV[j]=Sep[1]) or (CSV[j]=#0); + inc(i); + end; + delete(CSV,i,length(OldValue)); + insert(NewValue,CSV,i); + result := true; +end; + +function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8): RawUTF8; +var i, len, seplen, L: Integer; + P: PAnsiChar; +begin + result := ''; + if high(Values)<0 then + exit; + seplen := length(Sep); + len := seplen*high(Values); + for i := 0 to high(Values) do + inc(len,length(Values[i])); + FastSetString(result,nil,len); + P := pointer(result); + i := 0; + repeat + L := length(Values[i]); + if L>0 then begin + MoveFast(pointer(Values[i])^,P^,L); + inc(P,L); + end; + if i=high(Values) then + Break; + if seplen>0 then begin + MoveSmall(pointer(Sep),P,seplen); + inc(P,seplen); + end; + inc(i); + until false; +end; + +function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8; + Quote: AnsiChar): RawUTF8; +var i: integer; + tmp: TRawUTF8DynArray; +begin + SetLength(tmp,length(Values)); + for i := 0 to High(Values) do + tmp[i] := QuotedStr(Values[i],Quote); + result := RawUTF8ArrayToCSV(tmp,Sep); +end; + +function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; +var i: integer; +begin + Finalize(result); + SetLength(result,length(Values)); + for i := 0 to high(Values) do + result[i] := Values[i]; +end; + +{$ifdef HASCODEPAGE} +function LStringCodePage(info: PTypeInfo): integer; inline; +begin // caller checked that info^.kind=tkLString + result := PWord({$ifdef FPC}AlignTypeData{$endif}(pointer(PtrUInt(info)+info^.NameLen+2)))^; +end; +{$endif HASCODEPAGE} + +function IsRawUTF8DynArray(typeinfo: pointer): boolean; +var nfo: PTypeInfo; +begin + if typeinfo=System.TypeInfo(TRawUTF8DynArray) then + result := true else begin + nfo := GetTypeInfo(typeinfo,tkDynArray); + if (nfo<>nil) and (nfo^.elSize=SizeOf(pointer)) and + (nfo^.elType<>nil) then begin + nfo := DeRef(nfo^.elType); + result := (nfo^.kind=tkLString) + {$ifdef HASCODEPAGE}and (LStringCodePage(nfo)=CP_UTF8){$endif}; + end else + result := false; + end; +end; + +procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); +var i,n: Integer; +begin + n := length(Dest); + SetLength(Dest,n+length(Values)); + for i := 0 to high(Values) do + Dest[i+n] := Values[i]; +end; + +var + DefaultTextWriterTrimEnum: boolean; + +function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8; +var temp: TTextWriterStackBuffer; +begin + if Value=nil then + result := NULL_STR_VAR else + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + include(fCustomOptions,twoForceJSONStandard); + WriteObject(Value,Options); + SetText(result); + finally + Free; + end; +end; + +function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; + Options: TTextWriterWriteObjectOptions): RawUTF8; +var i,n: integer; + temp: TTextWriterStackBuffer; +begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + n := length(Names); + Add('{'); + for i := 0 to high(Values) do + if Values[i]<>nil then begin + if i0) and (n and 1=1) then begin + for A := 0 to n shr 1 do begin + VarRecToUTF8(NameValuePairs[A*2],name); + if not IsUrlValid(pointer(name)) then + continue; // just skip invalid names + with NameValuePairs[A*2+1] do + if VType=vtObject then + value := ObjectToJSON(VObject,[]) else + VarRecToUTF8(NameValuePairs[A*2+1],value); + result := result+'&'+name+'='+UrlEncode(value); + end; + result[1] := '?'; + end; +end; + +function IsUrlValid(P: PUTF8Char): boolean; +var tab: PTextCharSet; +begin + result := false; + if P=nil then + exit; + tab := @TEXT_CHARS; + repeat // cf. rfc3986 2.3. Unreserved Characters + if tcURIUnreserved in tab[P^] then + inc(P) else + exit; + until P^=#0; + result := true; +end; + +function AreUrlValid(const Url: array of RawUTF8): boolean; +var i: integer; +begin + result := false; + for i := 0 to high(Url) do + if not IsUrlValid(pointer(Url[i])) then + exit; + result := true; +end; + +function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; +begin + if (URI<>'') and (URI[length(URI)]<>'/') then + result := URI+'/' else + result := URI; +end; + +function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; + const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; +var i,j: integer; + sep: AnsiChar; + Params: TNameValuePUTF8CharDynArray; + temp: TTextWriterStackBuffer; +begin + if ParametersJSON=nil then + result := URIName else + with TTextWriter.CreateOwnedStream(temp) do + try + AddString(URIName); + if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin + sep := '?'; + for i := 0 to length(Params)-1 do + with Params[i] do begin + for j := 0 to high(PropNamesToIgnore) do + if IdemPropNameU(PropNamesToIgnore[j],Name,NameLen) then begin + NameLen := 0; + break; + end; + if NameLen=0 then + continue; + if IncludeQueryDelimiter then + Add(sep); + AddNoJSONEscape(Name,NameLen); + Add('='); + AddString(UrlEncode(Value)); + sep := '&'; + IncludeQueryDelimiter := true; + end; + end; + SetText(result); + finally + Free; + end; +end; + +function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; + const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; +var temp: TSynTempBuffer; +begin + temp.Init(ParametersJSON); + try + result := UrlEncodeJsonObject(URIName,temp.buf,PropNamesToIgnore,IncludeQueryDelimiter); + finally + temp.Done; + end; +end; + +function UrlDecode(const s: RawUTF8; i,len: PtrInt): RawUTF8; +var L: PtrInt; + P: PUTF8Char; + tmp: TSynTempBuffer; +begin + result := ''; + L := PtrInt(s); + if L=0 then + exit; + L := PStrLen(L-_STRLEN)^; + if len<0 then + len := L; + if i>L then + exit; + dec(i); + if len=i then + exit; + P := tmp.Init(len-i); // reserve enough space for result + while inil then begin + // compute resulting length of value + Beg := U; + len := 0; + while (U^<>#0) and (U^<>'&') do begin + if (U^='%') and HexToCharValid(PAnsiChar(U+1)) then + inc(U,3) else + inc(U); + inc(len); + end; + // decode value content + if len<>0 then begin + FastSetString(Value,nil,len); + V := pointer(Value); + U := Beg; + repeat + if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin + inc(V); + inc(U,3); + end else begin + if U^='+' then + V^ := ' ' else + V^ := U^; + inc(V); + inc(U); + end; + dec(len); + until len=0; + end; + end; + result := U; +end; + +function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; +var Beg, V: PUTF8Char; + len: PtrInt; +begin + result := nil; + if U=nil then + exit; + // compute resulting length of name + Beg := U; + len := 0; + repeat + case U^ of + #0: exit; + '=': begin + result := U+1; + break; + end; + '%': if (U[1]='3') and (U[2] in ['D','d']) then begin + result := U+3; + break; // %3d means = according to the RFC + end else + if HexToCharValid(PAnsiChar(U+1)) then + inc(U,3) else + inc(U); + else inc(U); + end; + inc(len); + until false; + if len=0 then + exit; + // decode name content + FastSetString(Name,nil,len); + V := pointer(Name); + U := Beg; + repeat + if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin + inc(V); + inc(U,3); + end else begin + if U^='+' then + V^ := ' ' else + V^ := U^; + inc(V); + inc(U); + end; + dec(len); + until len=0; +end; + +function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; +begin + result := nil; + if U=nil then + exit; + U := UrlDecodeNextName(U,Name); + if U=nil then + exit; + U := UrlDecodeNextValue(U,Value); + if U^=#0 then + result := U else + result := U+1; // jump '&' to let decode the next name=value pair +end; + +function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; + Next: PPUTF8Char): boolean; +begin + // UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@U) + // -> U^='where=...' and V='*' + result := false; // mark value not modified by default + if U=nil then begin + if Next<>nil then + Next^ := U; + exit; + end; + if IdemPChar(U,pointer(Upper)) then begin + result := true; + inc(U,length(Upper)); + U := UrlDecodeNextValue(U,Value); + end; + if Next=nil then + exit; + while not(U^ in [#0,'&']) do inc(U); + if U^=#0 then + Next^ := nil else + Next^ := U+1; // jump '&' +end; + +function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; + var Value: integer; Next: PPUTF8Char): boolean; +var V: PtrInt; + SignNeg: boolean; +begin + // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) + // -> Next^='where=...' and O=20 + result := false; // mark value not modified by default + if U=nil then begin + if Next<>nil then + Next^ := U; + exit; + end; + if IdemPChar(U,pointer(Upper)) then begin + inc(U,length(Upper)); + if U^='-' then begin + SignNeg := True; + Inc(U); + end else + SignNeg := false; + if U^ in ['0'..'9'] then begin + V := 0; + repeat + V := (V*10)+ord(U^)-48; + inc(U); + until not (U^ in ['0'..'9']); + if SignNeg then + Value := -V else + Value := V; + result := true; + end; + end; + if Next=nil then + exit; + while not(U^ in [#0,'&']) do inc(U); + if U^=#0 then + Next^ := nil else + Next^ := U+1; // jump '&' +end; + +function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; + var Value: Cardinal; Next: PPUTF8Char): boolean; +var V: PtrInt; +begin + // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) + // -> Next^='where=...' and O=20 + result := false; // mark value not modified by default + if U=nil then begin + if Next<>nil then + Next^ := U; + exit; + end; + if IdemPChar(U,pointer(Upper)) then begin + inc(U,length(Upper)); + if U^ in ['0'..'9'] then begin + V := 0; + repeat + V := (V*10)+ord(U^)-48; + inc(U); + until not (U^ in ['0'..'9']); + Value := V; + result := true; + end; + end; + if Next=nil then + exit; + while not(U^ in [#0,'&']) do inc(U); + if U^=#0 then + Next^ := nil else + Next^ := U+1; // jump '&' +end; + +function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; + var Value: Int64; Next: PPUTF8Char): boolean; +var tmp: RawUTF8; +begin + result := UrlDecodeValue(U,Upper,tmp,Next); + if result then + SetInt64(pointer(tmp),Value); +end; + +function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; + var Value: TSynExtended; Next: PPUTF8Char): boolean; +var tmp: RawUTF8; + err: integer; +begin + result := UrlDecodeValue(U,Upper,tmp,Next); + if result then begin + Value := GetExtended(pointer(tmp),err); + if err<>0 then + result := false; + end; +end; + +function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; + Next: PPUTF8Char): boolean; +var tmp: RawUTF8; + err: integer; +begin + result := UrlDecodeValue(U,Upper,tmp,Next); + if result then begin + Value := GetExtended(pointer(tmp),err); + if err<>0 then + result := false; + end; +end; + +function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; +var tmp: array[byte] of AnsiChar; + L: integer; + Beg: PUTF8Char; +// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will +// return TRUE +begin + result := (CSVNames=nil); + if result then + exit; // no parameter to check -> success + if U=nil then + exit; // no input data -> error + repeat + L := 0; + while (CSVNames^<>#0) and (CSVNames^<>',') do begin + tmp[L] := NormToUpper[CSVNames^]; + if L=high(tmp) then + exit else // invalid CSV parameter + inc(L); + inc(CSVNames); + end; + if L=0 then + exit; // invalid CSV parameter + PWord(@tmp[L])^ := ord('='); + Beg := U; + repeat + if IdemPChar(U,tmp) then + break; + while not(U^ in [#0,'&']) do inc(U); + if U^=#0 then + exit else // didn't find tmp in U + inc(U); // Jump & + until false; + U := Beg; + if CSVNames^=#0 then + Break else // no more parameter to check + inc(CSVNames); // jump & + until false; + result := true; // all parameters found +end; + +function CSVEncode(const NameValuePairs: array of const; + const KeySeparator, ValueSeparator: RawUTF8): RawUTF8; +var i: integer; + temp: TTextWriterStackBuffer; +begin + if length(NameValuePairs)<2 then + result := '' else + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + for i := 1 to length(NameValuePairs) shr 1 do begin + Add(NameValuePairs[i*2-2],twNone); + AddNoJSONEscape(pointer(KeySeparator),length(KeySeparator)); + Add(NameValuePairs[i*2-1],twNone); + AddNoJSONEscape(pointer(ValueSeparator),length(ValueSeparator)); + end; + SetText(result); + finally + Free; + end; +end; + +function ArrayOfConstValueAsText(const NameValuePairs: array of const; + const aName: RawUTF8): RawUTF8; +var i: integer; + name: RawUTF8; +begin + for i := 1 to length(NameValuePairs) shr 1 do + if VarRecToUTF8IsString(NameValuePairs[i*2-2],name) and + IdemPropNameU(name,aName) then begin + VarRecToUTF8(NameValuePairs[i*2-1],result); + exit; + end; + result := ''; +end; + +function IsZero(P: pointer; Length: integer): boolean; +var i: integer; +begin + result := false; + for i := 1 to Length shr 4 do // 16 bytes (4 DWORD) by loop - aligned read + {$ifdef CPU64} + if (PInt64Array(P)^[0]<>0) or (PInt64Array(P)^[1]<>0) then + {$else} + if (PCardinalArray(P)^[0]<>0) or (PCardinalArray(P)^[1]<>0) or + (PCardinalArray(P)^[2]<>0) or (PCardinalArray(P)^[3]<>0) then + {$endif} + exit else + inc(PByte(P),16); + for i := 1 to (Length shr 2)and 3 do // 4 bytes (1 DWORD) by loop + if PCardinal(P)^<>0 then + exit else + inc(PByte(P),4); + for i := 1 to Length and 3 do // remaining content + if PByte(P)^<>0 then + exit else + inc(PByte(P)); + result := true; +end; + +function IsZeroSmall(P: pointer; Length: PtrInt): boolean; +begin + result := false; + repeat + if PByte(P)^<>0 then + exit; + inc(PByte(P)); + dec(Length); + if Length=0 then + break; + until false; + result := true; +end; + +function IsZero(const Values: TRawUTF8DynArray): boolean; +var i: integer; +begin + result := false; + for i := 0 to length(Values)-1 do + if Values[i]<>'' then + exit; + result := true; +end; + +function IsZero(const Values: TIntegerDynArray): boolean; +var i: integer; +begin + result := false; + for i := 0 to length(Values)-1 do + if Values[i]<>0 then + exit; + result := true; +end; + +function IsZero(const Values: TInt64DynArray): boolean; +var i: integer; +begin + result := false; + for i := 0 to length(Values)-1 do + if Values[i]<>0 then + exit; + result := true; +end; + +procedure FillZero(var Values: TRawUTF8DynArray); +var i: integer; +begin + for i := 0 to length(Values)-1 do + {$ifdef FPC}Finalize(Values[i]){$else}Values[i] := ''{$endif}; +end; + +procedure FillZero(var Values: TIntegerDynArray); +begin + FillCharFast(Values[0],length(Values)*SizeOf(integer),0); +end; + +procedure FillZero(var Values: TInt64DynArray); +begin + FillCharFast(Values[0],length(Values)*SizeOf(Int64),0); +end; + + +function crc16(Data: PAnsiChar; Len: integer): cardinal; +var i, j: Integer; +begin + result := $ffff; + for i := 0 to Len-1 do begin + result := result xor (ord(Data[i]) shl 8); + for j := 1 to 8 do + if result and $8000<>0 then + result := (result shl 1) xor $1021 else + result := result shl 1; + end; + result := result and $ffff; +end; + +function Hash32(const Text: RawByteString): cardinal; +begin + result := Hash32(pointer(Text),length(Text)); +end; + +function Hash32(Data: PCardinalArray; Len: integer): cardinal; +{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; +asm {$else} asm .noframe {$endif} // rcx/rdi=Data edx/esi=Len + xor eax, eax + xor r9d, r9d + test Data, Data + jz @z + {$ifdef win64} + mov r8, rdx + shr r8, 4 + {$else} + mov edx, esi + shr esi, 4 + {$endif} + jz @by4 + {$ifdef FPC} align 16 {$else} .align 16 {$endif} +@by16: add eax, dword ptr[Data] + add r9d, eax + add eax, dword ptr[Data+4] + add r9d, eax + add eax, dword ptr[Data+8] + add r9d, eax + add eax, dword ptr[Data+12] + add r9d, eax + add Data, 16 + {$ifdef win64} + dec r8d + {$else} + dec esi + {$endif} + jnz @by16 +@by4: mov dh, dl + and dl, 15 + jz @0 + shr dl, 2 + jz @rem +@4: add eax, dword ptr[Data] + add r9d, eax + add Data, 4 + dec dl + jnz @4 +@rem: and dh, 3 + jz @0 + dec dh + jz @1 + dec dh + jz @2 + mov ecx, dword ptr[Data] + and ecx, $ffffff + jmp @e +@2: movzx ecx, word ptr[Data] + jmp @e +@1: movzx ecx, byte ptr[Data] +@e: add eax, ecx +@0: add r9d, eax + shl r9d, 16 + xor eax, r9d +@z: +end; +{$else} +{$ifdef PUREPASCAL} +var s1,s2: cardinal; + i: integer; +begin + if Data<>nil then begin + s1 := 0; + s2 := 0; + for i := 1 to Len shr 4 do begin // 16 bytes (128-bit) loop - aligned read + inc(s1,Data[0]); + inc(s2,s1); + inc(s1,Data[1]); + inc(s2,s1); + inc(s1,Data[2]); + inc(s2,s1); + inc(s1,Data[3]); + inc(s2,s1); + Data := @Data[4]; + end; + for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop + inc(s1,Data[0]); + inc(s2,s1); + Data := @Data[1]; + end; + case Len and 3 of // remaining 0..3 bytes + 1: inc(s1,PByte(Data)^); + 2: inc(s1,PWord(Data)^); + 3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16)); + end; + inc(s2,s1); + result := s1 xor (s2 shl 16); + end else + result := 0; +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=Data edx=Len + push esi + push edi + mov cl, dl + mov ch, dl + xor esi, esi + xor edi, edi + test eax, eax + jz @z + shr edx, 4 + jz @by4 + nop +@by16: add esi, dword ptr[eax] + add edi, esi + add esi, dword ptr[eax+4] + add edi, esi + add esi, dword ptr[eax+8] + add edi, esi + add esi, dword ptr[eax+12] + add edi, esi + add eax, 16 + dec edx + jnz @by16 +@by4: and cl, 15 + jz @0 + shr cl, 2 + jz @rem +@4: add esi, dword ptr[eax] + add edi, esi + add eax, 4 + dec cl + jnz @4 +@rem: and ch, 3 + jz @0 + dec ch + jz @1 + dec ch + jz @2 + mov eax, dword ptr[eax] + and eax, $ffffff + jmp @e +@2: movzx eax, word ptr[eax] + jmp @e +@1: movzx eax, byte ptr[eax] +@e: add esi, eax +@0: add edi, esi + mov eax, esi + shl edi, 16 + xor eax, edi +@z: pop edi + pop esi +end; +{$endif PUREPASCAL} +{$endif CPUX64} + +procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); +begin + while size>=SizeOf(PtrInt) do begin + dec(size,SizeOf(PtrInt)); + PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^; + inc(PPtrInt(Dest)); + inc(PPtrInt(Source)); + end; + while size>0 do begin + dec(size); + Dest[size] := Dest[size] or Source[size]; + end; +end; + +procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); +begin + while size>=SizeOf(PtrInt) do begin + dec(size,SizeOf(PtrInt)); + PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^; + inc(PPtrInt(Dest)); + inc(PPtrInt(Source)); + end; + while size>0 do begin + dec(size); + Dest[size] := Dest[size] xor Source[size]; + end; +end; + +procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); +begin + while size>=SizeOf(PtrInt) do begin + dec(size,SizeOf(PtrInt)); + PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^; + inc(PPtrInt(Dest)); + inc(PPtrInt(Source1)); + inc(PPtrInt(Source2)); + end; + while size>0 do begin + dec(size); + Dest[size] := Source1[size] xor Source2[size]; + end; +end; + +procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); +begin + while size>=SizeOf(PtrInt) do begin + dec(size,SizeOf(PtrInt)); + PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^; + inc(PPtrInt(Dest)); + inc(PPtrInt(Source)); + end; + while size>0 do begin + dec(size); + Dest[size] := Dest[size] and Source[size]; + end; +end; + +{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32 + +{$ifdef CPUX86} +function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm + xchg edx, ecx + push ebp + push edi + lea ebp, [ecx+edx] + push esi + push ebx + sub esp, 8 + mov ebx, eax + mov dword ptr [esp], edx + lea eax, [ebx+165667B1H] + cmp edx, 15 + jbe @2 + lea eax, [ebp-10H] + lea edi, [ebx+24234428H] + lea esi, [ebx-7A143589H] + mov dword ptr [esp+4H], ebp + mov edx, eax + lea eax, [ebx+61C8864FH] + mov ebp, edx +@1: mov edx, dword ptr [ecx] + imul edx, -2048144777 + add edi, edx + rol edi, 13 + imul edi, -1640531535 + mov edx, dword ptr [ecx+4] + imul edx, -2048144777 + add esi, edx + rol esi, 13 + imul esi, -1640531535 + mov edx, dword ptr [ecx+8] + imul edx, -2048144777 + add ebx, edx + rol ebx, 13 + imul ebx, -1640531535 + mov edx, dword ptr [ecx+12] + lea ecx, [ecx+16] + imul edx, -2048144777 + add eax, edx + rol eax, 13 + imul eax, -1640531535 + cmp ebp, ecx + jnc @1 + rol edi, 1 + rol esi, 7 + rol ebx, 12 + add esi, edi + mov ebp, dword ptr [esp+4H] + ror eax, 14 + add ebx, esi + add eax, ebx +@2: lea esi, [ecx+4H] + add eax, dword ptr [esp] + cmp ebp, esi + jc @4 + mov ebx, esi + nop +@3: imul edx, dword ptr [ebx-4H], -1028477379 + add ebx, 4 + add eax, edx + ror eax, 15 + imul eax, 668265263 + cmp ebp, ebx + jnc @3 + lea edx, [ebp-4H] + sub edx, ecx + mov ecx, edx + and ecx, 0FFFFFFFCH + add ecx, esi +@4: cmp ebp, ecx + jbe @6 +@5: movzx edx, byte ptr [ecx] + add ecx, 1 + imul edx, 374761393 + add eax, edx + rol eax, 11 + imul eax, -1640531535 + cmp ebp, ecx + jnz @5 + nop +@6: mov edx, eax + add esp, 8 + shr edx, 15 + xor eax, edx + imul eax, -2048144777 + pop ebx + pop esi + mov edx, eax + shr edx, 13 + xor eax, edx + imul eax, -1028477379 + pop edi + pop ebp + mov edx, eax + shr edx, 16 + xor eax, edx +end; +{$endif CPUX86} + +{$ifdef CPUX64} +function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif} + {$ifdef LINUX} // crc=rdi P=rsi len=rdx + mov r8, rdi + mov rcx, rsi + {$else} // crc=r8 P=rcx len=rdx + mov r10, r8 + mov r8, rcx + mov rcx, rdx + mov rdx, r10 + push rsi // Win64 expects those registers to be preserved + push rdi + {$endif} + // P=r8 len=rcx crc=rdx + push r12 + push rbx + mov r12d, -1640531535 + lea r10, [rcx+rdx] + lea eax, [r8+165667B1H] + cmp rdx, 15 + jbe @2 + lea rsi, [r10-10H] + lea ebx, [r8+24234428H] + lea edi, [r8-7A143589H] + lea eax, [r8+61C8864FH] +@1: imul r9d, dword ptr [rcx], -2048144777 + add rcx, 16 + imul r11d, dword ptr [rcx-0CH], -2048144777 + add ebx, r9d + lea r9d, [r11+rdi] + rol ebx, 13 + rol r9d, 13 + imul ebx, r12d + imul edi, r9d, -1640531535 + imul r9d, dword ptr [rcx-8H], -2048144777 + add r8d, r9d + imul r9d, dword ptr [rcx-4H], -2048144777 + rol r8d, 13 + imul r8d, r12d + add eax, r9d + rol eax, 13 + imul eax, r12d + cmp rsi, rcx + jnc @1 + rol edi, 7 + rol ebx, 1 + rol r8d, 12 + mov r9d, edi + ror eax, 14 + add r9d, ebx + add r8d, r9d + add eax, r8d +@2: lea r9, [rcx+4H] + add eax, edx + cmp r10, r9 + jc @4 + mov r8, r9 +@3: imul edx, dword ptr [r8-4H], -1028477379 + add r8, 4 + add eax, edx + ror eax, 15 + imul eax, 668265263 + cmp r10, r8 + jnc @3 + lea rdx, [r10-4H] + sub rdx, rcx + mov rcx, rdx + and rcx, 0FFFFFFFFFFFFFFFCH + add rcx, r9 +@4: cmp r10, rcx + jbe @6 +@5: movzx edx, byte ptr [rcx] + add rcx, 1 + imul edx, 374761393 + add eax, edx + rol eax, 11 + imul eax, r12d + cmp r10, rcx + jnz @5 +@6: mov edx, eax + shr edx, 15 + xor eax, edx + imul eax, -2048144777 + mov edx, eax + shr edx, 13 + xor eax, edx + imul eax, -1028477379 + mov edx, eax + shr edx, 16 + xor eax, edx + pop rbx + pop r12 + {$ifndef LINUX} + pop rdi + pop rsi + {$endif} +end; +{$endif CPUX64} + +{$else not CPUINTEL} + +const + PRIME32_1 = 2654435761; + PRIME32_2 = 2246822519; + PRIME32_3 = 3266489917; + PRIME32_4 = 668265263; + PRIME32_5 = 374761393; + +{$ifdef FPC} // RolDWord is an intrinsic function under FPC :) +function Rol13(value: cardinal): cardinal; inline; +begin + result := RolDWord(value, 13); +end; +{$else} +{$ifdef HASINLINENOTX86} +function RolDWord(value: cardinal; count: integer): cardinal; inline; +begin + result := (value shl count) or (value shr (32-count)); +end; + +function Rol13(value: cardinal): cardinal; inline; +begin + result := (value shl 13) or (value shr 19); +end; +{$else} +function RolDWord(value: cardinal; count: integer): cardinal; +asm + mov cl, dl + rol eax, cl +end; + +function Rol13(value: cardinal): cardinal; +asm + rol eax, 13 +end; +{$endif HASINLINENOTX86} +{$endif FPC} + +function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; +var c1, c2, c3, c4: cardinal; + PLimit, PEnd: PAnsiChar; +begin + PEnd := P + len; + if len >= 16 then begin + PLimit := PEnd - 16; + c3 := crc; + c2 := c3 + PRIME32_2; + c1 := c2 + PRIME32_1; + c4 := c3 - PRIME32_1; + repeat + c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^); + c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^); + c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^); + c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^); + inc(P, 16); + until not (P <= PLimit); + result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); + end else + result := crc + PRIME32_5; + inc(result, len); + while P + 4 <= PEnd do begin + inc(result, PCardinal(P)^ * PRIME32_3); + result := RolDWord(result, 17) * PRIME32_4; + inc(P, 4); + end; + while P < PEnd do begin + inc(result, PByte(P)^ * PRIME32_5); + result := RolDWord(result, 11) * PRIME32_1; + inc(P); + end; + result := result xor (result shr 15); + result := result * PRIME32_2; + result := result xor (result shr 13); + result := result * PRIME32_3; + result := result xor (result shr 16); +end; + +{$endif CPUINTEL} + +type + TRegisters = record + eax,ebx,ecx,edx: cardinal; + end; + +{$ifdef CPUINTEL} +{$ifdef CPU64} +procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // ecx=param, rdx=Registers (Linux: edi,rsi) +{$endif FPC} + mov eax, Param + mov r9, Registers + mov r10, rbx // preserve rbx + xor ebx, ebx + xor ecx, ecx + xor edx, edx + cpuid + mov TRegisters(r9).&eax, eax + mov TRegisters(r9).&ebx, ebx + mov TRegisters(r9).&ecx, ecx + mov TRegisters(r9).&edx, edx + mov rbx, r10 +end; + +{$ifndef ABSOLUTEPASCAL} +const + CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 + _UpperCopy255BufSSE42: array[0..31] of AnsiChar = + 'azazazazazazazaz '; + +function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=dest, rdx=source, r8=len (Linux: rdi,rsi,rdx) +{$endif FPC} + {$ifdef win64} + mov rax, rcx + mov r9, rdx + mov rdx, r8 + {$else} + mov rax, rdi + mov r9, rsi + {$endif} + lea rcx, [rip + _UpperCopy255BufSSE42] + test rdx, rdx + jz @z + movups xmm1, dqword ptr [rcx] + movups xmm3, dqword ptr [rcx + 16] + cmp rdx, 16 + ja @big + // optimize the common case of sourceLen<=16 + movups xmm2, [r9] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 + {$else} + db $66, $0F, $3A, $62, $CA, CMP_RANGES + {$endif} + pand xmm0, xmm3 + pxor xmm2, xmm0 + movups [rax], xmm2 + add rax, rdx +@z: ret +@big: mov rcx, rax + cmp rdx, 240 + jb @ok + mov rdx, 239 +@ok: add rax, rdx // return end position with the exact size + shr rdx, 4 + sub r9, rcx + add rdx, 1 +{$ifdef FPC} align 16 {$else} .align 16{$endif} +@s: movups xmm2, [r9 + rcx] + {$ifdef HASAESNI} + pcmpistrm xmm1, xmm2, CMP_RANGES + {$else} + db $66, $0F, $3A, $62, $CA, CMP_RANGES + {$endif} + pand xmm0, xmm3 + pxor xmm2, xmm0 + movups [rcx], xmm2 + add rcx, 16 + dec rdx + jnz @s +end; + +{$ifdef HASAESNI} +const + EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 + NEGATIVE_POLARITY = 16; + +function StrLenSSE42(S: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + xor rax, rax + mov rdx, S + test S, S + jz @null + xor rcx, rcx + pxor xmm0, xmm0 + pcmpistri xmm0, [rdx], EQUAL_EACH // result in ecx + jnz @L + mov eax, ecx +@null: ret +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@L: add rax, 16 // add before comparison flag + pcmpistri xmm0, [rdx + rax], EQUAL_EACH // result in ecx + jnz @L + add rax, rcx +end; + +function StrCompSSE42(Str1, Str2: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=Str1, rdx=Str2 (Linux: rdi,rsi) +{$endif FPC} + {$ifdef win64} + mov rax, rcx + test rcx, rdx + {$else} + mov rax, rdi + mov rdx, rsi + test rdi, rsi // is one of Str1/Str2 nil ? + {$endif} + jz @n +@ok: sub rax, rdx + xor rcx, rcx + movups xmm0, dqword [rdx] + pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY // result in rcx + ja @1 + jc @2 + xor rax, rax + ret +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@1: add rdx, 16 + movups xmm0, dqword [rdx] + pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY + ja @1 + jc @2 +@0: xor rax, rax // Str1=Str2 + ret +@n: cmp rax, rdx + je @0 + test rax, rax // Str1='' ? + jz @max + test rdx, rdx // Str2='' ? + jnz @ok + mov rax, 1 + ret +@max: dec rax // returns -1 + ret +@2: add rax, rdx + movzx rax, byte ptr [rax + rcx] + movzx rdx, byte ptr [rdx + rcx] + sub rax, rdx +end; +{$endif HASAESNI} +{$endif ABSOLUTEPASCAL} + +function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,edx) +{$endif FPC} + mov eax, crc + not eax + test len, len + jz @0 + test buf, buf + jz @0 + jmp @align +@7: crc32 eax, byte ptr[buf] + inc buf + dec len + jz @0 +@align: test buf, 7 + jnz @7 + mov ecx, len + shr len, 3 + jnz @s +@2: test cl, 4 + jz @3 + crc32 eax, dword ptr[buf] + add buf, 4 +@3: test cl, 2 + jz @1 + crc32 eax, word ptr[buf] + add buf, 2 +@1: test cl, 1 + jz @0 + crc32 eax, byte ptr[buf] +@0: not eax + ret +{$ifdef FPC} align 16 +@s: crc32 rax, qword [buf] // hash 8 bytes per loop +{$else} .align 16 +@s: db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug +{$endif}add buf, 8 + dec len + jnz @s + jmp @2 +end; + +function StrLenSSE2(S: pointer): PtrInt; +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=S (Linux: rdi) +{$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize + {$ifdef win64} + mov rax, rcx // get pointer to string from rcx + mov r8, rcx // copy pointer + test rcx, rcx + {$else} + mov rax, rdi + mov ecx, edi + test rdi, rdi + {$endif} + jz @null // returns 0 if S=nil + // rax=s,ecx=32-bit of s + pxor xmm0, xmm0 // set to zero + and ecx, 15 // lower 4 bits indicate misalignment + and rax, -16 // align pointer by 16 + // will never read outside a memory page boundary, so won't trigger GPF + movaps xmm1, [rax] // read from nearest preceding boundary + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + shr edx, cl // shift out false bits + shl edx, cl // shift back again + bsf edx, edx // find first 1-bit + jnz @L2 // found + // Main loop, search 16 bytes at a time +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@L1: add rax, 10H // increment pointer by 16 + movaps xmm1, [rax] // read 16 bytes aligned + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + bsf edx, edx // find first 1-bit + // (moving the bsf out of the loop and using test here would be faster + // for long strings on old processors, but we are assuming that most + // strings are short, and newer processors have higher priority) + jz @L1 // loop if not found +@L2: // Zero-byte found. Compute string length + {$ifdef win64} + sub rax, r8 // subtract start address + {$else} + sub rax, rdi + {$endif} + add rax, rdx // add byte index +@null: +end; + +{$endif CPU64} + +procedure crcblockssse42(crc128, data128: PBlock128; count: integer); +{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe {$endif FPC} + test count, count + jle @z + mov rax, data128 + {$ifdef win64} + mov rdx, rcx + mov ecx, r8d + {$else} + mov ecx, edx + mov rdx, rdi + {$endif win64} + mov r8d, dword ptr [rdx] // we can't use qword ptr here + mov r9d, dword ptr [rdx + 4] + mov r10d, dword ptr [rdx + 8] + mov r11d, dword ptr [rdx + 12] +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@s: crc32 r8d, dword ptr [rax] + crc32 r9d, dword ptr [rax + 4] + crc32 r10d, dword ptr [rax + 8] + crc32 r11d, dword ptr [rax + 12] + add rax, 16 + dec ecx + jnz @s + mov dword ptr [rdx], r8d + mov dword ptr [rdx + 4], r9d + mov dword ptr [rdx + 8], r10d + mov dword ptr [rdx + 12], r11d +@z: +end; +{$else} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // eax=crc128 edx=data128 ecx=count + push ebx + push esi + push edi + push ebp + test count, count + jle @z + mov ebp, count + mov esi, crc128 + mov edi, data128 + mov eax, dword ptr[esi] + mov ebx, dword ptr[esi + 4] + mov ecx, dword ptr[esi + 8] + mov edx, dword ptr[esi + 12] +{$ifdef FPC_X86ASM} align 8 +@s: crc32 eax, dword ptr[edi] + crc32 ebx, dword ptr[edi + 4] + crc32 ecx, dword ptr[edi + 8] + crc32 edx, dword ptr[edi + 12] +{$else}@s:db $F2, $0F, $38, $F1, $07 + db $F2, $0F, $38, $F1, $5F, $04 + db $F2, $0F, $38, $F1, $4F, $08 + db $F2, $0F, $38, $F1, $57, $0C +{$endif} add edi, 16 + dec ebp + jnz @s + mov dword ptr[esi], eax + mov dword ptr[esi + 4], ebx + mov dword ptr[esi + 8], ecx + mov dword ptr[esi + 12], edx +@z: pop ebp + pop edi + pop esi + pop ebx +end; +{$endif CPUX64} +{$endif CPUINTEL} + +procedure crcblocksfast(crc128, data128: PBlock128; count: integer); +{$ifdef PUREPASCAL} // efficient registers use on 64-bit, ARM or PIC +var c: cardinal; + tab: PCrc32tab; +begin + tab := @crc32ctab; + if count>0 then + repeat + c := crc128^[0] xor data128^[0]; + crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[1] xor data128^[1]; + crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[2] xor data128^[2]; + crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + c := crc128^[3] xor data128^[3]; + crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] + xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; + inc(data128); + dec(count); + until count=0; +end; +{$else} // call optimized x86 asm within the loop +begin + while count>0 do begin + crcblockNoSSE42(crc128,data128); + inc(data128); + dec(count); + end; +end; +{$endif PUREPASCAL} + +{$ifdef CPUINTEL} +function crc32cBy4SSE42(crc, value: cardinal): cardinal; +{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe {$endif FPC} + mov eax, crc + crc32 eax, value +end; +{$else} {$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=crc, edx=value + {$ifdef FPC_X86ASM} + crc32 eax, edx + {$else} + db $F2, $0F, $38, $F1, $C2 + {$endif} +end; +{$endif CPU64} + +procedure crcblockSSE42(crc128, data128: PBlock128); +{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=crc128, rdx=data128 (Linux: rdi,rsi) +{$endif FPC} + mov eax, dword ptr[crc128] // we can't use two qword ptr here + mov r8d, dword ptr[crc128 + 4] + mov r9d, dword ptr[crc128 + 8] + mov r10d, dword ptr[crc128 + 12] + crc32 eax, dword ptr[data128] + crc32 r8d, dword ptr[data128 + 4] + crc32 r9d, dword ptr[data128 + 8] + crc32 r10d, dword ptr[data128 + 12] + mov dword ptr[crc128], eax + mov dword ptr[crc128 + 4], r8d + mov dword ptr[crc128 + 8], r9d + mov dword ptr[crc128 + 12], r10d +end; +{$else} {$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=crc128, edx=data128 + mov ecx, eax + {$ifdef FPC_X86ASM} + mov eax, dword ptr[ecx] + crc32 eax, dword ptr[edx] + mov dword ptr[ecx], eax + mov eax, dword ptr[ecx + 4] + crc32 eax, dword ptr[edx + 4] + mov dword ptr[ecx + 4], eax + mov eax, dword ptr[ecx + 8] + crc32 eax, dword ptr[edx + 8] + mov dword ptr[ecx + 8], eax + mov eax, dword ptr[ecx + 12] + crc32 eax, dword ptr[edx + 12] + mov dword ptr[ecx + 12], eax + {$else} + mov eax, dword ptr[ecx] + db $F2, $0F, $38, $F1, $02 + mov dword ptr[ecx], eax + mov eax, dword ptr[ecx + 4] + db $F2, $0F, $38, $F1, $42, $04 + mov dword ptr[ecx + 4], eax + mov eax, dword ptr[ecx + 8] + db $F2, $0F, $38, $F1, $42, $08 + mov dword ptr[ecx + 8], eax + mov eax, dword ptr[ecx + 12] + db $F2, $0F, $38, $F1, $42, $0C + mov dword ptr[ecx + 12], eax + {$endif FPC_OR_UNICODE} +end; +{$endif CPU64} +{$endif CPUINTEL} + +function crc32cBy4fast(crc, value: cardinal): cardinal; +var tab: PCrc32tab; +begin + tab := @crc32ctab; + result := crc xor value; + result := tab[3,ToByte(result)] xor + tab[2,ToByte(result shr 8)] xor + tab[1,ToByte(result shr 16)] xor + tab[0,ToByte(result shr 24)]; +end; + +function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$ifdef HASINLINE} +var tab: PCrc32tab; +begin + result := not crc; + if len>0 then begin + tab := @crc32ctab; + repeat + result := tab[0,ToByte(result) xor ord(buf^)] xor (result shr 8); + inc(buf); + dec(len); + until len=0; + end; + result := not result; +end; +{$else} +begin + result := crc32c(crc,buf,len); +end; +{$endif} + +{$ifdef CPUX86} +procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); +{$ifdef FPC}nostackframe; assembler;{$endif} +asm + push esi + push edi + mov esi, edx + mov edi, eax + pushfd + pop eax + mov edx, eax + xor eax, $200000 + push eax + popfd + pushfd + pop eax + xor eax, edx + jz @nocpuid + push ebx + mov eax, edi + xor ecx, ecx + {$ifdef DELPHI5OROLDER} + db $0f, $a2 + {$else} + cpuid + {$endif} + mov TRegisters(esi).&eax, eax + mov TRegisters(esi).&ebx, ebx + mov TRegisters(esi).&ecx, ecx + mov TRegisters(esi).&edx, edx + pop ebx +@nocpuid: + pop edi + pop esi +end; + +function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; +{$ifdef FPC}nostackframe; assembler;{$endif} +asm // eax=crc, edx=buf, ecx=len + not eax + test ecx, ecx + jz @0 + test edx, edx + jz @0 + jmp @align + db $8D, $0B4, $26, $00, $00, $00, $00 // manual @by8 align 16 +@a: {$ifdef FPC_X86ASM} + crc32 eax, byte ptr[edx] + {$else} + db $F2, $0F, $38, $F0, $02 + {$endif} + inc edx + dec ecx + jz @0 +@align: test dl, 3 + jnz @a + push ecx + shr ecx, 3 + jnz @by8 +@rem: pop ecx + test cl, 4 + jz @4 + {$ifdef FPC_X86ASM} + crc32 eax, dword ptr[edx] + {$else} + db $F2, $0F, $38, $F1, $02 + {$endif} + add edx, 4 +@4: test cl, 2 + jz @2 + {$ifdef FPC_X86ASM} + crc32 eax, word ptr[edx] + {$else} + db $66, $F2, $0F, $38, $F1, $02 + {$endif} + add edx, 2 +@2: test cl, 1 + jz @0 + {$ifdef FPC_X86ASM} + crc32 eax, byte ptr[edx] + {$else} + db $F2, $0F, $38, $F0, $02 + {$endif} +@0: not eax + ret +@by8: {$ifdef FPC_X86ASM} + crc32 eax, dword ptr[edx] + crc32 eax, dword ptr[edx + 4] + {$else} + db $F2, $0F, $38, $F1, $02 + db $F2, $0F, $38, $F1, $42, $04 + {$endif} + add edx, 8 + dec ecx + jnz @by8 + jmp @rem +end; +{$endif CPUX86} + +function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; +begin + result := CardinalToHex(crc32c(0,pointer(str),length(str))); +end; + +function crc64c(buf: PAnsiChar; len: cardinal): Int64; +var hilo: Int64Rec absolute result; +begin + hilo.Lo := crc32c(0,buf,len); + hilo.Hi := crc32c(hilo.Lo,buf,len); +end; + +function crc63c(buf: PAnsiChar; len: cardinal): Int64; +var hilo: Int64Rec absolute result; +begin + hilo.Lo := crc32c(0,buf,len); + hilo.Hi := crc32c(hilo.Lo,buf,len) and $7fffffff; +end; + +procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); +var h: THash128Rec absolute crc; + h1,h2: cardinal; +begin // see https://goo.gl/Pls5wi + h1 := crc32c(0,buf,len); + h2 := crc32c(h1,buf,len); + h.i0 := h1; inc(h1,h2); + h.i1 := h1; inc(h1,h2); + h.i2 := h1; inc(h1,h2); + h.i3 := h1; +end; + +function IsZero(const dig: THash128): boolean; +var a: TPtrIntArray absolute dig; +begin + result := a[0] or a[1] {$ifndef CPU64}or a[2] or a[3]{$endif} = 0; +end; + +function IsEqual(const A,B: THash128): boolean; +var a_: TPtrIntArray absolute A; + b_: TPtrIntArray absolute B; +begin // uses anti-forensic time constant "xor/or" pattern + result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) + {$ifndef CPU64} or (a_[2] xor b_[2]) or (a_[3] xor b_[3]){$endif})=0; +end; + +procedure FillZero(out dig: THash128); +var d: TInt64Array absolute dig; +begin + d[0] := 0; + d[1] := 0; +end; + +function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; +{$ifdef CPU64} +var _0, _1: PtrInt; +begin + if P<>nil then begin + _0 := h^.Lo; + _1 := h^.Hi; + for result := 0 to Count-1 do + if (P^.Lo=_0) and (P^.Hi=_1) then + exit else + inc(P); + end; + result := -1; // not found +end; +{$else} +begin // fast O(n) brute force search + if P<>nil then + for result := 0 to Count-1 do + if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) then + exit else + inc(P); + result := -1; // not found +end; +{$endif CPU64} + +function IP4Text(ip4: cardinal): shortstring; +var b: array[0..3] of byte absolute ip4; +begin + if ip4=0 then + result := '' else + FormatShort('%.%.%.%',[b[0],b[1],b[2],b[3]],result); +end; + +procedure IP6Text(ip6: PHash128; result: PShortString); +var i: integer; + p: PByte; + {$ifdef PUREPASCAL}tab: ^TByteToWord;{$endif} +begin + if IsZero(ip6^) then + result^ := '' else begin + result^[0] := AnsiChar(39); + p := @result^[1]; + {$ifdef PUREPASCAL}tab := @TwoDigitsHexWBLower;{$endif} + for i := 0 to 7 do begin + PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[0]]; inc(p,2); + PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[1]]; inc(p,2); + inc(PWord(ip6)); + p^ := ord(':'); inc(p); + end; + end; +end; + +function IP6Text(ip6: PHash128): shortstring; +begin + IP6Text(ip6, @result); +end; + +function IsZero(const dig: THash160): boolean; +var a: TIntegerArray absolute dig; +begin + result := a[0] or a[1] or a[2] or a[3] or a[4] = 0; +end; + +function IsEqual(const A,B: THash160): boolean; +var a_: TIntegerArray absolute A; + b_: TIntegerArray absolute B; +begin // uses anti-forensic time constant "xor/or" pattern + result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or + (a_[3] xor b_[3]) or (a_[4] xor b_[4]))=0; +end; + +procedure FillZero(out dig: THash160); +begin + PInt64Array(@dig)^[0] := 0; + PInt64Array(@dig)^[1] := 0; + PIntegerArray(@dig)^[4] := 0; +end; + +procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); +var h: THash256Rec absolute crc; + h1,h2: cardinal; +begin // see https://goo.gl/Pls5wi + h1 := crc32c(0,buf,len); + h2 := crc32c(h1,buf,len); + h.i0 := h1; inc(h1,h2); + h.i1 := h1; inc(h1,h2); + h.i2 := h1; inc(h1,h2); + h.i3 := h1; inc(h1,h2); + h.i4 := h1; inc(h1,h2); + h.i5 := h1; inc(h1,h2); + h.i6 := h1; inc(h1,h2); + h.i7 := h1; +end; + +function IsZero(const dig: THash256): boolean; +var a: TPtrIntArray absolute dig; +begin + result := a[0] or a[1] or a[2] or a[3] + {$ifndef CPU64} or a[4] or a[5] or a[6] or a[7]{$endif} = 0; +end; + +function IsEqual(const A,B: THash256): boolean; +var a_: TPtrIntArray absolute A; + b_: TPtrIntArray absolute B; +begin // uses anti-forensic time constant "xor/or" pattern + result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or + (a_[2] xor b_[2]) or (a_[3] xor b_[3]) + {$ifndef CPU64} or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) + or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif})=0; +end; + +function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; +{$ifdef CPU64} +var _0, _1: PtrInt; +begin // fast O(n) brute force search + if P<>nil then begin + _0 := h^.d0; + _1 := h^.d1; + for result := 0 to Count-1 do + if (P^.d0=_0) and (P^.d1=_1) and (P^.d2=h^.d2) and (P^.d3=h^.d3) then + exit else + inc(P); + end; + result := -1; // not found +end; +{$else} +begin + if P<>nil then + for result := 0 to Count-1 do + if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) and + (P^.i4=h^.i4) and (P^.i5=h^.i5) and (P^.i6=h^.i6) and (P^.i7=h^.i7) then + exit else + inc(P); + result := -1; // not found +end; +{$endif CPU64} + +procedure FillZero(out dig: THash256); +var d: TInt64Array absolute dig; +begin + d[0] := 0; + d[1] := 0; + d[2] := 0; + d[3] := 0; +end; + +function IsZero(const dig: THash384): boolean; +var a: TPtrIntArray absolute dig; +begin + result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] + {$ifndef CPU64} or a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif} = 0; +end; + +function IsEqual(const A,B: THash384): boolean; +var a_: TPtrIntArray absolute A; + b_: TPtrIntArray absolute B; +begin // uses anti-forensic time constant "xor/or" pattern + result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or + (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or + (a_[4] xor b_[4]) or (a_[5] xor b_[5]) + {$ifndef CPU64} or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) + or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) + or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif})=0; +end; + +procedure FillZero(out dig: THash384); +var d: TInt64Array absolute dig; +begin + d[0] := 0; + d[1] := 0; + d[2] := 0; + d[3] := 0; + d[4] := 0; + d[5] := 0; +end; + +function IsZero(const dig: THash512): boolean; +var a: TPtrIntArray absolute dig; +begin + result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifndef CPU64} + or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif} = 0; +end; + +function IsEqual(const A,B: THash512): boolean; +var a_: TPtrIntArray absolute A; + b_: TPtrIntArray absolute B; +begin // uses anti-forensic time constant "xor/or" pattern + result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or + (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or + (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or + (a_[6] xor b_[6]) or (a_[7] xor b_[7]) + {$ifndef CPU64} or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) + or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) + or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) + or (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif})=0; +end; + +procedure FillZero(out dig: THash512); +var d: TInt64Array absolute dig; +begin + d[0] := 0; + d[1] := 0; + d[2] := 0; + d[3] := 0; + d[4] := 0; + d[5] := 0; + d[6] := 0; + d[7] := 0; +end; + +procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); +var h: THash512Rec absolute crc; + h1,h2: cardinal; +begin // see https://goo.gl/Pls5wi + h1 := crc32c(0,buf,len); + h2 := crc32c(h1,buf,len); + h.i0 := h1; inc(h1,h2); + h.i1 := h1; inc(h1,h2); + h.i2 := h1; inc(h1,h2); + h.i3 := h1; inc(h1,h2); + h.i4 := h1; inc(h1,h2); + h.i5 := h1; inc(h1,h2); + h.i6 := h1; inc(h1,h2); + h.i7 := h1; inc(h1,h2); + h.i8 := h1; inc(h1,h2); + h.i9 := h1; inc(h1,h2); + h.i10 := h1; inc(h1,h2); + h.i11 := h1; inc(h1,h2); + h.i12 := h1; inc(h1,h2); + h.i13 := h1; inc(h1,h2); + h.i14 := h1; inc(h1,h2); + h.i15 := h1; +end; + +procedure FillZero(var secret: RawByteString); +begin + if secret<>'' then + with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do + if refCnt=1 then // avoid GPF if const + FillCharFast(pointer(secret)^,length,0); +end; + +procedure FillZero(var secret: RawUTF8); +begin + if secret<>'' then + with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do + if refCnt=1 then // avoid GPF if const + FillCharFast(pointer(secret)^,length,0); +end; + +procedure mul64x64(const left, right: QWord; out product: THash128Rec); +{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx/rdi=left, rdx/rsi=right r8/rdx=product +{$endif}{$ifdef WIN64} + mov rax, rcx + mul rdx // uses built-in 64-bit -> 128-bit multiplication +{$else} mov r8, rdx + mov rax, rdi + mul rsi +{$endif}mov qword ptr [r8], rax + mov qword ptr [r8+8], rdx +end; +{$else} +{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif} +asm // adapted from FPC compiler output, which is much better than Delphi's here + {$ifdef FPC} + push ebp + mov ebp, esp + {$endif FPC} + mov ecx, eax + mov eax, dword ptr [ebp+8H] + mul dword ptr [ebp+10H] + mov dword ptr [ecx], eax + mov dword ptr [ebp-4H], edx + mov eax, dword ptr [ebp+8H] + mul dword ptr [ebp+14H] + add eax, dword ptr [ebp-4H] + adc edx, 0 + mov dword ptr [ebp-10H], eax + mov dword ptr [ebp-0CH], edx + mov eax, dword ptr [ebp+0CH] + mul dword ptr [ebp+10H] + add eax, dword ptr [ebp-10H] + adc edx, 0 + mov dword ptr [ecx+4H], eax + mov dword ptr [ebp-14H], edx + mov eax, dword ptr [ebp+0CH] + mul dword ptr [ebp+14H] + add eax, dword ptr [ebp-0CH] + adc edx, 0 + add eax, dword ptr [ebp-14H] + adc edx, 0 + mov dword ptr [ecx+8H], eax + mov dword ptr [ecx+0CH], edx + {$ifdef FPC} + pop ebp + {$endif FPC} +end; +{$else} // CPU-neutral implementation +var l: TQWordRec absolute left; + r: TQWordRec absolute right; + t1,t2,t3: TQWordRec; +begin + t1.V := QWord(l.L)*r.L; + t2.V := QWord(l.H)*r.L+t1.H; + t3.V := QWord(l.L)*r.H+t2.L; + product.H := QWord(l.H)*r.H+t2.H+t3.H; + product.L := t3.V shl 32 or t1.L; +end; +{$endif CPUX86} +{$endif CPUX64} + +{$ifndef ABSOLUTEPASCAL} +{$ifdef CPUX64} +const + // non-temporal writes should bypass the cache when the size is bigger than + // half the size of the largest level cache - we assume low 1MB cache here + CPUCACHEX64 = 512*1024; + +{ + regarding benchmark numbers from TTestLowLevelCommon.CustomRTL + -> FillCharFast/MoveFast are faster, especially for small lengths (strings) + -> Delphi RTL is lower than FPC's, and it doesn't support AVX assembly yet + -> cpuERMS - of little benefit - is disabled, unless WITH_ERMS is defined + http://blog.synopse.info/post/2020/02/17/New-move/fillchar-optimized-sse2/avx-asm-version +} + +// these stand-alone functions will use CPUIDX64 to adjust the algorithm +procedure MoveFast(const src; var dst; cnt: PtrInt); +{$ifdef FPC}nostackframe; assembler; +asm {$else} asm .noframe {$endif} // rcx/rdi=src rdx/rsi=dst r8/rdx=cnt + {$ifdef WIN64} + mov rax, r8 + {$else} + mov rax, rdx // rax=r8=cnt + mov r8, rdx + {$endif} + lea r10, [rip+@jmptab] + cmp src, dst + je @equal + cmp cnt, 32 + ja @lrg // >32 or <0 + sub rax, 8 + jg @sml // 9..32 + jmp qword ptr[r10 + 64 + rax * 8] // 0..8 +@equal: ret +{$ifdef FPC} align 8 {$else} .align 8 {$endif} +@jmptab:dq @exit, @01, @02, @03, @04, @05, @06, @07, @08 +@sml: mov r8, qword ptr[src + rax] // last 8 + mov r9, qword ptr[src] // first 8 + cmp al, 8 + jle @sml16 + mov r10, qword ptr[src + 8] // second 8 + cmp al, 16 + jle @sml24 + mov r11, qword ptr[src + 16] // third 8 + mov qword ptr[dst + 16], r11 // third 8 +@sml24: mov qword ptr[dst + 8], r10 // second 8 +@sml16: mov qword ptr[dst], r9 // first 8 + mov qword ptr[dst + rax], r8 // last 8 (may be overlapping) + ret +@02: movzx eax, word ptr[src] // use small size moves as code alignment + mov word ptr[dst], ax + ret +@04: mov eax, [src] + mov dword ptr[dst], eax + ret +@08: mov rax, [src] + mov [dst], rax +@exit: ret +@lrg: jng @exit // cnt < 0 + cmp src, dst + ja @lrgfwd + sub dst, rax + cmp src, dst + lea dst, [dst + rax] + ja @lrgbwd +@lrgfwd:{$ifdef WITH_ERMS} + test byte ptr[rip+CPUIDX64], 1 shl cpuERMS + jz @nofwe + cmp rax, 2048 + jb @nofwe + cld +@repmov:{$ifdef WIN64} + push rsi + push rdi + mov rsi, src + mov rdi, dst + mov rcx, r8 + rep movsb + pop rdi + pop rsi + {$else} + mov rax, dst // dst=rsi and src=rdi -> rax to swap + mov rsi, src + mov rdi, rax + mov rcx, r8 + rep movsb + {$endif} + ret +@nofwe: {$endif WITH_ERMS} + mov r9, dst + {$ifdef FPC} // no AVX asm on Delphi :( + cmp rax, 256 // vzeroupper penaly for cnt>255 + jb @fsse2 + test byte ptr[rip+CPUIDX64], 1 shl cpuAVX + jnz @fwdavx + {$endif FPC} +@fsse2: movups xmm2, oword ptr[src] // first 16 + lea src, [src + rax - 16] + lea rax, [rax + dst - 16] + movups xmm1, oword ptr[src] // last 16 + mov r10, rax + neg rax + and dst, -16 // 16-byte aligned writes + lea rax, [rax + dst + 16] + cmp r8, CPUCACHEX64 + ja @fwdnv // bypass cache for cnt>512KB +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@fwd: movups xmm0, oword ptr[src + rax] // regular loop + movaps [r10 + rax], xmm0 + add rax, 16 + jl @fwd +@fwdend:movups [r10], xmm1 // last 16 + movups [r9], xmm2 // first 16 + ret +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@fwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop + movntdq [r10 + rax], xmm0 + add rax, 16 + jl @fwdnv + sfence + jmp @fwdend +{$ifdef FPC} +@fwdavx:vmovups ymm2, oword ptr[src] // first 32 + lea src, [src + rax - 32] + lea rax, [rax + dst - 32] + vmovups ymm1, oword ptr[src] // last 32 + mov r10, rax + neg rax + and dst, -32 // 32-byte aligned writes + lea rax, [rax + dst + 32] + cmp r8, CPUCACHEX64 + ja @favxn // bypass cache for cnt>512KB + align 16 +@favxr: vmovups ymm0, oword ptr[src + rax] // regular loop + vmovaps [r10 + rax], ymm0 + add rax, 32 + jl @favxr +@favxe: vmovups [r10], ymm1 // last 32 + vmovups [r9], ymm2 // first 32 +// https://software.intel.com/en-us/articles/avoiding-avx-sse-transition-penalties + vzeroupper + ret + align 16 +@favxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop + vmovntps [r10 + rax], ymm0 + add rax, 32 + jl @favxn + sfence + jmp @favxe +{$endif FPC} +@lrgbwd:{$ifdef WITH_ERMS} // backward move + test byte ptr[rip+CPUIDX64], 1 shl cpuERMS + jz @nobwe + cmp rax, 2048 + jb @nobwe + std + lea src, [src + rax - 1] + lea dst, [dst + rax - 1] + jmp @repmov +@nobwe: {$endif WITH_ERMS} + {$ifdef FPC} + cmp rax, 256 + jb @bsse2 + test byte ptr[rip+CPUIDX64], 1 shl cpuAVX + jnz @bwdavx + {$endif FPC} +@bsse2: sub rax, 16 + mov r9, rax + movups xmm2, oword ptr[src + rax] // last 16 + movups xmm1, oword ptr[src] // first 16 + add rax, dst + and rax, -16 // 16-byte aligned writes + sub rax, dst + cmp r8, CPUCACHEX64 + ja @bwdnv // bypass cache for cnt>512KB +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@bwd: movups xmm0, oword ptr[src + rax] // regular loop + movaps oword ptr[dst + rax], xmm0 + sub rax, 16 + jg @bwd +@bwdend:movups oword ptr[dst], xmm1 // first 16 + movups oword ptr[dst + r9], xmm2 // last 16 + ret +@01: mov al, byte ptr[src] + mov byte ptr[dst], al + ret +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@bwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop + movntdq oword ptr[dst + rax], xmm0 + sub rax, 16 + jg @bwdnv + sfence + jmp @bwdend +{$ifdef FPC} +@bwdavx:sub rax, 32 + mov r9, rax + vmovups ymm2, oword ptr[src + rax] // last 32 + vmovups ymm1, oword ptr[src] // first 32 + add rax, dst + and rax, -32 // 32-byte aligned writes + sub rax, dst + cmp r8, CPUCACHEX64 + ja @bavxn // bypass cache for cnt>512KB + align 16 +@bavxr: vmovups ymm0, oword ptr[src + rax] // regular loop + vmovaps oword ptr[dst + rax], ymm0 + sub rax, 32 + jg @bavxr +@bavxe: vmovups oword ptr[dst], ymm1 // first 32 + vmovups oword ptr[dst + r9], ymm2 // last 32 + vzeroupper + ret + align 16 +@bavxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop + vmovntps oword ptr[dst + rax], ymm0 + sub rax, 32 + jg @bavxn + sfence + jmp @bavxe +{$endif FPC} +@03: movzx eax, word ptr[src] + mov cl, byte ptr[src + 2] + mov word ptr[dst], ax + mov byte ptr[dst + 2], cl + ret +@05: mov eax, dword ptr[src] + mov cl, byte ptr[src + 4] + mov dword ptr[dst], eax + mov byte ptr[dst + 4], cl + ret +@06: mov eax, dword ptr[src] + mov cx, word ptr[src + 4] + mov dword ptr[dst], eax + mov word ptr[dst + 4], cx + ret +@07: mov r8d, dword ptr[src] // faster with no overlapping + mov ax, word ptr[src + 4] + mov cl, byte ptr[src + 6] + mov dword ptr[dst], r8d + mov word ptr[dst + 4], ax + mov byte ptr[dst + 6], cl +end; + +procedure FillCharFast(var dst; cnt: PtrInt; value: byte); +{$ifdef FPC}nostackframe; assembler; +asm {$else} asm .noframe {$endif} // rcx/rdi=dst rdx/rsi=cnt r8b/dl=val + mov r9, $0101010101010101 + lea r10, [rip+@jmptab] + {$ifdef WIN64} + movzx eax, r8b + {$else} + movzx eax, dl + mov rdx, rsi // rdx=cnt + {$endif} + imul rax, r9 // broadcast value into all bytes of rax (in 1 cycle) + cmp cnt, 32 + ja @abv32 // >32 or <0 + sub rdx, 8 + jg @sml // small 9..32 + jmp qword ptr[r10 + 64 + rdx*8] // tiny 0..8 bytes +{$ifdef FPC} align 8 {$else} .align 8 {$endif} +@jmptab:dq @00, @01, @02, @03, @04, @05, @06, @07, @08 +@sml: cmp dl, 8 // 9..32 bytes + jle @sml16 + cmp dl, 16 + jle @sml24 + mov qword ptr[dst+16], rax +@sml24: mov qword ptr[dst+8], rax +@sml16: mov qword ptr[dst+rdx], rax // last 8 (may be overlapping) +@08: mov qword ptr[dst], rax +@00: ret +@07: mov dword ptr[dst+3], eax +@03: mov word ptr[dst+1], ax +@01: mov byte ptr[dst], al + ret +@06: mov dword ptr[dst+2], eax +@02: mov word ptr[dst], ax + ret +@05: mov byte ptr[dst+4], al +@04: mov dword ptr[dst], eax + ret +{$ifdef FPC} align 8{$else} .align 8{$endif} +@abv32: jng @00 // < 0 + movd xmm0, eax + lea r8, [dst+cnt] // r8 point to end + pshufd xmm0, xmm0, 0 // broadcast value into all bytes of xmm0 + mov r10, rdx // save rdx=cnt + {$ifdef FPC} // Delphi doesn't support avx, and erms is slower + cmp rdx, 256 + jae @abv256 // try erms or avx if cnt>255 (vzeroupper penalty) + {$endif FPC} +@sse2: movups oword ptr[dst], xmm0 // first unaligned 16 bytes + lea rdx, [dst+rdx-1] + and rdx, -16 + add dst, 16 + and dst, -16 // dst is 16-bytes aligned + sub dst, rdx + jnb @last + cmp r10, CPUCACHEX64 + ja @nv // bypass cache for cnt>512KB +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@reg: movaps oword ptr[rdx+dst], xmm0 // regular loop + add dst, 16 + jnz @reg +@last: movups oword ptr[r8-16], xmm0 // last unaligned 16 bytes + ret +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@nv: movntdq [rdx+dst], xmm0 // non-temporal loop + add dst, 16 + jnz @nv + sfence + movups oword ptr[r8-16], xmm0 + ret +{$ifdef FPC} +@abv256:{$ifdef WITH_ERMS} + mov r9b, byte ptr[rip+CPUIDX64] + test r9b, 1 shl cpuERMS + jz @noerms + cmp rdx, 2048 // ERMS is worth it for cnt>2KB + jb @noerms + cmp rdx, CPUCACHEX64 // non-temporal moves are still faster + jae @noerms + cld +{$ifdef WIN64} + mov r8, rdi + mov rdi, dst + mov rcx, cnt + rep stosb + mov rdi, r8 +{$else} mov rcx, cnt + rep stosb +{$endif}ret +@noerms:test r9b, 1 shl cpuAVX +{$else} test byte ptr[rip+CPUIDX64], 1 shl cpuAVX + {$endif WITH_ERMS} + jz @sse2 + movups oword ptr[dst], xmm0 // first unaligned 1..16 bytes + add dst, 16 + and dst, -16 + movaps oword ptr[dst], xmm0 // aligned 17..32 bytes + vinsertf128 ymm0,ymm0,xmm0,1 + add dst, 16 + and dst, -32 // dst is 32-bytes aligned + mov rdx, r8 + and rdx, -32 + sub dst, rdx + cmp r10, CPUCACHEX64 + ja @avxnv + align 16 +@avxreg:vmovaps ymmword ptr[rdx+dst], ymm0 // regular loop + add dst, 32 + jnz @avxreg +@avxok: vmovups oword ptr[r8-32], ymm0 // last unaligned 32 bytes + vzeroupper + ret + align 16 +@avxnv: vmovntps oword ptr [rdx+dst], ymm0 // non-temporal loop + add dst, 32 + jnz @avxnv + sfence + jmp @avxok +{$endif FPC} +end; +{$endif CPUX64} +{$endif ABSOLUTEPASCAL} + +procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); +var i,len: integer; + d: PCardinal; + tab: PCrc32tab; +begin + if data='' then + exit; // nothing to cypher + tab := @crc32ctab; + {$ifdef FPC} + UniqueString(data); // @data[1] won't call UniqueString() under FPC :( + {$endif} + d := @data[1]; + len := length(data); + key := key xor cardinal(len); + for i := 0 to (len shr 2)-1 do begin + key := key xor tab[0,(cardinal(i) xor key)and 1023]; + d^ := d^ xor key; + inc(d); + end; + for i := 0 to (len and 3)-1 do + PByteArray(d)^[i] := PByteArray(d)^[i] xor key xor tab[0,17 shl i]; +end; + +function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; +begin + result := UnixTime / SecsPerDay + UnixDateDelta; +end; + +function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; +begin + result := Round((AValue - UnixDateDelta) * SecsPerDay); +end; + +const + UnixFileTimeDelta = 116444736000000000; // from year 1601 to 1970 + DateFileTimeDelta = 94353120000000000; // from year 1601 to 1899 + +{$ifdef MSWINDOWS} +function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; +{$ifdef CPU64}var nano100: Int64;{$endif} +begin + {$ifdef CPU64} + FileTimeToInt64(ft,nano100); + result := (nano100-UnixFileTimeDelta) div 10000000; + {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix + result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000000; + {$endif} +end; + +function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; +{$ifdef CPU64}var nano100: Int64;{$endif} +begin + {$ifdef CPU64} + FileTimeToInt64(ft,nano100); + result := (nano100-UnixFileTimeDelta) div 10000; + {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix + result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000; + {$endif} +end; + +function UnixTimeUTC: TUnixTime; +var ft: TFileTime; +begin + GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit + result := FileTimeToUnixTime(ft); +end; + +function UnixMSTimeUTC: TUnixMSTime; +var ft: TFileTime; +begin + GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution + result := FileTimeToUnixMSTime(ft); +end; + +function UnixMSTimeUTCFast: TUnixMSTime; +var ft: TFileTime; +begin + GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution + result := FileTimeToUnixMSTime(ft); +end; +{$else MSWINDOWS} +function UnixTimeUTC: TUnixTime; +begin + result := GetUnixUTC; // direct retrieval from UNIX API +end; + +function UnixMSTimeUTC: TUnixMSTime; +begin + result := GetUnixMSUTC; // direct retrieval from UNIX API +end; + +function UnixMSTimeUTCFast: TUnixMSTime; +begin + result := GetUnixMSUTC; // direct retrieval from UNIX API +end; +{$endif MSWINDOWS} + +function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; +var Y,M: cardinal; +begin + Y := 0; + while Days>365 do begin + dec(Days,366); + inc(Y); + end; + M := 0; + if Days>31 then begin + inc(M); + while Days>MonthDays[false][M] do begin + dec(Days,MonthDays[false][M]); + inc(M); + end; + end; + result := DateToIso8601(Y,M,Days,Expanded); +end; + +function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean; + FirstTimeChar: AnsiChar): RawUTF8; +begin // inlined UnixTimeToDateTime + result := DateTimeToIso8601(UnixTime/SecsPerDay+UnixDateDelta,Expanded, + FirstTimeChar,false); +end; + +function DateTimeToFileShort(const DateTime: TDateTime): TShort16; +begin + DateTimeToFileShort(DateTime,result); +end; + +procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); +var T: TSynSystemTime; + tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin // use 'YYMMDDHHMMSS' format + if DateTime<=0 then begin + PWord(@result[0])^ := 1+ord('0') shl 8; + exit; + end; + T.FromDate(DateTime); + if T.Year > 1999 then + if T.Year < 2100 then + dec(T.Year,2000) else + T.Year := 99 else + T.Year := 0; + T.FromTime(DateTime); + {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} + result[0] := #12; + PWord(@result[1])^ := tab[T.Year]; + PWord(@result[3])^ := tab[T.Month]; + PWord(@result[5])^ := tab[T.Day]; + PWord(@result[7])^ := tab[T.Hour]; + PWord(@result[9])^ := tab[T.Minute]; + PWord(@result[11])^ := tab[T.Second]; +end; + +procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); +begin // use 'YYMMDDHHMMSS' format + if UnixTime<=0 then + PWord(@result[0])^ := 1+ord('0') shl 8 else + DateTimeToFileShort(UnixTime/SecsPerDay+UnixDateDelta, result); +end; + +function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; +begin + UnixTimeToFileShort(UnixTime, result); +end; + +function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; +begin + UnixTimeToFileShort(UnixMSTime div MSecsPerSec, result); +end; + +function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8; +begin + if UnixTime0; + end else + result := false; +end; + +function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; +var B: PtrUInt; +begin + B := ConvertHexToBin[ord(P[0])]; + if B<=9 then begin + Value := B; + B := ConvertHexToBin[ord(P[1])]; + if B<=9 then begin + Value := Value*10+B; + result := false; + exit; + end; + end; + result := true; // error +end; + +function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; +var B: PtrUInt; +begin + B := ConvertHexToBin[ord(P[0])]; + if B<=9 then begin + Value := B; + B := ConvertHexToBin[ord(P[1])]; + if B<=9 then begin + Value := Value*10+B; + B := ConvertHexToBin[ord(P[2])]; + if B<=9 then begin + Value := Value*10+B; + result := false; + exit; + end; + end; + end; + result := true; // error +end; + +function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; +var B: PtrUInt; +begin + B := ConvertHexToBin[ord(P[0])]; + if B<=9 then begin + Value := B; + B := ConvertHexToBin[ord(P[1])]; + if B<=9 then begin + Value := Value*10+B; + B := ConvertHexToBin[ord(P[2])]; + if B<=9 then begin + Value := Value*10+B; + B := ConvertHexToBin[ord(P[3])]; + if B<=9 then begin + Value := Value*10+B; + result := false; + exit; + end; + end; + end; + end; + result := true; // error +end; + +procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); +var B: cardinal; + Y,M,D, H,MI,SS,MS: cardinal; + d100: TDiv100Rec; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; +// expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]' +begin + unaligned(result) := 0; + if P=nil then + exit; + if L=0 then + L := StrLen(P); + if L<4 then + exit; // we need 'YYYY' at least + if (P[0]='''') and (P[L-1]='''') then begin // unquote input + inc(P); + dec(L, 2); + if L<4 then exit; + end; + if P[0]='T' then begin + dec(P,8); + inc(L,8); + end else begin + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 + B := tab[ord(P[0])]; // first digit + if B>9 then exit else Y := B; // fast check '0'..'9' + B := tab[ord(P[1])]; + if B>9 then exit else Y := Y*10+B; + B := tab[ord(P[2])]; + if B>9 then exit else Y := Y*10+B; + B := tab[ord(P[3])]; + if B>9 then exit else Y := Y*10+B; + if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD + D := 1; + if L>=6 then begin // YYYYMM + M := ord(P[4])*10+ord(P[5])-(48+480); + if (M=0) or (M>12) then exit; + if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD + if L>=8 then begin // YYYYMMDD + if (L>8) and not(P[8] in [#0,' ','T']) then + exit; // invalid date format + D := ord(P[6])*10+ord(P[7])-(48+480); + if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true + end; + end else + M := 1; + if M>2 then // inlined EncodeDate(Y,M,D) + dec(M,3) else + if M>0 then begin + inc(M,9); + dec(Y); + end; + if Y>9999 then + exit; // avoid integer overflow e.g. if '0000' is an invalid date + Div100(Y,d100); + unaligned(result) := (146097*d100.d) shr 2 + (1461*d100.m) shr 2 + + (153*M+2) div 5+D; + unaligned(result) := unaligned(result)-693900; // as float: avoid sign issue + if L<15 then + exit; // not enough space to retrieve the time + end; + H := ord(P[9])*10+ord(P[10])-(48+480); + if P[11]=':' then begin inc(P); dec(L); end;// allow hh:mm:ss + MI := ord(P[11])*10+ord(P[12])-(48+480); + if P[13]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss + SS := ord(P[13])*10+ord(P[14])-(48+480); + if (L>16) and (P[15]='.') then begin + // one or more digits representing a decimal fraction of a second + MS := ord(P[16])*100-4800; + if L>17 then MS := MS+ord(P[17])*10-480; + if L>18 then MS := MS+ord(P[18])-48; + if MS>1000 then + MS := 0; + end else + MS := 0; + if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime() + result := result+(H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ + MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay; +end; + +function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime; +begin + Iso8601ToTimePUTF8CharVar(P,L,result); +end; + +procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); +var H,MI,SS,MS: cardinal; +begin + if Iso8601ToTimePUTF8Char(P,L,H,MI,SS,MS) then + result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ + MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay else + result := 0; +end; + +function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; +begin + result := false; // error + if P=nil then + exit; + if L=0 then + L := StrLen(P); + if L<6 then + exit; // we need 'hhmmss' at least + H := ord(P[0])*10+ord(P[1])-(48+480); + if P[2]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss + M := ord(P[2])*10+ord(P[3])-(48+480); + if P[4]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss + S := ord(P[4])*10+ord(P[5])-(48+480); + if (L>6) and (P[6]='.') then begin + // one or more digits representing a decimal fraction of a second + MS := ord(P[7])*100-4800; + if L>7 then MS := MS+ord(P[8])*10-480; + if L>8 then MS := MS+ord(P[9])-48; + end else + MS := 0; + if (H<24) and (M<60) and (S<60) and (MS<1000) then + result := true; +end; + +function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; +begin + result := false; // error + if P=nil then + exit; + if L=0 then + L := StrLen(P); + if (L<8) or not (P[0] in ['0'..'9']) or not (P[1] in ['0'..'9']) or + not (P[2] in ['0'..'9']) or not (P[3] in ['0'..'9']) then + exit; // we need 'YYYYMMDD' at least + Y := ord(P[0])*1000+ord(P[1])*100+ord(P[2])*10+ord(P[3])-(48+480+4800+48000); + if (Y<1000) or (Y>2999) then + exit; + if P[4] in ['-','/'] then inc(P); // allow YYYY-MM-DD + M := ord(P[4])*10+ord(P[5])-(48+480); + if (M=0) or (M>12) then + exit; + if P[6] in ['-','/'] then inc(P); + D := ord(P[6])*10+ord(P[7])-(48+480); + if (D<>0) and (D<=MonthDays[true][M]) then + result := true; +end; + +function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; +begin + IntervalTextToDateTimeVar(Text,result); +end; + +procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); +var negative: boolean; + Time: TDateTime; +begin // e.g. IntervalTextToDateTime('+0 06:03:20') + result := 0; + if Text=nil then + exit; + if Text^ in ['+','-'] then begin + negative := (Text^='-'); + result := GetNextItemDouble(Text,' '); + end else + negative := false; + Iso8601ToTimePUTF8CharVar(Text,0,Time); + if negative then + result := result-Time else + result := result+Time; +end; + +function Iso8601ToDateTime(const S: RawByteString): TDateTime; +begin + result := Iso8601ToDateTimePUTF8Char(pointer(S),length(S)); +end; + +function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; +begin + result := PTimeLogBits(@Timestamp)^.ToDateTime; +end; + +function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; +begin + result := PTimeLogBits(@Timestamp)^.ToUnixTime; +end; + +function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; +// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded +var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin + {$ifdef CPUX86NOTPIC} + YearToPChar(Y,P); + {$else} + tab := @TwoDigitLookupW; + YearToPChar2(tab,Y,P); + {$endif} + inc(P,4); + if Expanded then begin + P^ := '-'; + inc(P); + end; + PWord(P)^ := tab[M]; + inc(P,2); + if Expanded then begin + P^ := '-'; + inc(P); + end; + PWord(P)^ := tab[D]; + result := P+2; +end; + +function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; + FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; +var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin // use Thhmmss[.sss] format + if FirstChar<>#0 then begin + P^ := FirstChar; + inc(P); + end; + {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} + PWord(P)^ := tab[H]; + inc(P,2); + if Expanded then begin + P^ := ':'; + inc(P); + end; + PWord(P)^ := tab[M]; + inc(P,2); + if Expanded then begin + P^ := ':'; + inc(P); + end; + PWord(P)^ := tab[S]; + inc(P,2); + if WithMS then begin + {$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P); + P^ := '.'; // override first '0' digit + inc(P,4); + end; + result := P; +end; + +function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; +var T: TSynSystemTime; +begin // use YYYYMMDD / YYYY-MM-DD date format + T.FromDate(Date); + result := DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); +end; + +function DateToIso8601Text(Date: TDateTime): RawUTF8; +begin // into 'YYYY-MM-DD' date format + if Date=0 then + result := '' else begin + FastSetString(result,nil,10); + DateToIso8601PChar(Date,pointer(result),True); + end; +end; + +function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; + FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; +var T: TSynSystemTime; +begin + T.FromTime(Time); + result := TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS); +end; + +function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; + FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): integer; +var S: PUTF8Char; +begin + S := P; + if QuotedChar<>#0 then begin + P^ := QuotedChar; + inc(P); + end; + P := DateToIso8601PChar(D,P,Expanded); + P := TimeToIso8601PChar(D,P,Expanded,FirstChar,WithMS); + if QuotedChar<>#0 then begin + P^ := QuotedChar; + inc(P); + end; + result := P-S; +end; + +function DateTimeToIso8601(D: TDateTime; Expanded: boolean; + FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUTF8; +var tmp: array[0..31] of AnsiChar; +begin // D=0 is handled in DateTimeToIso8601Text() + FastSetString(result,@tmp,DateTimeToIso8601(@tmp,D,Expanded,FirstChar,WithMS,QuotedChar)); +end; + +function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; +// use YYYYMMDD / YYYY-MM-DD date format +begin + FastSetString(result,nil,8+2*integer(Expanded)); + DateToIso8601PChar(Date,pointer(result),Expanded); +end; + +function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; +// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded +begin + FastSetString(result,nil,8+2*integer(Expanded)); + DateToIso8601PChar(pointer(result),Expanded,Y,M,D); +end; + +function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar; + WithMS: boolean): RawUTF8; +// use Thhmmss[.sss] / Thh:mm:ss[.sss] format +begin + FastSetString(result,nil,7+2*integer(Expanded)+4*integer(WithMS)); + TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar,WithMS); +end; + +function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar; + WithMS: boolean): RawUTF8; +begin + DateTimeToIso8601TextVar(DT,FirstChar,result,WithMS); +end; + +procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; + var result: RawUTF8; WithMS: boolean); +begin + if DT=0 then + result := '' else + if frac(DT)=0 then + result := DateToIso8601(DT,true) else + if trunc(DT)=0 then + result := TimeToIso8601(DT,true,FirstChar,WithMS) else + result := DateTimeToIso8601(DT,true,FirstChar,WithMS); +end; + +procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; + var result: string; WithMS: boolean); +var tmp: RawUTF8; +begin + DateTimeToIso8601TextVar(DT,FirstChar,tmp,WithMS); + Ansi7ToString(Pointer(tmp),length(tmp),result); +end; + +function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; + FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; +begin + if Value<>0 then begin + if trunc(Value)<>0 then + Dest := DateToIso8601PChar(Value,Dest,true); + if frac(Value)<>0 then + Dest := TimeToIso8601PChar(Value,Dest,true,FirstChar,WithMS); + end; + Dest^ := #0; + result := Dest; +end; + +function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean): TTimeLog; +// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 +// i.e. S<64 M<64 H<32 D<32 M<16 Y<9999: power of 2 -> use fast shl/shr +var V,B: PtrUInt; + tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; +begin + result := 0; + if P=nil then + exit; + if L=0 then + L := StrLen(P); + if L<4 then + exit; // we need 'YYYY' at least + if P[0]='T' then + dec(P,8) else begin // 'YYYY' -> year decode + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC/x86_64 + V := tab[ord(P[0])]; + if V>9 then exit; + B := tab[ord(P[1])]; + if B>9 then exit else V := V*10+B; + B := tab[ord(P[2])]; + if B>9 then exit else V := V*10+B; + B := tab[ord(P[3])]; + if B>9 then exit else V := V*10+B; + result := Int64(V) shl 26; // store YYYY + if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD + if L>=6 then begin // YYYYMM + V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11 + if V<=11 then + inc(result,V shl 22) else begin + result := 0; + exit; + end; + if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD + if L>=8 then begin // YYYYMMDD + V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30 + if (V<=30) and ((L=8) or (P[8] in [#0,' ','T'])) then + inc(result,V shl 17) else begin + result := 0; + exit; + end; + end; + end; + if L<15 then begin // not enough place to retrieve a time + if ContainsNoTime<>nil then + ContainsNoTime^ := true; + exit; + end; + end; + if ContainsNoTime<>nil then + ContainsNoTime^ := false; + B := ord(P[9])*10+ord(P[10])-(48+480); + if B<=23 then V := B shl 12 else exit; + if P[11]=':' then inc(P); // allow hh:mm:ss + B := ord(P[11])*10+ord(P[12])-(48+480); + if B<=59 then inc(V,B shl 6) else exit; + if P[13]=':' then inc(P); // allow hh:mm:ss + B := ord(P[13])*10+ord(P[14])-(48+480); + if B<=59 then inc(result,PtrUInt(V+B)); +end; + +function IsIso8601(P: PUTF8Char; L: integer): boolean; +begin + result := Iso8601ToTimeLogPUTF8Char(P,L)<>0; +end; + +function DateTimeToi18n(const DateTime: TDateTime): string; +begin + if Assigned(i18nDateTimeText) then + result := i18nDateTimeText(DateTime) else + result := {$ifdef UNICODE}Ansi7ToString{$endif}(DateTimeToIso8601(DateTime,true,' ',true)); +end; + + +{ TTimeLogBits } + +// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 +// size: S=6 M=6 H=5 D=5 M=4 Y=12 +// i.e. S<64 M<64 H<32 D<32 M<16 Y<=9999: power of 2 -> use fast shl/shr + +procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal); +begin + inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10)); + Value := SS+MM shl 6+Int64(HH) shl 12; +end; + +procedure TTimeLogBits.From(P: PUTF8Char; L: integer); +begin + Value := Iso8601ToTimeLogPUTF8Char(P,L); +end; + +procedure TTimeLogBits.Expand(out Date: TSynSystemTime); +var V: PtrUInt; +begin + V := PPtrUint(@Value)^; + Date.Year := {$ifdef CPU32}Value{$else}V{$endif} shr (6+6+5+5+4); + Date.Month := 1+(V shr (6+6+5+5)) and 15; + Date.DayOfWeek := 0; + Date.Day := 1+(V shr (6+6+5)) and 31; + Date.Hour := (V shr (6+6)) and 31; + Date.Minute := (V shr 6) and 63; + Date.Second := V and 63; + Date.MilliSecond := 0; +end; + +procedure TTimeLogBits.From(const S: RawUTF8); +begin + Value := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); +end; + +procedure TTimeLogBits.From(FileDate: integer); +begin +{$ifdef MSWINDOWS} + From(PInt64Rec(@FileDate)^.Hi shr 9+1980, + PInt64Rec(@FileDate)^.Hi shr 5 and 15, + PInt64Rec(@FileDate)^.Hi and 31, + PInt64Rec(@FileDate)^.Lo shr 11, + PInt64Rec(@FileDate)^.Lo shr 5 and 63, + PInt64Rec(@FileDate)^.Lo and 31 shl 1); +{$else} // FileDate depends on the running OS + From(FileDateToDateTime(FileDate)); +{$endif} +end; + +procedure TTimeLogBits.From(DateTime: TDateTime; DateOnly: Boolean); +var T: TSynSystemTime; + V: PtrInt; +begin + T.FromDate(DateTime); + if DateOnly then + T.Hour := 0 else + T.FromTime(DateTime); + V := T.Day shl 5+T.Month shl 10+T.Year shl 14-(1 shl 5+1 shl 10); + Value := V; // circumvent C1093 error on Delphi 5 + Value := Value shl 12; + if not DateOnly then begin + V := T.Second+T.Minute shl 6+T.Hour shl 12; + Value := Value+V; + end; +end; + +procedure TTimeLogBits.FromUnixTime(const UnixTime: TUnixTime); +begin + From(UnixTimeToDateTime(UnixTime)); +end; + +procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: TUnixMSTime); +begin + From(UnixMSTimeToDateTime(UnixMSTime)); +end; + +procedure TTimeLogBits.From(Time: PSynSystemTime); +var V: PtrInt; +begin + V := Time^.Hour+Time^.Day shl 5+Time^.Month shl 10+Time^.Year shl 14-(1 shl 5+1 shl 10); + Value := V; // circumvent C1093 error on Delphi 5 + V := Time^.Second+Time^.Minute shl 6; + Value := (Value shl 12)+V; +end; + +var // GlobalTime[LocalTime] cache protected using RCU128() + GlobalTime: array[boolean] of record + time: TSystemTime; + clock: PtrInt; // avoid slower API call with 8-16ms loss of precision + end; + +{$ifndef FPC}{$ifdef CPUINTEL} // intrinsic in FPC +procedure ReadBarrier; +asm + {$ifdef CPUX86} + lock add dword ptr [esp], 0 + {$else} + lfence // lfence requires an SSE CPU, which is OK on x86-64 + {$endif} +end; +{$endif}{$endif} + +procedure RCU32(var src,dst); +begin + repeat + Integer(dst) := Integer(src); + ReadBarrier; + until Integer(dst)=Integer(src); +end; + +procedure RCU64(var src,dst); +begin + repeat + Int64(dst) := Int64(src); + ReadBarrier; + until Int64(dst)=Int64(src); +end; + +procedure RCUPtr(var src,dst); +begin + repeat + PtrInt(dst) := PtrInt(src); + ReadBarrier; + until PtrInt(dst)=PtrInt(src); +end; + +procedure RCU128(var src,dst); +var s: THash128Rec absolute src; + d: THash128Rec absolute dst; +begin + repeat + d := s; + ReadBarrier; + until (d.L=s.L) and (d.H=s.H); +end; + +procedure RCU(var src,dst; len: integer); +begin + if len>0 then + repeat + MoveSmall(@src,@dst,len); // per-byte inlined copy + ReadBarrier; + until CompareMemSmall(@src,@dst,len); +end; + +procedure FromGlobalTime(LocalTime: boolean; out NewTime: TSynSystemTime); +var tix: PtrInt; + newtimesys: TSystemTime absolute NewTime; +begin + with GlobalTime[LocalTime] do begin + tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 + {$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh + if clock<>tix then begin // Windows: typically in range of 10-16 ms + clock := tix; + NewTime.Clear; + if LocalTime then + GetLocalTime(newtimesys) else + {$ifdef MSWINDOWS}GetSystemTime{$else}GetNowUTCSystem{$endif}(newtimesys); + RCU128(newtimesys,time); + end else + RCU128(time,NewTime); + end; + {$ifndef MSWINDOWS} // those TSystemTime fields are inverted in datih.inc :( + tix := newtimesys.DayOfWeek; + NewTime.Day := newtimesys.Day; + NewTime.DayOfWeek := tix; + {$endif} +end; + +procedure TTimeLogBits.FromUTCTime; +var now: TSynSystemTime; +begin + FromGlobalTime(false,now); + From(@now); +end; + +procedure TTimeLogBits.FromNow; +var now: TSynSystemTime; +begin + FromGlobalTime(true,now); + From(@now); +end; + +function TTimeLogBits.ToTime: TDateTime; +var lo: PtrUInt; +begin + lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; + if lo and (1 shl (6+6+5)-1)=0 then + result := 0 else + result := EncodeTime((lo shr(6+6))and 31, (lo shr 6)and 63, lo and 63, 0); +end; + +function IsLeapYear(Year: cardinal): boolean; +var d100: TDiv100Rec; +begin + if Year and 3 = 0 then begin + Div100(Year,d100); + result := ((d100.M <> 0) or // (Year mod 100 > 0) + (Year - ((d100.D shr 2) * 400) = 0)); // (Year mod 400 = 0)) + end else + result := false; +end; + +function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; +var d100: TDiv100Rec; +begin // faster version by AB + result := False; + if (Year>0) and (Year<10000) and (Month>0) and (Month<13) and (Day>0) and + (Day <= MonthDays[IsLeapYear(Year)][Month]) then begin + if Month>2 then + dec(Month,3) else + if (Month>0) then begin + inc(Month,9); + dec(Year); + end + else exit; // Month <= 0 + Div100(Year,d100); + Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+ + (153*Month+2) div 5+Day; + Date := Date-693900; // should be separated to avoid sign issues + result := true; + end; +end; + +function TTimeLogBits.ToDate: TDateTime; +var Y, lo: PtrUInt; +begin + {$ifdef CPU64} + lo := Value; + Y := lo shr (6+6+5+5+4); + {$else} + Y := Value shr (6+6+5+5+4); + lo := PCardinal(@Value)^; + {$endif} + if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then + result := 0; +end; + +function TTimeLogBits.ToDateTime: TDateTime; +var Y, lo: PtrUInt; + Time: TDateTime; +begin + {$ifdef CPU64} + lo := Value; + Y := lo shr (6+6+5+5+4); + {$else} + Y := Value shr (6+6+5+5+4); + lo := PCardinal(@Value)^; + {$endif} + if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then + result := 0; + if (lo and (1 shl(6+6+5)-1)<>0) and TryEncodeTime((lo shr(6+6)) and 31, + (lo shr 6)and 63, lo and 63, 0, Time) then + result := result+Time; +end; + +function TTimeLogBits.Year: Integer; +begin + result := Value shr (6+6+5+5+4); +end; + +function TTimeLogBits.Month: Integer; +begin + result := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15; +end; + +function TTimeLogBits.Day: Integer; +begin + result := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31; +end; + +function TTimeLogBits.Hour: Integer; +begin + result := (PCardinal(@Value)^ shr (6+6)) and 31; +end; + +function TTimeLogBits.Minute: Integer; +begin + result := (PCardinal(@Value)^ shr 6) and 63; +end; + +function TTimeLogBits.Second: Integer; +begin + result := PCardinal(@Value)^ and 63; +end; + +function TTimeLogBits.ToUnixTime: TUnixTime; +begin + result := DateTimeToUnixTime(ToDateTime); +end; + +function TTimeLogBits.ToUnixMSTime: TUnixMSTime; +begin + result := DateTimeToUnixMSTime(ToDateTime); +end; + +function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer; +var lo: PtrUInt; + S: PUTF8Char; +begin + if Value=0 then begin + result := 0; + exit; + end; + S := Dest; + lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; + if lo and (1 shl (6+6+5)-1)=0 then + // no Time: just convert date + result := DateToIso8601PChar(Dest, Expanded, + {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), + 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31)-S else + if {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5)=0 then + // no Date: just convert time + result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, + (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S else begin + // convert time and date + Dest := DateToIso8601PChar(Dest, Expanded, + {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), + 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); + result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, + (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S; + end; +end; + +function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; +var tmp: array[0..31] of AnsiChar; +begin + if Value=0 then + result := '' else + FastSetString(result,@tmp,Text(tmp,Expanded,FirstTimeChar)); +end; + +function TTimeLogBits.FullText(Dest: PUTF8Char; Expanded: boolean; + FirstTimeChar,QuotedChar: AnsiChar): PUTF8Char; +var lo: PtrUInt; +begin // convert full time and date + if QuotedChar<>#0 then begin + Dest^ := QuotedChar; + inc(Dest); + end; + lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; + Dest := DateToIso8601PChar(Dest, Expanded, + {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), + 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); + Dest := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, + (lo shr 6) and 63, lo and 63, 0, FirstTimeChar); + if QuotedChar<>#0 then begin + Dest^ := QuotedChar; + inc(Dest); + end; + result := Dest; +end; + +function TTimeLogBits.FullText(Expanded: boolean; FirstTimeChar,QuotedChar: AnsiChar): RawUTF8; +var tmp: array[0..31] of AnsiChar; +begin + FastSetString(result,@tmp,FullText(tmp,Expanded,FirstTimeChar,QuotedChar)-@tmp); +end; + +function TTimeLogBits.i18nText: string; +begin + if Assigned(i18nDateText) then + result := i18nDateText(Value) else + result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' ')); +end; + +function TimeLogNow: TTimeLog; +begin + PTimeLogBits(@result)^.FromNow; +end; + +function TimeLogNowUTC: TTimeLog; +begin + PTimeLogBits(@result)^.FromUTCTime; +end; + +function NowToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; +var I: TTimeLogBits; +begin + I.FromNow; + result := I.Text(Expanded,FirstTimeChar); +end; + +function NowUTCToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; +var I: TTimeLogBits; +begin + I.FromUTCTime; + result := I.Text(Expanded,FirstTimeChar); +end; + +const + DTMS_FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%%:%:%.%%'); + +function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean; + FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; +var T: TSynSystemTime; +begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format + if DateTime=0 then + result := '' else begin + T.FromDateTime(DateTime); + result := DateTimeMSToString(T.Hour,T.Minute,T.Second,T.MilliSecond, + T.Year,T.Month,T.Day,Expanded,FirstTimeChar,TZD); + end; +end; + +function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; + FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; +begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format + FormatUTF8(DTMS_FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShortFast(M), + UInt2DigitsToShortFast(D),FirstTimeChar,UInt2DigitsToShortFast(HH), + UInt2DigitsToShortFast(MM),UInt2DigitsToShortFast(SS),UInt3DigitsToShort(MS),TZD], result); +end; + +function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8): RawUTF8; +var T: TSynSystemTime; +begin + if dt=0 then + result := '' else begin + T.FromDateTime(dt); + T.ToHTTPDate(result,tz); + end; +end; + +function TimeToString: RawUTF8; +var I: TTimeLogBits; +begin + I.FromNow; + I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time + result := I.Text(true,' '); +end; + +function TimeLogFromFile(const FileName: TFileName): TTimeLog; +var Date: TDateTime; +begin + Date := FileAgeToDateTime(FileName); + if Date=0 then + result := 0 else + PTimeLogBits(@result)^.From(Date); +end; + +function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; +begin + PTimeLogBits(@result)^.From(DateTime); +end; + +function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; +begin + PTimeLogBits(@result)^.FromUnixTime(UnixTime); +end; + + +{ TSynDate } + +procedure TSynDate.Clear; +begin + PInt64(@self)^ := 0; +end; + +procedure TSynDate.SetMax; +begin + PInt64(@self)^ := $001F0000000C270F; // 9999 + 12 shl 16 + 31 shl 48 +end; + +function TSynDate.IsZero: boolean; +begin + result := PInt64(@self)^=0; +end; + +function TSynDate.ParseFromText(var P: PUTF8Char): boolean; +var L: PtrInt; + Y,M,D: cardinal; +begin + result := false; + if P=nil then + exit; + while P^ in [#9,' '] do inc(P); + L := 0; + while P[L] in ['0'..'9','-','/'] do inc(L); + if not Iso8601ToDatePUTF8Char(P,L,Y,M,D) then + exit; + Year := Y; + Month := M; + DayOfWeek := 0; + Day := D; + inc(P,L); // move P^ just after the date + result := true; +end; + +procedure TSynDate.FromNow(localtime: boolean); +var dt: TSynSystemTime; +begin + FromGlobalTime(localtime,dt); + self := PSynDate(@dt)^; // 4 first fields of TSynSystemTime do match +end; + +procedure TSynDate.FromDate(date: TDate); +var dt: TSynSystemTime; +begin + dt.FromDate(date); // faster than DecodeDate + self := PSynDate(@dt)^; +end; + +function TSynDate.IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; +begin + result := (PCardinal(@Year)^=PCardinal(@TSynDate(another).Year)^) and (Day=TSynDate(another).Day); +end; + +function TSynDate.Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; +begin + result := Year-TSynDate(another).Year; + if result=0 then begin + result := Month-TSynDate(another).Month; + if result=0 then + result := Day-TSynDate(another).Day; + end; +end; + +procedure TSynDate.ComputeDayOfWeek; +var d: TDateTime; + i: PtrInt; +begin + if not TryEncodeDate(Year,Month,Day,d) then begin + DayOfWeek := 0; + exit; + end; + i := ((trunc(d)-1) mod 7)+1; // sunday is day 1 + if i<=0 then + DayOfWeek := i+7 else + DayOfWeek := i; +end; + +function TSynDate.ToDate: TDate; +begin + if not TryEncodeDate(Year,Month,Day,PDateTime(@result)^) then + result := 0; +end; + +function TSynDate.ToText(Expanded: boolean): RawUTF8; +begin + if PInt64(@self)^=0 then + result := '' else + result := DateToIso8601(Year,Month,Day,Expanded); +end; + + +{ TSynSystemTime } + +function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer; + out AValue: TDateTime): Boolean; +var LStartOfMonth, LDay: integer; +begin // adapted from DateUtils + result := TryEncodeDate(AYear,AMonth,1,aValue); + if not result then + exit; + LStartOfMonth := (DateTimeToTimestamp(aValue).Date-1)mod 7+1; + if LStartOfMonth<=ADayOfWeek then + dec(ANthDayOfWeek); + LDay := (ADayOfWeek-LStartOfMonth+1)+7*ANthDayOfWeek; + result := TryEncodeDate(AYear,AMonth,LDay,AValue); +end; + +function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime; +var dow,d: word; +begin + if DayOfWeek=0 then + dow := 7 else // Delphi Sunday = 7 + dow := DayOfWeek; + // Encoding the day of change + d := Day; + while not TryEncodeDayOfWeekInMonth(aYear,Month,d,dow,Result) do begin + // if Day = 5 then try it and if needed decrement to find the last + // occurence of the day in this month + if d=0 then begin + TryEncodeDayOfWeekInMonth(aYear,Month,1,7,Result); + break; + end; + dec(d); + end; + // finally add the time when change is due + result := result+EncodeTime(Hour,Minute,Second,MilliSecond); +end; + +procedure TSynSystemTime.Clear; +begin + PInt64Array(@self)[0] := 0; + PInt64Array(@self)[1] := 0; +end; + +function TSynSystemTime.IsZero: boolean; +begin + result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0); +end; + +function TSynSystemTime.IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; +begin + result := (PInt64Array(@self)[0]=PInt64Array(@another)[0]) and + (PInt64Array(@self)[1]=PInt64Array(@another)[1]); +end; + +function TSynSystemTime.IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; +begin + result := (PCardinal(@Year)^=PCardinal(@TSynDate(date).Year)^) and + (Day=TSynDate(date).Day); +end; + +procedure TSynSystemTime.FromNowUTC; +begin + FromGlobalTime(false,self); +end; + +procedure TSynSystemTime.FromNowLocal; +begin + FromGlobalTime(true,self); +end; + +procedure TSynSystemTime.FromDateTime(const dt: TDateTime); +begin + FromDate(dt); + FromTime(dt); +end; + +procedure TSynSystemTime.FromDate(const dt: TDateTime); +var t,t2,t3: PtrUInt; +begin + t := Trunc(dt); + t := (t+693900)*4-1; + if PtrInt(t)>=0 then begin + t3 := t div 146097; + t2 := (t-t3*146097) and not 3; + t := PtrUInt(t2+3) div 1461; // PtrUInt() needed for FPC i386 + Year := t3*100+t; + t2 := ((t2+7-t*1461)shr 2)*5; + t3 := PtrUInt(t2-3) div 153; + Day := PtrUInt(t2+2-t3*153) div 5; + if t3<10 then + inc(t3,3) else begin + dec(t3,9); + inc(Year); + end; + Month := t3; + DayOfWeek := 0; // not set by default + end else + PInt64(@Year)^ := 0; +end; + +procedure TSynSystemTime.FromTime(const dt: TDateTime); +begin + FromMS(QWord(round(abs(dt)*MSecsPerDay)) mod MSecsPerDay); +end; + +procedure TSynSystemTime.FromMS(ms: PtrUInt); +var t: PtrUInt; +begin + t := ms div 3600000; + Hour := t; + dec(ms,t*3600000); + t := ms div 60000; + Minute := t; + dec(ms,t*60000); + t := ms div 1000; + Second := t; + dec(ms,t*1000); + MilliSecond := ms; +end; + +procedure TSynSystemTime.FromSec(s: PtrUInt); +var t: PtrUInt; +begin + t := s div 3600; + Hour := t; + dec(s,t*3600); + t := s div 60; + Minute := t; + dec(s,t*60); + Second := s; + MilliSecond := 0; +end; + +function TSynSystemTime.FromText(const iso: RawUTF8): boolean; +var t: TTimeLogBits; +begin + t.From(iso); + if t.Value=0 then + result := false else begin + t.Expand(self); // TTimeLogBits is faster than FromDateTime() + result := true; + end; +end; + +function TSynSystemTime.ToText(Expanded: boolean; + FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; +begin + result := DateTimeMSToString(Hour,Minute,Second,MilliSecond,Year,Month,Day, + Expanded,FirstTimeChar,TZD); +end; + +procedure TSynSystemTime.AddLogTime(WR: TTextWriter); +var y,d100: PtrUInt; + P: PUTF8Char; + tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin + if WR.BEnd-WR.B<=18 then + WR.FlushToStream; + {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} + y := Year; + d100 := y div 100; + P := WR.B+1; + PWord(P)^ := tab[d100]; + PWord(P+2)^ := tab[y-(d100*100)]; + PWord(P+4)^ := tab[Month]; + PWord(P+6)^ := tab[Day]; + P[8] := ' '; + PWord(P+9)^ := tab[Hour]; + PWord(P+11)^ := tab[Minute]; + PWord(P+13)^ := tab[Second]; + y := Millisecond; + PWord(P+15)^ := tab[y shr 4]; + inc(WR.B,17); +end; + +const + HTML_WEEK_DAYS: array[1..7] of string[3] = + ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); + HTML_MONTH_NAMES: array[1..12] of string[3] = + ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); + +function TSynSystemTime.ToNCSAText(P: PUTF8Char): PtrInt; +var y,d100: PtrUInt; + tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; +begin + {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} + PWord(P)^ := tab[Day]; + PCardinal(P+2)^ := PCardinal(@HTML_MONTH_NAMES[Month])^; + P[2] := '/'; // overwrite HTML_MONTH_NAMES[][0] + P[6] := '/'; + y := Year; + d100 := y div 100; + PWord(P+7)^ := tab[d100]; + PWord(P+9)^ := tab[y-(d100*100)]; + P[11] := ':'; + PWord(P+12)^ := tab[Hour]; + P[14] := ':'; + PWord(P+15)^ := tab[Minute]; + P[17] := ':'; + PWord(P+18)^ := tab[Second]; + P[20] := ' '; + result := 21; +end; + +procedure TSynSystemTime.ToHTTPDate(out text: RawUTF8; const tz: RawUTF8); +begin + if DayOfWeek=0 then + PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match + FormatUTF8('%, % % % %:%:% %', [HTML_WEEK_DAYS[DayOfWeek], + UInt2DigitsToShortFast(Day),HTML_MONTH_NAMES[Month],UInt4DigitsToShort(Year), + UInt2DigitsToShortFast(Hour),UInt2DigitsToShortFast(Minute), + UInt2DigitsToShortFast(Second),tz],text); +end; + +procedure TSynSystemTime.ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar); +begin + FormatUTF8('%-%-%%%:%:%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), + UInt2DigitsToShortFast(Day),FirstTimeChar,UInt2DigitsToShortFast(Hour), + UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); +end; + +procedure TSynSystemTime.ToIsoDate(out text: RawUTF8); +begin + FormatUTF8('%-%-%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), + UInt2DigitsToShortFast(Day)],text); +end; + +procedure TSynSystemTime.ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8); +begin + FormatUTF8('%%:%:%', [FirstTimeChar,UInt2DigitsToShortFast(Hour), + UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); +end; + +procedure TSynSystemTime.AddNCSAText(WR: TTextWriter); +begin + if WR.BEnd-WR.B<=21 then + WR.FlushToStream; + inc(WR.B,ToNCSAText(WR.B+1)); +end; + +function TSynSystemTime.ToDateTime: TDateTime; +var time: TDateTime; +begin + if TryEncodeDate(Year,Month,Day,result) then + if TryEncodeTime(Hour,Minute,Second,MilliSecond,time) then + result := result+time else + result := 0 else + result := 0; +end; + +procedure TSynSystemTime.ToSynDate(out date: TSynDate); +begin + date := PSynDate(@self)^; // first 4 fields do match +end; + +procedure TSynSystemTime.ComputeDayOfWeek; +begin + PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match +end; + +procedure TSynSystemTime.IncrementMS(ms: integer); +begin + inc(MilliSecond, ms); + if MilliSecond >= 1000 then + repeat + dec(MilliSecond, 1000); + if Second < 60 then + inc(Second) + else begin + Second := 0; + if Minute < 60 then + inc(Minute) + else begin + Minute := 0; + if Hour < 24 then + inc(Hour) + else begin + Hour := 0; + if Day < MonthDays[false, Month] then + inc(Day) + else begin + Day := 1; + if Month < 12 then + inc(Month) + else begin + Month := 1; + inc(Year); + end; + end; + end; + end; + end; + until MilliSecond < 1000; +end; + +procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; + aMaxSize: Int64; aUTCTimeStamp: boolean); +var F: THandle; + Old: TFileName; + Date: array[1..22] of AnsiChar; + size: Int64; + i: integer; + now: TSynSystemTime; +begin + if aFileName='' then + exit; + F := FileOpen(aFileName,fmOpenWrite or fmShareDenyNone); + if PtrInt(F)<0 then begin + F := FileCreate(aFileName); + if PtrInt(F)<0 then + exit; // you may not have write access to this folder + end; + // append to end of file + size := FileSeek64(F,0,soFromEnd); + if (aMaxSize>0) and (size>aMaxSize) then begin + // rotate log file if too big + FileClose(F); + Old := aFileName+'.bak'; // '.log.bak' + DeleteFile(Old); // rotate once + RenameFile(aFileName,Old); + F := FileCreate(aFileName); + if PtrInt(F)<0 then + exit; + end; + PWord(@Date)^ := 13+10 shl 8; // first go to next line + if aUTCTimeStamp then + now.FromNowUTC else + now.FromNowLocal; + DateToIso8601PChar(@Date[3],true,Now.Year,Now.Month,Now.Day); + TimeToIso8601PChar(@Date[13],true,Now.Hour,Now.Minute,Now.Second,0,' '); + Date[22] := ' '; + FileWrite(F,Date,SizeOf(Date)); + for i := 1 to length(aLine) do + if aLine[i]<' ' then + aLine[i] := ' '; // avoid line feed in text log file + FileWrite(F,pointer(aLine)^,length(aLine)); + FileClose(F); +end; + +procedure LogToTextFile(Msg: RawUTF8); +begin + if Msg='' then begin + StringToUTF8(SysErrorMessage(GetLastError),Msg); + if Msg='' then + exit; + end; + AppendToTextFile(Msg,{$ifndef MSWINDOWS}ExtractFileName{$endif} + (ChangeFileExt(ExeVersion.ProgramFileName,'.log'))); +end; + +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +begin + result := (PHash128Rec(@guid1).L=PHash128Rec(@guid2).L) and + (PHash128Rec(@guid1).H=PHash128Rec(@guid2).H); +end; + +function IsEqualGUID(guid1, guid2: PGUID): Boolean; +begin + result := (PHash128Rec(guid1).L=PHash128Rec(guid2).L) and + (PHash128Rec(guid1).H=PHash128Rec(guid2).H); +end; + +function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; +begin + result := Hash128Index(@guids[0],length(guids),@guid); +end; + +function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; +var a: TPtrIntArray absolute guid; +begin + result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif}; +end; + +function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; + NoDuplicates: boolean): integer; +begin + if NoDuplicates then begin + result := Hash128Index(pointer(guids),length(guids),@guid); + if result>=0 then + exit; + end; + result := length(guids); + SetLength(guids,result+1); + guids[result] := guid; +end; + +function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; +var i: integer; +begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301' + for i := 3 downto 0 do begin + PWord(P)^ := TwoDigitsHexWB[guid[i]]; + inc(P,2); + end; + inc(PByte(guid),4); + for i := 1 to 2 do begin + P[0] := '-'; + PWord(P+1)^ := TwoDigitsHexWB[guid[1]]; + PWord(P+3)^ := TwoDigitsHexWB[guid[0]]; + inc(PByte(guid),2); + inc(P,5); + end; + P[0] := '-'; + PWord(P+1)^ := TwoDigitsHexWB[guid[0]]; + PWord(P+3)^ := TwoDigitsHexWB[guid[1]]; + P[5] := '-'; + inc(PByte(guid),2); + inc(P,6); + for i := 0 to 5 do begin + PWord(P)^ := TwoDigitsHexWB[guid[i]]; + inc(P,2); + end; + result := P; +end; + +function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif} +var B,C: PtrUInt; +begin + B := ConvertHexToBin[Ord(P[0])]; + if B<=15 then begin + C := ConvertHexToBin[Ord(P[1])]; + if C<=15 then begin + Dest := B shl 4+C; + result := true; + exit; + end; + end; + result := false; // mark error +end; + +function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; +var i: integer; +begin // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301' + result := nil; + for i := 3 downto 0 do begin + if not HexaToByte(P,guid[i]) then + exit; + inc(P,2); + end; + inc(PByte(guid),4); + for i := 1 to 2 do begin + if (P^<>'-') or not HexaToByte(P+1,guid[1]) or not HexaToByte(P+3,guid[0]) then + exit; + inc(P,5); + inc(PByte(guid),2); + end; + if (P[0]<>'-') or (P[5]<>'-') or + not HexaToByte(P+1,guid[0]) or not HexaToByte(P+3,guid[1]) then + exit; + inc(PByte(guid),2); + inc(P,6); + for i := 0 to 5 do + if HexaToByte(P,guid[i]) then + inc(P,2) else + exit; + result := P; +end; + +function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; +var P: PUTF8Char; +begin + FastSetString(result,nil,38); + P := pointer(result); + P^ := '{'; + GUIDToText(P+1,@guid)^ := '}'; +end; + +function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString; +begin + GUIDToShort(guid,result); +end; + +procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; + out dest: TGUIDShortString); +begin + dest[0] := #38; + dest[1] := '{'; + dest[38] := '}'; + GUIDToText(@dest[2],@guid); +end; + +function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; +{$ifdef UNICODE} +var tmp: array[0..35] of AnsiChar; + i: integer; +begin + GUIDToText(tmp,@guid); + SetString(result,nil,38); + PWordArray(result)[0] := ord('{'); + for i := 1 to 36 do + PWordArray(result)[i] := ord(tmp[i-1]); // no conversion for 7 bit Ansi + PWordArray(result)[37] := ord('}'); +end; +{$else} +begin + result := GUIDToRawUTF8(guid); +end; +{$endif} + +{$ifdef CPUINTEL} /// NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode +function RdRand32: cardinal; {$ifdef CPU64} +{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC} {$else} +{$ifdef FPC}nostackframe; assembler;{$endif} asm {$endif} + // rdrand eax: same opcodes for x86 and x64 + db $0f, $c7, $f0 + // returns in eax, ignore carry flag (eax=0 won't hurt) +end; +{$endif CPUINTEL} + +threadvar + _Lecuyer: TLecuyer; // uses only 16 bytes per thread + +procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt); +var time, crc: THash128Rec; + i, j: PtrInt; +begin + repeat + QueryPerformanceCounter(time.Lo); + time.Hi := UnixMSTimeUTCFast xor PtrUInt(GetCurrentThreadID); + crcblock(@crc.b,@time.b); + crcblock(@crc.b,@ExeVersion.Hash.b); + if entropy<>nil then + for i := 0 to entropylen-1 do begin + j := i and 15; + crc.b[j] := crc.b[j] xor entropy^[i]; + end; + rs1 := rs1 xor crc.c0; + rs2 := rs2 xor crc.c1; + rs3 := rs3 xor crc.c2; + {$ifdef CPUINTEL} + if cfRAND in CpuFeatures then begin // won't hurt e.g. from Random32gsl + rs1 := rs1 xor RdRand32; + rs2 := rs2 xor RdRand32; + rs3 := rs3 xor RdRand32; + end; + {$endif CPUINTEL} + until (rs1>1) and (rs2>7) and (rs3>15); + seedcount := 1; + for i := 1 to crc.i3 and 15 do + Next; // warm up +end; + +function TLecuyer.Next: cardinal; +begin + if word(seedcount)=0 then // reseed after 256KB of output + Seed(nil,0) else + inc(seedcount); + result := rs1; + rs1 := ((result and -2)shl 12) xor (((result shl 13)xor result)shr 19); + result := rs2; + rs2 := ((result and -8)shl 4) xor (((result shl 2)xor result)shr 25); + result := rs3; + rs3 := ((result and -16)shl 17) xor (((result shl 3)xor result)shr 11); + result := rs1 xor rs2 xor result; +end; + +function TLecuyer.Next(max: cardinal): cardinal; +begin + result := (QWord(Next)*max)shr 32; +end; + +procedure Random32Seed(entropy: pointer; entropylen: PtrInt); +begin + _Lecuyer.Seed(entropy,entropylen); +end; + +function Random32: cardinal; +begin + {$ifdef CPUINTEL} + if cfRAND in CpuFeatures then begin + result := RdRand32; + if ((integer(result)<>-1) and (result<>0)) or (RdRand32<>result) then + exit; // ensure not affected by old AMD bug after suspend to RAM + exclude(CpuFeatures,cfRAND); // disable if weakness detected + end; + {$endif CPUINTEL} + result := _Lecuyer.Next; +end; + +function Random32(max: cardinal): cardinal; +begin + result := (QWord(Random32)*max)shr 32; +end; + +function Random32gsl: cardinal; +begin + result := _Lecuyer.Next; +end; + +function Random32gsl(max: cardinal): cardinal; +begin + result := (QWord(_Lecuyer.Next)*max)shr 32; +end; + +procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; forcegsl: boolean); +var i: PtrInt; + c: cardinal; + seed: TQWordRec; + lecuyer: ^TLecuyer; +begin + if CardinalCount<=0 then + exit; + {$ifdef CPUINTEL} + if (cfRAND in CpuFeatures) and not forcegsl then + lecuyer := nil else + {$endif CPUINTEL} + lecuyer := @_Lecuyer; + QueryPerformanceCounter(PInt64(@seed)^); + c := crc32cBy4(seed.L,seed.H); + for i := 0 to CardinalCount-1 do begin + {$ifdef CPUINTEL} + if lecuyer=nil then + c := crc32cBy4(c,RdRand32) else // never trust plain Intel values + {$endif CPUINTEL} + c := c xor lecuyer^.Next; + Dest^[i] := Dest^[i] xor c; + end; +end; + +function RandomGUID: TGUID; +begin + FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); +end; + +procedure RandomGUID(out result: TGUID); +begin + FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); +end; + +procedure FillZero(var result: TGUID); +begin + FillZero(PHash128(@result)^); +end; + +function RawUTF8ToGUID(const text: RawByteString): TGUID; +begin + if (length(text)<>38) or (text[1]<>'{') or (text[38]<>'}') or + (TextToGUID(@text[2],@result)=nil) then + FillZero(PHash128(@result)^); +end; + +function StringToGUID(const text: string): TGUID; +{$ifdef UNICODE} +var tmp: array[0..35] of byte; + i: integer; +{$endif} +begin + if (length(text)=38) and (text[1]='{') and (text[38]='}') then begin + {$ifdef UNICODE} + for i := 0 to 35 do + tmp[i] := PWordArray(text)[i+1]; + if TextToGUID(@tmp,@result)<>nil then + {$else} + if TextToGUID(@text[2],@result)<>nil then + {$endif} + exit; // conversion OK + end; + FillZero(PHash128(@result)^); +end; + +function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; +var c: QWord; + d: cardinal; + {$ifndef CPU64}c64: Int64Rec absolute c;{$endif} +begin + if Value=0 then begin + result := P-1; + result^ := '0'; + exit; + end; + if Value<0 then + c := -Value else + c := Value; + if {$ifdef CPU64}c<10000{$else}(c64.Hi=0) and (c64.Lo<10000){$endif} then begin + result := P-6; // only decimals -> append '0.xxxx' + PWord(result)^ := ord('0')+ord('.')shl 8; + YearToPChar(c,PUTF8Char(P)-4); + end else begin + result := StrUInt64(P-1,c); + d := PCardinal(P-5)^; // in two explit steps for CPUARM (alf) + PCardinal(P-4)^ := d; + P[-5] := '.'; // insert '.' just before last 4 decimals + end; + if Value<0 then begin + dec(result); + result^ := '-'; + end; +end; + +procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); +var tmp: array[0..31] of AnsiChar; + P: PAnsiChar; + Decim, L: Cardinal; +begin + if Value=0 then + result := SmallUInt32UTF8[0] else begin + P := StrCurr64(@tmp[31],Value); + L := @tmp[31]-P; + if L>4 then begin + Decim := PCardinal(P+L-SizeOf(cardinal))^; // 4 last digits = 4 decimals + if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then + dec(L,5) else // no decimal + if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then + dec(L,2); // 2 decimals + end; + FastSetString(result,P,L); + end; +end; + +function Curr64ToStr(const Value: Int64): RawUTF8; +begin + Curr64ToStr(Value,result); +end; + +function CurrencyToStr(Value: currency): RawUTF8; +begin + result := Curr64ToStr(PInt64(@Value)^); +end; + +function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; +var tmp: array[0..31] of AnsiChar; + P: PAnsiChar; + Decim: Cardinal; +begin + P := StrCurr64(@tmp[31],Value); + result := @tmp[31]-P; + if result>4 then begin + Decim := PCardinal(P+result-SizeOf(cardinal))^; // 4 last digits = 4 decimals + if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then + dec(result,5) else // no decimal + if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then + dec(result,2); // 2 decimals + end; + MoveSmall(P,Dest,result); +end; + +function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean): Int64; +var c: cardinal; + minus: boolean; + Dec: cardinal; +begin + result := 0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='-' then begin + minus := true; + repeat inc(P) until P^<>' '; + end else begin + minus := false; + if P^='+' then + repeat inc(P) until P^<>' '; + end; + if P^='.' then begin // '.5' -> 500 + Dec := 2; + inc(P); + end else + Dec := 0; + c := byte(P^)-48; + if c>9 then + exit; + PCardinal(@result)^ := c; + inc(P); + repeat + if P^<>'.' then begin + c := byte(P^)-48; + if c>9 then + break; + {$ifdef CPU32DELPHI} + result := result shl 3+result+result; + {$else} + result := result*10; + {$endif} + inc(result,c); + inc(P); + if Dec<>0 then begin + inc(Dec); + if Dec<5 then continue else break; + end; + end else begin + inc(Dec); + inc(P); + end; + until false; + if NoDecimal<>nil then + if Dec=0 then begin + NoDecimal^ := true; + if minus then + result := -result; + exit; + end else + NoDecimal^ := false; + if Dec<>5 then // Dec=5 most of the time + case Dec of + 0,1: result := result*10000; + {$ifdef CPU32DELPHI} + 2: result := result shl 10-result shl 4-result shl 3; + 3: result := result shl 6+result shl 5+result shl 2; + 4: result := result shl 3+result+result; + {$else} + 2: result := result*1000; + 3: result := result*100; + 4: result := result*10; + {$endif} + end; + if minus then + result := -result; +end; + +function StrToCurrency(P: PUTF8Char): currency; +begin + PInt64(@result)^ := StrToCurr64(P,nil); +end; + +function TruncTo2Digits(Value: Currency): Currency; +var V64: Int64 absolute Value; // to avoid any floating-point precision issues +begin + dec(V64,V64 mod 100); + result := Value; +end; + +procedure TruncTo2DigitsCurr64(var Value: Int64); +begin + dec(Value,Value mod 100); +end; + +function TruncTo2Digits64(Value: Int64): Int64; +begin + result := Value-Value mod 100; +end; + +function SimpleRoundTo2Digits(Value: Currency): Currency; +var V64: Int64 absolute Value; // to avoid any floating-point precision issues +begin + SimpleRoundTo2DigitsCurr64(V64); + result := Value; +end; + +procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); +var Spare: PtrInt; +begin + Spare := Value mod 100; + if Spare<>0 then + if Spare>50 then + inc(Value,100-Spare) else + if Spare<-50 then + dec(Value,100+Spare) else + dec(Value,Spare); +end; + +function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; +begin + result := Pointer(V); + if result<>nil then begin + while result^ in ['a'..'z'] do + inc(result); + if result^=#0 then + result := Pointer(V); + end; +end; + +function TrimLeftLowerCaseToShort(V: PShortString): ShortString; +begin + TrimLeftLowerCaseToShort(V,result); +end; + +procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); +var P: PAnsiChar; + L: integer; +begin + L := length(V^); + P := @V^[1]; + while (L>0) and (P^ in ['a'..'z']) do begin + inc(P); + dec(L); + end; + if L=0 then + result := V^ else + SetString(result,P,L); +end; + +{$ifdef FPC_OR_PUREPASCAL} +function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; +var P: PAnsiChar; + L: integer; +begin + L := length(V^); + P := @V^[1]; + while (L>0) and (P^ in ['a'..'z']) do begin + inc(P); + dec(L); + end; + if L=0 then + FastSetString(result,@V^[1],length(V^)) else + FastSetString(result,P,L); +end; +{$else} +function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; +asm // eax=V + xor ecx, ecx + push edx // save result RawUTF8 + test eax, eax + jz @2 // avoid GPF + lea edx, [eax + 1] + mov cl, [eax] +@1: mov ch, [edx] // edx=source cl=length + sub ch, 'a' + sub ch, 'z' - 'a' + ja @2 // not a lower char -> create a result string starting at edx + inc edx + dec cl + jnz @1 + mov cl, [eax] + lea edx, [eax + 1] // no UpperCase -> retrieve full text (result := V^) +@2: pop eax + movzx ecx, cl +{$ifdef UNICODE} + push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call below, not jump + call System.@LStrFromPCharLen // eax=Dest edx=Source ecx=Length + rep ret // we need a call just above for right push CP_UTF8 retrieval +{$else} jmp System.@LStrFromPCharLen // eax=dest edx=source ecx=length(source) +{$endif} +end; +{$endif FPC_OR_PUREPASCAL} + +function UnCamelCase(const S: RawUTF8): RawUTF8; +var tmp: TSynTempBuffer; + destlen: PtrInt; +begin + if S='' then + result := '' else begin + destlen := UnCamelCase(tmp.Init(length(S)*2),pointer(S)); + tmp.Done(PAnsiChar(tmp.buf)+destlen,result); + end; +end; + +function UnCamelCase(D, P: PUTF8Char): integer; +var Space, SpaceBeg, DBeg: PUTF8Char; + CapitalCount: integer; + Number: boolean; +label Next; +begin + DBeg := D; + if (D<>nil) and (P<>nil) then begin // avoid GPF + Space := D; + SpaceBeg := D; + repeat + CapitalCount := 0; + Number := P^ in ['0'..'9']; + if Number then + repeat + inc(CapitalCount); + D^ := P^; + inc(P); + inc(D); + until not (P^ in ['0'..'9']) else + repeat + inc(CapitalCount); + D^ := P^; + inc(P); + inc(D); + until not (P^ in ['A'..'Z']); + if P^=#0 then break; // no lowercase conversion of last fully uppercased word + if (CapitalCount > 1) and not Number then begin + dec(P); + dec(D); + end; + while P^ in ['a'..'z'] do begin + D^ := P^; + inc(D); + inc(P); + end; + if P^='_' then + if P[1]='_' then begin + D^ := ':'; + inc(P); + inc(D); + goto Next; + end else begin + PWord(D)^ := ord(' ')+ord('-')shl 8; + inc(D,2); + Next: if Space=SpaceBeg then + SpaceBeg := D+1; + inc(P); + Space := D+1; + end else + Space := D; + if P^=#0 then break; + D^ := ' '; + inc(D); + until false; + if Space>DBeg then + dec(Space); + while Space>SpaceBeg do begin + if Space^ in ['A'..'Z'] then + if not (Space[1] in ['A'..'Z',' ']) then + inc(Space^,32); // lowercase conversion of not last fully uppercased word + dec(Space); + end; + end; + result := D-DBeg; +end; + +procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; + const isWord: TSynByteSet); +var i: PtrInt; + d: PAnsiChar; + tmp: array[byte] of AnsiChar; +begin + if len > SizeOf(tmp) then + len := SizeOf(tmp); + for i := 0 to len-1 do + if not(ord(P[i]) in isWord) then begin + if i>0 then begin + MoveSmall(P,@tmp,i); + inc(P,i); + dec(len,i); + end; + d := @tmp[i]; + while len > 0 do begin + while (len > 0) and not (ord(P^) in isWord) do begin + inc(P); + dec(len); + end; + if len = 0 then + break; + d^ := NormToUpperAnsi7[P^]; + inc(d); + repeat + inc(P); + dec(len); + if not (ord(P^) in isWord) then + break; + d^ := P^; + inc(d); + until len = 0; + end; + P := @tmp; + len := d-tmp; + break; + end; + FastSetString(s,P,len); +end; + +procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet); +begin + CamelCase(pointer(text), length(text), s, isWord); +end; + +procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); +var Temp: array[byte] of AnsiChar; +begin // "out result" parameter definition already made result := '' + if P=nil then + exit; +{$ifdef UNICODE} + // property and enumeration names are UTF-8 encoded with Delphi 2009+ + UTF8DecodeToUnicodeString(Temp,UnCamelCase(@Temp,P),result); +{$else} + SetString(result,Temp,UnCamelCase(@Temp,P)); +{$endif} +{$ifndef LVCL} // LVCL system.pas doesn't implement LoadResStringTranslate() + if Assigned(LoadResStringTranslate) then + LoadResStringTranslate(result); +{$endif} +end; + +function GetDisplayNameFromClass(C: TClass): RawUTF8; +var DelphiName: PShortString; + TrimLeft: integer; +begin + if C=nil then begin + result := ''; + exit; + end; + DelphiName := ClassNameShort(C); + TrimLeft := 0; + if DelphiName^[0]>#4 then + case PInteger(@DelphiName^[1])^ and $DFDFDFDF of + // fast case-insensitive compare + ord('T')+ord('S')shl 8+ord('Q')shl 16+ord('L')shl 24: + if (DelphiName^[0]<=#10) or + (PInteger(@DelphiName^[5])^ and $DFDFDFDF<> // fast case-insensitive compare + ord('R')+ord('E')shl 8+ord('C')shl 16+ord('O')shl 24) or + (PWord(@DelphiName^[9])^ and $DFDF<>ord('R')+ord('D')shl 8) then + TrimLeft := 4 else + TrimLeft := 10; + ord('T')+ord('S')shl 8+ord('Y')shl 16+ord('N')shl 24: + TrimLeft := 4; + end; + if (Trimleft=0) and (DelphiName^[1]='T') then + Trimleft := 1; + FastSetString(result,@DelphiName^[TrimLeft+1],ord(DelphiName^[0])-TrimLeft); +end; + +function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; + aClass: TClass): integer; + procedure AddParentsFirst(C: TClass); + type + TMethodInfo = packed record + {$ifdef FPC} + Name: PShortString; + Addr: Pointer; + {$else} + Len: Word; + Addr: Pointer; + Name: ShortString; + {$endif} + end; + var Table: {$ifdef FPC}PCardinalArray{$else}PWordArray{$endif}; + M: ^TMethodInfo; + i: integer; + begin + if C=nil then + exit; + AddParentsFirst(GetClassParent(C)); // put children published methods afterward + Table := PPointer(PtrUInt(C)+PtrUInt(vmtMethodTable))^; + if Table=nil then + exit; + SetLength(Methods,result+Table^[0]); + M := @Table^[1]; + for i := 1 to Table^[0] do // Table^[0] = methods count + with Methods[result] do begin + ShortStringToAnsi7String(M^.Name{$ifdef FPC}^{$endif},Name); + Method.Data := Instance; + Method.Code := M^.Addr; + {$ifdef FPC} + inc(M); + {$else} + inc(PByte(M),M^.Len); + {$endif} + inc(result); + end; + end; +begin + result := 0; + if aClass <> nil then + AddParentsFirst(aClass) + else if Instance<>nil then + AddParentsFirst(PPointer(Instance)^); // use recursion for adding +end; + +function GetCaptionFromClass(C: TClass): string; +var tmp: RawUTF8; + P: PUTF8Char; +begin + if C=nil then + result := '' else begin + ToText(C,tmp); + P := pointer(tmp); + if IdemPChar(P,'TSQL') or IdemPChar(P,'TSYN') then + inc(P,4) else + if P^='T' then + inc(P); + GetCaptionFromPCharLen(P,result); + end; +end; + +function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; +begin + GetCaptionFromTrimmed(GetEnumName(aTypeInfo,aIndex),result); +end; + +function CharSetToCodePage(CharSet: integer): cardinal; +begin + case CharSet of + SHIFTJIS_CHARSET: result := 932; + HANGEUL_CHARSET: result := 949; + GB2312_CHARSET: result := 936; + HEBREW_CHARSET: result := 1255; + ARABIC_CHARSET: result := 1256; + GREEK_CHARSET: result := 1253; + TURKISH_CHARSET: result := 1254; + VIETNAMESE_CHARSET: result := 1258; + THAI_CHARSET: result := 874; + EASTEUROPE_CHARSET: result := 1250; + RUSSIAN_CHARSET: result := 1251; + BALTIC_CHARSET: result := 1257; + else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252 + end; +end; + +function CodePageToCharSet(CodePage: Cardinal): Integer; +begin + case CodePage of + 932: result := SHIFTJIS_CHARSET; + 949: result := HANGEUL_CHARSET; + 936: result := GB2312_CHARSET; + 1255: result := HEBREW_CHARSET; + 1256: result := ARABIC_CHARSET; + 1253: result := GREEK_CHARSET; + 1254: result := TURKISH_CHARSET; + 1258: result := VIETNAMESE_CHARSET; + 874: result := THAI_CHARSET; + 1250: result := EASTEUROPE_CHARSET; + 1251: result := RUSSIAN_CHARSET; + 1257: result := BALTIC_CHARSET; + else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252 + end; +end; + +function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; + const DefaultContentType: RawUTF8): RawUTF8; +begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers + result := DefaultContentType; + if (Content<>nil) and (Len>4) then + case PCardinal(Content)^ of + $04034B50: result := 'application/zip'; // 50 4B 03 04 + $46445025: result := 'application/pdf'; // 25 50 44 46 2D 31 2E + $21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00 + $AFBC7A37: result := 'application/x-7z-compressed'; // 37 7A BC AF 27 1C + $694C5153: result := 'application/x-sqlite3'; // SQlite format 3 = 53 51 4C 69 + $75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66 + $9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00 + $474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A + $38464947: result := 'image/gif'; // 47 49 46 38 + $46464F77: result := 'application/font-woff'; // wOFF in BigEndian + $A3DF451A: result := 'video/webm'; // 1A 45 DF A3 MKV Matroska stream file + $002A4949, $2A004D4D, $2B004D4D: + result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B + $46464952: if Len>16 then // RIFF + case PCardinalArray(Content)^[2] of + $50424557: result := 'image/webp'; + $20495641: if PCardinalArray(Content)^[3]=$5453494C then + result := 'video/x-msvideo'; // Windows Audio Video Interleave file + end; + $E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE + if Len>600 then + case PWordArray(Content)^[256] of // at offset 512 + $A5EC: result := 'application/msword'; // EC A5 C1 00 + $FFFD: // FD FF FF + case PByteArray(Content)^[516] of + $0E,$1C,$43: result := 'application/vnd.ms-powerpoint'; + $10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel'; + end; + end; + $5367674F: + if Len>14 then // OggS + if (PCardinalArray(Content)^[1]=$00000200) and + (PCardinalArray(Content)^[2]=$00000000) and + (PWordArray(Content)^[6]=$0000) then + result := 'video/ogg'; + $1C000000: + if Len>12 then + if PCardinalArray(Content)^[1]=$70797466 then // ftyp + case PCardinalArray(Content)^[2] of + $6D6F7369, // isom: ISO Base Media file (MPEG-4) v1 + $3234706D: // mp42: MPEG-4 video/QuickTime file + result := 'video/mp4'; + $35706733: // 3gp5: MPEG-4 video files + result := 'video/3gpp'; + end; + else + case PCardinal(Content)^ and $00ffffff of + $685A42: result := 'application/bzip2'; // 42 5A 68 + $088B1F: result := 'application/gzip'; // 1F 8B 08 + $492049: result := 'image/tiff'; // 49 20 49 + $FFD8FF: result := JPEG_CONTENT_TYPE; // FF D8 FF DB/E0/E1/E2/E3/E8 + else + case PWord(Content)^ of + $4D42: result := 'image/bmp'; // 42 4D + end; + end; + end; +end; + +function GetMimeContentType(Content: Pointer; Len: PtrInt; + const FileName: TFileName): RawUTF8; +begin + if FileName<>'' then begin // file extension is more precise -> check first + result := LowerCase(StringToAnsi7(ExtractFileExt(FileName))); + case PosEx(copy(result,2,4), + 'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+ + // 1 5 9 14 18 23 27 31 35 40 44 47 51 55 59 + 'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,'+ + // 63 68 72 76 81 86 91 96 100 105 110 114 118 122 + 'm2p,mp3,h264,text,log,gz,webm,mkv,rar,7z') of + // 126 130 134 139 144 148 151 156 160 164 + 1: result := 'image/png'; + 5: result := 'image/gif'; + 9: result := 'image/tiff'; + 14,18: result := JPEG_CONTENT_TYPE; + 23: result := 'image/bmp'; + 27,91: result := 'application/msword'; + 31,35: result := HTML_CONTENT_TYPE; + 40: result := 'text/css'; + 44: result := 'application/javascript'; + // text/javascript and application/x-javascript are obsolete (RFC 4329) + 47: result := 'image/x-icon'; + 51,105: result := 'application/font-woff'; + 55,139,144: result := TEXT_CONTENT_TYPE; + 59: result := 'image/svg+xml'; + 63,68,72,96: result := XML_CONTENT_TYPE; + 76: result := 'image/webp'; + 81,86: result := 'text/cache-manifest'; + 100: result := JSON_CONTENT_TYPE_VAR; + 110,114: result := 'video/ogg'; // RFC 5334 + 118: result := 'video/mp4'; // RFC 4337 6381 + 122,126: result := 'video/mp2'; + 130: result := 'audio/mpeg'; // RFC 3003 + 134: result := 'video/H264'; // RFC 6184 + 148: result := 'application/gzip'; + 151,156: result := 'video/webm'; + 160: result := 'application/x-rar-compressed'; + 164: result := 'application/x-7z-compressed'; + else + result := GetMimeContentTypeFromBuffer(Content,Len,'application/'+copy(result,2,20)); + end; + end else + result := GetMimeContentTypeFromBuffer(Content,Len,BINARY_CONTENT_TYPE); +end; + +function GetMimeContentTypeHeader(const Content: RawByteString; + const FileName: TFileName): RawUTF8; +begin + result := HEADER_CONTENT_TYPE+ + GetMimeContentType(Pointer(Content),length(Content),FileName); +end; + +function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; +begin // see http://www.garykessler.net/library/file_sigs.html + result := false; + if (Content<>nil) and (Len>8) then + case PCardinal(Content)^ of + $002a4949, $2a004d4d, $2b004d4d, // 'image/tiff' + $04034b50, // 'application/zip' = 50 4B 03 04 + $184d2204, // LZ4 stream format = 04 22 4D 18 + $21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00 + $28635349, // cab = 49 53 63 28 + $38464947, // 'image/gif' = 47 49 46 38 + $43614c66, // FLAC = 66 4C 61 43 00 00 00 22 + $4643534d, // cab = 4D 53 43 46 [MSCF] + $46464952, // avi,webp,wav = 52 49 46 46 [RIFF] + $46464f77, // 'application/font-woff' = wOFF in BigEndian + $474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A + $4d5a4cff, // LZMA = FF 4C 5A 4D 41 00 + $72613c21, // .ar/.deb files = '!' (assuming compressed) + $75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66 + $766f6f6d, // mov = 6D 6F 6F 76 [....moov] + $89a8275f, // jar = 5F 27 A8 89 + $9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00 + $a5a5a5a5, // .mab file = MAGIC_MAB in SynLog.pas + $a5aba5a5, // .data = TSQLRESTSTORAGEINMEMORY_MAGIC in mORMot.pas + $aba51051, // .log.synlz = LOG_MAGIC in SynLog.pas + $aba5a5ab, // .dbsynlz = SQLITE3_MAGIC in SynSQLite3.pas + $afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C + $b7010000, $ba010000, // mpeg = 00 00 01 Bx + $cececece, // jceks = CE CE CE CE + $dbeeabed, // .rpm package file + $e011cfd0: // msi = D0 CF 11 E0 A1 B1 1A E1 + result := true; + else + case PCardinal(Content)^ and $00ffffff of + $088b1f, // 'application/gzip' = 1F 8B 08 + $334449, // mp3 = 49 44 33 [ID3] + $492049, // 'image/tiff' = 49 20 49 + $535746, // swf = 46 57 53 [FWS] + $535743, // swf = 43 57 53 [zlib] + $53575a, // zws/swf = 5A 57 53 [FWS] + $564c46, // flv = 46 4C 56 [FLV] + $685a42, // 'application/bzip2' = 42 5A 68 + $ffd8ff: // JPEG_CONTENT_TYPE = FF D8 FF DB/E0/E1/E2/E3/E8 + result := true; + else + case PCardinalArray(Content)^[1] of // 4 byte offset + 1{TAlgoSynLZ.AlgoID}: // crc32 01 00 00 00 crc32 = Compress() header + result := PCardinalArray(Content)^[0]<>PCardinalArray(Content)^[2]; + $70797466, // mp4,mov = 66 74 79 70 [33 67 70 35/4D 53 4E 56..] + $766f6f6d: // mov = 6D 6F 6F 76 + result := true; + end; + end; + end; +end; + +function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; +var je: PAnsiChar; +begin // see https://en.wikipedia.org/wiki/JPEG#Syntax_and_structure + result := false; + if (jpeg=nil) or (len<100) or (PWord(jpeg)^<>$d8ff) then // SOI + exit; + je := jpeg+len-1; + inc(jpeg,2); + while jpeg#$ff then + exit; + inc(jpeg); + case ord(jpeg^) of + $c0..$c3,$c5..$c7,$c9..$cb,$cd..$cf: begin // SOF + Height := swap(PWord(jpeg+4)^); + Width := swap(PWord(jpeg+6)^); + result := (Height>0) and (Height<20000) and (Width>0) and (Width<20000); + exit; + end; + $d0..$d8,$01: inc(jpeg); // RST, SOI + $d9: break; // EOI + $ff: ; // padding + else inc(jpeg,swap(PWord(jpeg+1)^)+1); + end; + end; +end; + +function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; +var map: TMemoryMap; +begin + if map.Map(jpeg) then + try + result := GetJpegSize(map.Buffer,map.Size,Height,Width); + finally + map.UnMap; + end else + result := false; +end; + +function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; +begin + result := ExistsIniNameValue(Headers,HEADER_CONTENT_TYPE_UPPER, + [JSON_CONTENT_TYPE_UPPER,'TEXT/','APPLICATION/XML','APPLICATION/JAVASCRIPT', + 'APPLICATION/X-JAVASCRIPT','IMAGE/SVG+XML']); +end; + +function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; + var MultiPart: TMultiPartDynArray): boolean; +var boundary,endBoundary: RawUTF8; + i,j: integer; + P: PUTF8Char; + part: TMultiPart; +begin + result := false; + i := PosEx('boundary=',MimeType); + if i=0 then + exit; + TrimCopy(MimeType,i+9,200,boundary); + if (boundary<>'') and (boundary[1]='"') then + boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary + boundary := '--'+boundary; + endBoundary := boundary+'--'+#13#10; + boundary := boundary+#13#10; + i := PosEx(boundary,Body); + if i<>0 then + repeat + inc(i,length(boundary)); + if i=length(body) then + exit; // reached the end + P := PUTF8Char(Pointer(Body))+i-1; + Finalize(part); + repeat + if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin + inc(P,21); + if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then + IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else + IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"') + end else + if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then + IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding); + P := GotoNextLine(P); + if P=nil then + exit; + until PWord(P)^=13+10 shl 8; + i := P-PUTF8Char(Pointer(Body))+3; // i = just after header + j := PosEx(boundary,Body,i); + if j=0 then begin + j := PosEx(endboundary,Body,i); // try last boundary + if j=0 then + exit; + end; + part.Content := copy(Body,i,j-i-2); // -2 to ignore latest #13#10 + if (part.ContentType='') or (PosEx('-8',part.ContentType)>0) then begin + part.ContentType := TEXT_CONTENT_TYPE; + {$ifdef HASCODEPAGE} + SetCodePage(part.Content,CP_UTF8,false); // ensure raw field value is UTF-8 + {$endif} + end; + if IdemPropNameU(part.Encoding,'base64') then + part.Content := Base64ToBin(part.Content); + // note: "quoted-printable" not yet handled here + SetLength(MultiPart,length(MultiPart)+1); + MultiPart[high(MultiPart)] := part; + result := true; + i := j; + until false; +end; + +function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; + var MultiPartContentType, MultiPartContent: RawUTF8): boolean; +var len, boundcount, filescount, i: integer; + boundaries: array of RawUTF8; + bound: RawUTF8; + W: TTextWriter; + temp: TTextWriterStackBuffer; + procedure NewBound; + var random: array[1..3] of cardinal; + begin + FillRandom(@random,3,{forcegsl=}true); + bound := BinToBase64(@random,SizeOf(Random)); + SetLength(boundaries,boundcount+1); + boundaries[boundcount] := bound; + inc(boundcount); + end; +begin + result := false; + len := length(MultiPart); + if len=0 then + exit; + boundcount := 0; + filescount := 0; + W := TTextWriter.CreateOwnedStream(temp); + try + // header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html + NewBound; + MultiPartContentType := 'Content-Type: multipart/form-data; boundary='+bound; + for i := 0 to len-1 do + with MultiPart[i] do begin + if FileName='' then + W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10+ + 'Content-Type: %'#13#10#13#10'%'#13#10'--%'#13#10, + [bound,Name,ContentType,Content,bound]) else begin + // if this is the first file, create the header for files + if filescount=0 then begin + if i>0 then + NewBound; + W.Add('Content-Disposition: form-data; name="files"'#13#10+ + 'Content-Type: multipart/mixed; boundary=%'#13#10#13#10,[bound]); + end; + inc(filescount); + W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10+ + 'Content-Type: %'#13#10,[bound,FileName,ContentType]); + if Encoding<>'' then + W.Add('Content-Transfer-Encoding: %'#13#10,[Encoding]); + W.AddCR; + W.AddString(MultiPart[i].Content); + W.Add(#13#10'--%'#13#10,[bound]); + end; + end; + // footer multipart + for i := boundcount-1 downto 0 do + W.Add('--%--'#13#10, [boundaries[i]]); + W.SetText(MultiPartContent); + result := True; + finally + W.Free; + end; +end; + +function MultiPartFormDataAddFile(const FileName: TFileName; + var MultiPart: TMultiPartDynArray; const Name: RawUTF8): boolean; +var part: TMultiPart; + newlen: integer; + content: RawByteString; +begin + result := false; + content := StringFromFile(FileName); + if content='' then + exit; + newlen := length(MultiPart)+1; + if Name='' then + FormatUTF8('File%',[newlen],part.Name) else + part.Name := Name; + part.FileName := StringToUTF8(ExtractFileName(FileName)); + part.ContentType := GetMimeContentType(pointer(content),length(content),FileName); + part.Encoding := 'base64'; + part.Content := BinToBase64(content); + SetLength(MultiPart,newlen); + MultiPart[newlen-1] := part; + result := true; +end; + +function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; + var MultiPart: TMultiPartDynArray): boolean; +var + part: TMultiPart; + newlen: integer; +begin + result := false; + if FieldName='' then + exit; + newlen := length(MultiPart)+1; + part.Name := FieldName; + part.ContentType := GetMimeContentTypeFromBuffer( + pointer(FieldValue),length(FieldValue),'text/plain'); + part.Content := FieldValue; + SetLength(MultiPart,newlen); + MultiPart[newlen-1] := part; + result := true; +end; + +function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; +begin + result := FastLocatePUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp)); +end; + +function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; + Compare: TUTF8Compare): PtrInt; +var L,i,cmp: PtrInt; +begin // fast O(log(n)) binary search + if not Assigned(Compare) or (R<0) then + result := 0 else + if Compare(P^[R],Value)<0 then // quick return if already sorted + result := R+1 else begin + L := 0; + result := -1; // return -1 if found + repeat + i := (L + R) shr 1; + cmp := Compare(P^[i],Value); + if cmp=0 then + exit; + if cmp<0 then + L := i + 1 else + R := i - 1; + until (L > R); + while (i>=0) and (Compare(P^[i],Value)>=0) do dec(i); + result := i+1; // return the index where to insert + end; +end; + +function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; + Compare: TUTF8Compare): PtrInt; +var L, cmp: PtrInt; +begin // fast O(log(n)) binary search + L := 0; + if Assigned(Compare) and (R>=0) then + repeat + result := (L+R) shr 1; + cmp := Compare(P^[result],Value); + if cmp=0 then + exit; + if cmp<0 then begin + L := result+1; + if L<=R then + continue; + break; + end; + R := result-1; + if L<=R then + continue; + break; + until false; + result := -1; +end; + +function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; +{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8/rdx +{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} + {$ifdef win64} + push rdi + mov rdi, P // P=rdi + {$endif} + push r12 + push r13 + xor r9, r9 // L=r9 + test R, R + jl @err + test Value, Value + jz @void + mov cl, byte ptr[Value] // to check first char (likely diverse) +@s: lea rax, qword ptr[r9 + R] + shr rax, 1 + lea r12, qword ptr[rax - 1] // branchless main loop + lea r13, qword ptr[rax + 1] + mov r10, qword ptr[rdi + rax * 8] + test r10, r10 + jz @lt + cmp cl, byte ptr[r10] + je @eq + cmovc R, r12 + cmovnc r9, r13 +@nxt: cmp r9, R + jle @s +@err: or rax, -1 +@found: pop r13 + pop r12 + {$ifdef win64} + pop rdi + {$endif} + ret +@lt: mov r9, r13 // very unlikely P[rax]=nil + jmp @nxt +@eq: mov r11, Value +@sub: mov cl, byte ptr[r10] + inc r10 + inc r11 + test cl, cl + jz @found + mov cl, byte ptr[r11] + cmp cl, byte ptr[r10] + je @sub + mov cl, byte ptr[Value] // reset first char + cmovc R, r12 + cmovnc r9, r13 + cmp r9, R + jle @s + jmp @err +@void: or rax, -1 + cmp qword ptr[P], 0 + cmove rax, Value + jmp @found +end; +{$else} +var L: PtrInt; + c: byte; + piv,val: PByte; +begin // fast O(log(n)) binary search using inlined StrCompFast() + if R>=0 then + if Value<>nil then begin + L := 0; + repeat + result := (L+R) shr 1; + piv := pointer(P^[result]); + if piv<>nil then begin + val := pointer(Value); + c := piv^; + if c=val^ then + repeat + if c=0 then + exit; // StrComp(P^[result],Value)=0 + inc(piv); + inc(val); + c := piv^; + until c<>val^; + if c>val^ then begin + R := result-1; // StrComp(P^[result],Value)>0 + if L<=R then + continue; + break; + end; + end; + L := result+1; // StrComp(P^[result],Value)<0 + if L<=R then + continue; + break; + until false; + end else + if P^[0]=nil then begin // '' should be in lowest P[] slot + result := 0; + exit; + end; + result := -1; +end; +{$endif CPUX64} + +function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; + Value: PUTF8Char; ValueLen: PtrInt): PtrInt; +var tmp: array[byte] of AnsiChar; +begin + UpperCopy255Buf(@tmp,Value,ValueLen)^ := #0; + result := FastFindPUTF8CharSorted(P,R,@tmp); +end; + +function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; + var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; + ItemComp: TUTF8Compare): PtrInt; +var L, cmp: PtrInt; +begin // fast O(log(n)) binary search + L := 0; + if 0<=R then + repeat + result := (L + R) shr 1; + cmp := ItemComp(P^[SortedIndexes[result]],Value); + if cmp=0 then begin + result := SortedIndexes[result]; + exit; + end; + if cmp<0 then begin + L := result+1; + if L<=R then + continue; + break; + end; + R := result-1; + if L<=R then + continue; + break; + until false; + result := -1; +end; + +function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + const Value: RawUTF8; CoValues: PIntegerDynArray; ForcedIndex: PtrInt; + Compare: TUTF8Compare): PtrInt; +var n: PtrInt; +begin + if ForcedIndex>=0 then + result := ForcedIndex else begin + if not Assigned(Compare) then + Compare := @StrComp; + result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare); + if result<0 then + exit; // Value exists -> fails + end; + n := Length(Values); + if ValuesCount=n then begin + n := NextGrow(n); + SetLength(Values,n); + if CoValues<>nil then + SetLength(CoValues^,n); + end; + n := ValuesCount; + if resultnil then begin + {$ifdef CPU64}n := n shr 1;{$endif} // 64-bit pointer size is twice an integer + MoveFast(CoValues^[result],CoValues^[result+1],n); + end; + end else + result := n; + Values[result] := Value; + inc(ValuesCount); +end; + + +type + /// used internaly for faster quick sort + TQuickSortRawUTF8 = object + Values: PPointerArray; + Compare: TUTF8Compare; + CoValues: PIntegerArray; + pivot: pointer; + procedure Sort(L,R: PtrInt); + end; + +procedure TQuickSortRawUTF8.Sort(L, R: PtrInt); +var I, J, P: PtrInt; + Tmp: Pointer; + TmpInt: integer; +begin + if L0 do Dec(J); + if I <= J then begin + Tmp := Values^[J]; + Values^[J] := Values^[I]; + Values^[I] := Tmp; + if CoValues<>nil then begin + TmpInt := CoValues^[J]; + CoValues^[J] := CoValues^[I]; + CoValues^[I] := TmpInt; + end; + if P = I then P := J else if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + Sort(L, J); + L := I; + end else begin + if I < R then + Sort(I, R); + R := J; + end; + until L >= R; +end; + +procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; + CoValues: PIntegerDynArray; Compare: TUTF8Compare); +var QS: TQuickSortRawUTF8; +begin + QS.Values := pointer(Values); + if Assigned(Compare) then + QS.Compare := Compare else + QS.Compare := @StrComp; + if CoValues=nil then + QS.CoValues := nil else + QS.CoValues := pointer(CoValues^); + QS.Sort(0,ValuesCount-1); +end; + +function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; +var n: integer; +begin + n := length(Values); + if cardinal(Index)>=cardinal(n) then + result := false else begin + dec(n); + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); + Values[Index] := ''; // avoid GPF + if n>Index then begin + MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),(n-Index)*SizeOf(pointer)); + PtrUInt(Values[n]) := 0; // avoid GPF + end; + SetLength(Values,n); + result := true; + end; +end; + +function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; + Index: integer; CoValues: PIntegerDynArray): boolean; +var n: integer; +begin + n := ValuesCount; + if cardinal(Index)>=cardinal(n) then + result := false else begin + dec(n); + ValuesCount := n; + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); + Values[Index] := ''; // avoid GPF + dec(n,Index); + if n>0 then begin + if CoValues<>nil then + MoveFast(CoValues^[Index+1],CoValues^[Index],n*SizeOf(Integer)); + MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),n*SizeOf(pointer)); + PtrUInt(Values[ValuesCount]) := 0; // avoid GPF + end; + result := true; + end; +end; + +function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8): RawUTF8; +var f: TIntelCpuFeature; + List: PShortString; + MaxValue: integer; +begin + result := ''; + List := GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue); + if List<>nil then + for f := low(f) to high(f) do begin + if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin + if result<>'' then + result := result+Sep; + result := result+RawUTF8(copy(List^,3,10)); + end; + inc(PByte(List),PByte(List)^+1); // next + end; +end; + +{$ifdef MSWINDOWS} + +// wrapper around some low-level Windows-specific API + +{$ifdef DELPHI6OROLDER} +function GetFileVersion(const FileName: TFileName): cardinal; +var Size, Size2: DWord; + Pt: Pointer; + Info: ^TVSFixedFileInfo; + tmp: TFileName; +begin + result := cardinal(-1); + if FileName='' then + exit; + // GetFileVersionInfo modifies the filename parameter data while parsing + // Copy the string const into a local variable to create a writeable copy + SetString(tmp,PChar(FileName),length(FileName)); + Size := GetFileVersionInfoSize(pointer(tmp), Size2); + if Size>0 then begin + GetMem(Pt, Size); + try + GetFileVersionInfo(pointer(FileName), 0, Size, Pt); + if VerQueryValue(Pt, '\', pointer(Info), Size2) then + result := Info^.dwFileVersionMS; + finally + Freemem(Pt); + end; + end; +end; +{$endif DELPHI6OROLDER} + +function WndProcMethod(Hwnd: HWND; Msg,wParam,lParam: integer): integer; stdcall; +var obj: TObject; + dsp: TMessage; +begin + {$ifdef CPU64} + obj := pointer(GetWindowLongPtr(HWnd,GWLP_USERDATA)); + {$else} + obj := pointer(GetWindowLong(HWnd,GWL_USERDATA)); // faster than GetProp() + {$endif CPU64} + if not Assigned(obj) then + result := DefWindowProc(HWnd,Msg,wParam,lParam) else begin + dsp.msg := Msg; + dsp.wParam := WParam; + dsp.lParam := lParam; + dsp.result := 0; + obj.Dispatch(dsp); + result := dsp.result; + end; +end; + +function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; +var TempClass: TWndClass; +begin + result := 0; + if GetClassInfo(HInstance, pointer(aWindowName), TempClass) then + exit; // class name already registered -> fail + FillCharFast(TempClass,SizeOf(TempClass),0); + TempClass.hInstance := HInstance; + TempClass.lpfnWndProc := @DefWindowProc; + TempClass.lpszClassName := pointer(aWindowName); + Windows.RegisterClass(TempClass); + result := CreateWindowEx(WS_EX_TOOLWINDOW, pointer(aWindowName), + '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); + if result=0 then + exit; // impossible to create window -> fail + {$ifdef CPU64} + SetWindowLongPtr(result,GWLP_USERDATA,PtrInt(aObject)); + SetWindowLongPtr(result,GWLP_WNDPROC,PtrInt(@WndProcMethod)); + {$else} + SetWindowLong(result,GWL_USERDATA,PtrInt(aObject)); // faster than SetProp() + SetWindowLong(result,GWL_WNDPROC,PtrInt(@WndProcMethod)); + {$endif CPU64} +end; + +function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; +begin + if (aWindow<>0) and (aWindowName<>'') then begin + {$ifdef CPU64} + SetWindowLongPtr(aWindow,GWLP_WNDPROC,PtrInt(@DefWindowProc)); + {$else} + SetWindowLong(aWindow,GWL_WNDPROC,PtrInt(@DefWindowProc)); + {$endif CPU64} + DestroyWindow(aWindow); + Windows.UnregisterClass(pointer(aWindowName),HInstance); + aWindow := 0; + aWindowName := ''; + result := true; + end else + result := false; +end; + +var + LastAppUserModelID: string; + +function SetAppUserModelID(const AppUserModelID: string): boolean; +var shell32: THandle; + id: SynUnicode; + SetCurrentProcessExplicitAppUserModelID: function(appID: PWidechar): HResult; stdcall; +begin + if AppUserModelID=LastAppUserModelID then begin + result := true; + exit; // nothing to set + end; + result := false; + shell32 := GetModuleHandle('shell32.dll'); + if shell32=0 then + exit; + SetCurrentProcessExplicitAppUserModelID := GetProcAddress( + shell32,'SetCurrentProcessExplicitAppUserModelID'); + if not Assigned(SetCurrentProcessExplicitAppUserModelID) then + exit; // API available since Windows Seven / Server 2008 R2 + StringToSynUnicode(AppUserModelID,id); + if Pos('.',AppUserModelID)=0 then + id := id+'.'+id; // at least CompanyName.ProductName + if SetCurrentProcessExplicitAppUserModelID(pointer(id))<>S_OK then + exit; + result := true; + LastAppUserModelID := AppUserModelID; +end; + +{$endif MSWINDOWS} + +{ TFileVersion } + +constructor TFileVersion.Create(const aFileName: TFileName; + aMajor,aMinor,aRelease,aBuild: integer); +var M,D: word; +{$ifdef MSWINDOWS} + Size, Size2: DWord; + Pt, StrPt, StrValPt: Pointer; + LanguageInfo: RawUTF8; + Info: ^TVSFixedFileInfo; + FileTime: TFILETIME; + SystemTime: TSYSTEMTIME; + tmp: TFileName; + function ReadResourceByName(const From: RawUTF8): RawUTF8; + var sz: DWord; + begin + VerQueryValueA(Pt,PAnsiChar('\StringFileInfo\'+LanguageInfo+'\'+From),StrValPt,sz); + if sz>0 then + FastSetString(Result,StrValPt,sz) + end; +{$else} +{$ifdef FPCUSEVERSIONINFO} + VI: TVersionInfo; + LanguageInfo: String; + TI, I: Integer; +{$endif} +{$endif MSWINDOWS} +begin + fFileName := aFileName; + {$ifdef MSWINDOWS} + if aFileName<>'' then begin + // GetFileVersionInfo modifies the filename parameter data while parsing. + // Copy the string const into a local variable to create a writeable copy. + SetString(tmp,PChar(aFileName),length(aFileName)); + Size := GetFileVersionInfoSize(pointer(tmp), Size2); + if Size>0 then begin + GetMem(Pt, Size); + try + GetFileVersionInfo(pointer(aFileName), 0, Size, Pt); + VerQueryValue(Pt, '\', pointer(Info), Size2); + with Info^ do begin + if Version32=0 then begin + aMajor := dwFileVersionMS shr 16; + aMinor := word(dwFileVersionMS); + aRelease := dwFileVersionLS shr 16; + end; + aBuild := word(dwFileVersionLS); + if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin + FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info + FileTime.dwHighDateTime:= dwFileDateMS; + FileTimeToSystemTime(FileTime, SystemTime); + fBuildDateTime := EncodeDate( + SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay); + end; + end; + VerQueryValue(Pt, '\VarFileInfo\Translation', StrPt, Size2); + if Size2 >= 4 then begin + LanguageInfo := BinToHexDisplay(PAnsiChar(StrPt), 2) + BinToHexDisplay(PAnsiChar(StrPt)+2, 2); + CompanyName := ReadResourceByName('CompanyName'); + FileDescription := ReadResourceByName('FileDescription'); + FileVersion := ReadResourceByName('FileVersion'); + InternalName := ReadResourceByName('InternalName'); + LegalCopyright := ReadResourceByName('LegalCopyright'); + OriginalFilename := ReadResourceByName('OriginalFilename'); + ProductName := ReadResourceByName('ProductName'); + ProductVersion := ReadResourceByName('ProductVersion'); + Comments := ReadResourceByName('Comments'); + end + finally + Freemem(Pt); + end; + end; + end; + {$else MSWINDOWS} + {$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in Synopse.inc / project options + if aFileName<>'' then + try + VI := TVersionInfo.Create; + try + if (aFileName<>ExeVersion.ProgramFileName) and (aFileName<>ParamStr(0)) then + VI.Load(aFileName) else + VI.Load(HInstance); // load info for currently running program + aMajor := VI.FixedInfo.FileVersion[0]; + aMinor := VI.FixedInfo.FileVersion[1]; + aRelease := VI.FixedInfo.FileVersion[2]; + aBuild := VI.FixedInfo.FileVersion[3]; + //fBuildDateTime := TDateTime(VI.FixedInfo.FileDate); << need to find out how to convert this before uncommenting + // detect translation. + if VI.VarFileInfo.Count>0 then + with VI.VarFileInfo.Items[0] do + LanguageInfo := Format('%.4x%.4x',[language,codepage]); + if LanguageInfo='' then begin + // take first language + Ti := 0; + if VI.StringFileInfo.Count>0 then + LanguageInfo := VI.StringFileInfo.Items[0].Name + end else begin + // look for index of language + TI := VI.StringFileInfo.Count-1; + while (TI>=0) and (CompareText(VI.StringFileInfo.Items[TI].Name,LanguageInfo)<>0) do + dec(TI); + if (TI < 0) then begin + TI := 0; // revert to first translation + LanguageInfo := VI.StringFileInfo.Items[TI].Name; + end; + end; + with VI.StringFileInfo.Items[TI] do begin + CompanyName := Values['CompanyName']; + FileDescription := Values['FileDescription']; + FileVersion := Values['FileVersion']; + InternalName := Values['InternalName']; + LegalCopyright := Values['LegalCopyright']; + OriginalFilename := Values['OriginalFilename']; + ProductName := Values['ProductName']; + ProductVersion := Values['ProductVersion']; + Comments := Values['Comments']; + end; + finally + VI.Free; + end; + except + // just ignore if version information resource is missing + end; + {$endif FPCUSEVERSIONINFO} + {$endif MSWINDOWS} + SetVersion(aMajor,aMinor,aRelease,aBuild); + if fBuildDateTime=0 then // get build date from file age + fBuildDateTime := FileAgeToDateTime(aFileName); + if fBuildDateTime<>0 then + DecodeDate(fBuildDateTime,BuildYear,M,D); +end; + +function TFileVersion.Version32: integer; +begin + result := Major shl 16+Minor shl 8+Release; +end; + +procedure TFileVersion.SetVersion(aMajor,aMinor,aRelease,aBuild: integer); +begin + Major := aMajor; + Minor := aMinor; + Release := aRelease; + Build := aBuild; + Main := IntToString(Major)+'.'+IntToString(Minor); + fDetailed := Main+ '.'+IntToString(Release)+'.'+IntToString(Build); +end; + +function TFileVersion.BuildDateTimeString: string; +begin + DateTimeToIso8601StringVar(fBuildDateTime,' ',result); +end; + +function TFileVersion.DetailedOrVoid: string; +begin + if (self=nil) or (Major or Minor or Release or Build=0) then + result := '' else + result := fDetailed; +end; + +function TFileVersion.VersionInfo: RawUTF8; +begin + FormatUTF8('% % (%)',[ExtractFileName(fFileName),DetailedOrVoid,BuildDateTimeString],result); +end; + +function TFileVersion.UserAgent: RawUTF8; +begin + if self=nil then + result := '' else + FormatUTF8('%/%%',[GetFileNameWithoutExt(ExtractFileName(fFileName)), + DetailedOrVoid,OS_INITIAL[OS_KIND]],result); + {$ifdef MSWINDOWS} + if OSVersion in WINDOWS_32 then + result := result+'32'; + {$endif MSWINDOWS} +end; + +class function TFileVersion.GetVersionInfo(const aFileName: TFileName): RawUTF8; +begin + with Create(aFileName,0,0,0,0) do + try + result := VersionInfo; + finally + Free; + end; +end; + +procedure SetExecutableVersion(const aVersionText: RawUTF8); +var P: PUTF8Char; + i: integer; + ver: array[0..3] of integer; +begin + P := pointer(aVersionText); + for i := 0 to 3 do + ver[i] := GetNextItemCardinal(P,'.'); + SetExecutableVersion(ver[0],ver[1],ver[2],ver[3]); +end; + +procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); +var {$ifdef MSWINDOWS} + tmp: array[byte] of WideChar; + tmpsize: cardinal; + {$else} + tmp: string; + {$endif} +begin + with ExeVersion do begin + if Version=nil then begin + {$ifdef MSWINDOWS} + ProgramFileName := paramstr(0); + {$else} + ProgramFileName := GetModuleName(HInstance); + if ProgramFileName='' then + ProgramFileName := ExpandFileName(paramstr(0)); + {$endif MSWINDOWS} + ProgramFilePath := ExtractFilePath(ProgramFileName); + if IsLibrary then + InstanceFileName := GetModuleName(HInstance) else + InstanceFileName := ProgramFileName; + ProgramName := StringToUTF8(GetFileNameWithoutExt(ExtractFileName(ProgramFileName))); + {$ifdef MSWINDOWS} + tmpsize := SizeOf(tmp); + GetComputerNameW(tmp,tmpsize); + RawUnicodeToUtf8(@tmp,StrLenW(tmp),Host); + tmpsize := SizeOf(tmp); + GetUserNameW(tmp,tmpsize); + RawUnicodeToUtf8(@tmp,StrLenW(tmp),User); + {$else} + StringToUTF8(GetHostName,Host); + if Host='' then + StringToUTF8(GetEnvironmentVariable('HOSTNAME'),Host); + tmp := GetEnvironmentVariable('LOGNAME'); // POSIX + if tmp='' then + tmp := GetEnvironmentVariable('USER'); + {$ifdef KYLIX3} + if tmp='' then + User := LibC.getpwuid(LibC.getuid)^.pw_name else + {$endif} + StringToUTF8(tmp,User); + {$endif MSWINDOWS} + if Host='' then + Host := 'unknown'; + if User='' then + User := 'unknown'; + GarbageCollectorFreeAndNil(Version, + TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild)); + end else + Version.SetVersion(aMajor,aMinor,aRelease,aBuild); + FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed, + DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec); + Hash.c0 := Version.Version32; + {$ifdef CPUINTEL} + Hash.c0 := crc32c(Hash.c0,@CpuFeatures,SizeOf(CpuFeatures)); + {$endif} + Hash.c0 := crc32c(Hash.c0,pointer(Host),length(Host)); + Hash.c1 := crc32c(Hash.c0,pointer(User),length(User)); + Hash.c2 := crc32c(Hash.c1,pointer(ProgramFullSpec),length(ProgramFullSpec)); + Hash.c3 := crc32c(Hash.c2,pointer(InstanceFileName),length(InstanceFileName)); + end; +end; + +{$ifdef MSWINDOWS} +// avoid unneeded reference to ShlObj.pas +function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle; + dwFlags: DWord; pszPath: PChar): HRESULT; stdcall; external 'SHFolder.dll' + name {$ifdef UNICODE}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif}; + +var + _SystemPath: array[TSystemPath] of TFileName; + +function GetSystemPath(kind: TSystemPath): TFileName; +const + CSIDL_PERSONAL = $0005; + CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder + CSIDL_COMMON_APPDATA = $0023; + CSIDL_COMMON_DOCUMENTS = $002E; + CSIDL: array[TSystemPath] of integer = ( + // spCommonData, spUserData, spCommonDocuments + CSIDL_COMMON_APPDATA, CSIDL_LOCAL_APPDATA, CSIDL_COMMON_DOCUMENTS, + // spUserDocuments, spTempFolder, spLog + CSIDL_PERSONAL, 0, CSIDL_LOCAL_APPDATA); + ENV: array[TSystemPath] of TFileName = ( + 'ALLUSERSAPPDATA', 'LOCALAPPDATA', '', '', 'TEMP', 'LOCALAPPDATA'); +var tmp: array[0..MAX_PATH] of char; +begin + if _SystemPath[kind]='' then + if (kind=spLog) and IsDirectoryWritable(ExeVersion.ProgramFilePath) then + _SystemPath[kind] := EnsureDirectoryExists(ExeVersion.ProgramFilePath+'log') else + if (CSIDL[kind]<>0) and (SHGetFolderPath(0,CSIDL[kind],0,0,@tmp)=S_OK) then + _SystemPath[kind] := IncludeTrailingPathDelimiter(tmp) else begin + _SystemPath[kind] := GetEnvironmentVariable(ENV[kind]); + if _SystemPath[kind]='' then + _SystemPath[kind] := GetEnvironmentVariable('APPDATA'); + _SystemPath[kind] := IncludeTrailingPathDelimiter(_SystemPath[kind]); + end; + result := _SystemPath[kind]; +end; +{$else MSWINDOWS} +var + _HomePath, _TempPath, _UserPath, _LogPath: TFileName; + +function GetSystemPath(kind: TSystemPath): TFileName; +begin + case kind of + spLog: begin + if _LogPath='' then + if IsDirectoryWritable('/var/log') then + _LogPath := '/var/log/' else // may not be writable by not root on POSIX + if IsDirectoryWritable(ExeVersion.ProgramFilePath) then + _LogPath := ExeVersion.ProgramFilePath else + _LogPath := GetSystemPath(spUserData); + result := _LogPath; + end; + spUserData: begin + if _UserPath='' then begin // ~/.cache/appname + _UserPath := GetEnvironmentVariable('XDG_CACHE_HOME'); + if (_UserPath='') or not IsDirectoryWritable(_UserPath) then + _UserPath := EnsureDirectoryExists(GetSystemPath(spUserDocuments)+'.cache'); + _UserPath := EnsureDirectoryExists(_UserPath+UTF8ToString(ExeVersion.ProgramName)); + end; + result := _UserPath; + end; + spTempFolder: begin + if _TempPath='' then begin + _TempPath := GetEnvironmentVariable('TMPDIR'); // POSIX + if _TempPath='' then + _TempPath := GetEnvironmentVariable('TMP'); + if _TempPath='' then + if DirectoryExists('/tmp') then + _TempPath := '/tmp' else + _TempPath := '/var/tmp'; + _TempPath := IncludeTrailingPathDelimiter(_TempPath); + end; + result := _TempPath; + end else begin + if _HomePath='' then // POSIX requires a value for $HOME + _HomePath := IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME')); + result := _HomePath; + end; + end; +end; +{$endif MSWINDOWS} + +procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer; + LeaveUnprotected: boolean); +{$ifdef MSWINDOWS} +var RestoreProtection, Ignore: DWORD; + i: integer; +begin + if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then + begin + if Backup<>nil then + for i := 0 to Size-1 do // do not use Move() here + PByteArray(Backup)^[i] := PByteArray(Old)^[i]; + for i := 0 to Size-1 do // do not use Move() here + PByteArray(Old)^[i] := PByteArray(New)^[i]; + if not LeaveUnprotected then + VirtualProtect(Old, Size, RestoreProtection, Ignore); + FlushInstructionCache(GetCurrentProcess, Old, Size); + if not CompareMemFixed(Old,New,Size) then + raise ESynException.Create('PatchCode?'); + end; +end; +{$else} +var PageSize: PtrUInt; + AlignedAddr: pointer; + i: PtrInt; + ProtectedResult: boolean; + ProtectedMemory: boolean; +begin + if Backup<>nil then + for i := 0 to Size-1 do // do not use Move() here + PByteArray(Backup)^[i] := PByteArray(Old)^[i]; + PageSize := SystemInfo.dwPageSize; + AlignedAddr := Pointer((PtrUInt(Old) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize); + while PtrUInt(Old)+PtrUInt(Size)>=PtrUInt(AlignedAddr)+PageSize do + Inc(PageSize,SystemInfo.dwPageSize); + ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE or PROT_EXEC) = 0; + ProtectedMemory := not ProtectedResult; + if ProtectedMemory then + ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE) = 0; + if ProtectedResult then + try + for i := 0 to Size-1 do // do not use Move() here + PByteArray(Old)^[i] := PByteArray(New)^[i]; + if not LeaveUnprotected and ProtectedMemory then + SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_EXEC); + except + end; +end; +{$endif MSWINDOWS} + +procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; + LeaveUnprotected: boolean); +begin + PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected); +end; + +{$ifdef CPUINTEL} + +procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode); +var NewJump: packed record + Code: byte; // $e9 = jmp {relative} + Distance: integer; // relative jump is 32-bit even on CPU64 + end; +begin + if (Func=nil) or (RedirectFunc=nil) then + exit; // nothing to redirect to + assert(SizeOf(TPatchCode)=SizeOf(NewJump)); + NewJump.Code := $e9; + NewJump.Distance := integer(PtrUInt(RedirectFunc)-PtrUInt(Func)-SizeOf(NewJump)); + PatchCode(Func,@NewJump,SizeOf(NewJump),Backup); + {$ifndef LVCL} + assert(pByte(Func)^=$e9); + {$endif} +end; + +procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); +begin + PatchCode(Func,@Backup,SizeOf(TPatchCode)); +end; + +{$endif CPUINTEL} + +{$ifndef LVCL} +{$ifndef FPC} +{$ifndef UNICODE} + +const + MemoryDelta = $8000; // 32 KB granularity (must be a power of 2) + +function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer; +// allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*() +// and uses bigger growing size -> a lot faster +var i: PtrInt; +begin + if NewCapacity>0 then begin + i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick + if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate + result := Memory; + Seek(i,soBeginning); + exit; + end; + NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1); + Seek(i,soBeginning); + end; + Result := Memory; + if NewCapacity <> Capacity then begin + if NewCapacity = 0 then begin + FreeMem(Memory); + Result := nil; + end else begin + if Capacity = 0 then + GetMem(Result, NewCapacity) else + if NewCapacity > Capacity then // only realloc if necessary (grow up) + ReallocMem(Result, NewCapacity) else + NewCapacity := Capacity; // same capacity as before + if Result = nil then + raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug + end; + end; +end; + +{$endif UNICODE} +{$endif FPC} +{$endif LVCL} + + +{ TSortedWordArray } + +function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; +var L,cmp: PtrInt; +begin + if R<0 then + result := 0 else begin + L := 0; + repeat + result := (L + R) shr 1; + cmp := P^[result]-Value; + if cmp=0 then begin + result := -result-1; // return -(foundindex+1) if already exists + exit; + end; + if cmp<0 then + L := result + 1 else + R := result - 1; + until (L > R); + while (result>=0) and (P^[result]>=Value) do dec(result); + result := result+1; // return the index where to insert + end; +end; + +function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; +{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8w/dx +{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} + {$ifdef win64} + push rdi + mov rdi, P // rdi=P + {$endif} + xor r9, r9 // r9=L rax=result + test R, R + jl @ko +{$ifdef FPC} align 8 {$else} .align 8 {$endif} +@s: lea rax, [r9 + R] + shr rax, 1 + lea r10, qword ptr[rax - 1] // branchless loop + lea r11, qword ptr[rax + 1] + movzx ecx, word ptr[rdi + rax * 2] + {$ifdef win64} + cmp ecx, r8d + {$else} + cmp ecx, edx // 'cmp cx,Value' is silently rejected by Darwin asm + {$endif win64} + je @ok + cmovg R, r10 + cmovl r9, r11 + cmp r9, R + jle @s +@ko: or rax, -1 +@ok: {$ifdef win64} + pop rdi + {$endif} +end; +{$else} +var L: PtrInt; + cmp: integer; +begin + L := 0; + if 0<=R then + repeat + result := (L + R) shr 1; + cmp := P^[result]-Value; + if cmp=0 then + exit; + if cmp<0 then begin + L := result+1; + if L<=R then + continue; + break; + end; + R := result-1; + if L<=R then + continue; + break; + until false; + result := -1 +end; +{$endif CPUX64} + +function TSortedWordArray.Add(aValue: Word): PtrInt; +begin + result := Count; // optimistic check of perfectly increasing aValue + if (result>0) and (aValue<=Values[result-1]) then + result := FastLocateWordSorted(pointer(Values),result-1,aValue); + if result<0 then // aValue already exists in Values[] -> fails + exit; + if Count=length(Values) then + SetLength(Values,NextGrow(Count)); + if result J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortCompare(OnCompare, Index, L, J); + L := I; + end else begin + if I < R then + QuickSortCompare(OnCompare, Index, I, R); + R := J; + end; + until L >= R; +end; + +procedure Exchg32(var A,B: integer); {$ifdef HASINLINE}inline;{$endif} +var tmp: integer; +begin + tmp := A; + A := B; + B := tmp; +end; + +function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; +var low, high, median, middle, ll, hh: PtrInt; +begin + if n=0 then begin + result := 0; + exit; + end; + if n=1 then begin + result := Values[0]; + exit; + end; + low := 0; + high := n-1; + median := high shr 1; + repeat + if high<=low then begin // one item left + result := Values[median]; + exit; + end; + if high=low+1 then begin // two items -> return the smallest (not average) + if Values[low]>Values[high] then + Exchg32(Values[low],Values[high]); + result := Values[median]; + exit; + end; + // find median of low, middle and high items; swap into position low + middle := (low+high) shr 1; + if Values[middle]>Values[high] then + Exchg32(Values[middle],Values[high]); + if Values[low]>Values[high] then + Exchg32(Values[low],Values[high]); + if Values[middle]>Values[low] then + Exchg32(Values[middle],Values[low]); + // swap low item (now in position middle) into position (low+1) + Exchg32(Values[middle],Values[low+1]); + // nibble from each end towards middle, swapping items when stuck + ll := low+1; + hh := high; + repeat + repeat + inc(ll); + until not (Values[low]>Values[ll]); + repeat + dec(hh); + until not (Values[hh]>Values[low]); + if hh=median then + high := hh-1; + until false; +end; + +function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; + var TempBuffer: TSynTempBuffer): integer; +var low, high, middle, median, ll, hh: PtrInt; + tmp: integer; + ndx: PIntegerArray; +begin + if n<=1 then begin + TempBuffer.buf := nil; // avoid GPF in TempBuffer.Done + result := 0; + exit; + end; + low := 0; + high := n-1; + ndx := TempBuffer.InitIncreasing(n*4); // no heap alloacation until n>1024 + median := high shr 1; + repeat + if high<=low then begin // one item left + result := ndx[median]; + TempBuffer.Done; + exit; + end; + if high=low+1 then begin // two items -> return the smallest (not average) + if OnCompare(ndx[low],ndx[high]) then + Exchg32(ndx[low],ndx[high]); + result := ndx[median]; + TempBuffer.Done; + exit; + end; + // find median of low, middle and high items; swap into position low + middle := (low+high) shr 1; + if OnCompare(ndx[middle],ndx[high]) then + Exchg32(ndx[middle],ndx[high]); + if OnCompare(ndx[low],ndx[high]) then + Exchg32(ndx[low],ndx[high]); + if OnCompare(ndx[middle],ndx[low]) then + Exchg32(ndx[middle],ndx[low]); + // swap low item (now in position middle) into position (low+1) + Exchg32(ndx[middle],ndx[low+1]); + // nibble from each end towards middle, swapping items when stuck + ll := low+1; + hh := high; + repeat + tmp := ndx[low]; + repeat + inc(ll); + until not OnCompare(tmp,ndx[ll]); + repeat + dec(hh); + until not OnCompare(ndx[hh],tmp); + if hh=median then + high := hh-1; + until false; +end; + +function gcd(a, b: cardinal): cardinal; +begin + while a <> b do + if a > b then + dec(a, b) else + dec(b, a); + result := a; +end; + +function ToVarUInt32Length(Value: PtrUInt): PtrUInt; +begin + if Value<=$7f then + result := 1 else + if Value<$80 shl 7 then + result := 2 else + if Value<$80 shl 14 then + result := 3 else + if Value <$80 shl 21 then + result := 4 else + result := 5; +end; + +function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; +begin + if Value<=$7f then + result := Value+1 else + if Value<$80 shl 7 then + result := Value+2 else + if Value<$80 shl 14 then + result := Value+3 else + if Value<$80 shl 21 then + result := Value+4 else + result := Value+5; +end; + +{$ifdef HASINLINE} +function FromVarUInt32(var Source: PByte): cardinal; +begin + result := Source^; + inc(Source); + if result>$7f then + result := (result and $7F) or FromVarUInt32Up128(Source); +end; + +function FromVarUInt32Big(var Source: PByte): cardinal; +{$else} +function FromVarUInt32Big(var Source: PByte): cardinal; +asm + jmp FromVarUInt32 +end; + +function FromVarUInt32(var Source: PByte): cardinal; +{$endif} +var c: cardinal; + p: PByte; +begin + p := Source; + result := p^; + inc(p); + if result>$7f then begin // Values between 128 and 16256 + c := p^; + c := c shl 7; + result := result and $7F or c; + inc(p); + if c>$7f shl 7 then begin // Values between 16257 and 2080768 + c := p^; + c := c shl 14; + inc(p); + result := result and $3FFF or c; + if c>$7f shl 14 then begin // Values between 2080769 and 266338304 + c := p^; + c := c shl 21; + inc(p); + result := result and $1FFFFF or c; + if c>$7f shl 21 then begin + c := p^; + c := c shl 28; + inc(p); + result := result and $FFFFFFF or c; + end; + end; + end; + end; + Source := p; +end; + +function FromVarUInt32Up128(var Source: PByte): cardinal; +var c: cardinal; + p: PByte; +begin // Values above 128 + p := Source; + result := p^ shl 7; + inc(p); + if result>$7f shl 7 then begin // Values above 16257 + c := p^; + c := c shl 14; + inc(p); + result := result and $3FFF or c; + if c>$7f shl 14 then begin + c := p^; + c := c shl 21; + inc(p); + result := result and $1FFFFF or c; + if c>$7f shl 21 then begin + c := p^; + c := c shl 28; + inc(p); + result := result and $FFFFFFF or c; + end; + end; + end; + Source := p; +end; + +function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; +begin + if SourceMax=nil then begin + Value := FromVarUInt32(Source); + result := true; + end else begin + Source := FromVarUInt32Safe(Source,SourceMax,Value); + result := Source<>nil; + end; +end; + +function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; +var c: cardinal; +begin + result := nil; // error + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + inc(Source); + Value := c; + if c>$7f then begin // Values between 128 and 16256 + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + c := c shl 7; + Value := Value and $7F or c; + inc(Source); + if c>$7f shl 7 then begin // Values between 16257 and 2080768 + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + c := c shl 14; + inc(Source); + Value := Value and $3FFF or c; + if c>$7f shl 14 then begin // Values between 2080769 and 266338304 + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + c := c shl 21; + inc(Source); + Value := Value and $1FFFFF or c; + if c>$7f shl 21 then begin + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + c := c shl 28; + inc(Source); + Value := Value and $FFFFFFF or c; + end; + end; + end; + end; + result := Source; // safely decoded +end; + +function FromVarInt32(var Source: PByte): integer; +var c: cardinal; + p: PByte; +begin // fast stand-alone function with no FromVarUInt32 call + p := Source; + result := p^; + inc(p); + if result>$7f then begin + c := p^; + c := c shl 7; + result := result and $7F or integer(c); + inc(p); + if c>$7f shl 7 then begin + c := p^; + c := c shl 14; + inc(p); + result := result and $3FFF or integer(c); + if c>$7f shl 14 then begin + c := p^; + c := c shl 21; + inc(p); + result := result and $1FFFFF or integer(c); + if c>$7f shl 21 then begin + c := p^; + c := c shl 28; + inc(p); + result := result and $FFFFFFF or integer(c); + end; + end; + end; + end; + Source := p; + // 0=0,1=1,2=-1,3=2,4=-2... + if result and 1<>0 then + // 1->1, 3->2.. + result := result shr 1+1 else + // 0->0, 2->-1, 4->-2.. + result := -(result shr 1); +end; + +function FromVarUInt32High(var Source: PByte): cardinal; +var c: cardinal; +begin + result := Source^; + inc(Source); + c := Source^ shl 7; + inc(Source); + result := result and $7F or c; + if c<=$7f shl 7 then + exit; + c := Source^ shl 14; + inc(Source); + result := result and $3FFF or c; + if c<=$7f shl 14 then + exit; + c := Source^ shl 21; + inc(Source); + result := result and $1FFFFF or c; + if c<=$7f shl 21 then + exit; + c := Source^ shl 28; + inc(Source); + result := result and $FFFFFFF or c; +end; + +function ToVarInt64(Value: Int64; Dest: PByte): PByte; +begin // 0=0,1=1,2=-1,3=2,4=-2... + {$ifdef CPU32} + if Value<=0 then + // 0->0, -1->2, -2->4.. + result := ToVarUInt64((-Value) shl 1,Dest) else + // 1->1, 2->3.. + result := ToVarUInt64((Value shl 1)-1,Dest); + {$else} + if Value<=0 then + // 0->0, -1->2, -2->4.. + Value := (-Value) shl 1 else + // 1->1, 2->3.. + Value := (Value shl 1)-1; + result := ToVarUInt64(Value,Dest); + {$endif} +end; + +function ToVarUInt64(Value: QWord; Dest: PByte): PByte; +label _1,_2,_4; // ugly but fast +var c: cardinal; +begin + repeat + c := Value; + if {$ifdef CPU32}PInt64Rec(@Value)^.Hi=0{$else}Value shr 32=0{$endif} then begin + if c>$7f then begin // inlined result := ToVarUInt32(Value,Dest); + if c<$80 shl 7 then goto _1 else + if c<$80 shl 14 then goto _2 else + if c>=$80 shl 21 then goto _4; + Dest^ := (c and $7F) or $80; + c := c shr 7; + inc(Dest); + _2: Dest^ := (c and $7F) or $80; + c := c shr 7; + inc(Dest); + _1: Dest^ := (c and $7F) or $80; + c := c shr 7; + inc(Dest); + end; + Dest^ := c; + inc(Dest); + result := Dest; + exit; + end; +_4: PCardinal(Dest)^ := (c and $7F) or (((c shr 7)and $7F)shl 8) or + (((c shr 14)and $7F)shl 16) or (((c shr 21)and $7F)shl 24) or $80808080; + inc(Dest,4); + Value := Value shr 28; + until false; +end; + +function FromVarUInt64(var Source: PByte): QWord; +var c,n: PtrUInt; + p: PByte; +begin + p := Source; + {$ifdef CPU64} + result := p^; + if result>$7f then begin + result := result and $7F; + {$else} + if p^>$7f then begin + result := PtrUInt(p^) and $7F; + {$endif} + n := 0; + inc(p); + repeat + c := p^; + inc(n,7); + if c<=$7f then + break; + result := result or (QWord(c and $7f) shl n); + inc(p); + until false; + result := result or (QWord(c) shl n); + end{$ifndef CPU64} else + result := p^{$endif}; + inc(p); + Source := p; +end; + +function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; +var c,n: PtrUInt; +begin + result := nil; // error + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; + c := Source^; + inc(Source); + if c>$7f then begin + Value := c and $7F; + n := 7; + repeat + if PAnsiChar(Source)>=PAnsiChar(SourceMax) then + exit; + c := Source^; + inc(Source); + if c<=$7f then + break; + c := c and $7f; + Value := Value or (QWord(c) shl n); + inc(n,7); + until false; + Value := Value or (QWord(c) shl n); + end else + Value := c; + result := Source; // safely decoded +end; + +function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: QWord): boolean; +begin + if SourceMax=nil then begin + Value := FromVarUInt64(Source); + result := true; + end else begin + Source := FromVarUInt64Safe(Source,SourceMax,Value); + result := Source<>nil; + end; +end; + +function FromVarInt64(var Source: PByte): Int64; +var c,n: PtrUInt; +begin // 0=0,1=1,2=-1,3=2,4=-2... + {$ifdef CPU64} + result := Source^; + if result>$7f then begin + result := result and $7F; + n := 0; + inc(Source); + repeat + c := Source^; + inc(n,7); + if c<=$7f then + break; + result := result or (Int64(c and $7f) shl n); + inc(Source); + until false; + result := result or (Int64(c) shl n); + end; + if result and 1<>0 then + // 1->1, 3->2.. + result := result shr 1+1 else + // 0->0, 2->-1, 4->-2.. + result := -(result shr 1); + {$else} + c := Source^; + if c>$7f then begin + result := c and $7F; + n := 0; + inc(Source); + repeat + c := Source^; + inc(n,7); + if c<=$7f then + break; + result := result or (Int64(c and $7f) shl n); + inc(Source); + until false; + result := result or (Int64(c) shl n); + if PCardinal(@result)^ and 1<>0 then + // 1->1, 3->2.. + result := result shr 1+1 else + // 0->0, 2->-1, 4->-2.. + result := -(result shr 1); + end else begin + if c=0 then + result := 0 else + if c and 1=0 then + // 0->0, 2->-1, 4->-2.. + result := -Int64(c shr 1) else + // 1->1, 3->2.. + result := (c shr 1)+1; + end; + {$endif} + inc(Source); +end; + +function FromVarInt64Value(Source: PByte): Int64; +{$ifdef DELPHI5OROLDER} +begin // try to circumvent Internal Error C1093 on Delphi 5 :( + result := FromVarInt64(Source); +end; +{$else} +var c,n: PtrUInt; +begin // 0=0,1=1,2=-1,3=2,4=-2... + c := Source^; + if c>$7f then begin + result := c and $7F; + n := 0; + inc(Source); + repeat + c := Source^; + inc(n,7); + if c<=$7f then + break; + result := result or (Int64(c and $7f) shl n); + inc(Source); + until false; + result := result or (Int64(c) shl n); + if {$ifdef CPU64}result{$else}PCardinal(@result)^{$endif} and 1<>0 then + // 1->1, 3->2.. + result := result shr 1+1 else + // 0->0, 2->-1, 4->-2.. + result := -Int64(result shr 1); + end else + if c=0 then + result := 0 else + if c and 1=0 then + // 0->0, 2->-1, 4->-2.. + result := -Int64(c shr 1) else + // 1->1, 3->2.. + result := (c shr 1)+1; +end; +{$endif DELPHI5OROLDER} + +function GotoNextVarInt(Source: PByte): pointer; +begin + if Source<>nil then begin + if Source^>$7f then + repeat + inc(Source) + until Source^<=$7f; + inc(Source); + end; + result := Source; +end; + +function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; +var Len: integer; +begin + Len := Length(Value); + Dest := ToVarUInt32(Len,Dest); + if Len>0 then begin + MoveFast(pointer(Value)^,Dest^,Len); + result := pointer(PAnsiChar(Dest)+Len); + end else + result := Dest; +end; + +function GotoNextVarString(Source: PByte): pointer; +begin + result := Pointer(PtrUInt(Source)+FromVarUInt32(Source)); +end; + +function FromVarString(var Source: PByte): RawUTF8; +var len: PtrUInt; +begin + len := FromVarUInt32(Source); + FastSetStringCP(Result,Source,len,CP_UTF8); + inc(Source,len); +end; + +function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; +var len: cardinal; +begin + Source := FromVarUInt32Safe(Source,SourceMax,len); + if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then + len := 0; + FastSetStringCP(Result,Source,len,CP_UTF8); + inc(Source,len); +end; + +procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); +var len: integer; +begin + len := FromVarUInt32(Source); + Value.Init(Source,len); + PByteArray(Value.buf)[len] := 0; // include trailing #0 + inc(Source,len); +end; + +function FromVarString(var Source: PByte; SourceMax: PByte; + var Value: TSynTempBuffer): boolean; +var len: cardinal; +begin + if SourceMax=nil then + len := FromVarUInt32(Source) else begin + Source := FromVarUInt32Safe(Source,SourceMax,len); + if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin + result := false; + exit; + end; + end; + Value.Init(Source,len); + PByteArray(Value.buf)[len] := 0; // include trailing #0 + inc(Source,len); + result := true; +end; + +procedure FromVarString(var Source: PByte; var Value: RawByteString; + CodePage: integer); +var Len: PtrUInt; +begin + Len := FromVarUInt32(Source); + FastSetStringCP(Value,Source,Len,CodePage); + inc(Source,Len); +end; + +function FromVarString(var Source: PByte; SourceMax: PByte; + var Value: RawByteString; CodePage: integer): boolean; +var len: cardinal; +begin + if SourceMax=nil then + len := FromVarUInt32(Source) else begin + Source := FromVarUInt32Safe(Source,SourceMax,len); + if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin + result := false; + exit; + end; + end; + FastSetStringCP(Value,Source,len,CodePage); + inc(Source,len); + result := true; +end; + +function FromVarBlob(Data: PByte): TValueResult; +begin + Result.Len := FromVarUInt32(Data); + Result.Ptr := pointer(Data); +end; + + +{ ************ low-level RTTI types and conversion routines } + +{$ifdef FPC} + +{$ifdef FPC_OLDRTTI} +function OldRTTIFirstManagedField(info: PTypeInfo): PFieldInfo; +var fieldtype: PTypeInfo; + i: integer; +begin + result := @info^.ManagedFields[0]; + for i := 1 to info^.ManagedCount do begin + fieldtype := DeRef(result^.TypeInfo); + if (fieldtype<>nil) and (fieldtype^.Kind in tkManagedTypes) then + exit; + inc(result); + end; + result := nil; +end; + +function OldRTTIManagedSize(typeInfo: Pointer): SizeInt; inline; +begin + case PTypeKind(typeInfo)^ of // match tkManagedTypes + tkLString,tkLStringOld,tkWString,tkUString, tkInterface,tkDynarray: + result := SizeOf(Pointer); + {$ifndef NOVARIANTS} + tkVariant: result := SizeOf(TVarData); + {$endif} + tkArray: with GetTypeInfo(typeInfo)^ do + result := arraySize{$ifdef VER2_6}*elCount{$endif}; + tkObject,tkRecord: result := GetTypeInfo(typeInfo)^.recSize; + else raise ESynException.CreateUTF8('OldRTTIManagedSize unhandled % (%)', + [ToText(PTypeKind(typeInfo)^)^,PByte(typeInfo)^]); + end; +end; + +procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); +begin // external name 'FPC_COPY' does not work as we need + FPCFinalize(@Dest,TypeInfo); + Move(Source,Dest,OldRTTIManagedSize(TypeInfo)); + FPCRecordAddRef(Dest,TypeInfo); +end; +{$else} +procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); +begin + FPCRecordCopy(Source,Dest,TypeInfo); +end; +{$endif FPC_OLDRTTI} + +procedure RecordClear(var Dest; TypeInfo: pointer); +begin + FPCFinalize(@Dest,TypeInfo); +end; + +{$else FPC} + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt); +asm +{$ifdef CPU64} + .noframe + jmp System.@CopyArray +{$else} push dword ptr[EBP + 8] + call System.@CopyArray // RTL is fast enough for this +{$endif} +end; + +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + {$ifdef CPU64} + .noframe + {$endif} + jmp System.@DynArrayClear +end; + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt); +asm + {$ifdef CPU64} + .noframe + {$endif} + jmp System.@FinalizeArray +end; + +procedure _Finalize(Data: Pointer; TypeInfo: Pointer); +asm +{$ifdef CPU64} + .noframe + mov r8, 1 // rcx=p rdx=typeInfo r8=ElemCount + jmp System.@FinalizeArray +{$else} // much faster than FinalizeArray(Data,TypeInfo,1) + movzx ecx, byte ptr[edx] // eax=ptr edx=typeinfo ecx=datatype + sub cl, tkLString + {$ifdef UNICODE} + cmp cl, tkUString - tkLString + 1 + {$else} + cmp cl, tkDynArray - tkLString + 1 + {$endif} + jnb @@err + jmp dword ptr[@@Tab + ecx * 4] + nop + nop // for @@Tab alignment +@@Tab: dd System.@LStrClr +{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString + dd System.@LStrClr +{$else} dd System.@WStrClr +{$endif LINUX} +{$ifdef LVCL} + dd @@err +{$else} dd System.@VarClr +{$endif LVCL} + dd @@ARRAY + dd RecordClear + dd System.@IntfClear + dd @@err + dd System.@DynArrayClear + {$ifdef UNICODE} + dd System.@UStrClr + {$endif} +@@err: mov al, reInvalidPtr + {$ifdef DELPHI5OROLDER} + jmp System.@RunError + {$else} + jmp System.Error + {$endif} +@@array:movzx ecx, [edx].TTypeInfo.NameLen + add ecx, edx + mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ + mov ecx, [ecx].TTypeInfo.ManagedCount + mov edx, [edx] + jmp System.@FinalizeArray +{$endif CPU64} +end; +{$endif FPC} + +procedure RecordZero(var Dest; TypeInfo: pointer); +var info: PTypeInfo; +begin + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if info<>nil then begin // record/object only + RecordClear(Dest,TypeInfo); + FillCharFast(Dest,info^.recSize,0); + end; +end; + +procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); +begin + FastDynArrayClear(@Value,TypeInfo(RawUTF8)); +end; + +function ArrayItemType(var info: PTypeInfo; out len: integer): PTypeInfo; + {$ifdef HASINLINE}inline;{$endif} +begin + {$ifdef HASALIGNTYPEDATA} // inlined info := GetTypeInfo(info) + info := FPCTypeInfoOverName(info); + {$else} + info := @PAnsiChar(info)[info^.NameLen]; + {$endif} + result := nil; + if (info=nil) or (info^.dimCount<>1) then begin + len := 0; + info := nil; // supports single dimension static array only + end else begin + len := info^.arraySize{$ifdef VER2_6}*info^.elCount{$endif}; + {$ifdef HASDIRECTTYPEINFO} // inlined result := DeRef(info^.arrayType) + result := info^.arrayType; + {$else} + if info^.arrayType=nil then + exit; + result := info^.arrayType^; + {$endif} + {$ifdef FPC} + if (result<>nil) and not(result^.Kind in tkManagedTypes) then + result := nil; // as with Delphi + {$endif} + end; +end; + +function ManagedTypeCompare(A,B: PAnsiChar; info: PTypeInfo): integer; +// returns -1 if info was not handled, 0 if A^<>B^, or SizeOf(A^) if A^=B^ +var i,arraysize: integer; + itemtype: PTypeInfo; + {$ifndef DELPHI5OROLDER} // do not know why this compiler does not like it + DynA, DynB: TDynArray; + {$endif} +begin // info is expected to come from a DeRef() if retrieved from RTTI + result := 0; // A^<>B^ + case info^.Kind of // should match tkManagedTypes + tkLString{$ifdef FPC},tkLStringOld{$endif}: + if PRawByteString(A)^=PRawByteString(B)^ then + result := SizeOf(pointer); + tkWString: + if PWideString(A)^=PWideString(B)^ then + result := SizeOf(pointer); + {$ifdef HASVARUSTRING} + tkUString: + if PUnicodeString(A)^=PUnicodeString(B)^ then + result := SizeOf(pointer); + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: + if not RecordEquals(A^,B^,info,@result) then + result := 0; // A^<>B^ + {$ifndef NOVARIANTS} + tkVariant: // slightly more optimized than PVariant(A)^=PVariant(B)^ + if SortDynArrayVariantComp(PVarData(A)^,PVarData(B)^,false)=0 then + result := SizeOf(variant); + {$endif} + {$ifndef DELPHI5OROLDER} + tkDynArray: begin + DynA.Init(info,A^); + DynB.Init(info,B^); + if DynA.Equals(DynB) then + result := SizeOf(pointer); + end; + {$endif} + tkInterface: + if PPointer(A)^=PPointer(B)^ then + result := SizeOf(pointer); + tkArray: begin + itemtype := ArrayItemType(info,arraysize); + if info=nil then + result := -1 else + if itemtype=nil then + if CompareMemFixed(A,B,arraysize) then + result := arraysize else + result := 0 else begin + for i := 1 to info^.elCount do begin // only compare managed fields + result := ManagedTypeCompare(A,B,itemtype); + if result<=0 then + exit; // invalid (-1) or not equals (0) + inc(A,result); + inc(B,result); + end; + result := arraysize; + end; + end; + else + result := -1; // Unhandled field + end; +end; + +function ManagedTypeSaveLength(data: PAnsiChar; info: PTypeInfo; + out len: integer): integer; +// returns 0 on error, or saved bytes + len=data^ length +var DynArray: TDynArray; + itemtype: PTypeInfo; + itemsize,size,i: integer; + P: PPtrUInt absolute data; +begin // info is expected to come from a DeRef() if retrieved from RTTI + case info^.Kind of // should match tkManagedTypes + tkLString{$ifdef FPC},tkLStringOld{$endif}: begin + len := SizeOf(pointer); + if P^=0 then + result := 1 else + result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^); + end; + tkWString: begin // PStrRec doesn't match on Widestring for FPC + len := SizeOf(pointer); + result := ToVarUInt32LengthWithData(length(PWideString(P)^)*2); + end; + {$ifdef HASVARUSTRING} + tkUString: begin + len := SizeOf(pointer); + if P^=0 then + result := 1 else + result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^*2); + end; + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: + result := RecordSaveLength(data^,info,@len); + tkArray: begin + itemtype := ArrayItemType(info,len); + result := 0; + if info<>nil then + if itemtype=nil then + result := len else + for i := 1 to info^.elCount do begin + size := ManagedTypeSaveLength(data,itemtype,itemsize); + if size=0 then begin + result := 0; + exit; + end; + inc(result,size); + inc(data,itemsize); + end; + end; + {$ifndef NOVARIANTS} + tkVariant: begin + len := SizeOf(variant); + result := VariantSaveLength(PVariant(data)^); + end; + {$endif} + tkDynArray: begin + DynArray.Init(info,data^); + len := SizeOf(pointer); + result := DynArray.SaveToLength; + end; + tkInterface: begin + len := SizeOf(Int64); // consume 64-bit even on CPU32 + result := SizeOf(PtrUInt); + end; + else + result := 0; // invalid/unhandled record content + end; +end; + +function ManagedTypeSave(data, dest: PAnsiChar; info: PTypeInfo; + out len: integer): PAnsiChar; +// returns nil on error, or final dest + len=data^ length +var DynArray: TDynArray; + itemtype: PTypeInfo; + itemsize,i: integer; + P: PPtrUInt absolute data; +begin // info is expected to come from a DeRef() if retrieved from RTTI + case info^.Kind of + tkLString {$ifdef HASVARUSTRING},tkUString{$endif} {$ifdef FPC},tkLStringOld{$endif}: begin + if P^=0 then begin + dest^ := #0; + result := dest+1; + end else begin + itemsize := PStrLen(P^-_STRLEN)^; + {$ifdef HASVARUSTRING} // UnicodeString length in WideChars + if info^.Kind=tkUString then + itemsize := itemsize*2; + {$endif} + result := pointer(ToVarUInt32(itemsize,pointer(dest))); + MoveFast(pointer(P^)^,result^,itemsize); + inc(result,itemsize); + end; + len := SizeOf(PtrUInt); // size of tkLString/tkUString in record + end; + tkWString: begin + itemsize := length(PWideString(P)^)*2; // PStrRec doesn't match on FPC + result := pointer(ToVarUInt32(itemsize,pointer(dest))); + MoveFast(pointer(P^)^,result^,itemsize); + inc(result,itemsize); + len := SizeOf(PtrUInt); + end; + tkRecord{$ifdef FPC},tkObject{$endif}: + result := RecordSave(data^,dest,info,len); + tkArray: begin + itemtype := ArrayItemType(info,len); + if info=nil then + result := nil else + if itemtype=nil then begin + MoveSmall(data,dest,len); + result := dest+len; + end else begin + for i := 1 to info^.elCount do begin + dest := ManagedTypeSave(data,dest,itemtype,itemsize); + if dest=nil then + break; // invalid/unhandled content + inc(data,itemsize) + end; + result := dest; + end; + end; + {$ifndef NOVARIANTS} + tkVariant: begin + result := VariantSave(PVariant(data)^,dest); + len := SizeOf(Variant); // size of tkVariant in record + end; + {$endif} + tkDynArray: begin + DynArray.Init(info,data^); + result := DynArray.SaveTo(dest); + len := SizeOf(PtrUInt); // size of tkDynArray in record + end; + {$ifndef DELPHI5OROLDER} + tkInterface: begin + PIInterface(dest)^ := PIInterface(data)^; // with proper refcount + result := dest+SizeOf(Int64); // consume 64-bit even on CPU32 + len := SizeOf(PtrUInt); + end; + {$endif} + else + result := nil; // invalid/unhandled record content + end; +end; + +function ManagedTypeLoad(data: PAnsiChar; var source: PAnsiChar; + info: PTypeInfo; sourceMax: PAnsiChar): integer; +// returns source=nil on error, or final source + result=data^ length +var DynArray: TDynArray; + itemtype: PTypeInfo; + itemsize: cardinal; + i: PtrInt; +begin // info is expected to come from a DeRef() if retrieved from RTTI + result := SizeOf(PtrUInt); // size of most items + if info^.Kind in [tkLString{$ifdef FPC},tkLStringOld{$endif},tkWString + {$ifdef HASVARUSTRING},tkUString{$endif}] then + if sourceMax<>nil then begin + source := pointer(FromVarUInt32Safe(PByte(source),PByte(sourceMax),itemsize)); + if source=nil then + exit; + if source+itemsize>sourceMax then begin + source := nil; + exit; // avoid buffer overflow + end; + end else + itemsize := FromVarUInt32(PByte(source)); // in source buffer bytes + case info^.Kind of + tkLString{$ifdef FPC}, tkLStringOld{$endif}: begin + {$ifdef HASCODEPAGE} + FastSetStringCP(data^,source,itemsize,LStringCodePage(info)); + {$else} + SetString(PRawUTF8(data)^,source,itemsize); + {$endif HASCODEPAGE} + inc(source,itemsize); + end; + tkWString: begin + SetString(PWideString(data)^,PWideChar(source),itemsize shr 1); + inc(source,itemsize); + end; + {$ifdef HASVARUSTRING} + tkUString: begin + SetString(PUnicodeString(data)^,PWideChar(source),itemsize shr 1); + inc(source,itemsize); + end; + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: + source := RecordLoad(data^,source,info,@result,sourceMax); + tkArray: begin + itemtype := ArrayItemType(info,result); + if info=nil then + source := nil else + if itemtype=nil then + if (sourceMax<>nil) and (source+result>sourceMax) then + source := nil else begin + MoveSmall(source,data,result); + inc(source,result); + end else + for i := 1 to info^.elCount do begin + inc(data,ManagedTypeLoad(data,source,itemtype,sourceMax)); + if source=nil then + exit; + end; + end; + {$ifndef NOVARIANTS} + tkVariant: begin + source := VariantLoad(PVariant(data)^,source,@JSON_OPTIONS[true]); + result := SizeOf(Variant); // size of tkVariant in record + end; + {$endif NOVARIANTS} + tkDynArray: begin + DynArray.Init(info,data^); + source := DynArray.LoadFrom(source,nil,{nohash=}true,sourceMax); + end; + {$ifndef DELPHI5OROLDER} + tkInterface: begin + if (sourceMax<>nil) and (source+SizeOf(Int64)>sourceMax) then begin + source := nil; + exit; + end; + PIInterface(data)^ := PIInterface(source)^; // with proper refcount + inc(source,SizeOf(Int64)); // consume 64-bit even on CPU32 + end; + {$endif DELPHI5OROLDER} + else + source := nil; // notify error for unexpected input type + end; +end; + +function GetManagedFields(info: PTypeInfo; out firstfield: PFieldInfo): integer; +{$ifdef HASINLINE}inline;{$endif} +{$ifdef FPC_NEWRTTI} +var + recInitData: PFPCRecInitData; // low-level type redirected from SynFPCTypInfo + aPointer:pointer; +begin + if Assigned(info^.RecInitInfo) then + recInitData := PFPCRecInitData(AlignTypeDataClean(PTypeInfo(info^.RecInitInfo+2+PByte(info^.RecInitInfo+1)^))) + else begin + aPointer:=@info^.RecInitInfo; + {$ifdef FPC_PROVIDE_ATTR_TABLE} + dec(PByte(aPointer),SizeOf(Pointer)); + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + {$ifdef CPUARM} + dec(PByte(aPointer),SizeOf(Pointer)); + {$endif CPUARM} + {$endif} + {$endif} + recInitData := PFPCRecInitData(aPointer); + end; + firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount)); + inc(PByte(firstfield),SizeOf(recInitData^.ManagedFieldCount)); + firstfield := AlignPTypeInfo(firstfield); + result := recInitData^.ManagedFieldCount; +{$else} +begin + firstfield := @info^.ManagedFields[0]; + result := info^.ManagedCount; +{$endif FPC_NEWRTTI} +end; + +function RecordEquals(const RecA, RecB; TypeInfo: pointer; + PRecSize: PInteger): boolean; +var info,fieldinfo: PTypeInfo; + F, offset: PtrInt; + field: PFieldInfo; + A, B: PAnsiChar; +begin + A := @RecA; + B := @RecB; + result := false; + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if info=nil then + exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]); + if PRecSize<>nil then + PRecSize^ := info^.recSize; + if A=B then begin // both nil or same pointer + result := true; + exit; + end; + offset := 0; + for F := 1 to GetManagedFields(info,field) do begin + fieldinfo := DeRef(field^.TypeInfo); + {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields + if not (fieldinfo^.Kind in tkManagedTypes) then begin + inc(field); + continue; // as with Delphi + end; + {$endif} + offset := integer(field^.Offset)-offset; + if offset<>0 then begin + if not CompareMemFixed(A,B,offset) then + exit; // binary block not equal + inc(A,offset); + inc(B,offset); + end; + offset := ManagedTypeCompare(A,B,fieldinfo); + if offset<=0 then + if offset=0 then // A^<>B^ + exit else // Diff=-1 for unexpected type + raise ESynException.CreateUTF8('RecordEquals: unexpected %', + [ToText(fieldinfo^.Kind)^]); + inc(A,offset); + inc(B,offset); + inc(offset,field^.Offset); + inc(field); + end; + if CompareMemFixed(A,B,integer(info^.recSize)-offset) then + result := true; +end; + +function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger): integer; +var info,fieldinfo: PTypeInfo; + F, recsize,saved: integer; + field: PFieldInfo; + R: PAnsiChar; +begin + R := @Rec; + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if (R=nil) or (info=nil) then begin + result := 0; // should have been checked before + exit; + end; + result := info^.recSize; + if Len<>nil then + Len^ := result; + for F := 1 to GetManagedFields(info,field) do begin + fieldinfo := DeRef(field^.TypeInfo); + {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) + if not (fieldinfo^.Kind in tkManagedTypes) then begin + inc(field); + continue; // as with Delphi + end; + {$endif}; + saved := ManagedTypeSaveLength(R+field^.Offset,fieldinfo,recsize); + if saved=0 then begin + result := 0; // invalid type + exit; + end; + inc(result,saved-recsize); // extract recsize from info^.recSize + inc(field); + end; +end; + +function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; + out Len: integer): PAnsiChar; +var info,fieldinfo: PTypeInfo; + F, offset: integer; + field: PFieldInfo; + R: PAnsiChar; +begin + R := @Rec; + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if (R=nil) or (info=nil) then begin + result := nil; // should have been checked before + exit; + end; + Len := info^.recSize; + offset := 0; + for F := 1 to GetManagedFields(info,field) do begin + {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() + fieldinfo := field^.TypeInfo; + {$else} + {$ifdef CPUINTEL} + fieldinfo := PPointer(field^.TypeInfo)^; + {$else} + fieldinfo := DeRef(field^.TypeInfo); + {$endif} + {$endif} + {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) + if not (fieldinfo^.Kind in tkManagedTypes) then begin + inc(field); + continue; // as with Delphi + end; + {$endif}; + offset := integer(field^.Offset)-offset; + if offset>0 then begin + MoveFast(R^,Dest^,offset); + inc(R,offset); + inc(Dest,offset); + end; + Dest := ManagedTypeSave(R,Dest,fieldinfo,offset); + if Dest=nil then begin + result := nil; // invalid/unhandled record content + exit; + end; + inc(R,offset); + inc(offset,field.Offset); + inc(field); + end; + offset := integer(info^.recSize)-offset; + if offset<0 then + raise ESynException.Create('RecordSave offset<0') else + if offset<>0 then begin + MoveFast(R^,Dest^,offset); + result := Dest+offset; + end else + result := Dest; +end; + +function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; +var dummylen: integer; +begin + result := RecordSave(Rec,Dest,TypeInfo,dummylen); +end; + +function RecordSave(const Rec; TypeInfo: pointer): RawByteString; +var destlen,dummylen: integer; + dest: PAnsiChar; +begin + destlen := RecordSaveLength(Rec,TypeInfo); + SetString(result,nil,destlen); + if destlen<>0 then begin + dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); + if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check + raise ESynException.CreateUTF8('RecordSave % len=%<>%', + [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); + end; +end; + +function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; +var destlen,dummylen: integer; + dest: PAnsiChar; +begin + destlen := RecordSaveLength(Rec,TypeInfo); + result := nil; // don't reallocate TBytes data from a previous call + SetLength(result,destlen); + if destlen<>0 then begin + dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); + if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check + raise ESynException.CreateUTF8('RecordSave % len=%<>%', + [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); + end; +end; + +procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); +var dummylen: integer; + P: PAnsiChar; +begin + Dest.Init(RecordSaveLength(Rec,TypeInfo)); + P := RecordSave(Rec,Dest.buf,TypeInfo,dummylen); + if (P=nil) or (P-Dest.buf<>Dest.len) then begin // paranoid check + Dest.Done; + raise ESynException.CreateUTF8('RecordSave TSynTempBuffer %',[TypeInfoToShortString(TypeInfo)^]); + end; +end; + +function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8; +var len,dummy: integer; + temp: TSynTempBuffer; +begin + result := ''; + len := RecordSaveLength(Rec,TypeInfo); + if len=0 then + exit; + temp.Init(len+4); + RecordSave(Rec,PAnsiChar(temp.buf)+4,TypeInfo,dummy); + PCardinal(temp.buf)^ := crc32c(0,PAnsiChar(temp.buf)+4,len); + if UriCompatible then + result := BinToBase64uri(temp.buf,temp.len) else + result := BinToBase64(temp.buf,temp.len); + temp.Done; +end; + +function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; + TypeInfo: pointer; UriCompatible: boolean): boolean; +var temp: TSynTempBuffer; +begin + result := false; + if Len<=6 then + exit; + if UriCompatible then + result := Base64uriToBin(Source,Len,temp) else + result := Base64ToBin(Source,Len,temp); + result := result and (temp.len>=4) and + (crc32c(0,PAnsiChar(temp.buf)+4,temp.len-4)=PCardinal(temp.buf)^) and + (RecordLoad(Rec,PAnsiChar(temp.buf)+4,TypeInfo,nil,PAnsiChar(temp.buf)+temp.len)<>nil); + temp.Done; +end; + +function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; + Len: PInteger; SourceMax: PAnsiChar): PAnsiChar; +var info,fieldinfo: PTypeInfo; + n, F: integer; + offset: PtrInt; + field: PFieldInfo; + R: PAnsiChar; +begin + result := nil; // indicates error + R := @Rec; + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if (R=nil) or (info=nil) then // should have been checked before + exit; + if Len<>nil then + Len^ := info^.recSize; + n := GetManagedFields(info,field); + if Source=nil then begin // inline RecordClear() function + for F := 1 to n do begin + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(R+field^.Offset,Deref(field^.TypeInfo)); + inc(field); + end; + exit; + end; + offset := 0; + for F := 1 to n do begin + {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() + fieldinfo := field^.TypeInfo; + {$else} + {$ifdef CPUINTEL} + fieldinfo := PPointer(field^.TypeInfo)^; + {$else} + fieldinfo := DeRef(field^.TypeInfo); + {$endif} + {$endif} + {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) + if not (fieldinfo^.Kind in tkManagedTypes) then begin + inc(field); + continue; // as with Delphi + end; + {$endif}; + offset := integer(field^.Offset)-offset; + if offset<>0 then begin + if (SourceMax<>nil) and (Source+offset>SourceMax) then + exit; + MoveFast(Source^,R^,offset); + inc(Source,offset); + inc(R,offset); + end; + offset := ManagedTypeLoad(R,Source,fieldinfo,SourceMax); + if Source=nil then + exit; // error at loading + inc(R,offset); + inc(offset,field^.Offset); + inc(field); + end; + offset := integer(info^.recSize)-offset; + if offset<0 then + raise ESynException.Create('RecordLoad offset<0') else + if offset<>0 then begin + if (SourceMax<>nil) and (Source+offset>SourceMax) then + exit; + MoveFast(Source^,R^,offset); + result := Source+offset; + end else + result := Source; +end; + +function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; +var P: PAnsiChar; +begin + P := pointer(Source); + P := RecordLoad(Res,P,TypeInfo,nil,P+length(Source)); + result := (P<>nil) and (P-pointer(Source)=length(Source)); +end; + +{$ifndef FPC} + + {$ifdef USEPACKAGES} + {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} + {$endif} + {$ifdef DELPHI5OROLDER} + {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} + {$endif} + {$ifdef PUREPASCAL} + {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} + {$endif} + {$ifndef DOPATCHTRTL} + {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} + {$endif} + +{$ifdef EXPECTSDELPHIRTLRECORDCOPYCLEAR} +procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); +asm // same params than _CopyRecord{ dest, source, typeInfo: Pointer } + {$ifdef CPU64} + .noframe + {$endif} + jmp System.@CopyRecord +end; + +procedure RecordClear(var Dest; TypeInfo: pointer); +asm + {$ifdef CPU64} + .noframe + {$endif} + jmp System.@FinalizeRecord +end; +{$endif EXPECTSDELPHIRTLRECORDCOPYCLEAR} + + +{$ifdef DOPATCHTRTL} + +function SystemRecordCopyAddress: Pointer; +asm + {$ifdef CPU64} + mov rax,offset System.@CopyRecord + {$else} + mov eax,offset System.@CopyRecord + {$endif} +end; + +function SystemFinalizeRecordAddress: Pointer; +asm + {$ifdef CPU64} + mov rax,offset System.@FinalizeRecord + {$else} + mov eax,offset System.@FinalizeRecord + {$endif} +end; + +function SystemInitializeRecordAddress: Pointer; +asm + {$ifdef CPU64} + mov rax,offset System.@InitializeRecord + {$else} + mov eax,offset System.@InitializeRecord + {$endif} +end; + +{$ifdef CPUX86} +procedure _InitializeRecord(P: Pointer; TypeInfo: Pointer); +asm // faster version by AB + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } +(* // this TObject.Create-like initialization sounds slower + movzx ecx,byte ptr [edx].TTypeInfo.NameLen + mov edx,[edx+ecx].TTypeInfo.Size + xor ecx,ecx + jmp dword ptr [FillCharFast] *) + movzx ecx, byte ptr[edx].TTypeInfo.NameLen + push ebx + mov ebx, eax + push esi + push edi + mov edi, [edx + ecx].TTypeInfo.ManagedCount + lea esi, [edx + ecx].TTypeInfo.ManagedFields + test edi, edi + jz @end +@loop: mov edx, [esi].TFieldInfo.TypeInfo + mov eax, [esi].TFieldInfo.&Offset + mov edx, [edx] + add esi, 8 + movzx ecx, [edx].TTypeInfo.Kind + add eax, ebx // eax=data to be initialized + jmp dword ptr[@tab + ecx * 4 - tkLString * 4] +@tab: dd @ptr, @ptr, @varrec, @array, @array, @ptr, @ptr, @ptr, @ptr +@ptr: mov dword ptr[eax], 0 // pointer initialization + dec edi + jg @loop +@end: pop edi + pop esi + pop ebx + ret +@varrec:xor ecx, ecx + mov dword ptr[eax], ecx + mov dword ptr[eax + 4], ecx + mov dword ptr[eax + 8], ecx + mov dword ptr[eax + 12], ecx + dec edi + jg @loop + pop edi + pop esi + pop ebx + ret +@array: mov ecx, 1 // here eax=data edx=typeinfo + call System.@InitializeArray + dec edi + jg @loop + pop edi + pop esi + pop ebx +end; + +{$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only +procedure TObjectCleanupInstance; +asm // faster version by AB + push ebx + mov ebx, eax +@loop: mov ebx, [ebx] // handle three VMT levels per iteration + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jz @end + mov ebx, [ebx] + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jz @end + mov ebx, [ebx] + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jnz @loop +@end: pop ebx + ret +@clr: push offset @loop // TObject has no vmtInitTable -> safe + jmp RecordClear // eax=self edx=typeinfo +end; +{$endif} + +procedure RecordClear(var Dest; TypeInfo: pointer); +asm // faster version by AB (direct call to finalization procedures) + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + { <- EAX pointer to record to be finalized } + movzx ecx, byte ptr[edx].TTypeInfo.NameLen + push ebx + mov ebx, eax + push esi + push edi + mov edi, [edx + ecx].TTypeInfo.ManagedCount + lea esi, [edx + ecx].TTypeInfo.ManagedFields + test edi, edi + jz @end +@loop: mov edx, [esi].TFieldInfo.TypeInfo + mov eax, [esi].TFieldInfo.&Offset + mov edx, [edx] + add esi, 8 + movzx ecx, [edx].TTypeInfo.Kind + add eax, ebx // eax=data to be initialized + sub cl, tkLString +{$ifdef UNICODE} + cmp cl, tkUString - tkLString + 1 +{$else} cmp cl, tkDynArray - tkLString + 1 +{$endif} + jnb @err + call dword ptr[@Tab + ecx * 4] + dec edi + jg @loop +@end: mov eax, ebx // keep eax at return (see e.g. TObject.CleanupInstance) + pop edi + pop esi + pop ebx + ret + nop + nop + nop // align @Tab +@Tab: dd System.@LStrClr +{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString + dd System.@LStrClr +{$else} dd System.@WStrClr +{$endif} +{$ifdef LVCL} + dd @err +{$else} dd System.@VarClr +{$endif} + dd @array + dd RecordClear + dd System.@IntfClear + dd @err + dd System.@DynArrayClear + {$ifdef UNICODE} + dd System.@UStrClr + {$endif} +@err: mov al, reInvalidPtr + pop edi + pop esi + pop ebx + jmp System.Error +@array: movzx ecx, [edx].TTypeInfo.NameLen + add ecx, edx + mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ + mov ecx, [ecx].TTypeInfo.ManagedCount + mov edx, [edx] + call System.@FinalizeArray + // we made Call @Array -> ret to continue +end; + +procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); +asm // faster version of _CopyRecord{dest, source, typeInfo: Pointer} by AB + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + push ebp + push ebx + push esi + push edi + movzx ebx, byte ptr[ecx].TTypeInfo.NameLen + mov esi, edx // esi = source + mov edi, eax // edi = dest + add ebx, ecx // ebx = TFieldTable + xor eax, eax // eax = current offset + mov ebp, [ebx].TTypeInfo.ManagedCount // ebp = TFieldInfo count + mov ecx, [ebx].TTypeInfo.recSize + test ebp, ebp + jz @fullcopy + push ecx // SizeOf(record) on stack + add ebx, offset TTypeInfo.ManagedFields[0] // ebx = first TFieldInfo +@next: mov ecx, [ebx].TFieldInfo.&Offset + mov edx, [ebx].TFieldInfo.TypeInfo + sub ecx, eax + mov edx, [edx] + jle @nomov + add esi, ecx + add edi, ecx + neg ecx +@mov1: mov al, [esi + ecx] // fast copy not destructable data + mov [edi + ecx], al + inc ecx + jnz @mov1 +@nomov: mov eax, edi + movzx ecx, [edx].TTypeInfo.Kind + cmp ecx, tkLString + je @LString + jb @err +{$ifdef UNICODE} + cmp ecx, tkUString + je @UString +{$else} cmp ecx, tkDynArray + je @dynaray +{$endif} ja @err + jmp dword ptr[ecx * 4 + @tab - tkWString * 4] + +@Tab: dd @WString, @variant, @array, @record, @interface, @err +{$ifdef UNICODE} + dd @dynaray +{$endif} +@errv: mov al, reVarInvalidOp + jmp @err2 +@err: mov al, reInvalidPtr +@err2: pop edi + pop esi + pop ebx + pop ebp + jmp System.Error + nop // all functions below have esi=source edi=dest +@array: movzx ecx, byte ptr[edx].TTypeInfo.NameLen + push dword ptr[edx + ecx].TTypeInfo.recSize + push dword ptr[edx + ecx].TTypeInfo.ManagedCount + mov ecx, dword ptr[edx + ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ + mov ecx, [ecx] + mov edx, esi + call System.@CopyArray + pop eax // restore SizeOf(Array) + jmp @finish +@record:movzx ecx, byte ptr[edx].TTypeInfo.NameLen + mov ecx, [edx + ecx].TTypeInfo.recSize + push ecx + mov ecx, edx + mov edx, esi + call RecordCopy + pop eax // restore SizeOf(Record) + jmp @finish + nop + nop + nop +@variant: +{$ifdef NOVARCOPYPROC} + mov edx, esi + call System.@VarCopy +{$else} mov edx, esi + cmp dword ptr[VarCopyProc], 0 + jz @errv + call [VarCopyProc] +{$endif} + mov eax, 16 + jmp @finish +{$ifdef DELPHI6OROLDER} + nop + nop +{$endif} +@interface: + mov edx, [esi] + call System.@IntfCopy + jmp @fin4 + nop + nop + nop +@dynaray: + mov ecx, edx // ecx=TypeInfo + mov edx, [esi] + call System.@DynArrayAsg + jmp @fin4 +@WString: +{$ifndef LINUX} + mov edx, [esi] + call System.@WStrAsg + jmp @fin4 +{$endif} +@LString: + mov edx, [esi] + call System.@LStrAsg +{$ifdef UNICODE} + jmp @fin4 + nop + nop +@UString: + mov edx, [esi] + call System.@UStrAsg +{$endif} +@fin4: mov eax, 4 +@finish: + add esi, eax + add edi, eax + add eax, [ebx].TFieldInfo.&Offset + add ebx, 8 + dec ebp // any other TFieldInfo? + jnz @next + pop ecx // ecx= SizeOf(record) +@fullcopy: + mov edx, edi + sub ecx, eax + mov eax, esi + jle @nomov2 + call dword ptr[MoveFast] +@nomov2: pop edi + pop esi + pop ebx + pop ebp +end; + +{$endif CPUX86} +{$endif DOPATCHTRTL} + +{$ifndef CPUARM} + +function SystemFillCharAddress: Pointer; +asm + {$ifdef CPU64} + mov rax,offset System.@FillChar + {$else} + mov eax,offset System.@FillChar + {$endif} +end; + +{$ifndef CPU64} + +{$ifndef PUREPASCAL} + +procedure FillCharX87; +asm // eax=Dest edx=Count cl=Value + // faster version by John O'Harrow (Code Size = 153 Bytes) + mov ch, cl // copy value into both bytes of cx + cmp edx, 32 + jl @small + mov [eax], cx // fill first 8 bytes + mov [eax + 2], cx + mov [eax + 4], cx + mov [eax + 6], cx + sub edx, 16 + fld qword ptr[eax] + fst qword ptr[eax + edx] // fill last 16 bytes + fst qword ptr[eax + edx + 8] + mov ecx, eax + and ecx, 7 // 8-byte align writes + sub ecx, 8 + sub eax, ecx + add edx, ecx + add eax, edx + neg edx +@loop: fst qword ptr[eax + edx] // fill 16 bytes per loop + fst qword ptr[eax + edx + 8] + add edx, 16 + jl @loop + ffree st(0) + fincstp + ret + nop +@small: test edx, edx + jle @done + mov [eax + edx - 1], cl // fill last byte + and edx, -2 // no. of words to fill + neg edx + lea edx, [@fill + 60 + edx * 2] + jmp edx + nop // align jump destinations + nop +@fill: mov [eax + 28], cx + mov [eax + 26], cx + mov [eax + 24], cx + mov [eax + 22], cx + mov [eax + 20], cx + mov [eax + 18], cx + mov [eax + 16], cx + mov [eax + 14], cx + mov [eax + 12], cx + mov [eax + 10], cx + mov [eax + 8], cx + mov [eax + 6], cx + mov [eax + 4], cx + mov [eax + 2], cx + mov [eax], cx + ret // for 4-bytes @fill alignment +@done: db $f3 // rep ret AMD trick here +end; + +/// faster implementation of Move() for Delphi versions with no FastCode inside +procedure MoveX87; +asm // eax=source edx=dest ecx=count + // original code by John O'Harrow - included since delphi 2007 + cmp eax, edx + jz @exit // exit if source=dest + cmp ecx, 32 + ja @lrg // count > 32 or count < 0 + sub ecx, 8 + jg @sml // 9..32 byte move + jmp dword ptr[@table + 32 + ecx * 4] // 0..8 byte move +@sml: fild qword ptr[eax + ecx] // load last 8 + fild qword ptr[eax] // load first 8 + cmp ecx, 8 + jle @sml16 + fild qword ptr[eax + 8] // load second 8 + cmp ecx, 16 + jle @sml24 + fild qword ptr[eax + 16] // load third 8 + fistp qword ptr[edx + 16] // save third 8 +@sml24: fistp qword ptr[edx + 8] // save second 8 +@sml16: fistp qword ptr[edx] // save first 8 + fistp qword ptr[edx + ecx] // save last 8 + ret +@exit: rep ret +@table: dd @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08 +@lrgfwd:push edx + fild qword ptr[eax] // first 8 + lea eax, [eax + ecx - 8] + lea ecx, [ecx + edx - 8] + fild qword ptr[eax] // last 8 + push ecx + neg ecx + and edx, -8 // 8-byte align writes + lea ecx, [ecx + edx + 8] + pop edx +@fwd: fild qword ptr[eax + ecx] + fistp qword ptr[edx + ecx] + add ecx, 8 + jl @fwd + fistp qword ptr[edx] // last 8 + pop edx + fistp qword ptr[edx] // first 8 + ret +@lrg: jng @exit // count < 0 + cmp eax, edx + ja @lrgfwd + sub edx, ecx + cmp eax, edx + lea edx, [edx + ecx] + jna @lrgfwd + sub ecx, 8 // backward move + push ecx + fild qword ptr[eax + ecx] // last 8 + fild qword ptr[eax] // first 8 + add ecx, edx + and ecx, -8 // 8-byte align writes + sub ecx, edx +@bwd: fild qword ptr[eax + ecx] + fistp qword ptr[edx + ecx] + sub ecx, 8 + jg @bwd + pop ecx + fistp qword ptr[edx] // first 8 + fistp qword ptr[edx + ecx] // last 8 + ret +@m01: movzx ecx, byte ptr[eax] + mov [edx], cl + ret +@m02: movzx ecx, word ptr[eax] + mov [edx], cx + ret +@m03: mov cx, [eax] + mov al, [eax + 2] + mov [edx], cx + mov [edx + 2], al + ret +@m04: mov ecx, [eax] + mov [edx], ecx + ret +@m05: mov ecx, [eax] + mov al, [eax + 4] + mov [edx], ecx + mov [edx + 4], al + ret +@m06: mov ecx, [eax] + mov ax, [eax + 4] + mov [edx], ecx + mov [edx + 4], ax + ret +@m07: mov ecx, [eax] + mov eax, [eax + 3] + mov [edx], ecx + mov [edx + 3], eax + ret +@m08: mov ecx, [eax] + mov eax, [eax + 4] + mov [edx], ecx + mov [edx + 4], eax +end; + +{$ifdef WITH_ERMS} +procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs +asm // eax=Dest edx=Count cl=Value + test edx, edx + jle @none + cld + push edi + mov edi, eax + mov al, cl + mov ecx, edx + rep stosb + pop edi +@none: +end; + +procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs +asm // eax=source edx=dest ecx=count + test ecx, ecx + jle @none + push esi + push edi + cmp edx, eax + ja @down + mov esi, eax + mov edi, edx + cld + rep movsb // (much) slower on small blocks moves + pop edi + pop esi +@none:ret +@down:lea esi, [eax + ecx - 1] + lea edi, [edx + ecx - 1] + std + rep movsb // backward move does not support ERMSB so is slow + pop edi + pop esi + cld +end; +{$endif WITH_ERMS} + +function StrLenX86(S: pointer): PtrInt; +// pure x86 function (if SSE2 not available) - faster than SysUtils' version +asm + test eax, eax + jz @0 + cmp byte ptr[eax + 0], 0 + je @0 + cmp byte ptr[eax + 1], 0 + je @1 + cmp byte ptr[eax + 2], 0 + je @2 + cmp byte ptr[eax + 3], 0 + je @3 + push eax + and eax, -4 { DWORD Align Reads } +@Loop: add eax, 4 + mov edx, [eax] { 4 Chars per Loop } + lea ecx, [edx - $01010101] + not edx + and edx, ecx + and edx, $80808080 { Set Byte to $80 at each #0 Position } + jz @Loop { Loop until any #0 Found } + pop ecx + bsf edx, edx { Find First #0 Position } + shr edx, 3 { Byte Offset of First #0 } + add eax, edx { Address of First #0 } + sub eax, ecx { Returns Length } + ret +@0: xor eax, eax + ret +@1: mov eax, 1 + ret +@2: mov eax, 2 + ret +@3: mov eax, 3 +end; + +{$ifndef DELPHI5OROLDER} // need SSE2 asm instruction set + +procedure FillCharSSE2; +asm // Dest=eax Count=edx Value=cl + mov ch, cl {copy value into both bytes of cx} + cmp edx, 32 + jl @small + sub edx, 16 + movd xmm0, ecx + pshuflw xmm0, xmm0, 0 + pshufd xmm0, xmm0, 0 + movups [eax], xmm0 {fill first 16 bytes} + movups [eax + edx], xmm0 {fill last 16 bytes} + mov ecx, eax {16-byte align writes} + and ecx, 15 + sub ecx, 16 + sub eax, ecx + add edx, ecx + add eax, edx + neg edx + cmp edx, - 512 * 1024 + jb @large +@loop: movaps [eax + edx], xmm0 {fill 16 bytes per loop} + add edx, 16 + jl @loop + ret +@large: movntdq [eax + edx], xmm0 {fill 16 bytes per loop} + add edx, 16 + jl @large + ret +@small: test edx, edx + jle @done + mov [eax + edx - 1], cl {fill last byte} + and edx, -2 {no. of words to fill} + neg edx + lea edx, [@smallfill + 60 + edx * 2] + jmp edx + nop {align jump destinations} + nop +@smallfill: + mov [eax + 28], cx + mov [eax + 26], cx + mov [eax + 24], cx + mov [eax + 22], cx + mov [eax + 20], cx + mov [eax + 18], cx + mov [eax + 16], cx + mov [eax + 14], cx + mov [eax + 12], cx + mov [eax + 10], cx + mov [eax + 8], cx + mov [eax + 6], cx + mov [eax + 4], cx + mov [eax + 2], cx + mov [eax], cx + ret {do not remove - this is for alignment} +@done: +end; + +{$endif DELPHI5OROLDER} + +{$endif PUREPASCAL} +{$endif CPU64} +{$endif CPUARM} + +{$endif FPC} + + +{ ************ Custom record / dynamic array JSON serialization } + +procedure SaveJSON(const Value; TypeInfo: pointer; + Options: TTextWriterOptions; var result: RawUTF8); +var temp: TTextWriterStackBuffer; +begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + fCustomOptions := fCustomOptions+Options; + AddTypedJSON(TypeInfo,Value); + SetText(result); + finally + Free; + end; +end; + +function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; +var options: TTextWriterOptions; +begin + if EnumSetsAsText then + options := [twoEnumSetsAsTextInRecord,twoFullSetsAsStar] else + options := [twoFullSetsAsStar]; + SaveJSON(Value,TypeInfo,options,result); +end; + +type + /// information about one customized JSON serialization + TJSONCustomParserRegistration = record + RecordTypeName: RawUTF8; + RecordTextDefinition: RawUTF8; + DynArrayTypeInfo: pointer; + RecordTypeInfo: pointer; + Reader: TDynArrayJSONCustomReader; + Writer: TDynArrayJSONCustomWriter; + RecordCustomParser: TJSONRecordAbstract; + end; + PJSONCustomParserRegistration = ^TJSONCustomParserRegistration; + TJSONCustomParserRegistrations = array of TJSONCustomParserRegistration; + + PTJSONCustomParserAbstract = ^TJSONRecordAbstract; + + /// used internally to manage custom record / dynamic array JSON serialization + // - e.g. used by TTextWriter.RegisterCustomJSONSerializer*() + TJSONCustomParsers = class + protected + fLastDynArrayIndex: integer; + fLastRecordIndex: integer; + fParser: TJSONCustomParserRegistrations; + fParsersCount: Integer; + fParsers: TDynArrayHashed; + {$ifndef NOVARIANTS} + fVariants: array of record + TypeClass: TCustomVariantType; + Reader: TDynArrayJSONCustomReader; + Writer: TDynArrayJSONCustomWriter; + end; + function VariantSearch(aClass: TCustomVariantType): PtrInt; + procedure VariantWrite(aClass: TCustomVariantType; + aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); + {$endif} + function TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer; + function Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration; + AddIfNotExisting: boolean): integer; + function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer; + AddIfNotExisting: boolean=true): integer; overload; + function RecordSearch(aRecordTypeInfo: pointer; + AddIfNotExisting: boolean=true): integer; overload; + function RecordSearch(aRecordTypeInfo: pointer; + out Reader: TDynArrayJSONCustomReader): boolean; overload; + function RecordSearch(aRecordTypeInfo: pointer; + out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; overload; + function RecordSearch(const aTypeName: RawUTF8): integer; overload; + function RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal; + out recsize: integer): boolean; + public + constructor Create; + procedure RegisterCallbacks(aTypeInfo: pointer; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); + function RegisterFromText(aTypeInfo: pointer; + const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; + {$ifndef NOVARIANTS} + procedure RegisterCallbacksVariant(aClass: TCustomVariantType; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); + {$endif} + property Parser: TJSONCustomParserRegistrations read fParser; + property ParsersCount: Integer read fParsersCount; + end; + +var + GlobalJSONCustomParsers: TJSONCustomParsers; + +constructor TJSONCustomParsers.Create; +begin + fParsers.InitSpecific(TypeInfo(TJSONCustomParserRegistrations), + fParser,djRawUTF8,@fParsersCount,true); + GarbageCollectorFreeAndNil(GlobalJSONCustomParsers,self); +end; + +function TJSONCustomParsers.TryToGetFromRTTI(aDynArrayTypeInfo, + aRecordTypeInfo: pointer): integer; +var Reg: TJSONCustomParserRegistration; + RegRoot: TJSONCustomParserRTTI; + {$ifdef ISDELPHI2010} + info: PTypeInfo; + {$endif} + added: boolean; + ndx, len: integer; + name: PShortString; +begin + result := -1; + Reg.RecordTypeInfo := aRecordTypeInfo; + Reg.DynArrayTypeInfo := aDynArrayTypeInfo; + TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); + if Reg.RecordTypeName='' then begin + name := TypeInfoToShortString(Reg.DynArrayTypeInfo); + if name=nil then + exit; // we need a type name! + len := length(name^); // try to guess from T*DynArray or T*s names + if (len>12) and (IdemPropName('DynArray',@name^[len-7],8)) then + FastSetString(Reg.RecordTypeName,@name^[1],len-8) else + if (len>3) and (name^[len]='s') then + FastSetString(Reg.RecordTypeName,@name^[1],len-1) else + exit; + end; + RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName); + {$ifdef ISDELPHI2010} + if RegRoot=nil then begin + info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); + if info=nil then + exit; // not enough RTTI + inc(PByte(info),info^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); + inc(PByte(info),info^.NumOps*SizeOf(pointer)); // jump RecOps[] + if info^.AllCount=0 then + exit; // not enough RTTI -> avoid exception in constructor below + end; + {$else} + if RegRoot=nil then + exit; // not enough RTTI for older versions of Delphi + {$endif} + Reg.RecordCustomParser := TJSONRecordRTTI.Create(Reg.RecordTypeInfo,RegRoot); + Reg.Reader := Reg.RecordCustomParser.CustomReader; + Reg.Writer := Reg.RecordCustomParser.CustomWriter; + if self=nil then + if GlobalJSONCustomParsers<>nil then // may have been set just above + self := GlobalJSONCustomParsers else + self := TJSONCustomParsers.Create; + ndx := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); + if not added then + exit; // name should be unique + fParser[ndx] := Reg; + result := ndx; +end; + +function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer; + AddIfNotExisting: boolean): Integer; +var threadsafe: integer; + parser: PJSONCustomParserRegistration; +begin // O(n) brute force is fast enough, since n remains small (mostly<64) + if self<>nil then + if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then begin + threadsafe := fLastDynArrayIndex; + if (cardinal(threadsafe)=0 then + fLastRecordIndex := result; + end else + result := -1; +end; + +function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; + AddIfNotExisting: boolean): integer; +begin + if aRecordTypeInfo=nil then begin + result := -1; + exit; + end; + if self<>nil then + if (cardinal(fLastRecordIndex)=0 then + fLastRecordIndex := result; + end else + result := -1; +end; + +function TJSONCustomParsers.RecordSearch(const aTypeName: RawUTF8): integer; +begin + if self=nil then + result := -1 else + if (cardinal(fLastRecordIndex)=0 then + fLastRecordIndex := result; + end; +end; + +function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; + out Reader: TDynArrayJSONCustomReader): boolean; +var ndx: integer; +begin + ndx := RecordSearch(aRecordTypeInfo); + if (ndx>=0) and Assigned(fParser[ndx].Reader) then begin + Reader := fParser[ndx].Reader; + result := true; + end else + result := false; +end; + +function TJSONCustomParsers.RecordRTTITextHash(aRecordTypeInfo: pointer; + var crc: cardinal; out recsize: integer): boolean; +var ndx: integer; +begin + if (self<>nil) and (aRecordTypeInfo<>nil) then + for ndx := 0 to fParsersCount-1 do + with fParser[ndx] do + if RecordTypeInfo=aRecordTypeInfo then begin + if RecordTextDefinition='' then + break; + crc := crc32c(crc,pointer(RecordTextDefinition),length(RecordTextDefinition)); + recsize := RecordTypeInfoSize(aRecordTypeInfo); + result := true; + exit; + end; + result := false; +end; + +function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; + out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; +var ndx: integer; +begin + result := false; + ndx := RecordSearch(aRecordTypeInfo); + if (ndx>=0) and Assigned(fParser[ndx].Writer) then begin + Writer := fParser[ndx].Writer; + if PParser<>nil then + PParser^ := fParser[ndx].RecordCustomParser; + result := true; + end; +end; + +function TJSONCustomParsers.Search(aTypeInfo: pointer; + var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer; +var added: boolean; +begin + if (aTypeInfo=nil) or (self=nil) then + raise ESynException.CreateUTF8('%.Search(%)',[self,aTypeInfo]); + FillCharFast(Reg,SizeOf(Reg),0); + case PTypeKind(aTypeInfo)^ of + tkDynArray: begin + Reg.DynArrayTypeInfo := aTypeInfo; + Reg.RecordTypeInfo := DynArrayTypeInfoToRecordInfo(aTypeInfo); + result := DynArraySearch(Reg.DynArrayTypeInfo,Reg.RecordTypeInfo,false); + end; + tkRecord{$ifdef FPC},tkObject{$endif}: begin + Reg.DynArrayTypeInfo := nil; + Reg.RecordTypeInfo := aTypeInfo; + result := RecordSearch(Reg.RecordTypeInfo,false); + end; + else raise ESynException.CreateUTF8('%.Search: % not a tkDynArray/tkRecord', + [self,ToText(PTypeKind(aTypeInfo)^)^]); + end; + if not AddIfNotExisting then + exit; + TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); + if Reg.RecordTypeName='' then + TypeInfoToName(Reg.DynArrayTypeInfo,Reg.RecordTypeName); + if Reg.RecordTypeName='' then + raise ESynException.CreateUTF8('%.Search(%) has no type name',[self,aTypeInfo]); + if result<0 then + result := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); +end; + +{$ifndef NOVARIANTS} +function TJSONCustomParsers.VariantSearch(aClass: TCustomVariantType): PtrInt; +begin + if self<>nil then + for result := 0 to length(fVariants)-1 do + if fVariants[result].TypeClass=aClass then + exit; + result := -1; +end; + +procedure TJSONCustomParsers.VariantWrite(aClass: TCustomVariantType; + aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); +var ndx: PtrInt; + temp: string; +begin + ndx := VariantSearch(aClass); + if (ndx>=0) and Assigned(fVariants[ndx].Writer) then + fVariants[ndx].Writer(aWriter,aValue) else begin + temp := aValue; // fallback to JSON string from variant-to-string conversion + if Escape=twJSONEscape then + aWriter.Add('"'); + {$ifdef UNICODE} + aWriter.AddW(pointer(temp),length(temp),Escape); + {$else} + aWriter.AddAnsiString(temp,Escape); + {$endif} + if Escape=twJSONEscape then + aWriter.Add('"'); + end; +end; + +procedure TJSONCustomParsers.RegisterCallbacksVariant(aClass: TCustomVariantType; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); +var ndx: PtrInt; +begin + if self=nil then + self := TJSONCustomParsers.Create; + ndx := VariantSearch(aClass); + if ndx<0 then begin + ndx := length(fVariants); + SetLength(fVariants,ndx+1); + fVariants[ndx].TypeClass := aClass; + end; + fVariants[ndx].Writer := aWriter; + fVariants[ndx].Reader := aReader; +end; +{$endif} + +procedure TJSONCustomParsers.RegisterCallbacks(aTypeInfo: pointer; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); +var Reg: TJSONCustomParserRegistration; + ForAdding: boolean; + ndx: integer; +begin + if self=nil then + self := TJSONCustomParsers.Create; + ForAdding := Assigned(aReader) or Assigned(aWriter); + ndx := Search(aTypeInfo,Reg,ForAdding); + if ForAdding then begin + Reg.Writer := aWriter; + Reg.Reader := aReader; + fParser[ndx] := Reg; + end else + if ndx>=0 then begin + fParsers.Delete(ndx); + fParsers.ReHash; + end; +end; + +function TJSONCustomParsers.RegisterFromText(aTypeInfo: pointer; + const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; +var Reg: TJSONCustomParserRegistration; + ForAdding: boolean; + ndx: integer; +begin + if self=nil then + self := TJSONCustomParsers.Create; + ForAdding := aRTTIDefinition<>''; + ndx := Search(aTypeInfo,Reg,ForAdding); + if ForAdding then begin + result := TJSONRecordTextDefinition.FromCache(Reg.RecordTypeInfo,aRTTIDefinition); + Reg.RecordTextDefinition := aRTTIDefinition; + Reg.Reader := result.CustomReader; + Reg.Writer := result.CustomWriter; + Reg.RecordCustomParser := result; + fParser[ndx] := Reg; + end else begin + result := nil; + if ndx>=0 then begin + fParsers.Delete(ndx); + fParsers.ReHash; + end; + end; +end; + +function ManagedTypeSaveRTTIHash(info: PTypeInfo; var crc: cardinal): integer; +var itemtype: PTypeInfo; + i, unmanagedsize: integer; + field: PFieldInfo; + dynarray: TDynArray; +begin // info is expected to come from a DeRef() if retrieved from RTTI + result := 0; + if info=nil then + exit; + {$ifdef FPC} // storage binary layout as Delphi's ordinal value + crc := crc32c(crc,@FPCTODELPHI[info^.Kind],1); + {$else} + crc := crc32c(crc,@info^.Kind,1); // hash RTTI kind, but not name + {$endif} + case info^.Kind of // handle nested RTTI + tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif} + tkWString,tkInterface: + result := SizeOf(pointer); + {$ifndef NOVARIANTS} + tkVariant: + result := SizeOf(variant); + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: // first search from custom RTTI text + if not GlobalJSONCustomParsers.RecordRTTITextHash(info,crc,result) then begin + itemtype := GetTypeInfo(info,tkRecordKinds); + if itemtype<>nil then begin + unmanagedsize := itemtype^.recsize; + for i := 1 to GetManagedFields(itemtype,field) do begin + info := DeRef(field^.TypeInfo); + {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields + if info^.Kind in tkManagedTypes then // as with Delphi + {$endif} + dec(unmanagedsize,ManagedTypeSaveRTTIHash(info,crc)); + inc(field); + end; + crc := crc32c(crc,@unmanagedsize,4); + result := itemtype^.recSize; + end; + end; + tkArray: begin + itemtype := ArrayItemType(info,result); + if info=nil then + exit; + unmanagedsize := result; + if itemtype<>nil then + for i := 1 to info^.elCount do + dec(unmanagedsize,ManagedTypeSaveRTTIHash(itemtype,crc)); + crc := crc32c(crc,@unmanagedsize,4); + end; + tkDynArray: begin + dynarray.Init(info,field); // fake void array pointer + crc := dynarray.SaveToTypeInfoHash(crc); + result := SizeOf(pointer); + end; + end; +end; + +function TypeInfoToHash(aTypeInfo: pointer): cardinal; +begin + result := 0; + ManagedTypeSaveRTTIHash(aTypeInfo,result); +end; + +function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; +begin + result := SaveJSON(Rec,TypeInfo,EnumSetsAsText); +end; + +const + NULCHAR: AnsiChar = #0; + +function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char + {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +var wasString, wasValid: boolean; + Reader: TDynArrayJSONCustomReader; + FirstChar,EndOfObj: AnsiChar; + Val: PUTF8Char; + ValLen: integer; +begin // code below must match TTextWriter.AddRecordJSON + result := nil; // indicates error + if JSON=nil then + exit; + if (@Rec=nil) or (TypeInfo=nil) then + raise ESynException.CreateUTF8('Invalid RecordLoadJSON(%) call',[TypeInfo]); + if JSON^=' ' then repeat inc(JSON); if JSON^=#0 then exit; until JSON^<>' '; + if PCardinal(JSON)^=JSON_BASE64_MAGIC_QUOTE then begin + if not (PTypeKind(TypeInfo)^ in tkRecordTypes) then + raise ESynException.CreateUTF8('RecordLoadJSON(%/%)', + [PShortString(@PTypeInfo(TypeInfo).NameLen)^,ToText(PTypeKind(TypeInfo)^)^]); + Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj,@ValLen); + if (Val=nil) or not wasString or (ValLen<3) or + (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or + not RecordLoad(Rec,Base64ToBin(PAnsiChar(Val)+3,ValLen-3),TypeInfo) then + exit; // invalid content + end else begin + if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then + exit; + FirstChar := JSON^; + JSON := Reader(JSON,Rec,wasValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + if not wasValid then + exit; + if JSON<>nil then + JSON := GotoNextNotSpace(JSON); + if (JSON<>nil) and (JSON^<>#0) then + if FirstChar='"' then // special case e.g. for TGUID string + EndOfObj := FirstChar else begin + EndOfObj := JSON^; + inc(JSON); + end else + EndOfObj := #0; + end; + if JSON=nil then // end reached, but valid content decoded + result := @NULCHAR else + result := JSON; + if EndOfObject<>nil then + EndOfObject^ := EndOfObj; +end; + +function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): boolean; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); // make private copy before in-place decoding + try + result := RecordLoadJSON(Rec,tmp.buf,TypeInfo,nil + {$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil; + finally + tmp.Done; + end; +end; + + +{ TJSONCustomParserCustom } + +constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8); +begin + inherited Create(aPropertyName,ptCustom); + fCustomTypeName := aCustomTypeName; +end; + +procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer); +begin // nothing to be done by default +end; + + +{ TJSONCustomParserCustomSimple } + +constructor TJSONCustomParserCustomSimple.Create( + const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer); +var info: PTypeInfo; + kind: TTypeKind; +begin + inherited Create(aPropertyName,aCustomTypeName); + fCustomTypeInfo := aCustomType; + if IdemPropNameU(aCustomTypeName,'TGUID') then begin + fKnownType := ktGUID; + fDataSize := SizeOf(TGUID); + end else + if fCustomTypeInfo<>nil then begin + TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName); + kind := PTypeKind(fCustomTypeInfo)^; + info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]); + fTypeData := info; + if info<>nil then + case kind of + tkEnumeration, tkSet: begin + fDataSize := ORDTYPE_SIZE[info^.EnumType]; + if kind=tkEnumeration then + fKnownType := ktEnumeration else + fKnownType := ktSet; + exit; // success + end; + tkArray: begin + if info^.dimCount<>1 then + raise ESynException.CreateUTF8('%.Create("%") supports only single '+ + 'dimension static array)',[self,fCustomTypeName]); + fKnownType := ktStaticArray; + {$ifdef VER2_6} + fFixedSize := info^.arraySize; // is elSize in fact + fDataSize := fFixedSize*info^.elCount; + {$else} + fDataSize := info^.arraySize; + fFixedSize := fDataSize div info^.elCount; + {$endif} + fNestedArray := TJSONCustomParserRTTI.CreateFromRTTI( + '',Deref(info^.arrayType),fFixedSize); + exit; // success + end; + tkDynArray: begin + fKnownType := ktDynamicArray; + exit; // success + end; + end; + raise ESynException.CreateUTF8('%.Create("%") unsupported type: % (%)', + [self,fCustomTypeName,ToText(kind)^,ord(kind)]); + end; +end; + +constructor TJSONCustomParserCustomSimple.CreateFixedArray( + const aPropertyName: RawUTF8; aFixedSize: cardinal); +begin + inherited Create(aPropertyName,FormatUTF8('Fixed%Byte',[aFixedSize])); + fKnownType := ktFixedArray; + fFixedSize := aFixedSize; + fDataSize := aFixedSize; +end; + +constructor TJSONCustomParserCustomSimple.CreateBinary( + const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal); +begin + inherited Create(aPropertyName,FormatUTF8('BinHex%Byte',[aFixedSize])); + fKnownType := ktBinary; + fFixedSize := aFixedSize; + fDataSize := aDataSize; +end; + +destructor TJSONCustomParserCustomSimple.Destroy; +begin + inherited; + fNestedArray.Free; +end; + +procedure TJSONCustomParserCustomSimple.CustomWriter( + const aWriter: TTextWriter; const aValue); +var i: integer; + V: PByte; +begin + case fKnownType of + ktStaticArray: begin + aWriter.Add('['); + V := @aValue; + for i := 1 to PTypeInfo(fTypeData)^.elCount do begin + fNestedArray.WriteOneLevel(aWriter,V,[]); + aWriter.Add(','); + end; + aWriter.CancelLastComma; + aWriter.Add(']'); + end; + ktEnumeration, ktSet: + aWriter.AddTypedJSON(fCustomTypeInfo,aValue); + ktDynamicArray: + raise ESynException.CreateUTF8('%.CustomWriter("%"): unsupported', + [self,fCustomTypeName]); + ktBinary: + if (fFixedSize<=SizeOf(QWord)) and IsZero(@aValue,fFixedSize) then + aWriter.AddShort('""') else // 0 -> "" + aWriter.AddBinToHexDisplayQuoted(@aValue,fFixedSize); + else begin // encoded as JSON strings + aWriter.Add('"'); + case fKnownType of + ktGUID: + aWriter.Add(TGUID(aValue)); + ktFixedArray: + aWriter.AddBinToHex(@aValue,fFixedSize); + end; + aWriter.Add('"'); + end; + end; +end; + +function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char; var aValue; + out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +var PropValue: PUTF8Char; + i, PropValueLen, i32: integer; + u64: QWord; + wasString: boolean; + Val: PByte; +begin + result := nil; // indicates error + case fKnownType of + ktStaticArray: begin + if P^<>'[' then + exit; // we expect a true array here + P := GotoNextNotSpace(P+1); + if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then + exit; // invalid number of items + Val := @aValue; + for i := 1 to PTypeInfo(fTypeData)^.elCount do + if not fNestedArray.ReadOneLevel( + P,Val,[]{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then + exit else + if P=nil then + exit; + P := GotoNextNotSpace(P); + EndOfObject := P^; + if P^ in [',','}'] then + inc(P); + result := P; + end; + ktDynamicArray: + raise ESynException.CreateUTF8('%.CustomReader("%"): unsupported', + [self,fCustomTypeName]); + ktSet: begin + i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject); + MoveSmall(@i32,@aValue,fDataSize); + result := P; + end; + else begin // encoded as JSON strings or number + PropValue := GetJSONField(P,P,@wasString,@EndOfObject,@PropValueLen); + if PropValue=nil then + exit; // not a JSON string or number + if P=nil then // result=nil=error + caller may dec(P); P^:=EndOfObject; + P := PropValue+PropValueLen; + case fKnownType of + ktGUID: + if wasString and (TextToGUID(PropValue,@aValue)<>nil) then + result := P; + ktEnumeration: begin + if wasString then + i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,PropValueLen,true) else + i32 := GetCardinal(PropValue); + if i32<0 then + exit; + MoveSmall(@i32,@aValue,fDataSize); + result := P; + end; + ktFixedArray: + if wasString and (PropValueLen=fFixedSize*2) and + SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then + result := P; + ktBinary: + if wasString then begin // default hexa serialization + FillCharFast(aValue,fDataSize,0); + if (PropValueLen=0) or ((PropValueLen=fFixedSize*2) and + HexDisplayToBin(PAnsiChar(PropValue),@aValue,fFixedSize)) then + result := P; + end else + if fFixedSize<=SizeOf(u64) then begin // allow integer serialization + SetQWord(PropValue,u64); + MoveSmall(@u64,@aValue,fDataSize); + result := P; + end; + end; + end; + end; +end; + + +{ TJSONCustomParserCustomRecord } + +constructor TJSONCustomParserCustomRecord.Create( + const aPropertyName: RawUTF8; aCustomTypeIndex: integer); +begin + fCustomTypeIndex := aCustomTypeIndex; + with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin + inherited Create(aPropertyName,RecordTypeName); + fCustomTypeInfo := RecordTypeInfo; + fCustomTypeName := RecordTypeName; + end; + fDataSize := RecordTypeInfoSize(fCustomTypeInfo); +end; + +function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer; +begin + result := nil; + if GlobalJSONCustomParsers<>nil then begin + if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or + not IdemPropNameU(fCustomTypeName, + GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then + fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo); + if fCustomTypeIndex>=0 then + result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex]; + end; + if result=nil then + raise ESynException.CreateUTF8( + '%: [%] type should not have been un-registered',[self,fCustomTypeName]); +end; + +procedure TJSONCustomParserCustomRecord.CustomWriter( + const aWriter: TTextWriter; const aValue); +var parser: PJSONCustomParserRegistration; +begin + parser := GetJSONCustomParserRegistration; + parser^.Writer(aWriter,aValue); +end; + +function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char; var aValue; + out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +var valid: boolean; + callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890 +begin + callback := GetJSONCustomParserRegistration; + result := callback^.Reader(P,aValue,valid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + if not valid then + result := nil; + if result=nil then + exit; + EndOfObject := result^; + if result^ in [',','}',']'] then + inc(result); +end; + +procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer); +begin + RecordClear(Data^,fCustomTypeInfo); +end; + + +{ TJSONCustomParserRTTI } + +type + TJSONSerializerFromTextSimple = record + TypeInfo: pointer; + BinaryDataSize, BinaryFieldSize: integer; + end; + TJSONSerializerFromTextSimpleDynArray = array of TJSONSerializerFromTextSimple; +var // RawUTF8/TJSONSerializerFromTextSimpleDynArray + GlobalCustomJSONSerializerFromTextSimpleType: TSynDictionary; + +procedure JSONSerializerFromTextSimpleTypeAdd(aTypeName: RawUTF8; + aTypeInfo: pointer; aDataSize, aFieldSize: integer); +var simple: TJSONSerializerFromTextSimple; +begin + if aTypeName='' then + TypeInfoToName(aTypeInfo,aTypeName); + if aDataSize<>0 then + if aFieldSize>aDataSize then + raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) fieldsize=%>%', + [aTypeName,aFieldSize,aDataSize]) else + if aFieldSize=0 then + aFieldSize := aDataSize; // not truncated + simple.TypeInfo := aTypeInfo; + simple.BinaryDataSize := aDataSize; + simple.BinaryFieldSize := aFieldSize; + UpperCaseSelf(aTypeName); + if GlobalCustomJSONSerializerFromTextSimpleType.Add(aTypeName,simple)<0 then + raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) duplicated', [aTypeName]); +end; + +/// if defined, will try to mimic the default record alignment +// -> is buggy, and compiler revision specific -> we would rather use packed records +{.$define ALIGNCUSTOMREC} + +constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8; + aPropertyType: TJSONCustomParserRTTIType); +begin + fPropertyName := aPropertyName; + fPropertyType := aPropertyType; +end; + +class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char; + TypeNameLen: PtrInt; ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; +const + SORTEDMAX = {$ifdef NOVARIANTS}32{$else}33{$endif}{$ifdef HASVARUSTRING}+1{$endif}; + SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char = + ('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY', + 'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT','QWORD', + 'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE', + 'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TDATETIMEMS','TGUID', + 'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED', + 'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG',{$ifdef HASVARUSTRING}'UNICODESTRING',{$endif} + 'UTF8STRING',{$ifndef NOVARIANTS}'VARIANT',{$endif} + 'WIDESTRING','WORD'); + // warning: recognized types should match at binary storage level! + SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType = + (ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency, + ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,ptQWord, + ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle, + ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptDateTimeMS,ptGUID, + ptID,ptTimeLog,ptInt64,ptInt64,ptInt64,ptRawByteString,ptTimeLog, + {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptRawUTF8, + {$ifndef NOVARIANTS}ptVariant,{$endif} + ptWideString,ptWord); +var ndx: integer; + up: PUTF8Char; + tmp: array[byte] of AnsiChar; // avoid unneeded memory allocation +begin + if ItemTypeName<>nil then begin + UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName^); + up := pointer(ItemTypeName^); + end else begin + UpperCopy255Buf(@tmp,TypeName,TypeNameLen)^ := #0; + up := @tmp; + end; +//for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]); + ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,up); + if ndx>=0 then + result := SORTEDTYPES[ndx] else + result := ptCustom; +end; + +class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( + const TypeName: RawUTF8): TJSONCustomParserRTTIType; +begin + if TypeName='' then + result := ptCustom else + result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),nil); +end; + +class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( + TypeName: PShortString): TJSONCustomParserRTTIType; +begin + if TypeName=nil then + result := ptCustom else + result := TypeNameToSimpleRTTIType(@TypeName^[1],ord(TypeName^[0]),nil); +end; + +class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; +begin + result := ptCustom; // e.g. for tkRecord + if Info=nil then + exit; + case PTypeKind(Info)^ of // FPC and Delphi will use a fast jmp table + tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8; + tkWString: result := ptWideString; + {$ifdef HASVARUSTRING}tkUString: result := ptUnicodeString;{$endif} + {$ifdef FPC_OR_UNICODE} + tkClassRef,tkPointer{$ifdef UNICODE},tkProcedure{$endif}: result := ptPtrInt; + {$endif} + {$ifndef NOVARIANTS} + tkVariant: result := ptVariant; + {$endif} + tkDynArray: result := ptArray; + tkChar: result := ptByte; + tkWChar: result := ptWord; + tkClass, tkMethod, tkInterface: result := ptPtrInt; + tkInteger: + case GetTypeInfo(Info)^.IntegerType of + otSByte,otUByte: result := ptByte; + otSWord,otUWord: result := ptWord; + otSLong: result := ptInteger; + otULong: result := ptCardinal; + {$ifdef FPC_NEWRTTI} + otSQWord: result := ptInt64; + otUQWord: result := ptQWord; + {$endif} + end; + tkInt64: + {$ifndef FPC} if Info=TypeInfo(QWord) then result := ptQWord else + {$ifdef UNICODE}with GetTypeInfo(Info)^ do // detect QWord/UInt64 + if MinInt64Value>MaxInt64Value then result := ptQWord else{$endif}{$endif} + result := ptInt64; + {$ifdef FPC} + tkQWord: result := ptQWord; + tkBool: result := ptBoolean; + {$else} + tkEnumeration: // other enumerates (or tkSet) use TJSONCustomParserCustomSimple + if Info=TypeInfo(boolean) then + result := ptBoolean; + {$endif} + tkFloat: + case GetTypeInfo(Info)^.FloatType of + ftSingle: result := ptSingle; + ftDoub: result := ptDouble; + ftCurr: result := ptCurrency; + ftExtended: result := ptExtended; + // ftComp: not implemented yet + end; + end; +end; + +function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; +begin // first by known name, then from RTTI + result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( + PUTF8Char(@PTypeInfo(aTypeInfo)^.NameLen)+1,PTypeInfo(aTypeInfo)^.NameLen,nil); + if result=ptCustom then + result := TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(aTypeInfo); +end; + +class function TJSONCustomParserRTTI.TypeNameToSimpleBinary(const aTypeName: RawUTF8; + out aDataSize, aFieldSize: integer): boolean; +var simple: ^TJSONSerializerFromTextSimple; +begin + simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aTypeName); + if (simple<>nil) and (simple^.BinaryFieldSize<>0) then begin + aDataSize := simple^.BinaryDataSize; + aFieldSize := simple^.BinaryFieldSize; + result := true; + end else + result := false; +end; + +class function TJSONCustomParserRTTI.CreateFromRTTI( + const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; +var Item: PTypeInfo absolute Info; + ItemType: TJSONCustomParserRTTIType; + ItemTypeName: RawUTF8; + ndx: integer; +begin + if Item=nil then // no RTTI -> stored as hexa string + result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin + ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,@ItemTypeName); + if ItemType=ptCustom then + ItemType := TypeInfoToSimpleRTTIType(Info); + if ItemType=ptCustom then + if Item^.kind in [tkEnumeration,tkArray,tkDynArray,tkSet] then + result := TJSONCustomParserCustomSimple.Create( + PropertyName,ItemTypeName,Item) else begin + ndx := GlobalJSONCustomParsers.RecordSearch(Item); + if ndx<0 then + ndx := GlobalJSONCustomParsers.RecordSearch(ItemTypeName); + if ndx<0 then + raise ESynException.CreateUTF8('%.CreateFromRTTI("%") unsupported %', + [self,ItemTypeName,ToText(Item^.kind)^]); + result := TJSONCustomParserCustomRecord.Create(PropertyName,ndx); + end else + result := TJSONCustomParserRTTI.Create(PropertyName,ItemType); + end; + if ItemSize<>0 then + result.fDataSize := ItemSize; +end; + +class function TJSONCustomParserRTTI.CreateFromTypeName( + const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; +var ndx: integer; + simple: ^TJSONSerializerFromTextSimple; +begin + simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aCustomRecordTypeName); + if simple<>nil then + if simple^.BinaryFieldSize<>0 then + result := TJSONCustomParserCustomSimple.CreateBinary( + aPropertyName,simple^.BinaryDataSize,simple^.BinaryFieldSize) else + result := TJSONCustomParserCustomSimple.Create( + aPropertyName,aCustomRecordTypeName,simple^.TypeInfo) else begin + ndx := GlobalJSONCustomParsers.RecordSearch(aCustomRecordTypeName); + if ndx<0 then + result := nil else + result := TJSONCustomParserCustomRecord.Create(aPropertyName,ndx); + end; +end; + +procedure TJSONCustomParserRTTI.ComputeFullPropertyName; +var i: PtrInt; +begin + for i := 0 to length(NestedProperty)-1 do begin + NestedProperty[i].ComputeFullPropertyName; + if fFullPropertyName<>'' then + NestedProperty[i].fFullPropertyName := + fFullPropertyName+'.'+NestedProperty[i].fPropertyName; + end; +end; + +procedure TJSONCustomParserRTTI.ComputeNestedDataSize; +var i: PtrInt; +begin + assert(fNestedDataSize=0); + fNestedDataSize := 0; + for i := 0 to length(NestedProperty)-1 do begin + NestedProperty[i].ComputeDataSizeAfterAdd; + inc(fNestedDataSize,NestedProperty[i].fDataSize); + if fFullPropertyName<>'' then + NestedProperty[i].fFullPropertyName := + fFullPropertyName+'.'+NestedProperty[i].fPropertyName; + end; +end; + +procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd; +const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom + JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = ( + SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency), + SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(QWord), + SizeOf(RawByteString),SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single), + SizeOf(String),SizeOf(SynUnicode),SizeOf(TDateTime),SizeOf(TDateTimeMS), + SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog), + {$ifdef HASVARUSTRING}SizeOf(UnicodeString),{$endif} + {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} + SizeOf(WideString),SizeOf(Word),0); +var i: PtrInt; +begin + if fFullPropertyName='' then begin + fFullPropertyName := fPropertyName; + ComputeFullPropertyName; + end; + if fDataSize=0 then begin + ComputeNestedDataSize; + case PropertyType of + ptRecord: + for i := 0 to length(NestedProperty)-1 do + inc(fDataSize,NestedProperty[i].fDataSize); + //ptCustom: fDataSize already set in TJSONCustomParserCustom.Create() + else + fDataSize := JSONRTTI_SIZE[PropertyType]; + end; + {$ifdef ALIGNCUSTOMREC} + inc(fDataSize,fDataSize and 7); + {$endif} + end; +end; + +procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte); +var j: PtrInt; +begin + for j := 0 to length(NestedProperty)-1 do begin + case NestedProperty[j].PropertyType of + ptRawByteString, + ptRawJSON, + ptRawUTF8: {$ifdef FPC}Finalize(PRawByteString(Data)^){$else}PRawByteString(Data)^ := ''{$endif}; + ptString: PString(Data)^ := ''; + ptSynUnicode: PSynUnicode(Data)^ := ''; + {$ifdef HASVARUSTRING} + ptUnicodeString: PUnicodeString(Data)^ := ''; + {$endif} + ptWideString: PWideString(Data)^ := ''; + ptArray: NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^); + {$ifndef NOVARIANTS} + ptVariant: VarClear(PVariant(Data)^); + {$endif} + ptRecord: begin + NestedProperty[j].FinalizeNestedRecord(Data); + continue; + end; + ptCustom: + TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data); + end; + inc(Data,NestedProperty[j].fDataSize); + end; +end; + +procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt); +var i: integer; + p: PDynArrayRec; + ItemData: PByte; +begin + if Data=0 then + exit; + ItemData := pointer(Data); + p := pointer(Data); + dec(p); + Data := 0; + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin + for i := 1 to p^.length do + FinalizeNestedRecord(ItemData); + FreeMem(p); + end; +end; + +procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt; + NewLength: integer); +begin + FinalizeNestedArray(Data); + if NewLength<=0 then + exit; + pointer(Data) := AllocMem(SizeOf(TDynArrayRec)+fNestedDataSize*NewLength); + PDynArrayRec(Data)^.refCnt := 1; + PDynArrayRec(Data)^.length := NewLength; + inc(Data,SizeOf(TDynArrayRec)); +end; + +procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt; + NewLength: integer); +var OldLength: integer; + p: PDynArrayRec; +begin + p := pointer(Data); + if p=nil then + raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]); + dec(p); + ReAllocMem(p,SizeOf(p^)+fNestedDataSize*NewLength); + OldLength := p^.length; + if NewLength>OldLength then + FillCharFast(PByteArray(p)[SizeOf(p^)+fNestedDataSize*OldLength], + fNestedDataSize*(NewLength-OldLength),0); + p^.length := NewLength; + inc(p); + Data := PtrUInt(p); +end; + +function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte; + Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): boolean; +var EndOfObject: AnsiChar; + function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char; + var Data: PByte): boolean; + var DynArray: PByte; + ArrayLen, ArrayCapacity, n, PropValueLen: integer; + wasString: boolean; + PropValue, ptr: PUTF8Char; + label Error; + begin + result := false; + P := GotoNextNotSpace(P); + case Prop.PropertyType of + ptRecord: begin + if not Prop.ReadOneLevel( + P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then + exit; + EndOfObject := P^; + if P^ in [',','}'] then + inc(P); + result := true; + exit; + end; + ptArray: + if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin + P := GotoNextNotSpace(P+4); + EndOfObject := P^; + if P^<>#0 then //if P^=',' then + inc(P); + Prop.FinalizeNestedArray(PPtrUInt(Data)^); // null -> void array + end else begin + if P^<>'[' then + exit; // we expect a true array here + repeat inc(P) until P^<>' '; + // try to allocate nested array at once (if not too slow) + ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here + if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax + ArrayCapacity := 512 else + ArrayCapacity := ArrayLen; + Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); + // read array content + if ArrayLen=0 then begin + if not NextNotSpaceCharIs(P,']') then + exit; + end else begin + n := 0; + DynArray := PPointer(Data)^; + repeat + inc(n); + if (ArrayLen<0) and (n>ArrayCapacity) then begin + ArrayCapacity := NextGrow(ArrayCapacity); + Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); + DynArray := PPointer(Data)^; + inc(DynArray,pred(n)*Prop.fNestedDataSize); + end; + if Prop.NestedProperty[0].PropertyName='' then begin + // array of simple type + ptr := P; + if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then + goto Error; + P := ptr; + end else begin + // array of record + ptr := P; + if not Prop.ReadOneLevel(ptr,DynArray,Options{$ifndef NOVARIANTS}, + CustomVariantOptions{$endif}) or (ptr=nil) then + goto Error; + P := GotoNextNotSpace(ptr); + EndOfObject := P^; + if not(P^ in [',',']']) then + goto Error; + inc(P); + end; + case EndOfObject of + ',': continue; + ']': begin + if ArrayLen<0 then + Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else + if n<>ArrayLen then + goto Error; + break; // we reached end of array + end; + else begin +Error: Prop.FinalizeNestedArray(PPtrUInt(Data)^); + exit; + end; + end; + until false; + end; + if P=nil then + exit; + P := GotoNextNotSpace(P); + EndOfObject := P^; + if P^<>#0 then //if P^=',' then + inc(P); + end; + ptCustom: begin + ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject + {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + if ptr=nil then + exit; + P := ptr; + end; + {$ifndef NOVARIANTS} + ptVariant: + P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject, + @JSON_OPTIONS[soCustomVariantCopiedByReference in Options]); + {$endif} + ptRawByteString: begin + PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); + if PropValue=nil then // null -> Blob='' + PRawByteString(Data)^ := '' else + if not Base64MagicCheckAndDecode(PropValue,PropValueLen,PRawByteString(Data)^) then + exit; + P := ptr; + end; + ptRawJSON: + GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject); + else begin + PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); + if (PropValue<>nil) and // PropValue=nil for null + (wasString<>(Prop.PropertyType in [ptRawUTF8,ptString,ptSynUnicode, + {$ifdef HASVARUSTRING}ptUnicodeString,{$endif} + ptDateTime,ptDateTimeMS,ptGUID,ptWideString])) then + exit; + P := ptr; + case Prop.PropertyType of + ptBoolean: PBoolean(Data)^ := GetBoolean(PropValue); + ptByte: PByte(Data)^ := GetCardinal(PropValue); + ptCardinal: PCardinal(Data)^ := GetCardinal(PropValue); + ptCurrency: PInt64(Data)^ := StrToCurr64(PropValue); + ptDouble: unaligned(PDouble(Data)^) := GetExtended(PropValue); + ptExtended: PExtended(Data)^ := GetExtended(PropValue); + ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^); + ptQWord: SetQWord(PropValue,PQWord(Data)^); + ptInteger: PInteger(Data)^ := GetInteger(PropValue); + ptSingle: PSingle(Data)^ := GetExtended(PropValue); + ptRawUTF8: FastSetString(PRawUTF8(Data)^,PropValue,PropValueLen); + ptString: UTF8DecodeToString(PropValue,PropValueLen,PString(Data)^); + ptSynUnicode:UTF8ToSynUnicode(PropValue,PropValueLen,PSynUnicode(Data)^); + {$ifdef HASVARUSTRING} + ptUnicodeString:UTF8DecodeToUnicodeString(PropValue,PropValueLen,PUnicodeString(Data)^); + {$endif} + ptDateTime, ptDateTimeMS: Iso8601ToDateTimePUTF8CharVar( + PropValue,PropValueLen,PDateTime(Data)^); + ptWideString:UTF8ToWideString(PropValue,PropValueLen,PWideString(Data)^); + ptWord: PWord(Data)^ := GetCardinal(PropValue); + ptGUID: TextToGUID(PropValue,pointer(Data)); + end; + end; + end; + inc(Data,Prop.fDataSize); + result := true; + end; +var i,j: integer; + PropName: shortstring; + ptr: PUTF8Char; + Values: array of PUTF8Char; +begin + result := false; + if P=nil then + exit; + P := GotoNextNotSpace(P); + if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin + P := GotoNextNotSpace(P+4); // a record stored as null + inc(Data,fDataSize); + result := true; + exit; + end; + EndOfObject := #0; + if not (PropertyType in [ptRecord,ptArray]) then begin + ptr := P; + result := ProcessValue(Self,P,Data); + exit; + end; + if P^<>'{' then + exit; // we expect a true object here + repeat inc(P) until (P^>' ') or (P^=#0); + if P^='}' then begin + inc(Data,fDataSize); + EndOfObject := '}'; + inc(P); + end else + for i := 0 to length(NestedProperty)-1 do begin + ptr := P; + GetJSONPropName(ptr,PropName); + if PropName='' then + exit; // invalid JSON content + P := ptr; + if IdemPropNameU(NestedProperty[i].PropertyName,@PropName[1],ord(PropName[0])) then begin + // O(1) optimistic search + if not ProcessValue(NestedProperty[i],P,Data) then + exit; + if EndOfObject='}' then begin // ignore missing properties + for j := i+1 to length(NestedProperty)-1 do + inc(Data,NestedProperty[j].fDataSize); + break; + end; + end else begin + SetLength(Values,length(NestedProperty)); // pessimistic check through all properties + repeat + for j := i to length(NestedProperty)-1 do + if (Values[j]=nil) and + IdemPropNameU(NestedProperty[j].PropertyName,@PropName[1],ord(PropName[0])) then begin + Values[j] := P; + PropName := ''; + break; + end; + if (PropName<>'') and not(soReadIgnoreUnknownFields in Options) then + exit; // unexpected property + ptr := GotoNextJSONItem(P,1,@EndOfObject); + if ptr=nil then + exit; + P := ptr; + if EndOfObject='}' then + break; + GetJSONPropName(ptr,PropName); // next name + if PropName='' then + exit; // invalid JSON content + P := ptr; + until false; + for j := i to length(NestedProperty)-1 do + if Values[j]=nil then // ignore missing properties + inc(Data,NestedProperty[j].fDataSize) else + if not ProcessValue(NestedProperty[j],Values[j],Data) then + exit; + EndOfObject := '}'; // ProcessValue() did update EndOfObject + break; + end; + end; + if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin + ptr := GotoNextJSONObjectOrArray(P,'}'); + if ptr=nil then + exit; + P := ptr; + end else + if EndOfObject<>'}' then + exit; + if P<>nil then + P := GotoNextNotSpace(P); + result := true; +end; + +function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; +var len,L: PtrInt; +begin + len := (AppendUInt32ToBuffer(@result[1],itemcount)-PUTF8Char(@result[1]))+1; + result[len] := ' '; + L := ord(itemname[0]); + if L in [1..240] then begin // avoid buffer overflow + MoveSmall(@itemname[1],@result[len+1],L); + inc(len,L); + if itemcount>1 then begin + inc(len); + result[len] := 's'; + end; + end; + result[0] := AnsiChar(len); +end; + +function TJSONCustomParserRTTI.IfDefaultSkipped(var Value: PByte): boolean; +begin + case PropertyType of + ptBoolean: result := not PBoolean(Value)^; + ptByte: result := PByte(Value)^=0; + ptWord: result := PWord(Value)^=0; + ptInteger,ptCardinal,ptSingle: + result := PInteger(Value)^=0; + ptCurrency,ptDouble,ptInt64,ptQWord,ptID,ptTimeLog,ptDateTime,ptDateTimeMS: + result := PInt64(Value)^=0; + ptExtended: result := PExtended(Value)^=0; + {$ifndef NOVARIANTS} + ptVariant: result := integer(PVarData(Value)^.VType)<=varNull; + {$endif} + ptRawJSON,ptRawByteString,ptRawUTF8,ptString,ptSynUnicode,ptWideString, + {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptArray: + result := PPointer(Value)^=nil; + ptGUID: result := IsNullGUID(PGUID(Value)^); + ptRecord: result := IsZero(Value,fDataSize); + else result := false; + end; + if result then + inc(Value,fDataSize); +end; + +procedure TJSONCustomParserRTTI.WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; + Options: TJSONCustomParserSerializationOptions); +var DynArray: PByte; + j: integer; +begin + case PropertyType of + ptBoolean: aWriter.Add(PBoolean(Value)^); + ptByte: aWriter.AddU(PByte(Value)^); + ptCardinal: aWriter.AddU(PCardinal(Value)^); + ptCurrency: aWriter.AddCurr64(PInt64(Value)^); + ptDouble: aWriter.AddDouble(unaligned(PDouble(Value)^)); + ptExtended: aWriter.Add(PExtended(Value)^,EXTENDED_PRECISION); + ptInt64,ptID,ptTimeLog: + aWriter.Add(PInt64(Value)^); + ptQWord: aWriter.AddQ(PQWord(Value)^); + ptInteger: aWriter.Add(PInteger(Value)^); + ptSingle: aWriter.AddSingle(PSingle(Value)^); + ptWord: aWriter.AddU(PWord(Value)^); + {$ifndef NOVARIANTS} + ptVariant: aWriter.AddVariant(PVariant(Value)^,twJSONEscape); + {$endif} + ptRawJSON: aWriter.AddRawJSON(PRawJSON(Value)^); + ptRawByteString: + aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),{withMagic=}true); + ptRawUTF8, ptString, ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} + ptDateTime, ptDateTimeMS, ptGUID, ptWideString: begin + aWriter.Add('"'); + case PropertyType of + ptRawUTF8: aWriter.AddJSONEscape(PPointer(Value)^); + ptString: aWriter.AddJSONEscapeString(PString(Value)^); + ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} + ptWideString: aWriter.AddJSONEscapeW(PPointer(Value)^); + ptDateTime: aWriter.AddDateTime(unaligned(PDateTime(Value)^),{withms=}false); + ptDateTimeMS: aWriter.AddDateTime(unaligned(PDateTime(Value)^),true); + ptGUID: aWriter.Add(PGUID(Value)^); + end; + aWriter.Add('"'); + end; + ptArray: begin + aWriter.Add('['); + inc(aWriter.fHumanReadableLevel); + DynArray := PPointer(Value)^; + if DynArray<>nil then + for j := 1 to DynArrayLength(DynArray) do begin + if soWriteHumanReadable in Options then + aWriter.AddCRAndIndent; + if NestedProperty[0].PropertyName='' then // array of simple + NestedProperty[0].WriteOneSimpleValue(aWriter,DynArray,Options) else + WriteOneLevel(aWriter,DynArray,Options); // array of record + aWriter.Add(','); + {$ifdef ALIGNCUSTOMREC} + if PtrUInt(DynArray)and 7<>0 then + inc(DynArray,8-(PtrUInt(DynArray)and 7)); + {$endif} + end; + aWriter.CancelLastComma; + aWriter.Add(']'); + dec(aWriter.fHumanReadableLevel); + end; + ptRecord: begin + WriteOneLevel(aWriter,Value,Options); + exit; + end; + ptCustom: + TJSONCustomParserCustom(self).CustomWriter(aWriter,Value^); + end; + inc(Value,fDataSize); +end; + +procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte; + Options: TJSONCustomParserSerializationOptions); +var i: integer; + SubProp: TJSONCustomParserRTTI; +begin + if P=nil then begin + aWriter.AddShort('null'); + exit; + end; + if not (PropertyType in [ptRecord,ptArray]) then begin + WriteOneSimpleValue(aWriter,P,Options); + exit; + end; + aWriter.Add('{'); + Inc(aWriter.fHumanReadableLevel); + for i := 0 to length(NestedProperty)-1 do begin + SubProp := NestedProperty[i]; + if soWriteIgnoreDefault in Options then + if SubProp.IfDefaultSkipped(P) then + continue; + if soWriteHumanReadable in Options then + aWriter.AddCRAndIndent; + aWriter.AddFieldName(SubProp.PropertyName); + if soWriteHumanReadable in Options then + aWriter.Add(' '); + SubProp.WriteOneSimpleValue(aWriter,P,Options); + aWriter.Add(','); + end; + aWriter.CancelLastComma; + dec(aWriter.fHumanReadableLevel); + if soWriteHumanReadable in Options then + aWriter.AddCRAndIndent; + aWriter.Add('}'); +end; + + +{ TJSONRecordAbstract } + +constructor TJSONRecordAbstract.Create; +begin + fItems := TSynObjectList.Create; +end; + +function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8; + aPropertyType: TJSONCustomParserRTTIType; + const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; +begin + if aPropertyType=ptCustom then begin + result := TJSONCustomParserRTTI.CreateFromTypeName( + aPropertyName,aCustomRecordTypeName); + if result=nil then + raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)', + [self,aPropertyName,aCustomRecordTypeName]); + end else + result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType); + fItems.Add(result); +end; + +function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue; + out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +var Data: PByte; + EndOfObject: AnsiChar; +begin + if Root.PropertyType=ptCustom then begin + result := TJSONCustomParserCustom(Root).CustomReader(P,aValue,EndOfObject + {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + aValid := result<>nil; + if (EndOfObject<>#0) and aValid then begin + dec(result); + result^ := EndOfObject; // emulates simple read + end; + exit; + end; + Data := @aValue; + aValid := Root.ReadOneLevel(P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + result := P; +end; + +procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue); +var P: PByte; + o: TJSONCustomParserSerializationOptions; +begin + P := @aValue; + o := Options; + if twoIgnoreDefaultInRecord in aWriter.CustomOptions then + include(o,soWriteIgnoreDefault); + Root.WriteOneLevel(aWriter,P,o); +end; + +destructor TJSONRecordAbstract.Destroy; +begin + FreeAndNil(fItems); + inherited; +end; + + +{ TJSONRecordTextDefinition } + +var + JSONCustomParserCache: TRawUTF8List; + +class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer; + const aDefinition: RawUTF8): TJSONRecordTextDefinition; +begin + if JSONCustomParserCache=nil then + GarbageCollectorFreeAndNil(JSONCustomParserCache, + TRawUTF8List.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive])); + result := JSONCustomParserCache.GetObjectFrom(aDefinition); + if result<>nil then + exit; + result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition); + JSONCustomParserCache.AddObjectUnique(aDefinition,@result); +end; + +constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer; + const aDefinition: RawUTF8); +var P: PUTF8Char; + recordInfoSize: integer; +begin + inherited Create; + fDefinition := aDefinition; + fRoot := TJSONCustomParserRTTI.Create('',ptRecord); + TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName); + fItems.Add(fRoot); + P := pointer(aDefinition); + Parse(fRoot,P,eeNothing); + fRoot.ComputeDataSizeAfterAdd; + recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo); + if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then + raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+ + ' or the type has not been defined as PACKED record: RTTI size is %'+ + ' bytes but text definition covers % bytes', + [self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]); +end; + +function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; +begin + result := length(aDynArrayTypeName); + if (result>12) and IdemPropName('DynArray',@PByteArray(aDynArrayTypeName)[result-8],8) then + dec(result,8) else + if (result>3) and (aDynArrayTypeName[result] in ['s','S']) then + dec(result) else + result := 0; +end; + +function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; +var itemLen,dataSize,fieldSize: integer; +begin + itemLen := DynArrayItemTypeLen(aDynArrayTypeName); + result := (itemLen>0) and TJSONCustomParserRTTI.TypeNameToSimpleBinary( + copy(aDynArrayTypeName,1,itemLen),dataSize,fieldSize); +end; + +procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI; + var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd); + function GetNextFieldType(var P: PUTF8Char; + var TypIdent: RawUTF8): TJSONCustomParserRTTIType; + begin + if GetNextFieldProp(P,TypIdent) then + result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( + pointer(TypIdent),length(TypIdent),@TypIdent) else + raise ESynException.CreateUTF8('%.Parse: missing field type',[self]); + end; +var PropsName: TRawUTF8DynArray; + PropsMax, ndx, len, firstNdx: cardinal; + Typ, ArrayTyp: TJSONCustomParserRTTIType; + TypIdent, ArrayTypIdent: RawUTF8; + Item: TJSONCustomParserRTTI; + ExpectedEnd: TJSONCustomParserRTTIExpectedEnd; +begin + SetLength(PropsName,16); + PropsMax := 0; + while (P<>nil) and (P^<>#0) do begin + // fill Props[] + if P^ in ['''','"'] then begin // parse identifier as SQL string (e.g. "@field0") + P := UnQuoteSQLStringVar(P,PropsName[PropsMax]); + if P=nil then + break; + end else // regular object pascal identifier (i.e. 0..9,a..z,A..Z,_) + if not GetNextFieldProp(P,PropsName[PropsMax]) then + break; + case P^ of + ',': begin + inc(P); + inc(PropsMax); + if PropsMax=cardinal(length(PropsName)) then + SetLength(PropsName,PropsMax+16); + continue; // several properties defined with the same type + end; + ':': P := GotoNextNotSpace(P+1); + end; + // identify type + ArrayTyp := ptRecord; + if P^='{' then begin + Typ := ptRecord; + ExpectedEnd := eeCurly; + repeat inc(P) until (P^>' ') or (P^=#0); + end else + if P^='[' then begin + Typ := ptArray; + ExpectedEnd := eeSquare; + repeat inc(P) until (P^>' ') or (P^=#0); + end else begin + Typ := GetNextFieldType(P,TypIdent); + case Typ of + ptArray: begin + if IdemPChar(P,'OF') then begin + P := GotoNextNotSpace(P+2); + ArrayTyp := GetNextFieldType(P,ArrayTypIdent); + if ArrayTyp=ptArray then + P := nil; + end else + P := nil; + if P=nil then + raise ESynException.CreateUTF8('%.Parse: expected syntax is '+ + '"array of record" or "array of SimpleType"',[self]); + if ArrayTyp=ptRecord then + ExpectedEnd := eeEndKeyWord else + ExpectedEnd := eeNothing; + end; + ptRecord: + ExpectedEnd := eeEndKeyWord; + ptCustom: begin + len := DynArrayItemTypeLen(TypIdent); + if len>0 then begin + ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( + @PByteArray(TypIdent)[1],len-1,@ArrayTypIdent); // TByteDynArray -> byte + if ArrayTyp=ptCustom then begin // TMyTypeDynArray/TMyTypes -> TMyType + FastSetString(ArrayTypIdent,pointer(TypIdent),len); + if GlobalCustomJSONSerializerFromTextSimpleType.Find(ArrayTypIdent)>=0 then + Typ := ptArray; + end else + Typ := ptArray; + end; + ExpectedEnd := eeNothing; + end; + else ExpectedEnd := eeNothing; + end; + end; + // add elements + firstNdx := length(Props.fNestedProperty); + SetLength(Props.fNestedProperty,firstNdx+PropsMax+1); + for ndx := 0 to PropsMax do begin + Item := AddItem(PropsName[ndx],Typ,TypIdent); + Props.fNestedProperty[firstNdx+ndx] := Item; + if (Typ=ptArray) and (ArrayTyp<>ptRecord) then begin + SetLength(Item.fNestedProperty,1); + Item.fNestedProperty[0] := AddItem('',ArrayTyp,ArrayTypIdent); + end else + if Typ in [ptArray,ptRecord] then + if ndx=0 then // only parse once multiple fields nested type + Parse(Item,P,ExpectedEnd) else + Item.fNestedProperty := Props.fNestedProperty[firstNdx].fNestedProperty; + Item.ComputeDataSizeAfterAdd; + end; + // validate expected end + while P^ in [#1..' ',';'] do inc(P); + case PEnd of + eeEndKeyWord: + if IdemPChar(P,'END') then begin + inc(P,3); + while P^ in [#1..' ',';'] do inc(P); + break; + end; + eeSquare: + if P^=']' then begin + inc(P); + break; + end; + eeCurly: + if P^='}' then begin + inc(P); + break; + end; + end; + PropsMax := 0; + end; +end; + + +{ TJSONRecordRTTI } + +constructor TJSONRecordRTTI.Create(aRecordTypeInfo: pointer; + aRoot: TJSONCustomParserRTTI); +begin + inherited Create; + fRecordTypeInfo := aRecordTypeInfo; + fRoot := aRoot; + if fRoot=nil then begin + {$ifdef ISDELPHI2010} + fRoot := TJSONCustomParserRTTI.Create('',ptRecord); + FromEnhancedRTTI(fRoot,aRecordTypeInfo); + if fRoot.fNestedDataSize<>RecordTypeInfoSize(aRecordTypeInfo) then + raise ESynException.CreateUTF8( + '%.Create: error when retrieving enhanced RTTI for %', + [self,fRoot.CustomTypeName]); + {$else} + raise ESynException.CreateUTF8('%.Create with no enhanced RTTI for %', + [self,PShortString(@PTypeInfo(aRecordTypeInfo).NameLen)^]); + {$endif} + end; + fItems.Add(fRoot); + GarbageCollector.Add(self); +end; + +function TJSONRecordRTTI.AddItemFromRTTI( + const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; +begin + result := TJSONCustomParserRTTI.CreateFromRTTI(PropertyName,Info,ItemSize); + fItems.Add(result); +end; + +{$ifdef ISDELPHI2010} + +procedure TJSONRecordRTTI.FromEnhancedRTTI( + Props: TJSONCustomParserRTTI; Info: pointer); +var FieldTable: PTypeInfo; + i: integer; + FieldSize: cardinal; + RecField: PEnhancedFieldInfo; + ItemFields: array of PEnhancedFieldInfo; + ItemField: PTypeInfo; + ItemFieldName: RawUTF8; + ItemFieldSize: cardinal; + Item, ItemArray: TJSONCustomParserRTTI; +begin // only tkRecord is needed here + FieldTable := GetTypeInfo(Info,tkRecord); + if FieldTable=nil then + raise ESynException.CreateUTF8('%.FromEnhancedRTTI(%=record?)',[self,Info]); + FieldSize := FieldTable^.recSize; + inc(PByte(FieldTable),FieldTable^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); + inc(PByte(FieldTable),FieldTable^.NumOps*SizeOf(pointer)); // jump RecOps[] + if FieldTable^.AllCount=0 then + exit; // not enough RTTI -> will raise an error in Create() + TypeInfoToName(Info,Props.fCustomTypeName); + RecField := @FieldTable^.AllFields[0]; + SetLength(ItemFields,FieldTable^.AllCount); + for i := 0 to FieldTable^.AllCount-1 do begin + ItemFields[i] := RecField; + inc(PByte(RecField),RecField^.NameLen); // Delphi: no AlignPtr() needed + inc(RecField); + inc(PByte(RecField),PWord(RecField)^); + end; + SetLength(Props.fNestedProperty,FieldTable^.AllCount); + for i := 0 to FieldTable^.AllCount-1 do begin + if i=FieldTable^.AllCount-1 then + ItemFieldSize := FieldSize-ItemFields[i].Offset else + ItemFieldSize := ItemFields[i+1].Offset-ItemFields[i].Offset; + ItemField := Deref(ItemFields[i]^.TypeInfo); + FastSetString(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen); + Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize); + Props.fNestedProperty[i] := Item; + case Item.PropertyType of + ptArray: begin + inc(PByte(ItemField),ItemField^.NameLen); + ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2), + ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}); + if (ItemArray.PropertyType=ptCustom) and + (ItemArray.ClassType=TJSONCustomParserRTTI) then + FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin + SetLength(Item.fNestedProperty,1); + Item.fNestedProperty[0] := ItemArray; + Item.ComputeNestedDataSize; + end; + end; + ptCustom: + if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then + FromEnhancedRTTI(Item,ItemField); + end; + end; + Props.ComputeNestedDataSize; +end; + +{$endif ISDELPHI2010} + + +{ ************ variant-based process, including JSON/BSON document content } + +{$ifndef LVCL} + +procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); +begin + ClearVariantForString(Value); + if (Data=nil) or (DataLen<=0) then + TVarData(Value).VType := varNull else + SetString(RawByteString(TVarData(Value).VAny),PAnsiChar(Data),DataLen); +end; + +procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); +begin + ClearVariantForString(Value); + if Data='' then + TVarData(Value).VType := varNull else + RawByteString(TVarData(Value).VAny) := Data; +end; + +procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); +begin + case integer(TVarData(Value).VType) of + varEmpty, varNull: + Dest := ''; + varString: + Dest := RawByteString(TVarData(Value).VAny); + else // not from RawByteStringToVariant() -> conversion to string + Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value); + end; +end; + +procedure SetVariantNull(var Value: variant); +begin // slightly faster than Value := Null + VarClear(Value); + TVarData(Value).VType := varNull; +end; + +{$endif LVCL} + +function VarDataIsEmptyOrNull(VarData: pointer): Boolean; +var vt: cardinal; +begin + repeat + vt := PVarData(VarData)^.VType; + if vt<>varVariant or varByRef then + break; + VarData := PVarData(VarData)^.VPointer; + if VarData=nil then begin + result := true; + exit; + end; + until false; + result := (vt<=varNull) or (vt=varNull or varByRef); +end; + +function VarIsEmptyOrNull(const V: Variant): Boolean; +begin + result := VarDataIsEmptyOrNull(@V); +end; + +function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; +var VD: PVarData; + vt: cardinal; +begin + VD := @V; + repeat + vt := VD^.VType; + if vt<>varVariant or varByRef then + break; + VD := VD^.VPointer; + if VD=nil then begin + result := false; + exit; + end; + until false; + result := vt in VTypes; +end; + +function VarIsVoid(const V: Variant): boolean; +var vt: cardinal; +begin + vt := TVarData(V).VType; + with TVarData(V) do + case vt of + varEmpty,varNull: + result := true; + varBoolean: + result := not VBoolean; + varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: + result := VAny=nil; + varDate: + result := VInt64=0; + else + if vt=varVariant or varByRef then + result := VarIsVoid(PVariant(VPointer)^) else + if (vt=varByRef or varString) or (vt=varByRef or varOleStr) + {$ifdef HASVARUSTRING} or (vt=varByRef or varUString) {$endif} then + result := PPointer(VAny)^=nil else + {$ifndef NOVARIANTS} + if vt=cardinal(DocVariantVType) then + result := TDocVariantData(V).Count=0 else + {$endif} + result := false; + end; +end; + +function VarStringOrNull(const v: RawUTF8): variant; +begin + if v='' then + SetVariantNull(result) else + {$ifdef NOVARIANTS} result := v {$else} RawUTF8ToVariant(v,result) {$endif}; +end; + +{$ifndef NOVARIANTS} + +/// internal method used by VariantLoadJSON(), GetVariantFromJSON() and +// TDocVariantData.InitJSONInPlace() +procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; + EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); forward; + +procedure SetVariantByRef(const Source: Variant; var Dest: Variant); +var vt: cardinal; +begin + VarClear(Dest); + vt := TVarData(Source).VType; + if ((vt and varByRef)<>0) or (vt in [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then + TVarData(Dest) := TVarData(Source) else + if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin + TVarData(Dest).VType := varVariant or varByRef; + TVarData(Dest).VPointer := @Source; + end; +end; + +procedure SetVariantByValue(const Source: Variant; var Dest: Variant); +var s: PVarData; + d: TVarData absolute Dest; + vt: cardinal; +begin + s := @Source; + VarClear(Dest); + vt := s^.VType; + if vt=varVariant or varByRef then begin + s := s^.VPointer; + vt := s^.VType; + end; + case vt of + varEmpty..varDate,varBoolean,varShortInt..varWord64: begin + d.VType := vt; + d.VInt64 := s^.VInt64; + end; + varString: begin + d.VType := varString; + d.VAny := nil; + RawByteString(d.VAny) := RawByteString(s^.VAny); + end; + varByRef or varString: begin + d.VType := varString; + d.VAny := nil; + RawByteString(d.VAny) := PRawByteString(s^.VAny)^; + end; + {$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif} + varOleStr, varByRef or varOleStr: begin + d.VType := varString; + d.VAny := nil; + VariantToUTF8(PVariant(s)^,RawUTF8(d.VAny)); // store a RawUTF8 instance + end; + else + if not SetVariantUnRefSimpleValue(PVariant(s)^,d) then + if vt=cardinal(DocVariantVType) then + DocVariantType.CopyByValue(d,s^) else + Dest := PVariant(s)^; + end; +end; + +procedure ZeroFill(Value: PVarData); +begin // slightly faster than FillChar(Value,SizeOf(Value),0); + PInt64Array(Value)^[0] := 0; + PInt64Array(Value)^[1] := 0; + {$ifdef CPU64} + //assert(SizeOf(TVarData)=24); + PInt64Array(Value)^[2] := 0; + {$endif} +end; + +procedure FillZero(var value: variant); +begin + with TVarData(Value) do + if cardinal(VType)=varString then + FillZero(RawByteString(VString)); + VarClear(Value); +end; + +procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); +begin + ClearVariantForString(Value); + FastSetString(RawUTF8(TVarData(Value).VString), Txt, TxtLen); +end; + +procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); +begin + ClearVariantForString(Value); + if Txt='' then + exit; + RawByteString(TVarData(Value).VString) := Txt; + {$ifdef HASCODEPAGE} // force explicit UTF-8 + SetCodePage(RawByteString(TVarData(Value).VAny),CP_UTF8,false); + {$endif HASCODEPAGE} +end; + +procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; + var Value: variant); +begin + RawUTF8ToVariant(FormatUTF8(Fmt,Args),Value); +end; + +function RawUTF8ToVariant(const Txt: RawUTF8): variant; +begin + RawUTF8ToVariant(Txt,result); +end; + +procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; + ExpectedValueType: cardinal); +begin + if ExpectedValueType=varString then begin + RawUTF8ToVariant(Txt,variant(Value)); + exit; + end; + VarClear(variant(Value)); + Value.VType := ExpectedValueType; + Value.VAny := nil; // avoid GPF below + if Txt<>'' then + case ExpectedValueType of + varOleStr: + UTF8ToWideString(Txt,WideString(Value.VAny)); + {$ifdef HASVARUSTRING} + varUString: + UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny)); + {$endif} + else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)', + [ExpectedValueType]); + end; +end; + +function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; + procedure ComplexType; + begin + try + Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest))); + except + on Exception do + Dest := nil; // notify invalid/unhandled variant content + end; + end; +var LenBytes: integer; + tmp: TVarData; +begin + with TVarData(Value) do + if VType and varByRef<>0 then + if VType=varVariant or varByRef then begin + result := VariantSave(PVariant(VPointer)^,Dest); + exit; + end else + if SetVariantUnRefSimpleValue(Value,tmp) then begin + result := VariantSave(variant(tmp),Dest-SizeOf(VType)); + exit; + end; + with TVarData(Value) do begin + PWord(Dest)^ := VType; + inc(Dest,SizeOf(VType)); + case VType of + varNull, varEmpty: ; + varShortInt, varByte: begin + Dest^ := AnsiChar(VByte); + inc(Dest); + end; + varSmallint, varWord, varBoolean: begin + PWord(Dest)^ := VWord; + inc(Dest,SizeOf(VWord)); + end; + varSingle, varLongWord, varInteger: begin + PInteger(Dest)^ := VInteger; + inc(Dest,SizeOf(VInteger)); + end; + varInt64, varWord64, varDouble, varDate, varCurrency:begin + PInt64(Dest)^ := VInt64; + inc(Dest,SizeOf(VInt64)); + end; + varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin + if PtrUInt(VAny)=0 then + LenBytes := 0 else begin + LenBytes := PStrLen(PtrUInt(VAny)-_STRLEN)^; + {$ifdef HASVARUSTRING} + if VType=varUString then + LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars + {$endif} + end; + Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest))); + if LenBytes>0 then begin // direct raw copy + MoveFast(PPtrUInt(VAny)^,Dest^,LenBytes); + inc(Dest,LenBytes); + end; + end; + else ComplexType; // complex types are stored as JSON + end; + end; + result := Dest; +end; + +function VariantSaveLength(const Value: variant): integer; +var tmp: TVarData; + v: TVarData absolute Value; +begin // match VariantSave() storage + if v.VType and varByRef<>0 then + if v.VType=varVariant or varByRef then begin + result := VariantSaveLength(PVariant(v.VPointer)^); + exit; + end else + if SetVariantUnRefSimpleValue(Value,tmp) then begin + result := VariantSaveLength(variant(tmp)); + exit; + end; + case v.VType of + varEmpty, varNull: + result := SizeOf(tmp.VType); + varShortInt, varByte: + result := SizeOf(tmp.VByte)+SizeOf(tmp.VType); + varSmallint, varWord, varBoolean: + result := SizeOf(tmp.VSmallint)+SizeOf(tmp.VType); + varSingle, varLongWord, varInteger: + result := SizeOf(tmp.VInteger)+SizeOf(tmp.VType); + varInt64, varWord64, varDouble, varDate, varCurrency: + result := SizeOf(tmp.VInt64)+SizeOf(tmp.VType); + varString, varOleStr: + if PtrUInt(v.VAny)=0 then + result := 1+SizeOf(tmp.VType) else + result := ToVarUInt32LengthWithData( + PStrLen(PtrUInt(v.VAny)-_STRLEN)^)+SizeOf(tmp.VType); + {$ifdef HASVARUSTRING} + varUString: + if PtrUInt(v.VAny)=0 then // stored length is in bytes, not (wide)chars + result := 1+SizeOf(tmp.VType) else + result := ToVarUInt32LengthWithData( + PStrLen(PtrUInt(v.VAny)-_STRLEN)^*2)+SizeOf(tmp.VType); + {$endif} + else + try // complex types will be stored as JSON + result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+SizeOf(tmp.VType); + except + on Exception do + result := 0; // notify invalid/unhandled variant content + end; + end; +end; + +function VariantSave(const Value: variant): RawByteString; +var P: PAnsiChar; +begin + SetString(result,nil,VariantSaveLength(Value)); + P := VariantSave(Value,pointer(result)); + if P-pointer(result)<>length(result) then + raise ESynException.Create('VariantSave length'); +end; + +function VariantLoad(const Bin: RawByteString; + CustomVariantOptions: PDocVariantOptions): variant; +begin + if VariantLoad(result,Pointer(Bin),CustomVariantOptions, + PAnsiChar(pointer(Bin))+length(Bin))=nil then + VarClear(result); +end; + +function VariantLoad(var Value: variant; Source: PAnsiChar; + CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar; +var JSON: PUTF8Char; + n: cardinal; + tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy +begin + result := nil; // error + VarClear(Value); + if (SourceMax<>nil) and (Source+2>SourceMax) then exit; + TVarData(Value).VType := PWord(Source)^; + inc(Source,SizeOf(TVarData(Value).VType)); + case TVarData(Value).VType of + varNull, varEmpty: ; + varShortInt, varByte: begin + if (SourceMax<>nil) and (Source>=SourceMax) then exit; + TVarData(Value).VByte := byte(Source^); + inc(Source); + end; + varSmallint, varWord, varBoolean: begin + if (SourceMax<>nil) and (Source+2>SourceMax) then exit; + TVarData(Value).VWord := PWord(Source)^; + inc(Source,SizeOf(Word)); + end; + varSingle, varLongWord, varInteger: begin + if (SourceMax<>nil) and (Source+4>SourceMax) then exit; + TVarData(Value).VInteger := PInteger(Source)^; + inc(Source,SizeOf(Integer)); + end; + varInt64, varWord64, varDouble, varDate, varCurrency: begin + if (SourceMax<>nil) and (Source+8>SourceMax) then exit; + TVarData(Value).VInt64 := PInt64(Source)^; + inc(Source,SizeOf(Int64)); + end; + varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin + TVarData(Value).VAny := nil; // avoid GPF below when assigning a string variable to VAny + if not FromVarUInt32(PByte(Source),PByte(SourceMax),n) or + ((SourceMax<>nil) and (Source+n>SourceMax)) then + exit; + case TVarData(Value).VType of + varString: + FastSetString(RawUTF8(TVarData(Value).VString),Source,n); // explicit RawUTF8 + varOleStr: + SetString(WideString(TVarData(Value).VAny),PWideChar(Source),n shr 1); + {$ifdef HASVARUSTRING} + varUString: + SetString(UnicodeString(TVarData(Value).VAny),PWideChar(Source),n shr 1); + {$endif} + end; + inc(Source,n); + end; + else + if CustomVariantOptions<>nil then begin + try // expected format for complex type is JSON (VType may differ) + if FromVarString(PByte(Source),PByte(SourceMax),tmp) then + try + JSON := tmp.buf; + TVarData(Value).VType := varEmpty; // avoid GPF below + GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions,false); + finally + tmp.Done; + end else + exit; + except + on Exception do + exit; // notify invalid/unhandled variant content + end; + end else + exit; + end; + result := Source; +end; + +procedure FromVarVariant(var Source: PByte; var Value: variant; + CustomVariantOptions: PDocVariantOptions); +begin + Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions)); +end; + +function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char; + TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): PUTF8Char; +var wasString: boolean; + Val: PUTF8Char; +begin + result := JSON; + if JSON=nil then + exit; + if TryCustomVariants<>nil then begin + if dvoJSONObjectParseWithinString in TryCustomVariants^ then begin + JSON := GotoNextNotSpace(JSON); + if JSON^='"' then begin + Val := GetJSONField(result,result,@wasString,EndOfObject); + GetJSONToAnyVariant(Value,Val,EndOfObject,TryCustomVariants,AllowDouble); + end else + GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); + end else + GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); + end else begin + Val := GetJSONField(result,result,@wasString,EndOfObject); + GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble); + end; + if result=nil then + result := @NULCHAR; // reached end, but not invalid input +end; + +procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; + TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); // temp copy before in-place decoding + try + VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants,AllowDouble); + finally + tmp.Done; + end; +end; + +function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions; + AllowDouble: boolean): variant; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); + try + VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants,AllowDouble); + finally + tmp.Done; + end; +end; + +function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind): RawUTF8; +begin + VariantSaveJSON(Value,Escape,result); +end; + +procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; + var result: RawUTF8); +var temp: TTextWriterStackBuffer; +begin // not very optimized, but fast enough in practice, and creates valid JSON + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + AddVariant(Value,Escape); // may encounter TObjectVariant -> WriteObject + SetText(result); + finally + Free; + end; +end; + +function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer; +var Fake: TFakeWriterStream; + temp: TTextWriterStackBuffer; +begin // will avoid most memory allocations + Fake := TFakeWriterStream.Create; + try + with DefaultTextWriterSerializer.Create(Fake,@temp,SizeOf(temp)) do + try + AddVariant(Value,Escape); + FlushFinal; + result := fTotalFileSize; + finally + Free; + end; + finally + Fake.Free; + end; +end; + +procedure VariantToVarRec(const V: variant; var result: TVarRec); +begin + result.VType := vtVariant; + if TVarData(V).VType=varByRef or varVariant then + result.VVariant := TVarData(V).VPointer else + result.VVariant := @V; +end; + +function VarRecToVariant(const V: TVarRec): variant; +begin + VarRecToVariant(V,result); +end; + +procedure VarRecToVariant(const V: TVarRec; var result: variant); +begin + VarClear(result); + with TVarData(result) do + case V.VType of + vtPointer: + VType := varNull; + vtBoolean: begin + VType := varBoolean; + VBoolean := V.VBoolean; + end; + vtInteger: begin + VType := varInteger; + VInteger := V.VInteger; + end; + vtInt64: begin + VType := varInt64; + VInt64 := V.VInt64^; + end; + {$ifdef FPC} + vtQWord: begin + VType := varQWord; + VQWord := V.VQWord^; + end; + {$endif} + vtCurrency: begin + VType := varCurrency; + VCurrency := V.VCurrency^; + end; + vtExtended: begin + VType := varDouble; + VDouble := V.VExtended^; + end; + vtVariant: + result := V.VVariant^; + vtAnsiString: begin + VType := varString; + VAny := nil; + RawByteString(VAny) := RawByteString(V.VAnsiString); + end; + vtString, {$ifdef HASVARUSTRING}vtUnicodeString,{$endif} + vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin + VType := varString; + VString := nil; // avoid GPF on next line + VarRecToUTF8(V,RawUTF8(VString)); // convert to a new RawUTF8 instance + end; + vtObject: // class instance will be serialized as a TDocVariant + ObjectToVariant(V.VObject,result,[woDontStoreDefault]); + else raise ESynException.CreateUTF8('Unhandled TVarRec.VType=%',[V.VType]); + end; +end; + + +{ TSynInvokeableVariantType } + +function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer; +begin + result := -1; // this is not an array +end; + +procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData; + Index: integer); +begin // do nothing +end; + +{$ifndef FPC} +{$ifndef DELPHI6OROLDER} +function TSynInvokeableVariantType.FixupIdent(const AText: string): string; +begin + result := AText; // NO uppercased identifier for our custom types! +end; +{$endif DELPHI6OROLDER} +{$endif FPC} + +function TSynInvokeableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; +begin + raise ESynException.CreateUTF8('Unexpected %.IntGet(%): this kind of '+ + 'custom variant does not support sub-fields',[self,Name]); +end; + +function TSynInvokeableVariantType.IntSet(const Instance, Value: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; +begin + raise ESynException.CreateUTF8('Unexpected %.IntSet(%): this kind of '+ + 'custom variant is read-only',[self,Name]); +end; + + +function TSynInvokeableVariantType.GetProperty(var Dest: TVarData; + const V: TVarData; const Name: String): Boolean; +{$ifdef UNICODE} var Buf: array[byte] of AnsiChar; {$endif} +begin + IntGet(Dest,V,{$ifdef UNICODE}Buf,RawUnicodeToUtf8(Buf,SizeOf(Buf), + pointer(Name),length(Name),[]){$else}pointer(Name),length(Name){$endif}); + result := true; // IntGet=false+Dest=null e.g. if dvoReturnNullForUnknownProperty +end; + +{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 +function TSynInvokeableVariantType.SetProperty(var V: TVarData; + const Name: string; const Value: TVarData): Boolean; +{$else} +function TSynInvokeableVariantType.SetProperty(const V: TVarData; + const Name: string; const Value: TVarData): Boolean; +{$endif} +var ValueSet: TVarData; + PropName: PAnsiChar; + Unicode: pointer; + PropNameLen, UnicodeLen: PtrInt; + vt: cardinal; +{$ifdef UNICODE} + Buf: array[byte] of AnsiChar; // to avoid heap allocation +{$endif} +begin +{$ifdef UNICODE} + PropNameLen := RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]); + PropName := @Buf[0]; +{$else} + PropName := pointer(Name); + PropNameLen := length(Name); +{$endif} + vt := Value.VType; + if vt=varByRef or varOleStr then begin + Unicode := PPointer(Value.VAny)^; + UnicodeLen := length(WideString(Unicode)); + end else + if vt=varOleStr then begin + Unicode := Value.VAny; + UnicodeLen := length(WideString(Unicode)); + end else + {$ifdef HASVARUSTRING} + if vt=varByRef or varUString then begin + Unicode := PPointer(Value.VAny)^; + UnicodeLen := length(UnicodeString(Unicode)); + end else + if vt=varUString then begin + Unicode := Value.VAny; + UnicodeLen := length(UnicodeString(Unicode)); + end else + {$endif} + if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin + result := IntSet(V,ValueSet,PropName,PropNameLen); + exit; + end else begin + result := IntSet(V,Value,PropName,PropNameLen); + exit; + end; + try // unpatched RTL does not like Unicode values :( -> use a temp RawUTF8 + ValueSet.VType := varString; + ValueSet.VString := nil; // to avoid GPF in next line + RawUnicodeToUtf8(Unicode,UnicodeLen,RawUTF8(ValueSet.VString)); + result := IntSet(V,ValueSet,PropName,PropNameLen); + finally + RawUTF8(ValueSet.VString) := ''; // avoid memory leak + end; +end; + +procedure TSynInvokeableVariantType.Clear(var V: TVarData); +begin + ZeroFill(@V); // will set V.VType := varEmpty +end; + +procedure TSynInvokeableVariantType.Copy(var Dest: TVarData; + const Source: TVarData; const Indirect: Boolean); +begin + if Indirect then + SimplisticCopy(Dest,Source,true) else begin + VarClear(variant(Dest)); // Dest may be a complex type + Dest := Source; + end; +end; + +procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData); +begin + Copy(Dest,Source,false); +end; + +function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char; + var Value: variant; EndOfObject: PUTF8Char): boolean; +begin + result := false; +end; + +procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant; + Escape: TTextWriterKind); +begin + raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]); +end; + +function TSynInvokeableVariantType.IsOfType(const V: variant): boolean; +var vt: cardinal; + vd: PVarData; +begin + if self<>nil then begin + vd := @V; + repeat + vt := vd^.VType; + if vt<>varByRef or varVariant then + break; + vd := vd^.VPointer; + until false; + result := vt=VarType; + end else + result := false; +end; + +var // owned by Variants.pas as TInvokeableVariantType/TCustomVariantType + SynVariantTypes: array of TSynInvokeableVariantType; + +function FindSynVariantTypeFromVType(aVarType: cardinal): TSynInvokeableVariantType; + {$ifdef HASINLINE}inline;{$endif} +var i: integer; + t: ^TSynInvokeableVariantType; +begin + t := pointer(SynVariantTypes); + for i := 1 to length(TObjectDynArray(t)) do begin + result := t^; + if result.VarType=aVarType then + exit; + inc(t); + end; + result := nil; +end; + +function TSynInvokeableVariantType.FindSynVariantType(aVarType: Word; + out CustomType: TSynInvokeableVariantType): boolean; +begin + if aVarType=VarType then + CustomType := self else + CustomType := FindSynVariantTypeFromVType(VarType); + result := CustomType<>nil; +end; + +procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const Instance: TVarData; + FullName: PUTF8Char); +var handler: TSynInvokeableVariantType; + v, tmp: TVarData; // PVarData wouldn't store e.g. RowID/count + vt: cardinal; + itemName: ShortString; +begin + PInteger(@Dest)^ := varEmpty; // left to Unassigned if not found + v := Instance; + repeat + vt := v.VType; + if vt<>varByRef or varVariant then + break; + v := PVarData(v.VPointer)^; + until false; + repeat + if vt<=varString then + exit; // we need a complex type to lookup + GetNextItemShortString(FullName,itemName,'.'); + if itemName[0] in [#0,#255] then + exit; + itemName[ord(itemName[0])+1] := #0; // ensure is ASCIIZ + if vt=VarType then + handler := self else begin + handler := FindSynVariantTypeFromVType(vt); + if handler=nil then + exit; + end; + tmp := v; // v will be modified in-place + PInteger(@v)^ := varEmpty; // IntGet() would clear it otherwise! + if not handler.IntGet(v,tmp,@itemName[1],ord(itemName[0])) then + exit; // property not found + repeat + vt := v.VType; + if vt<>varByRef or varVariant then + break; + v := PVarData(v.VPointer)^; + until false; + if (vt=cardinal(DocVariantVType)) and (TDocVariantData(v).VCount=0) then + v.VType := varNull; // recognize void TDocVariant as null + until FullName=nil; + Dest := v; +end; + +procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; + EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); +// internal method used by VariantLoadJSON(), GetVariantFromJSON() and +// TDocVariantData.InitJSON() + procedure ProcessField; + var val: PUTF8Char; + wasString: boolean; + begin + val := GetJSONField(JSON,JSON,@wasString,EndOfObject); + GetVariantFromJSON(val,wasString,Value,nil,AllowDouble); + if JSON=nil then + JSON := @NULCHAR; + end; +var i: integer; + t: ^TSynInvokeableVariantType; + ToBeParsed: PUTF8Char; + wasParsedWithinString: boolean; + wasString: boolean; +begin + VarClear(Value); + if (Options<>nil) and (dvoAllowDoubleValue in Options^) then + AllowDouble := true; // for ProcessField() above + if EndOfObject<>nil then + EndOfObject^ := ' '; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if (Options=nil) or (JSON^ in ['-','0'..'9']) or (PInteger(JSON)^=NULL_LOW) or + (PInteger(JSON)^=TRUE_LOW) or (PInteger(JSON)^=FALSE_LOW) then begin + ProcessField; // obvious simple type + exit; + end; + wasParsedWithinString := false; + if JSON^='"' then + if dvoJSONObjectParseWithinString in Options^ then begin + ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject); + EndOfObject := nil; // already set just above + wasParsedWithinString := true; + end else begin + ProcessField; + exit; + end else + ToBeParsed := JSON; + t := pointer(SynVariantTypes); + if (t<>nil) and not(dvoJSONParseDoNotTryCustomVariants in Options^) then + for i := {$ifdef FPC}0{$else}1{$endif} to PDALen(PtrUInt(t)-_DALEN)^ do + if t^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin + if not wasParsedWithinString then + JSON := ToBeParsed; + exit; + end else + inc(t); + if ToBeParsed^ in ['[','{'] then begin + // default JSON parsing and conversion to TDocVariant instance + ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject); + if ToBeParsed=nil then begin + TDocVariantData(Value).Clear; + exit; // eror parsing + end; + if not wasParsedWithinString then + JSON := ToBeParsed; + end else + // back to simple variant types + if wasParsedWithinString then + GetVariantFromJSON(ToBeParsed,wasString,Value,nil,AllowDouble) else + ProcessField; +end; + +function TextToVariantNumberTypeNoDouble(json: PUTF8Char): cardinal; +var start: PUTF8Char; + c: AnsiChar; +begin + result := varString; + c := json[0]; + if (jcDigitFirstChar in JSON_CHARS[c]) and + (((c>='1') and (c<='9')) or // is first char numeric? + ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON + ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin + start := json; + repeat inc(json) until (json^<'0') or (json^>'9'); // check digits + case json^ of + '.': + if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'0'..'9']) then + if (json[2]=#0) or (json[3]=#0) or + ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or + ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then + result := varCurrency; // currency ###.1234 number + #0: + if json-start<=19 then // signed Int64 precision + result := varInt64; + end; + end; +end; + +function TextToVariantNumberType(json: PUTF8Char): cardinal; +var start: PUTF8Char; + exp: PtrInt; + c: AnsiChar; +label exponent; +begin + result := varString; + c := json[0]; + if (jcDigitFirstChar in JSON_CHARS[c]) and + (((c>='1') and (c<='9')) or // is first char numeric? + ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON + ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin + start := json; + repeat inc(json) until (json^<'0') or (json^>'9'); // check digits + case json^ of + #0: + if json-start<=19 then // signed Int64 precision + result := varInt64 else + result := varDouble; // we may lost precision, but still a number + '.': + if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'e','E','0'..'9']) then + if (json[2]=#0) or (json[3]=#0) or + ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or + ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then + result := varCurrency // currency ###.1234 number + else begin + repeat // more than 4 decimals + inc(json) + until (json^<'0') or (json^>'9'); + case json^ of + #0: + result := varDouble; + 'e','E': begin +exponent: inc(json); // inlined custom GetInteger() + start := json; + c := json^; + if (c='-') or (c='+') then begin + inc(json); + c := json^; + end; + inc(json); + dec(c,48); + if c>#9 then + exit; + exp := ord(c); + c := json^; + dec(c,48); + if c<=#9 then begin + inc(json); + exp := exp*10+ord(c); + c := json^; + dec(c,48); + if c<=#9 then begin + inc(json); + exp := exp*10+ord(c); + end; + end; + if json^<>#0 then + exit; + if start^='-' then + exp := -exp; + if (exp>-324) and (exp<308) then + result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308 + end; + end; + end; + 'e','E': + goto exponent; + end; + end; +end; + +function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; + AllowVarDouble: boolean): boolean; +var err: integer; + typ: cardinal; +label dbl; +begin + if JSON<>nil then begin + if AllowVarDouble then + typ := TextToVariantNumberType(JSON) else + typ := TextToVariantNumberTypeNoDouble(JSON); + with Value do + case typ of + varInt64: begin + VInt64 := GetInt64(JSON,err); + if err<>0 then // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point + if AllowVarDouble then + goto dbl else begin + result:= false; + exit; + end; + if (VInt64<=high(integer)) and (VInt64>=low(integer)) then + VType := varInteger else + VType := varInt64; + result := true; + exit; + end; + varCurrency: begin + VInt64 := StrToCurr64(JSON); + VType := varCurrency; + result := true; + exit; + end; + varDouble: begin +dbl: VDouble := GetExtended(JSON,err); + if err=0 then begin + VType := varDouble; + result := true; + exit; + end; + end; + end; + end; + result := false; +end; + +procedure JSONToVariantInPlace(var Value: variant; JSON: PUTF8Char; + Options: TDocVariantOptions; AllowDouble: boolean); +begin + if (JSON<>nil) and (JSON^<>#0) then + GetJSONToAnyVariant(Value,JSON,nil,@Options,AllowDouble) else + VarClear(Value); +end; + +function JSONToVariant(const JSON: RawUTF8; Options: TDocVariantOptions; + AllowDouble: boolean): variant; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); // temp copy before in-place decoding + try + JSONToVariantInPlace(result,tmp.buf,Options,AllowDouble); + finally + tmp.Done; + end; +end; + +procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; + out aDest: variant); +begin + if not GetNumericVariantFromJSON(pointer(aValue),TVarData(aDest),AllowVarDouble) then + RawUTF8ToVariant(aValue,aDest); +end; + +function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; + Sep: AnsiChar; AllowDouble: boolean): boolean; +var temp: RawUTF8; +begin + if P=nil then + result := false else begin + GetNextItem(P,Sep,temp); + if not GetNumericVariantFromJSON(pointer(temp),TVarData(Value),AllowDouble) then + RawUTF8ToVariant(temp,Value); + result := true; + end; +end; + +function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; + AllowDouble: boolean): boolean; +begin + if JSON<>nil then + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if (JSON=nil) or + ((PInteger(JSON)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]])) then + Value.VType := varNull else + if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and + (jcEndOfJSONValueField in JSON_CHARS[JSON[5]]) then begin + Value.VType := varBoolean; + Value.VBoolean := false; + end else + if (PInteger(JSON)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]]) then begin + Value.VType := varBoolean; + Value.VBoolean := true; + end else + if not GetNumericVariantFromJSON(JSON,Value,AllowDouble) then begin + result := false; + exit; + end; + result := true; +end; + +procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; + TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); +begin + // first handle any strict-JSON syntax objects or arrays into custom variants + // (e.g. when called directly from TSQLPropInfoRTTIVariant.SetValue) + if (TryCustomVariants<>nil) and (JSON<>nil) then + if (GotoNextNotSpace(JSON)^ in ['{','[']) and not wasString then begin + GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants,AllowDouble); + exit; + end else + AllowDouble := dvoAllowDoubleValue in TryCustomVariants^; + // handle simple text or numerical values + VarClear(Value); + if not wasString and GetVariantFromNotStringJSON(JSON,TVarData(Value),AllowDouble) then + exit; + with TVarData(Value) do begin + // found no numerical value -> return a string in the expected format + VType := varString; + VString := nil; // avoid GPF below when assigning a string variable to VAny + FastSetString(RawUTF8(VString),JSON,StrLen(JSON)); + end; +end; + +{$ifndef FPC} // better not try it with FPC - rely on the current implementation + +function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer; +var Size: Cardinal; + ByRef: Boolean; + V: Variant absolute Value; +const TYPE_BYREF = 128; + TYPE_BYREF_MASK = TYPE_BYREF-1; +begin // this code should copy parameters without any reference count handling + ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed + ByRef := (aType and TYPE_BYREF)<>0; + Size := SizeOf(pointer); + case aType and TYPE_BYREF_MASK of + varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin + if ByRef then + P := pointer(P^); + Value.VType := aType and TYPE_BYREF_MASK; + Value.VInteger := PInteger(P)^; + {$ifdef CPU64} + if not ByRef then + Size := SizeOf(Integer); + {$endif} + end; + varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin + if ByRef then + P := pointer(P^); + Value.VType := aType and TYPE_BYREF_MASK; + Value.VInt64 := PInt64(P)^; + {$ifndef CPU64} + if not ByRef then + Size := SizeOf(Int64); + {$endif} + end; + varStrArg: begin + if ByRef then + P := pointer(P^); + Value.VType := varString; + Value.VString := PPointer(P)^; + end; + {$ifdef HASVARUSTRARG} + varUStrArg: begin + if ByRef then + P := pointer(P^); + Value.VType := varUString; + Value.VUString := PPointer(P)^; + end; + {$endif} + varBoolean: + if ByRef then + V := PWordBool(pointer(P^))^ else + V := PWordBool(P)^; + varVariant: + {$ifdef CPU64} // circumvent Delphi x64 compiler oddiness + Value := PVarData(pointer(P^))^ + {$else} + if ByRef then + Value := PVarData(pointer(P^))^ else begin + Value := PVarData(P)^; + Size := SizeOf(Value); + end; + {$endif} + else + raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d', + [aType and TYPE_BYREF_MASK]); + end; + result := PAnsiChar(P)+Size; +end; + +var + LastDispInvokeType: TSynInvokeableVariantType; + +procedure SynVarDispProc(Result: PVarData; const Instance: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; +const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4; +var Value: TVarData; + Handler: TSynInvokeableVariantType; + CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe +begin + if Instance.VType=varByRef or varVariant then // handle By Ref variants + SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin + if Result<>nil then + VarClear(Variant(Result^)); + case Instance.VType of + varDispatch, varDispatch or varByRef, + varUnknown, varUnknown or varByRef, varAny: + // process Ole Automation variants + if Assigned(VarDispProc) then + VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params); + else begin + // first we check for our own TSynInvokeableVariantType types + if SynVariantTypes<>nil then begin + // simple cache for the latest type: most gets are grouped + CacheDispInvokeType := LastDispInvokeType; + if (CacheDispInvokeType<>nil) and + (CacheDispInvokeType.VarType=TVarData(Instance).VType) and + (CallDesc^.CallType in [GET_PROP, DO_PROP]) and + (Result<>nil) and (CallDesc^.ArgCount=0) then begin + CacheDispInvokeType.IntGet(Result^,Instance, + @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); + exit; + end; + end; + // handle any custom variant type + if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin + if Handler.InheritsFrom(TSynInvokeableVariantType) then + case CallDesc^.CallType of + GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method + if (Result<>nil) and (CallDesc^.ArgCount=0) then begin + Handler.IntGet(Result^,Instance, + @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); + LastDispInvokeType := Handler; // speed up in loop + exit; + end; + SET_PROP: // fast direct call of our IntSet() virtual method + if (Result=nil) and (CallDesc^.ArgCount=1) then begin + ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value); + Handler.IntSet(Instance,Value, + @CallDesc^.ArgTypes[1],StrLen(@CallDesc^.ArgTypes[1])); + exit; + end; + end; + // here we call the default code handling custom types + Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif}, + Instance,CallDesc,@Params) + end else + raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]); + end; + end; + end; +end; + +function VariantsDispInvokeAddress: pointer; +asm + {$ifdef CPU64} + mov rax,offset Variants.@DispInvoke + {$else} + mov eax,offset Variants.@DispInvoke + {$endif} +end; + +{$ifdef DOPATCHTRTL} + {$define DOPATCHDISPINVOKE} // much faster late-binding process for our types +{$endif} +{$ifdef CPU64} + {$define DOPATCHDISPINVOKE} + // we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64 +{$endif} +{$ifdef DELPHI6OROLDER} + {$define DOPATCHDISPINVOKE} + // to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke() +{$endif} + +{$endif FPC} + +function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; +var i: PtrInt; +{$ifdef DOPATCHDISPINVOKE} +{$ifdef NOVARCOPYPROC} + VarMgr: TVariantManager; +{$endif} +{$endif} +begin + {$ifdef DOPATCHDISPINVOKE} + if SynVariantTypes=nil then begin + {$ifndef CPU64} // we NEED our patched RTL on Win64 + if DebugHook=0 then // patch VCL/RTL only outside debugging + {$endif} begin + {$ifdef NOVARCOPYPROC} + GetVariantManager(VarMgr); + VarMgr.DispInvoke := @SynVarDispProc; + SetVariantManager(VarMgr); + {$else} + RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc); + {$endif NOVARCOPYPROC} + end; + end else + {$endif DOPATCHDISPINVOKE} + for i := 0 to length(SynVariantTypes)-1 do + if PPointer(SynVariantTypes[i])^=pointer(aClass) then begin + result := SynVariantTypes[i]; // returns already registered instance + exit; + end; + result := aClass.Create; // register variant type + ObjArrayAdd(SynVariantTypes,result); +end; + + +function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; +var tmp: TDocVariantData; +begin + tmp.InitArrayFromVariants(V); + result := tmp.ToJSON; +end; + +function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; +var tmp: TDocVariantData; +begin + tmp.InitJSON(JSON,JSON_OPTIONS_FAST); + result := tmp.VValue; +end; + +function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; +var tmp: TDocVariantData; +begin + tmp.InitArray(items,JSON_OPTIONS_FAST); + result := tmp.VValue; +end; + + +{ TDocVariantData } + +function TDocVariantData.GetKind: TDocVariantKind; +var opt: TDocVariantOptions; +begin + opt := VOptions; + if dvoIsArray in opt then + result := dvArray else + if dvoIsObject in opt then + result := dvObject else + result := dvUndefined; +end; + +function DocVariantData(const DocVariant: variant): PDocVariantData; +var docv,vt: integer; +begin + result := @DocVariant; + docv := DocVariantVType; + vt := result^.VType; + if vt=docv then + exit else + if vt=varByRef or varVariant then begin + result := PVarData(result)^.VPointer; + if integer(result^.VType)=docv then + exit; + end; + raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[ord(result^.VType)]); +end; + +function _Safe(const DocVariant: variant): PDocVariantData; +{$ifdef FPC_OR_PUREPASCAL} +var docv,vt: integer; +begin + result := @DocVariant; + docv := DocVariantVType; + vt := result^.VType; + if vt=docv then + exit else + if vt=varByRef or varVariant then begin + result := PVarData(result)^.VPointer; + if integer(result^.VType)=docv then + exit; + end; + result := @DocVariantDataFake; +end; +{$else} +asm + mov ecx,DocVariantVType + movzx edx,word ptr [eax].TVarData.VType + cmp edx,ecx + jne @by + ret +@ptr: mov eax,[eax].TVarData.VPointer + movzx edx,word ptr [eax].TVarData.VType + cmp edx,ecx + je @ok +@by: cmp edx,varByRef or varVariant + je @ptr + lea eax,[DocVariantDataFake] +@ok: +end; +{$endif} + +function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; +var o: TDocVariantOptions; +begin + result := _Safe(DocVariant); + o := result^.VOptions; + if dvoIsArray in o then begin + if ExpectedKind=dvArray then + exit; + end else if (dvoIsObject in o) and (ExpectedKind=dvObject) then + exit; + raise EDocVariant.CreateUTF8('_Safe(%)?',[ToText(ExpectedKind)^]); +end; + +function _CSV(const DocVariantOrString: variant): RawUTF8; +begin + with _Safe(DocVariantOrString)^ do + if dvoIsArray in VOptions then + result := ToCSV else + if (dvoIsObject in VOptions) or (TDocVariantData(DocVariantOrString).VType<=varNull) or + not VariantToUTF8(DocVariantOrString,result) then + result := ''; // VariantToUTF8() returns 'null' for empty/null +end; + +function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer; +begin + result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions); +end; + +function TDocVariantData.GetCapacity: integer; +begin + result := length(VValue); +end; + +function TDocVariant.InternNames: TRawUTF8Interning; +begin + if fInternNames=nil then + fInternNames := TRawUTF8Interning.Create; + result := fInternNames; +end; + +function TDocVariant.InternValues: TRawUTF8Interning; +begin + if fInternValues=nil then + fInternValues := TRawUTF8Interning.Create; + result := fInternValues; +end; + +procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions); +begin + VOptions := (opt-[dvoIsArray,dvoIsObject])+(VOptions*[dvoIsArray,dvoIsObject]); +end; + +procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind); +begin + aOptions := aOptions-[dvoIsArray,dvoIsObject]; + case aKind of + dvArray: include(aOptions,dvoIsArray); + dvObject: include(aOptions,dvoIsObject); + end; + ZeroFill(@self); + VType := DocVariantVType; + VOptions := aOptions; +end; + +procedure TDocVariantData.InitFast; +begin + ZeroFill(@self); + VType := DocVariantVType; + VOptions := JSON_OPTIONS_FAST; +end; + +procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind); +begin + InitFast; + case aKind of + dvArray: include(VOptions,dvoIsArray); + dvObject: include(VOptions,dvoIsObject); + end; + if aKind=dvObject then + SetLength(VName,InitialCapacity); + SetLength(VValue,InitialCapacity); +end; + +procedure TDocVariantData.InitObject(const NameValuePairs: array of const; + aOptions: TDocVariantOptions=[]); +begin + Init(aOptions,dvObject); + AddNameValuesToObject(NameValuePairs); +end; + +procedure TDocVariantData.AddNameValuesToObject(const NameValuePairs: array of const); +var n,arg: PtrInt; + tmp: variant; +begin + n := length(NameValuePairs); + if (n=0) or (n and 1=1) or (dvoIsArray in VOptions) then + exit; // nothing to add + include(VOptions,dvoIsObject); + n := n shr 1; + if length(VValue)=0 then begin + VCount := length(Items); + SetLength(VValue,VCount); + if dvoValueCopiedByReference in VOptions then + for arg := 0 to high(Items) do + VarRecToVariant(Items[arg],VValue[arg]) else + for arg := 0 to high(Items) do begin + VarRecToVariant(Items[arg],tmp); + SetVariantByValue(tmp,VValue[arg]); + end; + end; +end; + +procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray; + aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean); +begin + if Items=nil then + VType := varNull else begin + Init(aOptions,dvArray); + VCount := length(Items); + VValue := Items; // fast by-reference copy of VValue[] + if not ItemsCopiedByReference then + InitCopy(variant(self),aOptions); + end; +end; + +procedure TDocVariantData.InitArrayFromObjArray(const ObjArray; + aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions); +var ndx: integer; + Items: TObjectDynArray absolute ObjArray; +begin + if Items=nil then + VType := varNull else begin + Init(aOptions,dvArray); + VCount := length(Items); + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do + ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions); + end; +end; + +procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray; + aOptions: TDocVariantOptions); +var ndx: integer; +begin + if Items=nil then + VType := varNull else begin + Init(aOptions,dvArray); + VCount := length(Items); + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do + RawUTF8ToVariant(Items[ndx],VValue[ndx]); + end; +end; + +procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray; + aOptions: TDocVariantOptions); +var ndx: integer; +begin + if Items=nil then + VType := varNull else begin + Init(aOptions,dvArray); + VCount := length(Items); + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do + VValue[ndx] := Items[ndx]; + end; +end; + +procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray; + aOptions: TDocVariantOptions); +var ndx: integer; +begin + if Items=nil then + VType := varNull else begin + Init(aOptions,dvArray); + VCount := length(Items); + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do + VValue[ndx] := Items[ndx]; + end; +end; + +procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer; + aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); +var tmp: RawUTF8; +begin + tmp := SaveJSON(aValue,aTypeInfo,aEnumSetsAsText); + InitJSONInPlace(pointer(tmp),aOptions); +end; + +procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUTF8DynArray; + const aValues: TVariantDynArray; aOptions: TDocVariantOptions); +begin + if (aNames=nil) or (aValues=nil) or (length(aNames)<>length(aValues)) then + VType := varNull else begin + Init(aOptions,dvObject); + VCount := length(aNames); + VName := aNames; // fast by-reference copy of VName[] and VValue[] + VValue := aValues; + end; +end; + +procedure TDocVariantData.InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; + aOptions: TDocVariantOptions); +var right: RawUTF8; +begin + if aPath='' then + VType := varNull else begin + Init(aOptions,dvObject); + VCount := 1; + SetLength(VName,1); + SetLength(VValue,1); + split(aPath,'.',VName[0],right); + if right='' then + VValue[0] := aValue else + PDocVariantData(@VValue[0])^.InitObjectFromPath(right,aValue,aOptions); + end; +end; + +function TDocVariantData.InitJSONInPlace(JSON: PUTF8Char; + aOptions: TDocVariantOptions; aEndOfObject: PUTF8Char): PUTF8Char; +var EndOfObject: AnsiChar; + Name: PUTF8Char; + NameLen, n: integer; + intnames, intvalues: TRawUTF8Interning; +begin + Init(aOptions); + result := nil; + if JSON=nil then + exit; + if dvoInternValues in VOptions then + intvalues := DocVariantType.InternValues else + intvalues := nil; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + case JSON^ of + '[': begin + repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; + n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common) + if n<0 then + exit; // invalid content + include(VOptions,dvoIsArray); + if n>0 then begin + SetLength(VValue,n); + repeat + if VCount>=n then + exit; // unexpected array size means invalid JSON + GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); + if JSON=nil then + if EndOfObject=']' then // valid array end + JSON := @NULCHAR else + exit; // invalid input + if intvalues<>nil then + intvalues.UniqueVariant(VValue[VCount]); + inc(VCount); + until EndOfObject=']'; + end else + if JSON^=']' then // n=0 + repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else + exit; + end; + '{': begin + repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; + n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common) + if n<0 then + exit; // invalid content + include(VOptions,dvoIsObject); + if dvoInternNames in VOptions then + intnames := DocVariantType.InternNames else + intnames := nil; + if n>0 then begin + SetLength(VValue,n); + SetLength(VName,n); + repeat + if VCount>=n then + exit; // unexpected object size means invalid JSON + // see http://docs.mongodb.org/manual/reference/mongodb-extended-json + Name := GetJSONPropName(JSON,@NameLen); + if Name=nil then + exit; + FastSetString(VName[VCount],Name,NameLen); + if intnames<>nil then + intnames.UniqueText(VName[VCount]); + GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); + if JSON=nil then + if EndOfObject='}' then // valid object end + JSON := @NULCHAR else + exit; // invalid input + if intvalues<>nil then + intvalues.UniqueVariant(VValue[VCount]); + inc(VCount); + until EndOfObject='}'; + end else + if JSON^='}' then // n=0 + repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else + exit; + end; + 'n','N': begin + if IdemPChar(JSON+1,'ULL') then begin + include(VOptions,dvoIsObject); + result := GotoNextNotSpace(JSON+4); + end; + exit; + end; + else exit; + end; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if aEndOfObject<>nil then + aEndOfObject^ := JSON^; + if JSON^<>#0 then + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + result := JSON; // indicates successfully parsed +end; + +function TDocVariantData.InitJSON(const JSON: RawUTF8; + aOptions: TDocVariantOptions): boolean; +var tmp: TSynTempBuffer; +begin + if JSON='' then + result := false else begin + tmp.Init(JSON); + try + result := InitJSONInPlace(tmp.buf,aOptions)<>nil; + finally + tmp.Done; + end; + end; +end; + +function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName; + aOptions: TDocVariantOptions; RemoveComments: boolean): boolean; +var content: RawUTF8; +begin + content := AnyTextFileToRawUTF8(JsonFile,true); + if RemoveComments then + RemoveCommentsFromJSON(pointer(content)); + result := InitJSONInPlace(pointer(content),aOptions)<>nil; +end; + +procedure TDocVariantData.InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; + NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); +var n,v: RawUTF8; + val: variant; +begin + Init(aOptions,dvObject); + while CSV<>nil do begin + GetNextItem(CSV,NameValueSep,n); + if ItemSep=#10 then + GetNextItemTrimedCRLF(CSV,v) else + GetNextItem(CSV,ItemSep,v); + if DoTrim then + v := trim(v); + if n='' then + break; + RawUTF8ToVariant(v,val); + AddValue(n,val); + end; +end; + +procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; + NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); +begin + InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim); +end; + +procedure TDocVariantData.InitCopy(const SourceDocVariant: variant; + aOptions: TDocVariantOptions); +var ndx,vt: integer; + Source: PDocVariantData; + SourceVValue: TVariantDynArray; + Handler: TCustomVariantType; + v: PVarData; +begin + with TVarData(SourceDocVariant) do + if integer(VType)=varByRef or varVariant then + Source := VPointer else + Source := @SourceDocVariant; + if integer(Source^.VType)<>DocVariantVType then + raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[ord(Source.VType)]); + SourceVValue := Source^.VValue; // local fast per-reference copy + if Source<>@self then begin + VType := Source^.VType; + VCount := Source^.VCount; + pointer(VName) := nil; // avoid GPF + pointer(VValue) := nil; + aOptions := aOptions-[dvoIsArray,dvoIsObject]; // may not be same as Source + if dvoIsArray in Source^.VOptions then + include(aOptions,dvoIsArray) else + if dvoIsObject in Source^.VOptions then begin + include(aOptions,dvoIsObject); + SetLength(VName,VCount); + for ndx := 0 to VCount-1 do + VName[ndx] := Source^.VName[ndx]; // manual copy is needed + if dvoInternNames in aOptions then + with DocVariantType.InternNames do + for ndx := 0 to VCount-1 do + UniqueText(VName[ndx]); + end; + VOptions := aOptions; + end else begin + SetOptions(aOptions); + VariantDynArrayClear(VValue); // full copy of all values + end; + if VCount>0 then begin + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do begin + v := @SourceVValue[ndx]; + repeat + vt := v^.VType; + if vt<>varByRef or varVariant then + break; + v := v^.VPointer; + until false; + if vt<=varNativeString then // simple string/number types copy + VValue[ndx] := variant(v^) else + if vt=DocVariantVType then // direct recursive copy for TDocVariant + TDocVariantData(VValue[ndx]).InitCopy(variant(v^),VOptions) else + if FindCustomVariantType(vt,Handler) then + if Handler.InheritsFrom(TSynInvokeableVariantType) then + TSynInvokeableVariantType(Handler).CopyByValue(TVarData(VValue[ndx]),v^) else + Handler.Copy(TVarData(VValue[ndx]),v^,false) else + VValue[ndx] := variant(v^); // default copy + end; + if dvoInternValues in VOptions then + with DocVariantType.InternValues do + for ndx := 0 to VCount-1 do + UniqueVariant(VValue[ndx]); + end; + VariantDynArrayClear(SourceVValue); +end; + +procedure TDocVariantData.Clear; +begin + if integer(VType)=DocVariantVType then begin + PInteger(@VType)^ := 0; + RawUTF8DynArrayClear(VName); + VariantDynArrayClear(VValue); + VCount := 0; + end else + VarClear(variant(self)); +end; + +procedure TDocVariantData.Reset; +var backup: TDocVariantOptions; +begin + if VCount=0 then + exit; + backup := VOptions-[dvoIsArray,dvoIsObject]; + DocVariantType.Clear(TVarData(self)); + VType := DocVariantVType; + VOptions := backup; +end; + +procedure TDocVariantData.FillZero; +var ndx: integer; +begin + for ndx := 0 to VCount-1 do + SynCommons.FillZero(VValue[ndx]); + Reset; +end; + +procedure TDocVariantData.SetCount(aCount: integer); +begin + VCount := aCount; +end; + +function TDocVariantData.InternalAdd(const aName: RawUTF8): integer; +var len: integer; +begin + if aName<>'' then begin + if dvoIsArray in VOptions then + raise EDocVariant.CreateUTF8('Add: Unexpected [%] object property in an array',[aName]); + if not(dvoIsObject in VOptions) then begin + VType := DocVariantVType; // may not be set yet + include(VOptions,dvoIsObject); + end; + end else begin + if dvoIsObject in VOptions then + raise EDocVariant.Create('Add: Unexpected array item in an object'); + if not(dvoIsArray in VOptions) then begin + VType := DocVariantVType; // may not be set yet + include(VOptions,dvoIsArray); + end; + end; + len := length(VValue); + if VCount>=len then begin + len := NextGrow(VCount); + SetLength(VValue,len); + end; + if aName<>'' then begin + if Length(VName)<>len then + SetLength(VName,len); + if dvoInternNames in VOptions then begin // inlined InternNames method + if DocVariantType.fInternNames=nil then + DocVariantType.fInternNames := TRawUTF8Interning.Create; + DocVariantType.fInternNames.Unique(VName[VCount],aName); + end else + VName[VCount] := aName; + end; + result := VCount; + inc(VCount); +end; + +procedure TDocVariantData.SetCapacity(aValue: integer); +begin + if dvoIsObject in VOptions then + SetLength(VName,aValue); + SetLength(VValue,aValue); +end; + +function TDocVariantData.AddValue(const aName: RawUTF8; + const aValue: variant; aValueOwned: boolean): integer; +begin + if dvoCheckForDuplicatedNames in VOptions then begin + result := GetValueIndex(aName); + if result>=0 then + raise EDocVariant.CreateUTF8('AddValue: Duplicated [%] name',[aName]); + end; + result := InternalAdd(aName); + if aValueOwned then + VValue[result] := aValue else + SetVariantByValue(aValue,VValue[result]); + if dvoInternValues in VOptions then + DocVariantType.InternValues.UniqueVariant(VValue[result]); +end; + +function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer; + const aValue: variant; aValueOwned: boolean): integer; +var tmp: RawUTF8; +begin + FastSetString(tmp,aName,aNameLen); + result := AddValue(tmp,aValue,aValueOwned); +end; + +function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8; + Update, AllowVarDouble: boolean): integer; +begin + if aName='' then begin + result := -1; + exit; + end; + result := GetValueIndex(aName); + if not Update and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then + raise EDocVariant.CreateUTF8('AddValueFromText: Duplicated [%] name',[aName]); + if result<0 then + result := InternalAdd(aName); + VarClear(VValue[result]); + if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then + if dvoInternValues in VOptions then + DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else + RawUTF8ToVariant(aValue,VValue[result]); +end; + +procedure TDocVariantData.AddByPath(const aSource: TDocVariantData; + const aPaths: array of RawUTF8); +var p,added: integer; + v: TVarData; +begin + if (aSource.Count=0) or not(dvoIsObject in aSource.VOptions) or + (dvoIsArray in VOptions) then + exit; + for p := 0 to High(aPaths) do begin + DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p])); + if integer(v.VType)=0) and VariantEquals(VValue[result],aPropValue,aPropValueCaseSensitive) then + exit; + end else + if dvoIsArray in VOptions then + for result := 0 to VCount-1 do + with _Safe(VValue[result])^ do + if dvoIsObject in VOptions then begin + ndx := GetValueIndex(aPropName); + if (ndx>=0) and VariantEquals(VValue[ndx],aPropValue,aPropValueCaseSensitive) then + exit; + end; + result := -1; +end; + +function TDocVariantData.SearchItemByProp(const aPropNameFmt: RawUTF8; + const aPropNameArgs: array of const; const aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean): integer; +var name: RawUTF8; +begin + FormatUTF8(aPropNameFmt,aPropNameArgs,name); + result := SearchItemByProp(name,aPropValue,aPropValueCaseSensitive); +end; + +function TDocVariantData.SearchItemByValue(const aValue: Variant; + CaseInsensitive: boolean; StartIndex: integer): integer; +begin + for result := StartIndex to VCount-1 do + if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then + exit; + result := -1; +end; + +type + TQuickSortDocVariant = object + names: PPointerArray; + values: PVariantArray; + nameCompare: TUTF8Compare; + valueCompare: TVariantCompare; + procedure SortByName(L, R: PtrInt); + procedure SortByValue(L, R: PtrInt); + end; + +procedure TQuickSortDocVariant.SortByName(L, R: PtrInt); +var I, J, P: PtrInt; + pivot: pointer; +begin + if L0 do Dec(J); + if I <= J then begin + if I <> J then begin + ExchgPointer(@names[I],@names[J]); + ExchgVariant(@values[I],@values[J]); + end; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + SortByName(L,J); + L := I; + end else begin + if I < R then + SortByName(I,R); + R := J; + end; + until L >= R; +end; + +procedure TQuickSortDocVariant.SortByValue(L, R: PtrInt); +var I, J, P: PtrInt; + pivot: PVariant; +begin + if L0 do Dec(J); + if I <= J then begin + if I <> J then begin + if names<>nil then + ExchgPointer(@names[I],@names[J]); + ExchgVariant(@values[I],@values[J]); + end; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + SortByValue(L,J); + L := I; + end else begin + if I < R then + SortByValue(I,R); + R := J; + end; + until L >= R; +end; + +procedure TDocVariantData.SortByName(Compare: TUTF8Compare); +var qs: TQuickSortDocVariant; +begin + if not(dvoIsObject in VOptions) or (VCount<=0) then + exit; + if Assigned(Compare) then + qs.nameCompare := Compare else + qs.nameCompare := @StrIComp; + qs.names := pointer(VName); + qs.values := pointer(VValue); + qs.SortByName(0,VCount-1); +end; + +procedure TDocVariantData.SortByValue(Compare: TVariantCompare); +var qs: TQuickSortDocVariant; +begin + if VCount<=0 then + exit; + if Assigned(Compare) then + qs.valueCompare := Compare else + qs.valueCompare := @VariantCompare; + qs.names := pointer(VName); + qs.values := pointer(VValue); + qs.SortByValue(0,VCount-1); +end; + +type + {$ifdef USERECORDWITHMETHODS}TQuickSortDocVariantValuesByField = record + {$else}TQuickSortDocVariantValuesByField = object{$endif} + Lookup: array of PVariant; + Compare: TVariantCompare; + Doc: PDocVariantData; + Reverse: boolean; + procedure Sort(L, R: PtrInt); + end; + +procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt); +var I, J, P: PtrInt; + pivot: PVariant; +begin + if L0 do Dec(J); + end + else begin + while Compare(Lookup[I]^,pivot^)>0 do Inc(I); + while Compare(Lookup[J]^,pivot^)<0 do Dec(J); + end; + if I <= J then begin + if I <> J then begin + if Doc.VName<>nil then + ExchgPointer(@Doc.VName[I],@Doc.VName[J]); + ExchgVariant(@Doc.VValue[I],@Doc.VValue[J]); + pivot := Lookup[I]; + Lookup[I] := Lookup[J]; + Lookup[J] := pivot; + end; + if P = I then P := J else if P = J then P := I; + inc(I); dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + Sort(L,J); + L := I; + end else begin + if I < R then + Sort(I,R); + R := J; + end; + until L >= R; +end; + +procedure TDocVariantData.SortArrayByField(const aItemPropName: RawUTF8; + aValueCompare: TVariantCompare; aValueCompareReverse: boolean; aNameSortedCompare: TUTF8Compare); +var + QS: TQuickSortDocVariantValuesByField; + p: pointer; + row: PtrInt; +begin + if (VCount<=0) or (aItemPropName='') or not (dvoIsArray in VOptions) then + exit; + if not Assigned(aValueCompare) then + QS.Compare := VariantCompare else + QS.Compare := aValueCompare; + QS.Reverse := aValueCompareReverse; + SetLength(QS.Lookup,VCount); + for row := 0 to VCount-1 do begin // resolve GetPVariantByName(aIdemPropName) once + p := _Safe(VValue[row])^.GetVarData(aItemPropName,aNameSortedCompare); + if p = nil then + p := @NullVarData; + QS.Lookup[row] := p; + end; + QS.Doc := @self; + QS.Sort(0,VCount-1); +end; + +procedure TDocVariantData.Reverse; +var arr: TDynArray; +begin + if VCount=0 then + exit; + if VName<>nil then begin + SetLength(VName,VCount); + arr.Init(TypeInfo(TRawUTF8DynArray),VName); + arr.Reverse; + end; + if VValue<>nil then begin + SetLength(VValue,VCount); + arr.Init(TypeInfo(TVariantDynArray),VValue); + arr.Reverse; + end; +end; + +function TDocVariantData.Reduce(const aPropNames: array of RawUTF8; + aCaseSensitive,aDoNotAddVoidProp: boolean): variant; +begin + VarClear(result); + Reduce(aPropNames,aCaseSensitive,PDocVariantData(@result)^,aDoNotAddVoidProp); +end; + +procedure TDocVariantData.Reduce(const aPropNames: array of RawUTF8; + aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean); +var ndx,j: integer; + reduced: TDocVariantData; +begin + result.InitFast; + if (VCount=0) or (high(aPropNames)<0) then + exit; + if dvoIsObject in VOptions then begin + if aCaseSensitive then begin + for j := 0 to high(aPropNames) do + for ndx := 0 to VCount-1 do + if VName[ndx]=aPropNames[j] then begin + if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then + result.AddValue(VName[ndx],VValue[ndx]); + break; + end; + end else + for j := 0 to high(aPropNames) do + for ndx := 0 to VCount-1 do + if IdemPropNameU(VName[ndx],aPropNames[j]) then begin + if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then + result.AddValue(VName[ndx],VValue[ndx]); + break; + end; + end else + if dvoIsArray in VOptions then + for ndx := 0 to VCount-1 do begin + _Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp); + if dvoIsObject in reduced.VOptions then + result.AddItem(variant(reduced)); + end; +end; + +function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; + OnReduce: TOnReducePerItem): variant; +begin + VarClear(result); + ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); +end; + +procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; + out result: TDocVariantData; OnReduce: TOnReducePerItem); +var ndx,j: integer; + item: PDocVariantData; +begin + result.InitFast; + if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then + exit; + for ndx := 0 to VCount-1 do begin + item := _Safe(VValue[ndx]); + j := item^.GetValueIndex(aPropName); + if j>=0 then + if not Assigned(OnReduce) or OnReduce(item) then + result.AddItem(item^.VValue[j]); + end; +end; + +function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; + OnReduce: TOnReducePerValue): variant; +begin + VarClear(result); + ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); +end; + +procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; + out result: TDocVariantData; OnReduce: TOnReducePerValue); +var ndx,j: integer; + item: PDocVariantData; + v: PVariant; +begin + result.InitFast; + if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then + exit; + for ndx := 0 to VCount-1 do begin + item := _Safe(VValue[ndx]); + j := item^.GetValueIndex(aPropName); + if j>=0 then begin + v := @item^.VValue[j]; + if not Assigned(OnReduce) or OnReduce(v^) then + result.AddItem(v^); + end; + end; +end; + +function TDocVariantData.Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; +var n, p, ndx: integer; +begin + result := 0; + n := length(aFromPropName); + if length(aToPropName)=n then + for p := 0 to n-1 do begin + ndx := GetValueIndex(aFromPropName[p]); + if ndx>=0 then begin + VName[ndx] := aToPropName[p]; + inc(result); + end; + end; +end; + +function TDocVariantData.FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; +var ndx,len: integer; + Up: array[byte] of AnsiChar; + nested: TDocVariantData; +begin // {"p.a1":5,"p.a2":"dfasdfa"} -> {"p":{"a1":5,"a2":"dfasdfa"}} + result := false; + if (VCount=0) or (aObjectPropName='') or not(dvoIsObject in VOptions) then + exit; + PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.' + for ndx := 0 to Count-1 do + if not IdemPChar(pointer(VName[ndx]),Up) then + exit; // all fields should match "p.####" + len := length(aObjectPropName)+1; + for ndx := 0 to Count-1 do + system.delete(VName[ndx],1,len); + nested := self; + Clear; + InitObject([aObjectPropName,variant(nested)]); + result := true; +end; + +function TDocVariantData.Delete(Index: integer): boolean; +begin + if cardinal(Index)>=cardinal(VCount) then + result := false else begin + dec(VCount); + if VName<>nil then begin + if PDACnt(PtrUInt(VName)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@VName,TypeInfo(TRawUTF8DynArray)); + VName[Index] := ''; + end; + if PDACnt(PtrUInt(VValue)-_DAREFCNT)^>1 then + DynArrayMakeUnique(@VValue,TypeInfo(TVariantDynArray)); + VarClear(VValue[Index]); + if Indexnil then begin + MoveFast(VName[Index+1],VName[Index],(VCount-Index)*SizeOf(pointer)); + PtrUInt(VName[VCount]) := 0; // avoid GPF + end; + MoveFast(VValue[Index+1],VValue[Index],(VCount-Index)*SizeOf(variant)); + TVarData(VValue[VCount]).VType := varEmpty; // avoid GPF + end; + result := true; + end; +end; + +function TDocVariantData.Delete(const aName: RawUTF8): boolean; +begin + result := Delete(GetValueIndex(aName)); +end; + +function TDocVariantData.DeleteByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean): boolean; +var ndx: integer; +begin + ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); + if ndx<0 then + result := false else + result := Delete(ndx); +end; + +function TDocVariantData.DeleteByValue(const aValue: Variant; + CaseInsensitive: boolean): integer; +var ndx: PtrInt; +begin + result := 0; + if VarIsEmptyOrNull(aValue) then begin + for ndx := VCount-1 downto 0 do + if VarDataIsEmptyOrNull(@VValue[ndx]) then begin + Delete(ndx); + inc(result); + end; + end else + for ndx := VCount-1 downto 0 do + if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin + Delete(ndx); + inc(result); + end; +end; + +function TDocVariantData.DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; +var ndx: integer; + upname: array[byte] of AnsiChar; +begin + result := 0; + if aStartNameLen=0 then + aStartNameLen := StrLen(aStartName); + if (VCount=0) or not(dvoIsObject in VOptions) or (aStartNameLen=0) then + exit; + UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0; + for ndx := Count-1 downto 0 do + if IdemPChar(pointer(names[ndx]),upname) then begin + Delete(ndx); + inc(result); + end; +end; + +function FindNonVoidRawUTF8(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; +begin // FPC does proper inlining in this loop + for result := 0 to count-1 do // all VName[]<>'' so n^<>0 + if (PStrLen(n^-_STRLEN)^=len) and CompareMemFixed(pointer(n^),name,len) then + exit else + inc(n); + result := -1; +end; + +function FindNonVoidRawUTF8I(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; +begin + for result := 0 to count-1 do + if (PStrLen(n^-_STRLEN)^=len) and IdemPropNameUSameLen(pointer(n^),name,len) then + exit else + inc(n); + result := -1; +end; + +function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; + aCaseSensitive: boolean): integer; +var err: integer; +begin + if (integer(VType)=DocVariantVType) and (VCount>0) and (aName<>nil) and(aNameLen>0) then + if dvoIsArray in VOptions then begin // try index text in array document + result := GetInteger(aName,err); + if (err<>0) or (cardinal(result)>=cardinal(VCount)) then + result := -1; + end else + // O(n) lookup for object names -> efficient brute force sub-functions + if aCaseSensitive then + result := FindNonVoidRawUTF8(pointer(VName),aName,aNameLen,VCount) else + result := FindNonVoidRawUTF8I(pointer(VName),aName,aNameLen,VCount) else + result := -1; +end; + +function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant; +begin + RetrieveValueOrRaiseException(pointer(aName),length(aName), + dvoNameCaseSensitive in VOptions,result,false); +end; + +function TDocVariantData.GetValueOrDefault(const aName: RawUTF8; + const aDefault: variant): variant; +var ndx: integer; +begin + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then + result := aDefault else begin + ndx := GetValueIndex(aName); + if ndx>=0 then + result := VValue[ndx] else + result := aDefault; + end; +end; + +function TDocVariantData.GetValueOrNull(const aName: RawUTF8): variant; +var ndx: integer; +begin + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then + SetVariantNull(result) else begin + ndx := GetValueIndex(aName); + if ndx>=0 then + result := VValue[ndx] else + SetVariantNull(result); + end; +end; + +function TDocVariantData.GetValueOrEmpty(const aName: RawUTF8): variant; +var ndx: integer; +begin + VarClear(result); + if (integer(VType)=DocVariantVType) and (dvoIsObject in VOptions) then begin + ndx := GetValueIndex(aName); + if ndx>=0 then + result := VValue[ndx]; + end; +end; + +function TDocVariantData.GetAsBoolean(const aName: RawUTF8; out aValue: boolean; + aSortedCompare: TUTF8Compare): Boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else + result := VariantToBoolean(PVariant(found)^,aValue) +end; + +function TDocVariantData.GetAsInteger(const aName: RawUTF8; out aValue: integer; + aSortedCompare: TUTF8Compare): Boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else + result := VariantToInteger(PVariant(found)^,aValue); +end; + +function TDocVariantData.GetAsInt64(const aName: RawUTF8; out aValue: Int64; + aSortedCompare: TUTF8Compare): Boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else + result := VariantToInt64(PVariant(found)^,aValue) +end; + +function TDocVariantData.GetAsDouble(const aName: RawUTF8; out aValue: double; + aSortedCompare: TUTF8Compare): Boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else + result := VariantToDouble(PVariant(found)^,aValue); +end; + +function TDocVariantData.GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; + aSortedCompare: TUTF8Compare): Boolean; +var found: PVarData; + wasString: boolean; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else begin + if integer(found^.VType)>varNull then // default VariantToUTF8(null)='null' + VariantToUTF8(PVariant(found)^,aValue,wasString); + result := true; + end; +end; + +function TDocVariantData.GetValueEnumerate(const aName: RawUTF8; + aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean): boolean; +var text: RawUTF8; + ndx, ord: integer; +begin + result := false; + ndx := GetValueIndex(aName); + if ndx<0 then + exit; + VariantToUTF8(Values[ndx],text); + ord := GetEnumNameValue(aTypeInfo,text,true); + if ord<0 then + exit; + byte(aValue) := ord; + if aDeleteFoundEntry then + Delete(ndx); + result := true; +end; + +function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; + aSortedCompare: TUTF8Compare): boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else begin + aValue := _Safe(PVariant(found)^); + result := aValue<>@DocVariantDataFake; + end; +end; + +function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8; + aSortedCompare: TUTF8Compare): PDocVariantData; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := @DocVariantDataFake else + result := _Safe(PVariant(found)^); +end; + +function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; + aSortedCompare: TUTF8Compare): boolean; +begin + aValue := pointer(GetVarData(aName,aSortedCompare)); + result := aValue<>nil; +end; + +function TDocVariantData.GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; +var ndx: integer; +begin + ndx := GetValueIndex(aName,aNameLen,dvoNameCaseSensitive in VOptions); + if ndx>=0 then + result := @VValue[ndx] else + result := nil; +end; + +function TDocVariantData.GetVarData(const aName: RawUTF8; + aSortedCompare: TUTF8Compare): PVarData; +var ndx: integer; +begin + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or + (VCount=0) or (aName='') then + result := nil else begin + if Assigned(aSortedCompare) then + if @aSortedCompare=@StrComp then // to use branchless asm for StrComp() + ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName)) else + ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else + if dvoNameCaseSensitive in VOptions then + ndx := FindNonVoidRawUTF8(pointer(VName),pointer(aName),length(aName),VCount) else + ndx := FindNonVoidRawUTF8I(pointer(VName),pointer(aName),length(aName),VCount); + if ndx>=0 then + result := @VValue[ndx] else + result := nil; + end; +end; + +function TDocVariantData.GetVarData(const aName: RawUTF8; + var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean; +var found: PVarData; +begin + found := GetVarData(aName,aSortedCompare); + if found=nil then + result := false else begin + aValue := found^; + result := true; + end; +end; + +function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant; +var Dest: TVarData; +begin + VarClear(result); + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then + exit; + DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); + if integer(Dest.VType)>=varNull then + result := variant(Dest); // copy +end; + +function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; +var Dest: TVarData; +begin + result := false; + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then + exit; + DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); + if Dest.VType=varEmpty then + exit; + aValue := variant(Dest); // copy + result := true; +end; + +function TDocVariantData.GetPVariantByPath(const aPath: RawUTF8): PVariant; +var p: PUTF8Char; + item: RawUTF8; + par: PVariant; +begin + result := nil; + if (integer(VType)<>DocVariantVType) or (aPath='') or + not(dvoIsObject in VOptions) or (Count=0) then + exit; + par := @self; + P := pointer(aPath); + repeat + GetNextItem(P,'.',item); + if _Safe(par^).GetAsPVariant(item,result) then + par := result else begin + result := nil; + exit; + end; + until P=nil; + // if we reached here, we have par=result=found item +end; + +function TDocVariantData.GetDocVariantByPath(const aPath: RawUTF8; + out aValue: PDocVariantData): boolean; +var v: PVariant; +begin + v := GetPVariantByPath(aPath); + if v<>nil then begin + aValue := _Safe(v^); + result := integer(aValue^.VType)>varNull; + end else + result := false; +end; + +function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; +var found,res: PVarData; + vt,P: integer; +begin + VarClear(result); + if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or + (high(aDocVariantPath)<0) then + exit; + found := @self; + P := 0; + repeat + found := PDocVariantData(found).GetVarData(aDocVariantPath[P]); + if found=nil then + exit; + if P=high(aDocVariantPath) then + break; // we found the item! + inc(P); + // if we reached here, we should try for the next scope within Dest + repeat + vt := found^.VType; + if vt<>varByRef or varVariant then + break; + found := found^.VPointer; + until false; + if vt=VType then + continue; + exit; + until false; + res := found; + while integer(res^.VType)=varByRef or varVariant do + res := res^.VPointer; + if (integer(res^.VType)=VType) and (PDocVariantData(res)^.VCount=0) then + // return void TDocVariant as null + TVarData(result).VType := varNull else + // copy found value + result := PVariant(found)^; +end; + +function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; +var ndx: integer; +begin + result := false; + if not(dvoIsArray in VOptions) then + exit; + ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); + if ndx<0 then + exit; + RetrieveValueOrRaiseException(ndx,Dest,DestByRef); + result := true; +end; + +function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; + aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; +var ndx: integer; +begin + result := false; + if not(dvoIsArray in VOptions) then + exit; + ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); + if ndx<0 then + exit; + Dest := _Safe(VValue[ndx]); + result := Dest^.VType>varNull; +end; + +function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; +var Up: array[byte] of AnsiChar; + temp: TTextWriterStackBuffer; + ndx: integer; + W: TTextWriter; +begin + if not(dvoIsObject in VOptions) or (VCount=0) then begin + result := NULL_STR_VAR; + exit; + end; + UpperCopy255(Up,aStartName)^ := #0; + W := DefaultTextWriterSerializer.CreateOwnedStream(temp); + try + W.Add('{'); + for ndx := 0 to VCount-1 do + if IdemPChar(Pointer(VName[ndx]),Up) then begin + if (dvoSerializeAsExtendedJson in VOptions) and + JsonPropNameValid(pointer(VName[ndx])) then begin + W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); + end else begin + W.Add('"'); + W.AddJSONEscape(pointer(VName[ndx])); + W.Add('"'); + end; + W.Add(':'); + W.AddVariant(VValue[ndx],twJSONEscape); + W.Add(','); + end; + W.CancelLastComma; + W.Add('}'); + W.SetText(result); + finally + W.Free; + end; +end; + +function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8; + TrimLeftStartName: boolean): variant; +var Up: array[byte] of AnsiChar; + ndx: integer; + name: RawUTF8; +begin + if aStartName='' then begin + result := Variant(self); + exit; + end; + if not(dvoIsObject in VOptions) or (VCount=0) then begin + SetVariantNull(result); + exit; + end; + TDocVariant.NewFast(result); + UpperCopy255(Up,aStartName)^ := #0; + for ndx := 0 to VCount-1 do + if IdemPChar(Pointer(VName[ndx]),Up) then begin + name := VName[ndx]; + if TrimLeftStartName then + system.delete(name,1,length(aStartName)); + TDocVariantData(result).AddValue(name,VValue[ndx]); + end; +end; + +procedure TDocVariantData.SetValueOrRaiseException(Index: integer; const NewValue: variant); +begin + if cardinal(Index)>=cardinal(VCount) then + raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else + VValue[Index] := NewValue; +end; + +procedure TDocVariantData.RetrieveNameOrRaiseException(Index: integer; + var Dest: RawUTF8); +begin + if (cardinal(Index)>=cardinal(VCount)) or (VName=nil) then + if dvoReturnNullForUnknownProperty in VOptions then + Dest := '' else + raise EDocVariant.CreateUTF8('Out of range Names[%] (count=%)',[Index,VCount]) else + Dest := VName[Index]; +end; + +procedure TDocVariantData.RetrieveValueOrRaiseException(Index: integer; + var Dest: variant; DestByRef: boolean); +var Source: PVariant; +begin + if cardinal(Index)>=cardinal(VCount) then + if dvoReturnNullForUnknownProperty in VOptions then + SetVariantNull(Dest) else + raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else + if DestByRef then + SetVariantByRef(VValue[Index],Dest) else begin + Source := @VValue[Index]; + while PVarData(Source)^.VType=varVariant or varByRef do + Source := PVarData(Source)^.VPointer; + Dest := Source^; + end; +end; + +function TDocVariantData.RetrieveValueOrRaiseException( + aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean; + var Dest: variant; DestByRef: boolean): boolean; +var ndx: Integer; +begin + ndx := GetValueIndex(aName,aNameLen,aCaseSensitive); + if ndx<0 then + if dvoReturnNullForUnknownProperty in VOptions then + SetVariantNull(Dest) else + raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else + RetrieveValueOrRaiseException(ndx,Dest,DestByRef); + result := ndx>=0; +end; + +function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant; +var wasString: boolean; + Name: RawUTF8; +begin + if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] + RetrieveValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),result,true) else begin + VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] + if wasString then + RetrieveValueOrRaiseException(pointer(Name),length(Name), + dvoNameCaseSensitive in VOptions,result,true) else + RetrieveValueOrRaiseException(GetIntegerDef(pointer(Name),-1),result,true); + end; +end; + +procedure TDocVariantData.SetValueOrItem(const aNameOrIndex, aValue: variant); +var wasString: boolean; + ndx: integer; + Name: RawUTF8; +begin + if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] + SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue) else begin + VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] + if wasString then begin + ndx := GetValueIndex(Name); + if ndx<0 then + ndx := InternalAdd(Name); + SetVariantByValue(aValue,VValue[ndx]); + if dvoInternValues in VOptions then + DocVariantType.InternValues.UniqueVariant(VValue[ndx]); + end else + SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue); + end; +end; + +function TDocVariantData.AddOrUpdateValue(const aName: RawUTF8; + const aValue: variant; wasAdded: PBoolean; OnlyAddMissing: boolean): integer; +begin + if dvoIsArray in VOptions then + raise EDocVariant.CreateUTF8('AddOrUpdateValue("%") on an array',[aName]); + result := GetValueIndex(aName); + if result<0 then begin + result := InternalAdd(aName); + if wasAdded<>nil then + wasAdded^ := true; + end else begin + if wasAdded<>nil then + wasAdded^ := false; + if OnlyAddMissing then + exit; + end; + SetVariantByValue(aValue,VValue[result]); + if dvoInternValues in VOptions then + DocVariantType.InternValues.UniqueVariant(VValue[result]); +end; + +function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8; + Format: TTextWriterJSONFormat): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + if (integer(VType)<>DocVariantVType) and (VType>varNull) then begin + result := ''; // null -> 'null' + exit; + end; + W := DefaultTextWriterSerializer.CreateOwnedStream(temp); + try + W.AddString(Prefix); + DocVariantType.ToJSON(W,variant(self),twJSONEscape); + W.AddString(Suffix); + W.SetText(result, Format); + finally + W.Free; + end; +end; + +function TDocVariantData.ToNonExpandedJSON: RawUTF8; +var fields: TRawUTF8DynArray; + fieldsCount: integer; + W: TTextWriter; + r,f: integer; + row: PDocVariantData; + temp: TTextWriterStackBuffer; +begin + fields := nil; // to please Kylix + fieldsCount := 0; + if not(dvoIsArray in VOptions) then begin + result := ''; + exit; + end; + if VCount=0 then begin + result := '[]'; + exit; + end; + with _Safe(VValue[0])^ do + if dvoIsObject in VOptions then begin + fields := VName; + fieldsCount := VCount; + end; + if fieldsCount=0 then + raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object'); + W := DefaultTextWriterSerializer.CreateOwnedStream(temp); + try + W.Add('{"fieldCount":%,"rowCount":%,"values":[',[fieldsCount,VCount]); + for f := 0 to fieldsCount-1 do begin + W.Add('"'); + W.AddJSONEscape(pointer(fields[f])); + W.Add('"',','); + end; + for r := 0 to VCount-1 do begin + row := _Safe(VValue[r]); + if (r>0) and (not(dvoIsObject in row^.VOptions) or (row^.VCount<>fieldsCount)) then + raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not expected object',[r]); + for f := 0 to fieldsCount-1 do + if (r>0) and not IdemPropNameU(row^.VName[f],fields[f]) then + raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] field=% expected=%', + [r,row^.VName[f],fields[f]]) else begin + W.AddVariant(row^.VValue[f],twJSONEscape); + W.Add(','); + end; + end; + W.CancelLastComma; + W.Add(']','}'); + W.SetText(result); + finally + W.Free; + end; +end; + +procedure TDocVariantData.ToRawUTF8DynArray(out Result: TRawUTF8DynArray); +var ndx: integer; + wasString: boolean; +begin + if dvoIsObject in VOptions then + raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray'); + if dvoIsArray in VOptions then begin + SetLength(Result,VCount); + for ndx := 0 to VCount-1 do + VariantToUTF8(VValue[ndx],Result[ndx],wasString); + end; +end; + +function TDocVariantData.ToRawUTF8DynArray: TRawUTF8DynArray; +begin + ToRawUTF8DynArray(result); +end; + +function TDocVariantData.ToCSV(const Separator: RawUTF8): RawUTF8; +var tmp: TRawUTF8DynArray; // fast enough in practice +begin + ToRawUTF8DynArray(tmp); + result := RawUTF8ArrayToCSV(tmp,Separator); +end; + +procedure TDocVariantData.ToTextPairsVar(out result: RawUTF8; + const NameValueSep, ItemSep: RawUTF8; escape: TTextWriterKind); +var ndx: integer; + temp: TTextWriterStackBuffer; +begin + if dvoIsArray in VOptions then + raise EDocVariant.Create('ToTextPairs expects a dvObject'); + if (VCount>0) and (dvoIsObject in VOptions) then + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + ndx := 0; + repeat + AddString(VName[ndx]); + AddString(NameValueSep); + AddVariant(VValue[ndx],escape); + inc(ndx); + if ndx=VCount then + break; + AddString(ItemSep); + until false; + SetText(result); + finally + Free; + end; +end; + +function TDocVariantData.ToTextPairs(const NameValueSep: RawUTF8; + const ItemSep: RawUTF8; Escape: TTextWriterKind): RawUTF8; +begin + ToTextPairsVar(result,NameValueSep,ItemSep,escape); +end; + +procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray); +var ndx: integer; +begin + if dvoIsObject in VOptions then + raise EDocVariant.Create('ToArrayOfConst expects a dvArray'); + if dvoIsArray in VOptions then begin + SetLength(Result,VCount); + for ndx := 0 to VCount-1 do begin + Result[ndx].VType := vtVariant; + Result[ndx].VVariant := @VValue[ndx]; + end; + end; +end; + +function TDocVariantData.ToArrayOfConst: TTVarRecDynArray; +begin + ToArrayOfConst(result); +end; + +function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; +var json: RawUTF8; // temporary in-place modified buffer +begin + VariantSaveJSON(variant(self),twJSONEscape,json); + result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]); +end; + +function TDocVariantData.GetOrAddIndexByName(const aName: RawUTF8): integer; +begin + result := GetValueIndex(aName); + if result<0 then + result := InternalAdd(aName); +end; + +function TDocVariantData.GetOrAddPVariantByName(const aName: RawUTF8): PVariant; +var ndx: integer; +begin + ndx := GetValueIndex(aName); + if ndx<0 then + ndx := InternalAdd(aName); + result := @VValue[ndx]; +end; + +function TDocVariantData.GetPVariantByName(const aName: RawUTF8): PVariant; +var ndx: Integer; +begin + ndx := GetValueIndex(aName); + if ndx<0 then + if dvoReturnNullForUnknownProperty in VOptions then + result := @DocVariantDataFake else + raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else + result := @VValue[ndx]; +end; + +function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64; +begin + if not VariantToInt64(GetPVariantByName(aName)^,result) then + result := 0; +end; + +function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; +var wasString: boolean; + v: PVariant; +begin + v := GetPVariantByName(aName); + if PVarData(v)^.VType<=varNull then // default VariantToUTF8(null)='null' + result := '' else + VariantToUTF8(v^,result,wasString); +end; + +function TDocVariantData.GetStringByName(const aName: RawUTF8): string; +begin + result := VariantToString(GetPVariantByName(aName)^); +end; + +procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8; + const aValue: Int64); +begin + GetOrAddPVariantByName(aName)^ := aValue; +end; + +procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8); +begin + RawUTF8ToVariant(aValue,GetOrAddPVariantByName(aName)^); +end; + +procedure TDocVariantData.SetStringByName(const aName: RawUTF8; const aValue: string); +begin + RawUTF8ToVariant(StringToUTF8(aValue),GetOrAddPVariantByName(aName)^); +end; + +function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean; +begin + if not VariantToBoolean(GetPVariantByName(aName)^,result) then + result := false; +end; + +procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean); +begin + GetOrAddPVariantByName(aName)^ := aValue; +end; + +function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double; +begin + if not VariantToDouble(GetPVariantByName(aName)^,result) then + result := 0; +end; + +procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8; + const aValue: Double); +begin + GetOrAddPVariantByName(aName)^ := aValue; +end; + +function TDocVariantData.GetDocVariantExistingByName(const aName: RawUTF8; + aNotMatchingKind: TDocVariantKind): PDocVariantData; +begin + result := GetAsDocVariantSafe(aName); + if result^.Kind=aNotMatchingKind then + result := @DocVariantDataFake; +end; + +function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUTF8; + aKind: TDocVariantKind): PDocVariantData; +var ndx: integer; +begin + ndx := GetOrAddIndexByName(aName); + result := _Safe(VValue[ndx]); + if result^.Kind<>aKind then begin + result := @VValue[ndx]; + VarClear(PVariant(result)^); + result^.Init(JSON_OPTIONS_FAST,aKind); + end; +end; + +function TDocVariantData.GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; +begin + result := GetDocVariantExistingByName(aName,dvArray); +end; + +function TDocVariantData.GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; +begin + result := GetDocVariantOrAddByName(aName,dvObject); +end; + +function TDocVariantData.GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; +begin + result := GetDocVariantExistingByName(aName,dvObject); +end; + +function TDocVariantData.GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; +begin + result := GetDocVariantOrAddByName(aName,dvArray); +end; + +function TDocVariantData.GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; +begin + if cardinal(aIndex)4) and (Name[0]='_') and + IntGetPseudoProp(IdemPCharArray(@Name[1],['COUNT','KIND','JSON']),dv,variant(Dest)) then + result := true else + result := dv.RetrieveValueOrRaiseException(pointer(Name),NameLen, + dvoNameCaseSensitive in dv.VOptions,PVariant(@Dest)^,{byref=}true); +end; + +function TDocVariant.IntSet(const Instance, Value: TVarData; + Name: PAnsiChar; NameLen: PtrInt): boolean; +var ndx: Integer; + aName: RawUTF8; + dv: TDocVariantData absolute Instance; +begin + result := true; + if (dvoIsArray in dv.VOptions) and (PWord(Name)^=ord('_')) then begin + ndx := dv.InternalAdd(''); + SetVariantByValue(variant(Value),dv.VValue[ndx]); + if dvoInternValues in dv.VOptions then + DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); + exit; + end; + ndx := dv.GetValueIndex(pointer(Name),NameLen,dvoNameCaseSensitive in dv.VOptions); + if ndx<0 then begin + FastSetString(aName,Name,NameLen); + ndx := dv.InternalAdd(aName); + end; + SetVariantByValue(variant(Value),dv.VValue[ndx]); + if dvoInternValues in dv.VOptions then + DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); +end; + +function TDocVariant.IterateCount(const V: TVarData): integer; +var Data: TDocVariantData absolute V; +begin + if dvoIsArray in Data.VOptions then + result := Data.VCount else + result := -1; +end; + +procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer); +var Data: TDocVariantData absolute V; +begin + if (dvoIsArray in Data.VOptions) and (cardinal(Index) read/only + 0: if SameText(Name,'Clear') then begin + Data^.VCount := 0; + Data^.VOptions := Data^.VOptions-[dvoIsObject,dvoIsArray]; + exit; + end; {$endif FPC} + 1: {$ifndef FPC} if SameText(Name,'Add') then begin + ndx := Data^.InternalAdd(''); + SetVariantByValue(variant(Arguments[0]),Data^.VValue[ndx]); + if dvoInternValues in Data^.VOptions then + DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); + exit; + end else + if SameText(Name,'Delete') then begin + SetTempFromFirstArgument; + Data^.Delete(Data^.GetValueIndex(temp)); + exit; + end else {$endif FPC} + if SameText(Name,'Exists') then begin + SetTempFromFirstArgument; + variant(Dest) := Data^.GetValueIndex(temp)>=0; + exit; + end else + if SameText(Name,'NameIndex') then begin + SetTempFromFirstArgument; + variant(Dest) := Data^.GetValueIndex(temp); + exit; + end else + if VariantToInteger(variant(Arguments[0]),ndx) then begin + if (Name='_') or SameText(Name,'Value') then begin + Data^.RetrieveValueOrRaiseException(ndx,variant(Dest),true); + exit; + end else + if SameText(Name,'Name') then begin + Data^.RetrieveNameOrRaiseException(ndx,temp); + RawUTF8ToVariant(temp,variant(Dest)); + exit; + end; + end else + if (Name='_') or SameText(Name,'Value') then begin + SetTempFromFirstArgument; + Data^.RetrieveValueOrRaiseException(pointer(temp),length(temp), + dvoNameCaseSensitive in Data^.VOptions,variant(Dest),true); + exit; + end; + 2:{$ifndef FPC} if SameText(Name,'Add') then begin + SetTempFromFirstArgument; + ndx := Data^.InternalAdd(temp); + SetVariantByValue(variant(Arguments[1]),Data^.VValue[ndx]); + if dvoInternValues in Data^.VOptions then + DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); + exit; + end; {$endif FPC} + end; + result := false; +end; + +procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant; + escape: TTextWriterKind); +var ndx: integer; + vt: cardinal; + forced: TTextWriterOptions; + checkExtendedPropName: boolean; +begin + vt := TDocVariantData(Value).VType; + if vt>varNull then + if vt=cardinal(DocVariantVType) then + with TDocVariantData(Value) do + if [dvoIsArray,dvoIsObject]*VOptions=[] then + W.AddShort('null') else begin + if [twoForceJSONExtended,twoForceJSONStandard]*W.CustomOptions=[] then begin + if dvoSerializeAsExtendedJson in VOptions then + forced := [twoForceJSONExtended] else + forced := [twoForceJSONStandard]; + W.CustomOptions := W.CustomOptions+forced; + end else + forced := []; + if dvoIsObject in VOptions then begin + checkExtendedPropName := twoForceJSONExtended in W.CustomOptions; + W.Add('{'); + for ndx := 0 to VCount-1 do begin + if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin + W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); + end else begin + W.Add('"'); + W.AddJSONEscape(pointer(VName[ndx])); + W.Add('"'); + end; + W.Add(':'); + W.AddVariant(VValue[ndx],twJSONEscape); + W.Add(','); + end; + W.CancelLastComma; + W.Add('}'); + end else begin + W.Add('['); + for ndx := 0 to VCount-1 do begin + W.AddVariant(VValue[ndx],twJSONEscape); + W.Add(','); + end; + W.CancelLastComma; + W.Add(']'); + end; + if forced<>[] then + W.CustomOptions := W.CustomOptions-forced; + end else + raise ESynException.CreateUTF8('Unexpected variant type %',[vt]) else + W.AddShort('null'); +end; + +procedure TDocVariant.Clear(var V: TVarData); +var dv: TDocVariantData absolute V; +begin + //Assert(V.VType=DocVariantVType); + RawUTF8DynArrayClear(dv.VName); + VariantDynArrayClear(dv.VValue); + ZeroFill(@V); // will set V.VType := varEmpty and VCount=0 +end; + +procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); +begin + //Assert(Source.VType=DocVariantVType); + if Indirect then + SimplisticCopy(Dest,Source,true) else + if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin + VarClear(variant(Dest)); // Dest may be a complex type + pointer(TDocVariantData(Dest).VName) := nil; // avoid GPF + pointer(TDocVariantData(Dest).VValue) := nil; + TDocVariantData(Dest) := TDocVariantData(Source); // copy whole record + end else + CopyByValue(Dest,Source); +end; + +procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData); +var S: TDocVariantData absolute Source; + D: TDocVariantData absolute Dest; + i: integer; +begin + //Assert(Source.VType=DocVariantVType); + VarClear(variant(Dest)); // Dest may be a complex type + D.VType := S.VType; + D.VOptions := S.VOptions; // copies also Kind + D.VCount := S.VCount; + pointer(D.VName) := nil; // avoid GPF + pointer(D.VValue) := nil; + if S.VCount=0 then + exit; // no data to copy + D.VName := S.VName; // names can always be safely copied + // slower but safe by-value copy + SetLength(D.VValue,S.VCount); + for i := 0 to S.VCount-1 do + D.VValue[i] := S.VValue[i]; +end; + +procedure TDocVariant.Cast(var Dest: TVarData; const Source: TVarData); +begin + CastTo(Dest,Source,VarType); +end; + +procedure TDocVariant.CastTo(var Dest: TVarData; + const Source: TVarData; const AVarType: TVarType); +var Tmp: RawUTF8; + wasString: boolean; +begin + if AVarType=VarType then begin + VariantToUTF8(Variant(Source),Tmp,wasString); + if wasString then begin + VarClear(variant(Dest)); + variant(Dest) := _JSONFast(Tmp); // convert from JSON text + exit; + end; + RaiseCastError; + end else begin + if Source.VType<>VarType then + RaiseCastError; + VariantSaveJSON(variant(Source),twJSONEscape,tmp); + RawUTF8ToVariant(Tmp,Dest,AVarType); // convert to JSON text + end; +end; + +procedure TDocVariant.Compare(const Left, Right: TVarData; + var Relationship: TVarCompareResult); +var res: integer; + LeftU,RightU: RawUTF8; +begin + VariantSaveJSON(variant(Left),twJSONEscape,LeftU); + VariantSaveJSON(variant(Right),twJSONEscape,RightU); + if LeftU=RightU then + Relationship := crEqual else begin + res := StrComp(pointer(LeftU),pointer(RightU)); + if res<0 then + Relationship := crLessThan else + if res>0 then + Relationship := crGreaterThan else + Relationship := crEqual; + end; +end; + +class procedure TDocVariant.New(out aValue: variant; + aOptions: TDocVariantOptions); +begin + TDocVariantData(aValue).Init(aOptions); +end; + +class procedure TDocVariant.NewFast(out aValue: variant); +begin + TDocVariantData(aValue).InitFast; +end; + +class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant); +begin + if DocVariantType.IsOfType(aValue) then + exit; + VarClear(aValue); + TDocVariantData(aValue).InitFast; +end; + +class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData); +var i: integer; +begin + for i := 0 to high(aValues) do + aValues[i]^.InitFast; +end; + +class function TDocVariant.New(Options: TDocVariantOptions): Variant; +begin + VarClear(result); + TDocVariantData(result).Init(Options); +end; + +class function TDocVariant.NewObject(const NameValuePairs: array of const; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitObject(NameValuePairs,Options); +end; + +class function TDocVariant.NewArray(const Items: array of const; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitArray(Items,Options); +end; + +class function TDocVariant.NewArray(const Items: TVariantDynArray; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitArrayFromVariants(Items,Options); +end; + +class function TDocVariant.NewJSON(const JSON: RawUTF8; + Options: TDocVariantOptions): variant; +begin + _Json(JSON,result,Options); +end; + +class function TDocVariant.NewUnique(const SourceDocVariant: variant; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitCopy(SourceDocVariant,Options); +end; + +class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant; + var result: variant); +var vt: integer; +begin + vt := TVarData(DocVariantArray).VType; + if vt=varByRef or varVariant then + GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else + if (vt<>DocVariantVType) or (TDocVariantData(DocVariantArray).Count<>1) or + not(dvoIsArray in TDocVariantData(DocVariantArray).VOptions) then + result := default else + result := TDocVariantData(DocVariantArray).Values[0]; +end; + +function ToText(kind: TDocVariantKind): PShortString; +begin + result := GetEnumName(TypeInfo(TDocVariantKind),ord(kind)); +end; + +function _Obj(const NameValuePairs: array of const; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitObject(NameValuePairs,Options); +end; + +function _Arr(const Items: array of const; + Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result).InitArray(Items,Options); +end; + +procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); +var o: PDocVariantData; +begin + o := _Safe(Obj); + if not(dvoIsObject in o^.VOptions) then begin // create new object + VarClear(Obj); + TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST); + end else begin // append new names/values to existing object + TVarData(Obj) := PVarData(o)^; // ensure not stored by reference + o^.AddNameValuesToObject(NameValuePairs); + end; +end; + +procedure _ObjAddProps(const Document: variant; var Obj: variant); +var ndx: integer; + d,o: PDocVariantData; +begin + d := _Safe(Document); + o := _Safe(Obj); + if dvoIsObject in d.VOptions then + if not(dvoIsObject in o.VOptions) then + Obj := Document else + for ndx := 0 to d^.VCount-1 do + o^.AddOrUpdateValue(d^.VName[ndx],d^.VValue[ndx]); +end; + +function _ObjFast(const NameValuePairs: array of const): variant; +begin + VarClear(result); + TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST); +end; + +function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant; +begin + VarClear(result); + if TDocVariantData(result).InitJSONInPlace( + pointer(ObjectToJson(aObject,aOptions)),JSON_OPTIONS_FAST)=nil then + VarClear(result); +end; + +function _ArrFast(const Items: array of const): variant; +begin + VarClear(result); + TDocVariantData(result).InitArray(Items,JSON_OPTIONS_FAST); +end; + +function _Json(const JSON: RawUTF8; Options: TDocVariantOptions): variant; +begin + _Json(JSON,result,Options); +end; + +function _JsonFast(const JSON: RawUTF8): variant; +begin + _Json(JSON,result,JSON_OPTIONS_FAST); +end; + +function _JsonFastFloat(const JSON: RawUTF8): variant; +begin + _Json(JSON,result,JSON_OPTIONS_FAST_FLOAT); +end; + +function _JsonFastExt(const JSON: RawUTF8): variant; +begin + _Json(JSON,result,JSON_OPTIONS_FAST_EXTENDED); +end; + +function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; + Options: TDocVariantOptions): variant; +begin + _JsonFmt(Format,Args,Params,Options,result); +end; + +procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; + Options: TDocVariantOptions; out result: variant); +var temp: RawUTF8; +begin + temp := FormatUTF8(Format,Args,Params,true); + if TDocVariantData(result).InitJSONInPlace(pointer(temp),Options)=nil then + TDocVariantData(result).Clear; +end; + +function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; +begin + _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,result); +end; + +function _Json(const JSON: RawUTF8; var Value: variant; + Options: TDocVariantOptions): boolean; +begin + VarClear(Value); + if not TDocVariantData(Value).InitJSON(JSON,Options) then begin + VarClear(Value); + result := false; + end else + result := true; +end; + +procedure _Unique(var DocVariant: variant); +begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type + TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]); +end; + +procedure _UniqueFast(var DocVariant: variant); +begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type + TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS_FAST); +end; + +function _Copy(const DocVariant: variant): variant; +begin + result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]); +end; + +function _CopyFast(const DocVariant: variant): variant; +begin + result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS_FAST); +end; + +function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; +begin + VarClear(result); + TDocVariantData(result) := _Safe(DocVariant)^; // fast byref copy + TDocVariantData(result).SetOptions(Options); +end; + +procedure _ByRef(const DocVariant: variant; out Dest: variant; + Options: TDocVariantOptions); +begin + TDocVariantData(Dest) := _Safe(DocVariant)^; // fast byref copy + TDocVariantData(Dest).SetOptions(Options); +end; + +function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant; +const OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = ( + [woDontStoreDefault],[woDontStoreDefault,woEnumSetsAsText]); +begin + VarClear(result); + ObjectToVariant(Value,result,OPTIONS[EnumSetsAsText]); +end; + +procedure ObjectToVariant(Value: TObject; out Dest: variant); +begin + ObjectToVariant(Value,Dest,[woDontStoreDefault]); +end; + +procedure ObjectToVariant(Value: TObject; var result: variant; + Options: TTextWriterWriteObjectOptions); +var json: RawUTF8; +begin + json := ObjectToJSON(Value,Options); + PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST); +end; + +{$endif NOVARIANTS} + + +{ ****************** TDynArray wrapper } + +{$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like CopyFrom() +procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; + TypeInfo: pointer); +var DestDynArray: TDynArray; +begin + DestDynArray.Init(TypeInfo,Dest); + DestDynArray.CopyFrom(Source,SourceMaxElem); +end; +{$endif DELPHI5OROLDER} + +function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; +var DynArray: TDynArray; +begin + DynArray.Init(TypeInfo,Value); + result := DynArray.LoadFrom(Source); +end; + +function DynArraySave(var Value; TypeInfo: pointer): RawByteString; +var DynArray: TDynArray; +begin + DynArray.Init(TypeInfo,Value); + result := DynArray.SaveTo; +end; + +function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; + EndOfObject: PUTF8Char): PUTF8Char; +var DynArray: TDynArray; +begin + DynArray.Init(TypeInfo,Value); + result := DynArray.LoadFromJSON(JSON,EndOfObject); +end; + +function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); // make private copy before in-place decoding + try + result := DynArrayLoadJSON(Value,tmp.buf,TypeInfo)<>nil; + finally + tmp.Done; + end; +end; + +function DynArraySaveJSON(const Value; TypeInfo: pointer; + EnumSetsAsText: boolean): RawUTF8; +begin + result := SaveJSON(Value,TypeInfo,EnumSetsAsText); +end; + +{$ifndef DELPHI5OROLDER} +function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; + Array1Count, Array2Count: PInteger): boolean; +var DA1, DA2: TDynArray; +begin + DA1.Init(TypeInfo,Array1,Array1Count); + DA2.Init(TypeInfo,Array2,Array2Count); + result := DA1.Equals(DA2); +end; +{$endif DELPHI5OROLDER} + +function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; +var DynArray: TDynArray; + Value: pointer; // store the temporary dynamic array + temp: TTextWriterStackBuffer; +begin + Value := nil; + DynArray.Init(TypeInfo,Value); + try + if DynArray.LoadFrom(BlobValue)=nil then + result := '' else begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + AddDynArrayJSON(TypeInfo,Value); + SetText(result); + finally + Free; + end; + end; + finally + DynArray.SetCount(0); + end; +end; + +function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer; + ExactType: boolean): RawUTF8; +var DynArray: TDynArray; + VoidArray: pointer; +const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('', + 'boolean','byte','word','integer','cardinal','single','Int64','QWord', + 'double','currency','TTimeLog','TDateTime','TDateTimeMS', + 'RawUTF8','WinAnsiString','string','RawByteString','WideString','SynUnicode', + 'THash128','THash256','THash512','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}''); +begin + VoidArray := nil; + DynArray.Init(TypeInfo,VoidArray); + result := ''; + if ElemTypeInfo<>nil then + ElemTypeInfo^ := DynArray.ElemType; + if DynArray.ElemType<>nil then + TypeInfoToName(ElemTypeInfo,result) else + result := KNOWNTYPE_ITEMNAME[DynArray.GuessKnownType(ExactType)]; +end; + +procedure RawRecordDynArrayClear(v: PAnsiChar; info: PTypeInfo; n: integer); +var fields,f: PFieldInfo; + nfields,i: integer; +begin + info := GetTypeInfo(info); + nfields := GetManagedFields(info,fields); // inlined RecordClear() + if nfields>0 then + repeat + f := fields; + i := nfields; + repeat + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(v+f^.Offset, + {$ifdef HASDIRECTTYPEINFO}f^.TypeInfo{$else}PPointer(f^.TypeInfo)^{$endif}); + inc(f); + dec(i); + until i=0; + inc(v,info^.recSize); + dec(n); + until n=0; +end; + +procedure RawAnsiStringDynArrayClear(v: PPointer; n: PtrInt); +var p: PStrRec; +begin + repeat + p := v^; + if p<>nil then begin + v^ := nil; + dec(p); + if (p^.refCnt>=0) and StrCntDecFree(p^.refCnt) then + freemem(p); + end; + inc(v); + dec(n); + until n=0; +end; + +procedure FastFinalizeArray(v: PPointer; ElemTypeInfo: pointer; n: integer); +begin // caller ensured ElemTypeInfo<>nil and n>0 + case PTypeKind(ElemTypeInfo)^ of + tkRecord{$ifdef FPC},tkObject{$endif}: + RawRecordDynArrayClear(pointer(v),ElemTypeinfo,n); + {$ifndef NOVARIANTS} + tkVariant: + RawVariantDynArrayClear(pointer(v),n); + {$endif} + tkLString{$ifdef FPC},tkLStringOld{$endif}: + RawAnsiStringDynArrayClear(pointer(v),n); + tkWString: + repeat + if v^<>nil then + {$ifdef FPC}Finalize(WideString(v^)){$else}WideString(v^) := ''{$endif}; + inc(v); + dec(n); + until n=0; + {$ifdef HASVARUSTRING} + tkUString: + repeat + if v^<>nil then + {$ifdef FPC}Finalize(UnicodeString(v^)){$else}UnicodeString(v^) := ''{$endif}; + inc(v); + dec(n); + until n=0; + {$endif} + {$ifndef DELPHI5OROLDER} + tkInterface: + repeat + if v^<>nil then + {$ifdef FPC}Finalize(IInterface(v^)){$else}IInterface(v^) := nil{$endif}; + inc(v); + dec(n); + until n=0; + {$endif} + tkDynArray: begin + ElemTypeInfo := Deref(GetTypeInfo(ElemTypeInfo)^.elType); + repeat + if v^<>nil then + FastDynArrayClear(v,ElemTypeInfo); + inc(v); + dec(n); + until n=0; + end; + else // fallback to regular finalization code for less common types + {$ifdef FPC}FPCFinalizeArray{$else}_FinalizeArray{$endif}(v,ElemTypeInfo,n); + end; +end; + +procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); +var p: PDynArrayRec; +begin + if Value<>nil then begin + p := Value^; + if p<>nil then begin + dec(p); + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin + if ElemTypeInfo<>nil then + FastFinalizeArray(Value^,ElemTypeInfo,p^.length); + Freemem(p); + end; + Value^ := nil; + end; + end; +end; + +{$ifdef FPC_X64} +procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); +begin + info := Deref(GetTypeInfo(info)^.elType); + if info <> nil then + FastFinalizeArray(pointer(PAnsiChar(p) + SizeOf(p^)), info, p^.length); + Freemem(p); +end; +{$endif FPC_X64} + +function SortDynArrayBoolean(const A,B): integer; +begin + if boolean(A) then // normalize (seldom used, anyway) + if boolean(B) then + result := 0 else + result := 1 else + if boolean(B) then + result := -1 else + result := 0; +end; + +function SortDynArrayByte(const A,B): integer; +begin + result := byte(A)-byte(B); +end; + +function SortDynArraySmallint(const A,B): integer; +begin + result := smallint(A)-smallint(B); +end; + +function SortDynArrayShortint(const A,B): integer; +begin + result := shortint(A)-shortint(B); +end; + +function SortDynArrayWord(const A,B): integer; +begin + result := word(A)-word(B); +end; + +function SortDynArrayPUTF8CharI(const A,B): integer; +begin + result := StrIComp(PUTF8Char(A),PUTF8Char(B)); +end; + +function SortDynArrayString(const A,B): integer; +begin + {$ifdef UNICODE} + result := StrCompW(PWideChar(A),PWideChar(B)); + {$else} + result := StrComp(PUTF8Char(A),PUTF8Char(B)); + {$endif} +end; + +function SortDynArrayStringI(const A,B): integer; +begin + {$ifdef UNICODE} + result := AnsiICompW(PWideChar(A),PWideChar(B)); + {$else} + result := StrIComp(PUTF8Char(A),PUTF8Char(B)); + {$endif} +end; + +function SortDynArrayFileName(const A,B): integer; +var Aname, Aext, Bname, Bext: TFileName; +begin // code below is not very fast, but is correct ;) + AName := GetFileNameWithoutExt(string(A),@Aext); + BName := GetFileNameWithoutExt(string(B),@Bext); + result := AnsiCompareFileName(Aext,Bext); + if result=0 then // if both extensions matches, compare by filename + result := AnsiCompareFileName(Aname,Bname); +end; + +function SortDynArrayUnicodeString(const A,B): integer; +begin // works for tkWString and tkUString + result := StrCompW(PWideChar(A),PWideChar(B)); +end; + +function SortDynArrayUnicodeStringI(const A,B): integer; +begin + result := AnsiICompW(PWideChar(A),PWideChar(B)); +end; + +function SortDynArray128(const A,B): integer; +begin + if THash128Rec(A).LoTHash128Rec(B).Lo then + result := 1 else + if THash128Rec(A).HiTHash128Rec(B).Hi then + result := 1 else + result := 0; +end; + +function SortDynArray256(const A,B): integer; +begin + result := SortDynArray128(THash256Rec(A).Lo,THash256Rec(B).Lo); + if result = 0 then + result := SortDynArray128(THash256Rec(A).Hi,THash256Rec(B).Hi); +end; + +function SortDynArray512(const A,B): integer; +begin + result := SortDynArray128(THash512Rec(A).c0,THash512Rec(B).c0); + if result = 0 then begin + result := SortDynArray128(THash512Rec(A).c1,THash512Rec(B).c1); + if result = 0 then begin + result := SortDynArray128(THash512Rec(A).c2,THash512Rec(B).c2); + if result = 0 then + result := SortDynArray128(THash512Rec(A).c3,THash512Rec(B).c3); + end; + end; +end; + +{$ifndef NOVARIANTS} + +function VariantCompare(const V1,V2: variant): PtrInt; +begin + result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), false); +end; + +function VariantCompareI(const V1,V2: variant): PtrInt; +begin + result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), true); +end; + +function SortDynArrayVariantCompareAsString(const A,B: variant): integer; +var UA,UB: RawUTF8; + wasString: boolean; +begin + VariantToUTF8(A,UA,wasString); + VariantToUTF8(B,UB,wasString); + result := StrComp(pointer(UA),pointer(UB)); +end; + +function SortDynArrayVariantCompareAsStringI(const A,B: variant): integer; +var UA,UB: RawUTF8; + wasString: boolean; +begin + VariantToUTF8(A,UA,wasString); + VariantToUTF8(B,UB,wasString); + result := StrIComp(pointer(UA),pointer(UB)); +end; + +function SortDynArrayZero(const A,B): integer; +begin + result := 0; +end; + +function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; +type + TSortDynArrayVariantComp = function(const A,B: variant): integer; +const + CMP: array[boolean] of TSortDynArrayVariantComp = ( + SortDynArrayVariantCompareAsString,SortDynArrayVariantCompareAsStringI); + ICMP: array[TVariantRelationship] of integer = (0,-1,1,1); + SORT1: array[varEmpty..varDate] of TDynArraySortCompare = ( + SortDynArrayZero, SortDynArrayZero, SortDynArraySmallInt, SortDynArrayInteger, + SortDynArraySingle, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayDouble); + SORT2: array[varShortInt..varWord64] of TDynArraySortCompare = ( + SortDynArrayShortInt, SortDynArrayByte, SortDynArrayWord, SortDynArrayCardinal, + SortDynArrayInt64, SortDynArrayQWord); +var AT,BT: integer; +begin + AT := integer(A.VType); + BT := integer(B.VType); + if AT=varVariant or varByRef then + result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else + if BT=varVariant or varByRef then + result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else + if AT=BT then + case AT of // optimized comparison if A and B share the same type + low(SORT1)..high(SORT1): + result := SORT1[AT](A.VAny,B.VAny); + low(SORT2)..high(SORT2): + result := SORT2[AT](A.VAny,B.VAny); + varString: // RawUTF8 most of the time (e.g. from TDocVariant) + if caseInsensitive then + result := StrIComp(A.VAny,B.VAny) else + result := StrComp(A.VAny,B.VAny); + varBoolean: + if A.VBoolean then // normalize + if B.VBoolean then + result := 0 else + result := 1 else + if B.VBoolean then + result := -1 else + result := 0; + varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: + if caseInsensitive then + result := AnsiICompW(A.VAny,B.VAny) else + result := StrCompW(A.VAny,B.VAny); + else + if ATvarNull)-ord(BT>varNull) else + if (ATvarOleStr) and (BT<>varOleStr) then + result := ICMP[VarCompareValue(variant(A),variant(B))] else + result := CMP[caseInsensitive](variant(A),variant(B)); +end; + +function SortDynArrayVariant(const A,B): integer; +begin + result := SortDynArrayVariantComp(TVarData(A),TVarData(B),false); +end; + +function SortDynArrayVariantI(const A,B): integer; +begin + result := SortDynArrayVariantComp(TVarData(A),TVarData(B),true); +end; + +{$endif NOVARIANTS} + + +{ TDynArray } + +function TDynArray.GetCount: PtrInt; +begin + result := PtrUInt(fCountP); + if result<>0 then + result := PInteger(result)^ else begin + result := PtrUInt(fValue); + if result<>0 then begin + result := PPtrInt(result)^; + if result<>0 then + result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; + end; + end; +end; + +procedure TDynArray.ElemCopy(const A; var B); +begin + if ElemType=nil then + MoveFast(A,B,ElemSize) else begin + {$ifdef FPC} + {$ifdef FPC_OLDRTTI} + FPCFinalize(@B,ElemType); // inlined CopyArray() + Move(A,B,ElemSize); + FPCRecordAddRef(B,ElemType); + {$else} + FPCRecordCopy(A,B,ElemType); // works for any kind of ElemTyp + {$endif FPC_OLDRTTI} + {$else} + CopyArray(@B,@A,ElemType,1); + {$endif FPC} + end; +end; + +function TDynArray.Add(const Elem): PtrInt; +var p: PtrUInt; +begin + result := GetCount; + if fValue=nil then + exit; // avoid GPF if void + SetCount(result+1); + p := PtrUInt(fValue^)+PtrUInt(result)*ElemSize; + if ElemType=nil then + MoveFast(Elem,pointer(p)^,ElemSize) else + {$ifdef FPC} + FPCRecordCopy(Elem,pointer(p)^,ElemType); + {$else} + CopyArray(pointer(p),@Elem,ElemType,1); + {$endif} +end; + +function TDynArray.New: integer; +begin + result := GetCount; + if fValue=nil then + exit; // avoid GPF if void + SetCount(result+1); +end; + +function TDynArray.Peek(var Dest): boolean; +var index: PtrInt; +begin + index := GetCount-1; + result := index>=0; + if result then + ElemCopy(pointer(PtrUInt(fValue^)+PtrUInt(index)*ElemSize)^,Dest); +end; + +function TDynArray.Pop(var Dest): boolean; +var index: integer; +begin + index := GetCount-1; + result := index>=0; + if result then begin + ElemMoveTo(index,Dest); + SetCount(index); + end; +end; + +procedure TDynArray.Insert(Index: PtrInt; const Elem); +var n: PtrInt; + P: PByteArray; +begin + if fValue=nil then + exit; // avoid GPF if void + n := GetCount; + SetCount(n+1); + if PtrUInt(Index)nil then // avoid GPF in ElemCopy() below + FillCharFast(P^,ElemSize,0); + end else + // Index>=Count -> add at the end + P := pointer(PtrUInt(fValue^)+PtrUInt(n)*ElemSize); + ElemCopy(Elem,P^); +end; + +procedure TDynArray.Clear; +begin + SetCount(0); +end; + +function TDynArray.ClearSafe: boolean; +begin + try + SetCount(0); + result := true; + except // weak code, but may be a good idea in a destructor + result := false; + end; +end; + +function TDynArray.GetIsObjArray: boolean; +begin + result := (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray); +end; + +function TDynArray.Delete(aIndex: PtrInt): boolean; +var n, len: PtrInt; + P: PAnsiChar; +begin + result := false; + if fValue=nil then + exit; // avoid GPF if void + n := GetCount; + if PtrUInt(aIndex)>=PtrUInt(n) then + exit; // out of range + if PDACnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then + InternalSetLength(n,n); // unique + dec(n); + P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize); + if ElemType<>nil then + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(P,ElemType) else + if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then + FreeAndNil(PObject(P)^); + if n>aIndex then begin + len := PtrUInt(n-aIndex)*ElemSize; + MoveFast(P[ElemSize],P[0],len); + FillCharFast(P[len],ElemSize,0); + end else + FillCharFast(P^,ElemSize,0); + SetCount(n); + result := true; +end; + +function TDynArray.ElemPtr(index: PtrInt): pointer; +var c: PtrUInt; +begin // no goto/label, because it does not properly inline on modern Delphi + result := pointer(fValue); + if result=nil then + exit; + result := PPointer(result)^; + if result=nil then + exit; + c := PtrUInt(fCountP); + if c<>0 then + if PtrUInt(index)nil then + if ElemType=nil then + MoveFast(p^,Dest,ElemSize) else + {$ifdef FPC} + FPCRecordCopy(p^,Dest,ElemType); // works for any kind of ElemTyp + {$else} + CopyArray(@Dest,p,ElemType,1); + {$endif} +end; + +procedure TDynArray.ElemMoveTo(index: PtrInt; var Dest); +var p: pointer; +begin + p := ElemPtr(index); + if (p=nil) or (@Dest=nil) then + exit; + ElemClear(Dest); + MoveFast(p^,Dest,ElemSize); + FillCharFast(p^,ElemSize,0); // ElemType=nil for ObjArray +end; + +procedure TDynArray.ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean); +var p: pointer; +begin + p := ElemPtr(index); + if p<>nil then + if ElemType=nil then + MoveFast(Source,p^,ElemSize) else begin + if ClearBeforeCopy then // safer if Source is a copy of p^ + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(p,ElemType); + {$ifdef FPC} + FPCRecordCopy(Source,p^,ElemType); + {$else} + CopyArray(p,@Source,ElemType,1); + {$endif} + end; +end; + +procedure TDynArray.Reverse; +var n, siz: PtrInt; + P1, P2: PAnsiChar; + c: AnsiChar; + i32: integer; + i64: Int64; +begin + n := GetCount-1; + if n>0 then begin + siz := ElemSize; + P1 := fValue^; + case siz of + 1: begin // optimized version for TByteDynArray and such + P2 := P1+n; + while P1MemStream.Size then + MemStream.Size := PosiEnd; + if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then + raise EStreamError.Create('TDynArray.SaveToStream: SaveTo'); + MemStream.Seek(PosiEnd,soBeginning); + end else begin + tmp := SaveTo; + if Stream.Write(pointer(tmp)^,length(tmp))<>length(tmp) then + raise EStreamError.Create('TDynArray.SaveToStream: Write error'); + end; +end; + +procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream); +var P: PAnsiChar; +begin + P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soCurrent); + Stream.Seek(LoadFrom(P,nil,false,PAnsiChar(Stream.Memory)+Stream.Size)-P,soCurrent); +end; + +function TDynArray.SaveToTypeInfoHash(crc: cardinal): cardinal; +begin + if ElemType=nil then // hash fElemSize only if no pointer within + result := crc32c(crc,@fElemSize,4) else begin + result := crc; + ManagedTypeSaveRTTIHash(ElemType,result); + end; +end; + +function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar; +var i, n, LenBytes: integer; + P: PAnsiChar; +begin + if fValue=nil then begin + result := Dest; + exit; // avoid GPF if void + end; + // store the element size+type to check for the format (name='' mostly) + Dest := PAnsiChar(ToVarUInt32(ElemSize,pointer(Dest))); + if ElemType=nil then + Dest^ := #0 else + {$ifdef FPC} + Dest^ := AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]); + {$else} + Dest^ := PAnsiChar(ElemType)^; + {$endif} + inc(Dest); + // store dynamic array count + n := GetCount; + Dest := PAnsiChar(ToVarUInt32(n,pointer(Dest))); + if n=0 then begin + result := Dest; + exit; + end; + inc(Dest,SizeOf(Cardinal)); // leave space for Hash32 checksum + result := Dest; + // store dynamic array elements content + P := fValue^; + if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes + if GetIsObjArray then + raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray', + [ArrayTypeShort^]) else begin + n := n*integer(ElemSize); // binary types: store as one + MoveFast(P^,Dest^,n); + inc(Dest,n); + end else + if PTypeKind(ElemType)^ in tkRecordTypes then + for i := 1 to n do begin + Dest := RecordSave(P^,Dest,ElemType,LenBytes); + inc(P,LenBytes); + end else + for i := 1 to n do begin + Dest := ManagedTypeSave(P,Dest,ElemType,LenBytes); + if Dest=nil then + break; + inc(P,LenBytes); + end; + // store Hash32 checksum + if Dest<>nil then // may be nil if RecordSave/ManagedTypeSave failed + PCardinal(result-SizeOf(Cardinal))^ := Hash32(pointer(result),Dest-result); + result := Dest; +end; + +function TDynArray.SaveToLength: integer; +var i,n,L,size: integer; + P: PAnsiChar; +begin + if fValue=nil then begin + result := 0; + exit; // avoid GPF if void + end; + n := GetCount; + result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1; + if n=0 then + exit; + if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes + if GetIsObjArray then + raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray', + [ArrayTypeShort^]) else + inc(result,integer(ElemSize)*n) else begin + P := fValue^; + case PTypeKind(ElemType)^ of // inlined the most used kind of items + tkLString{$ifdef FPC},tkLStringOld{$endif}: + for i := 1 to n do begin + if PPtrUInt(P)^=0 then + inc(result) else + inc(result,ToVarUInt32LengthWithData(PStrLen(PPtrUInt(P)^-_STRLEN)^)); + inc(P,SizeOf(pointer)); + end; + tkRecord{$ifdef FPC},tkObject{$endif}: + for i := 1 to n do begin + inc(result,RecordSaveLength(P^,ElemType)); + inc(P,ElemSize); + end; + else + for i := 1 to n do begin + L := ManagedTypeSaveLength(P,ElemType,size); + if L=0 then + break; // invalid record type (wrong field type) + inc(result,L); + inc(P,size); + end; + end; + end; + inc(result,SizeOf(Cardinal)); // Hash32 checksum +end; + +function TDynArray.SaveTo: RawByteString; +var Len: integer; +begin + Len := SaveToLength; + SetString(result,nil,Len); + if Len<>0 then + if SaveTo(pointer(result))-pointer(result)<>Len then + raise ESynException.Create('TDynArray.SaveTo len concern'); +end; + +function TDynArray.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8; +begin + SaveToJSON(result,EnumSetsAsText,reformat); +end; + +procedure TDynArray.SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean; + reformat: TTextWriterJSONFormat); +var temp: TTextWriterStackBuffer; +begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + if EnumSetsAsText then + CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; + AddDynArrayJSON(self); + SetText(result,reformat); + finally + Free; + end; +end; + +const + PTRSIZ = SizeOf(Pointer); + KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = ( + 0, 1,1, 2, 4,4,4, 8,8,8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ, + 16,32,64, PTRSIZ, + {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} 0); + DYNARRAY_PARSERUNKNOWN = -2; + +var // for TDynArray.LoadKnownType + KINDTYPE_INFO: array[TDynArrayKind] of pointer; + +function TDynArray.GetArrayTypeName: RawUTF8; +begin + TypeInfoToName(fTypeInfo,result); +end; + +function TDynArray.GetArrayTypeShort: PShortString; +begin // not inlined since PTypeInfo is private to implementation section + if fTypeInfo=nil then + result := @NULCHAR else + result := PShortString(@PTypeInfo(fTypeInfo).NameLen); +end; + +function TDynArray.GuessKnownType(exactType: boolean): TDynArrayKind; +const + RTTI: array[TJSONCustomParserRTTIType] of TDynArrayKind = ( + djNone, djBoolean, djByte, djCardinal, djCurrency, djDouble, djNone, djInt64, + djInteger, djQWord, djRawByteString, djNone, djRawUTF8, djNone, djSingle, + djString, djSynUnicode, djDateTime, djDateTimeMS, djHash128, djInt64, djTimeLog, + {$ifdef HASVARUSTRING} {$ifdef UNICODE}djSynUnicode{$else}djNone{$endif}, {$endif} + {$ifndef NOVARIANTS} djVariant, {$endif} djWideString, djWord, djNone); +var info: PTypeInfo; + field: PFieldInfo; +label bin, rec; +begin + result := fKnownType; + if result<>djNone then + exit; + info := fTypeInfo; + case ElemSize of // very fast guess of most known exact dynarray types + 1: if info=TypeInfo(TBooleanDynArray) then + result := djBoolean; + 4: if info=TypeInfo(TCardinalDynArray) then + result := djCardinal else + if info=TypeInfo(TSingleDynArray) then + result := djSingle + {$ifdef CPU64} ; 8: {$else} else {$endif} + if info=TypeInfo(TRawUTF8DynArray) then + result := djRawUTF8 else + if info=TypeInfo(TStringDynArray) then + result := djString else + if info=TypeInfo(TWinAnsiDynArray) then + result := djWinAnsi else + if info=TypeInfo(TRawByteStringDynArray) then + result := djRawByteString else + if info=TypeInfo(TSynUnicodeDynArray) then + result := djSynUnicode else + if (info=TypeInfo(TClassDynArray)) or + (info=TypeInfo(TPointerDynArray)) then + result := djPointer else + {$ifndef DELPHI5OROLDER} + if info=TypeInfo(TInterfaceDynArray) then + result := djInterface + {$endif DELPHI5OROLDER} + {$ifdef CPU64} else {$else} ; 8: {$endif} + if info=TypeInfo(TDoubleDynArray) then + result := djDouble else + if info=TypeInfo(TCurrencyDynArray) then + result := djCurrency else + if info=TypeInfo(TTimeLogDynArray) then + result := djTimeLog else + if info=TypeInfo(TDateTimeDynArray) then + result := djDateTime else + if info=TypeInfo(TDateTimeMSDynArray) then + result := djDateTimeMS; + end; + if result=djNone then begin // guess from RTTU + fKnownSize := 0; + if fElemType=nil then begin + {$ifdef DYNARRAYELEMTYPE2} // not backward compatible - disabled + if fElemType2<>nil then // try if a simple type known by extended RTTI + result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType2)]; + if result=djNone then + {$endif} +bin: case fElemSize of + 1: result := djByte; + 2: result := djWord; + 4: result := djInteger; + 8: result := djInt64; + 16: result := djHash128; + 32: result := djHash256; + 64: result := djHash512; + else fKnownSize := fElemSize; + end; + end else // try to guess from 1st record/object field + if not exacttype and (PTypeKind(fElemType)^ in tkRecordTypes) then begin + info := fElemType; // inlined GetTypeInfo() +rec: {$ifdef HASALIGNTYPEDATA} + info := FPCTypeInfoOverName(info); + {$else} + inc(PByte(info),info^.NameLen); + {$endif} + {$ifdef FPC_OLDRTTI} + field := OldRTTIFirstManagedField(info); + if field=nil then + {$else} + if GetManagedFields(info,field)=0 then // only binary content + {$endif} + goto Bin; + case field^.Offset of + 0: begin + info := DeRef(field^.TypeInfo); + if info=nil then // paranoid check + goto bin else + if info^.kind in tkRecordTypes then + goto rec; // nested records + result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(info)]; + if result=djNone then + goto Bin; + end; + 1: result := djByte; + 2: result := djWord; + 4: result := djInteger; + 8: result := djInt64; + 16: result := djHash128; + 32: result := djHash256; + 64: result := djHash512; + else fKnownSize := field^.Offset; + end; + end else + // will recognize simple arrays from PTypeKind(fElemType)^ + result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType)]; + end; + if KNOWNTYPE_SIZE[result]<>0 then + fKnownSize := KNOWNTYPE_SIZE[result]; + fKnownType := result; +end; + +function TDynArray.ElemCopyFirstField(Source,Dest: Pointer): boolean; +begin + if fKnownType=djNone then + GuessKnownType(false); + case fKnownType of + djBoolean..djDateTimeMS,djHash128..djHash512: // no managed field + MoveFast(Source^,Dest^,fKnownSize); + djRawUTF8, djWinAnsi, djRawByteString: + PRawByteString(Dest)^ := PRawByteString(Source)^; + djSynUnicode: + PSynUnicode(Dest)^ := PSynUnicode(Source)^; + djString: + PString(Dest)^ := PString(Source)^; + djWideString: + PWideString(Dest)^ := PWideString(Source)^; + {$ifndef NOVARIANTS}djVariant: PVariant(Dest)^ := PVariant(Source)^;{$endif} + else begin // djNone, djInterface, djCustom + result := false; + exit; + end; + end; + result := true; +end; + +function TDynArray.LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; +var info: PTypeInfo; +begin + if fKnownType=djNone then + GuessKnownType({exacttype=}false); // set fKnownType and fKnownSize + if fKnownType in [djBoolean..djDateTimeMS,djHash128..djHash512] then + if (SourceMax<>nil) and (Source+fKnownSize>SourceMax) then + result := false else begin + MoveFast(Source^,Data^,fKnownSize); + result := true; + end else begin + info := KINDTYPE_INFO[fKnownType]; + if info=nil then + result := false else + result := (ManagedTypeLoad(Data,Source,info,SourceMax)<>0) and (Source<>nil); + end; +end; + +const // kind of types which are serialized as JSON text + DJ_STRING = [djTimeLog..djHash512]; + +function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +var n, i, ValLen: integer; + T: TDynArrayKind; + wasString, expectedString, isValid: boolean; + EndOfObject: AnsiChar; + Val: PUTF8Char; + V: pointer; + CustomReader: TDynArrayJSONCustomReader; + NestedDynArray: TDynArray; +begin // code below must match TTextWriter.AddDynArrayJSON() + result := nil; + if (P=nil) or (fValue=nil) then + exit; + P := GotoNextNotSpace(P); + if P^<>'[' then begin + if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin + SetCount(0); + result := P+4; // handle 'null' as void array + end; + exit; + end; + repeat inc(P) until not(P^ in [#1..' ']); + n := JSONArrayCount(P); + if n<0 then + exit; // invalid array content + if n=0 then begin + if NextNotSpaceCharIs(P,']') then begin + SetCount(0); + result := P; + end; + exit; // handle '[]' array + end; + {$ifndef NOVARIANTS} + if CustomVariantOptions=nil then + CustomVariantOptions := @JSON_OPTIONS[true]; + {$endif} + if HasCustomJSONParser then + CustomReader := GlobalJSONCustomParsers.fParser[fParser].Reader else + CustomReader := nil; + if Assigned(CustomReader) then + T := djCustom else + T := GuessKnownType({exacttype=}true); + if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin + Count := n; // fast allocation of the whole dynamic array memory at once + for i := 0 to n-1 do begin + NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]); + P := NestedDynArray.LoadFromJSON(P,@EndOfObject{$ifndef NOVARIANTS}, + CustomVariantOptions{$endif}); + if P=nil then + exit; + EndOfObject := P^; // ',' or ']' for the last item of the array + inc(P); + end; + end else + if (T=djNone) or + (PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin + if n<>1 then + exit; // expect one Base64 encoded string value preceded by \uFFF0 + Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); + if (Val=nil) or (ValLen<3) or not wasString or + (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or + not LoadFromBinary(Base64ToBin(PAnsiChar(Val)+3,ValLen-3)) then + exit; // invalid content + end else begin + if GetIsObjArray then + for i := 0 to Count-1 do // force release any previous instance + FreeAndNil(PObjectArray(fValue^)^[i]); + SetCount(n); // fast allocation of the whole dynamic array memory at once + case T of + {$ifndef NOVARIANTS} + djVariant: + for i := 0 to n-1 do + P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,CustomVariantOptions); + {$endif} + djCustom: begin + Val := fValue^; + for i := 1 to n do begin + P := CustomReader(P,Val^,isValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); + if not isValid then + exit; + EndOfObject := P^; // ',' or ']' for the last item of the array + inc(P); + inc(Val,ElemSize); + end; + end; + else begin + V := fValue^; + expectedString := T in DJ_STRING; + for i := 0 to n-1 do begin + Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); + if (Val=nil) or (wasString<>expectedString) then + exit; + case T of + djBoolean: PBooleanArray(V)^[i] := GetBoolean(Val); + djByte: PByteArray(V)^[i] := GetCardinal(Val); + djWord: PWordArray(V)^[i] := GetCardinal(Val); + djInteger: PIntegerArray(V)^[i] := GetInteger(Val); + djCardinal: PCardinalArray(V)^[i] := GetCardinal(Val); + djSingle: PSingleArray(V)^[i] := GetExtended(Val); + djInt64: SetInt64(Val,PInt64Array(V)^[i]); + djQWord: SetQWord(Val,PQWordArray(V)^[i]); + djTimeLog: PInt64Array(V)^[i] := Iso8601ToTimeLogPUTF8Char(Val,ValLen); + djDateTime, djDateTimeMS: + Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTimeArray(V)^[i]); + djDouble: PDoubleArray(V)^[i] := GetExtended(Val); + djCurrency: PInt64Array(V)^[i] := StrToCurr64(Val); + djRawUTF8: FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); + djRawByteString: + if not Base64MagicCheckAndDecode(Val,ValLen,PRawByteStringArray(V)^[i]) then + FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); + djWinAnsi: WinAnsiConvert.UTF8BufferToAnsi(Val,ValLen,PRawByteStringArray(V)^[i]); + djString: UTF8DecodeToString(Val,ValLen,string(PPointerArray(V)^[i])); + djWideString: UTF8ToWideString(Val,ValLen,WideString(PPointerArray(V)^[i])); + djSynUnicode: UTF8ToSynUnicode(Val,ValLen,SynUnicode(PPointerArray(V)^[i])); + djHash128: if ValLen<>SizeOf(THash128)*2 then FillZero(PHash128Array(V)^[i]) else + HexDisplayToBin(pointer(Val),@PHash128Array(V)^[i],SizeOf(THash128)); + djHash256: if ValLen<>SizeOf(THash256)*2 then FillZero(PHash256Array(V)^[i]) else + HexDisplayToBin(pointer(Val),@PHash256Array(V)^[i],SizeOf(THash256)); + djHash512: if ValLen<>SizeOf(THash512)*2 then FillZero(PHash512Array(V)^[i]) else + HexDisplayToBin(pointer(Val),@PHash512Array(V)^[i],SizeOf(THash512)); + else raise ESynException.CreateUTF8('% not readable',[ToText(T)^]); + end; + end; + end; + end; + end; + if aEndOfObject<>nil then + aEndOfObject^ := EndOfObject; + if EndOfObject=']' then + if P=nil then + result := @NULCHAR else + result := P; +end; + +{$ifndef NOVARIANTS} +function TDynArray.LoadFromVariant(const DocVariant: variant): boolean; +begin + with _Safe(DocVariant)^ do + if dvoIsArray in Options then + result := LoadFromJSON(pointer(_Safe(DocVariant)^.ToJSON))<>nil else + result := false; +end; +{$endif NOVARIANTS} + +function TDynArray.LoadFromBinary(const Buffer: RawByteString; + NoCheckHash: boolean): boolean; +var P: PAnsiChar; + len: PtrInt; +begin + len := length(Buffer); + P := LoadFrom(pointer(Buffer),nil,NoCheckHash,PAnsiChar(pointer(Buffer))+len); + result := (P<>nil) and (P-pointer(Buffer)=len); +end; + +function TDynArray.LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; +var n: cardinal; +begin + // check context + result := -1; // to notify error + if (Source=nil) or (fValue=nil) then + exit; + // ignore legacy element size for cross-platform compatibility + if not FromVarUInt32(Source,SourceMax,n) or // n=0 from mORMot 2 anyway + ((SourceMax<>nil) and (PAnsiChar(Source)>=PAnsiChar(SourceMax))) then + exit; + // check stored element type + if ElemType=nil then begin + if Source^<>0 then + exit; + end else + if Source^<>{$ifdef FPC}ord(FPCTODELPHI[PTypeKind(ElemType)^]){$else} + PByte(ElemType)^{$endif} then + exit; + inc(Source); + // retrieve dynamic array count + if FromVarUInt32(Source,SourceMax,n) then + if (n=0) or (SourceMax=nil) or + (PAnsiChar(Source)+SizeOf(cardinal)nil) and (Source+n>SourceMax) then exit; + MoveFast(Source^,P^,n); + inc(Source,n); + end else + if PTypeKind(ElemType)^ in tkRecordTypes then + for i := 1 to n do begin + Source := RecordLoad(P^,Source,ElemType,nil,SourceMax); + if Source=nil then exit; + if Assigned(AfterEach) then + AfterEach(P^); + inc(P,ElemSize); + end else + for i := 1 to n do begin + ManagedTypeLoad(P,Source,ElemType,SourceMax); + if Source=nil then exit; + if Assigned(AfterEach) then + AfterEach(P^); + inc(P,ElemSize); + end; + // check security checksum (Hash[0]=0 from mORMot2 DynArraySave) + if NoCheckHash or (Source=nil) or (Hash[0]=0) or + (Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))=Hash[0]) then + result := Source; +end; + +function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare): PtrInt; +var n, L: PtrInt; + cmp: integer; + P: PAnsiChar; +begin + n := GetCount; + if (@aCompare<>nil) and (n>0) then begin + dec(n); + P := fValue^; + if (n>10) and (length(aIndex)>=n) then begin + // array should be sorted via aIndex[] -> use fast O(log(n)) binary search + L := 0; + repeat + result := (L+n) shr 1; + cmp := aCompare(P[cardinal(aIndex[result])*ElemSize],Elem); + if cmp=0 then begin + result := aIndex[result]; // returns index in TDynArray + exit; + end; + if cmp<0 then + L := result+1 else + n := result-1; + until L>n; + end else + // array is not sorted, or aIndex=nil -> use O(n) iterating search + for result := 0 to n do + if aCompare(P^,Elem)=0 then + exit else + inc(P,ElemSize); + end; + result := -1; +end; + +function TDynArray.FindIndex(const Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): PtrInt; +begin + if aIndex<>nil then + result := Find(Elem,aIndex^,aCompare) else + if Assigned(aCompare) then + result := Find(Elem,nil,aCompare) else + result := Find(Elem); +end; + +function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): integer; +begin + result := FindIndex(Elem,aIndex,aCompare); + if result>=0 then // if found, fill Elem with the matching item + ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem); +end; + +function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): integer; +begin + result := FindIndex(Elem,aIndex,aCompare); + if result>=0 then + Delete(result); +end; + +function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): integer; +begin + result := FindIndex(Elem,aIndex,aCompare); + if result>=0 then // if found, fill Elem with the matching item + ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]); +end; + +function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray; + aCompare: TDynArraySortCompare): integer; +begin + result := FindIndex(Elem,aIndex,aCompare); + if result<0 then + Add(Elem); // -1 will mark success +end; + +function TDynArray.Find(const Elem): PtrInt; +var n, L: PtrInt; + cmp: integer; + P: PAnsiChar; +begin + n := GetCount; + if (@fCompare<>nil) and (n>0) then begin + dec(n); + P := fValue^; + if fSorted and (n>10) then begin + // array is sorted -> use fast O(log(n)) binary search + L := 0; + repeat + result := (L+n) shr 1; + cmp := fCompare(P[cardinal(result)*ElemSize],Elem); + if cmp=0 then + exit; + if cmp<0 then + L := result+1 else + n := result-1; + until L>n; + end else // array is very small, or not sorted + for result := 0 to n do + if fCompare(P^,Elem)=0 then // O(n) search + exit else + inc(P,ElemSize); + end; + result := -1; +end; + +function TDynArray.FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; +var found,last: integer; + P: PAnsiChar; +begin + result := FastLocateSorted(Elem,found); + if not result then + exit; + FirstIndex := found; + P := fValue^; + while (FirstIndex>0) and (fCompare(P[cardinal(FirstIndex-1)*ElemSize],Elem)=0) do + dec(FirstIndex); + last := GetCount-1; + LastIndex := found; + while (LastIndexnil then + if n=0 then // a void array is always sorted + Index := 0 else + if fSorted then begin + P := fValue^; + dec(n); + cmp := fCompare(Elem,P[cardinal(n)*ElemSize]); + if cmp>=0 then begin // greater than last sorted item + Index := n; + if cmp=0 then + result := true else // returns true + index of existing Elem + inc(Index); // returns false + insert after last position + exit; + end; + Index := 0; + while Index<=n do begin // O(log(n)) binary search of the sorted position + i := (Index+n) shr 1; + cmp := fCompare(P[cardinal(i)*ElemSize],Elem); + if cmp=0 then begin + Index := i; // returns true + index of existing Elem + result := True; + exit; + end else + if cmp<0 then + Index := i+1 else + n := i-1; + end; + // Elem not found: returns false + the index where to insert + end else + Index := -1 else // not Sorted + Index := -1; // no fCompare() +end; + +procedure TDynArray.FastAddSorted(Index: Integer; const Elem); +begin + Insert(Index,Elem); + fSorted := true; // Insert -> SetCount -> fSorted := false +end; + +procedure TDynArray.FastDeleteSorted(Index: Integer); +begin + Delete(Index); + fSorted := true; // Delete -> SetCount -> fSorted := false +end; + +function TDynArray.FastLocateOrAddSorted(const Elem; wasAdded: PBoolean): integer; +var toInsert: boolean; +begin + toInsert := not FastLocateSorted(Elem,result) and (result>=0); + if toInsert then begin + Insert(result,Elem); + fSorted := true; // Insert -> SetCount -> fSorted := false + end; + if wasAdded<>nil then + wasAdded^ := toInsert; +end; + +type + // internal structure used to make QuickSort faster & with less stack usage + TDynArrayQuickSort = object + Compare: TDynArraySortCompare; + CompareEvent: TEventDynArraySortCompare; + Pivot: pointer; + Index: PCardinalArray; + ElemSize: cardinal; + P: PtrInt; + Value: PAnsiChar; + IP, JP: PAnsiChar; + procedure QuickSort(L, R: PtrInt); + procedure QuickSortIndexed(L, R: PtrInt); + procedure QuickSortEvent(L, R: PtrInt); + procedure QuickSortEventReverse(L, R: PtrInt); + end; + +procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; + var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean); +var QS: TDynArrayQuickSort; +begin + if CaseSensitive then + QS.Compare := SortDynArrayPUTF8Char else + QS.Compare := SortDynArrayPUTF8CharI; + QS.Value := pointer(Values); + QS.ElemSize := SizeOf(PUTF8Char); + SetLength(SortedIndexes,Count); + FillIncreasing(pointer(SortedIndexes),0,Count); + QS.Index := pointer(SortedIndexes); + QS.QuickSortIndexed(0,Count-1); +end; + +procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; + out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); +var QS: TDynArrayQuickSort; +begin + QS.Compare := Compare; + QS.Value := Values; + QS.ElemSize := ElemSize; + QS.Index := pointer(Indexes.InitIncreasing(Count)); + QS.QuickSortIndexed(0,Count-1); +end; + +procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt); +var I, J: PtrInt; + {$ifndef PUREPASCAL}tmp: pointer;{$endif} +begin + if L0 do begin + dec(J); + dec(JP,ElemSize); + end; + if I <= J then begin + if I<>J then + {$ifndef PUREPASCAL} // inlined Exchg() is just fine + if ElemSize=SizeOf(pointer) then begin + // optimized version e.g. for TRawUTF8DynArray/TObjectDynArray + tmp := PPointer(IP)^; + PPointer(IP)^ := PPointer(JP)^; + PPointer(JP)^ := tmp; + end else + {$endif} + // generic exchange of row element data + Exchg(IP,JP,ElemSize); + if P = I then P := J else + if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSort(L, J); + L := I; + end else begin + if I < R then + QuickSort(I, R); + R := J; + end; + until L >= R; +end; + +procedure TDynArrayQuickSort.QuickSortEvent(L, R: PtrInt); +var I, J: PtrInt; +begin + if L0 do begin + dec(J); + dec(JP,ElemSize); + end; + if I <= J then begin + if I<>J then + Exchg(IP,JP,ElemSize); + if P = I then P := J else + if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortEvent(L, J); + L := I; + end else begin + if I < R then + QuickSortEvent(I, R); + R := J; + end; + until L >= R; +end; + +procedure TDynArrayQuickSort.QuickSortEventReverse(L, R: PtrInt); +var I, J: PtrInt; +begin + if L0 do begin + inc(I); + inc(IP,ElemSize); + end; + while CompareEvent(JP^,Pivot^)<0 do begin + dec(J); + dec(JP,ElemSize); + end; + if I <= J then begin + if I<>J then + Exchg(IP,JP,ElemSize); + if P = I then P := J else + if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortEventReverse(L, J); + L := I; + end else begin + if I < R then + QuickSortEventReverse(I, R); + R := J; + end; + until L >= R; +end; + +procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt); +var I, J: PtrInt; + tmp: integer; +begin + if L0 do dec(J); + if I <= J then begin + if I<>J then begin + tmp := Index[I]; + Index[I] := Index[J]; + Index[J] := tmp; + end; + if P = I then P := J else + if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortIndexed(L, J); + L := I; + end else begin + if I < R then + QuickSortIndexed(I, R); + R := J; + end; + until L >= R; +end; + +procedure TDynArray.Sort(aCompare: TDynArraySortCompare); +begin + SortRange(0,Count-1,aCompare); + fSorted := true; +end; + +procedure QuickSortPtr(L, R: PtrInt; Compare: TDynArraySortCompare; V: PPointerArray); +var I, J, P: PtrInt; + tmp: pointer; +begin + if L0 do + dec(J); + if I <= J then begin + tmp := V[I]; + V[I] := V[J]; + V[J] := tmp; + if P = I then P := J else + if P = J then P := I; + Inc(I); Dec(J); + end; + until I > J; + if J - L < R - I then begin // use recursion only for smaller range + if L < J then + QuickSortPtr(L, J, Compare, V); + L := I; + end else begin + if I < R then + QuickSortPtr(I, R, Compare, V); + R := J; + end; + until L >= R; +end; + +procedure TDynArray.SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare); +var QuickSort: TDynArrayQuickSort; +begin + if aStop<=aStart then + exit; // nothing to sort + if @aCompare=nil then + Quicksort.Compare := @fCompare else + Quicksort.Compare := aCompare; + if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then + if ElemSize=SizeOf(pointer) then + QuickSortPtr(aStart,aStop,QuickSort.Compare,fValue^) else begin + Quicksort.Value := fValue^; + Quicksort.ElemSize := ElemSize; + Quicksort.QuickSort(aStart,aStop); + end; +end; + +procedure TDynArray.Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean); +var QuickSort: TDynArrayQuickSort; + R: PtrInt; +begin + if not Assigned(aCompare) or (fValue = nil) or (fValue^=nil) then + exit; // nothing to sort + Quicksort.CompareEvent := aCompare; + Quicksort.Value := fValue^; + Quicksort.ElemSize := ElemSize; + R := Count-1; + if aReverse then + Quicksort.QuickSortEventReverse(0,R) else + Quicksort.QuickSortEvent(0,R); +end; + +procedure TDynArray.CreateOrderedIndex(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); +var QuickSort: TDynArrayQuickSort; + n: integer; +begin + if @aCompare=nil then + Quicksort.Compare := @fCompare else + Quicksort.Compare := aCompare; + if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin + n := GetCount; + if length(aIndex)nil) and (fValue<>nil) and (fValue^<>nil) then begin + n := GetCount; + Quicksort.Value := fValue^; + Quicksort.ElemSize := ElemSize; + Quicksort.Index := PCardinalArray(aIndex.InitIncreasing(n)); + Quicksort.QuickSortIndexed(0,n-1); + end else + aIndex.buf := nil; // avoid GPF in aIndex.Done +end; + +procedure TDynArray.CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); +var ndx: integer; +begin + ndx := GetCount-1; + if ndx<0 then + exit; + if aIndex<>nil then begin // whole FillIncreasing(aIndex[]) for first time + if ndx>=length(aIndex) then + SetLength(aIndex,NextGrow(ndx)); // grow aIndex[] if needed + aIndex[ndx] := ndx; + end; + CreateOrderedIndex(aIndex,aCompare); +end; + +function TDynArray.ElemEquals(const A,B): boolean; +begin + if @fCompare<>nil then + result := fCompare(A,B)=0 else + if ElemType=nil then + case ElemSize of // optimized versions for arrays of common types + 1: result := byte(A)=byte(B); + 2: result := word(A)=word(B); + 4: result := cardinal(A)=cardinal(B); + 8: result := Int64(A)=Int64(B); + 16: result := IsEqual(THash128(A),THash128(B)); + else result := CompareMemFixed(@A,@B,ElemSize); // binary comparison + end else + if PTypeKind(ElemType)^ in tkRecordTypes then // most likely + result := RecordEquals(A,B,ElemType) else + result := ManagedTypeCompare(@A,@B,ElemType)>0; // other complex types +end; + +{$ifndef DELPHI5OROLDER} // disabled for Delphi 5 buggy compiler +procedure TDynArray.InitFrom(const aAnother: TDynArray; var aValue); +begin + self := aAnother; + fValue := @aValue; + fCountP := nil; +end; + +procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex: integer; + aCount: integer); +var SourceCount: integer; +begin + if (aSource.fValue<>nil) and (ArrayType=aSource.ArrayType) then begin + SourceCount := aSource.Count; + if (aCount<0) or (aCount>SourceCount) then + aCount := SourceCount; // force use of external Source.Count, if any + AddArray(aSource.fValue^,aStartIndex,aCount); + end; +end; + +function TDynArray.Equals(const B: TDynArray; ignorecompare: boolean): boolean; +var i, n: integer; + P1,P2: PAnsiChar; + A1: PPointerArray absolute P1; + A2: PPointerArray absolute P2; + function HandleObjArray: boolean; + var tmp1,tmp2: RawUTF8; + begin + SaveToJSON(tmp1); + B.SaveToJSON(tmp2); + result := tmp1=tmp2; + end; +begin + result := false; + if ArrayType<>B.ArrayType then + exit; // array types should match exactly + n := GetCount; + if n<>B.Count then + exit; + if GetIsObjArray then begin + result := HandleObjArray; + exit; + end; + P1 := fValue^; + P2 := B.fValue^; + if (@fCompare<>nil) and not ignorecompare then // use customized comparison + for i := 1 to n do + if fCompare(P1^,P2^)<>0 then + exit else begin + inc(P1,ElemSize); + inc(P2,ElemSize); + end else + if ElemType=nil then begin // binary type is compared as a whole + result := CompareMem(P1,P2,ElemSize*cardinal(n)); + exit; + end else + case PTypeKind(ElemType)^ of // some optimized versions for most used types + tkLString{$ifdef FPC},tkLStringOld{$endif}: + for i := 0 to n-1 do + if AnsiString(A1^[i])<>AnsiString(A2^[i]) then + exit; + tkWString: + for i := 0 to n-1 do + if WideString(A1^[i])<>WideString(A2^[i]) then + exit; + {$ifdef HASVARUSTRING} + tkUString: + for i := 0 to n-1 do + if UnicodeString(A1^[i])<>UnicodeString(A2^[i]) then + exit; + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: + for i := 1 to n do + if not RecordEquals(P1^,P2^,ElemType) then + exit else begin + inc(P1,ElemSize); + inc(P2,ElemSize); + end; + else // generic TypeInfoCompare() use + for i := 1 to n do + if ManagedTypeCompare(P1,P2,ElemType)<=0 then + exit else begin // A^<>B^ or unexpected type + inc(P1,ElemSize); + inc(P2,ElemSize); + end; + end; + result := true; +end; + +procedure TDynArray.Copy(const Source: TDynArray; ObjArrayByRef: boolean); +var n: Cardinal; +begin + if (fValue=nil) or (ArrayType<>Source.ArrayType) then + exit; + if (fCountP<>nil) and (Source.fCountP<>nil) then + SetCapacity(Source.GetCapacity); + n := Source.Count; + SetCount(n); + if n<>0 then + if ElemType=nil then + if not ObjArrayByRef and GetIsObjArray then + LoadFromJSON(pointer(Source.SaveToJSON)) else + MoveFast(Source.fValue^^,fValue^^,n*ElemSize) else + CopyArray(fValue^,Source.fValue^,ElemType,n); +end; + +procedure TDynArray.CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean); +var SourceDynArray: TDynArray; +begin + SourceDynArray.Init(fTypeInfo,pointer(@Source)^); + SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init() + Copy(SourceDynArray,ObjArrayByRef); +end; + +procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean); +var DestDynArray: TDynArray; +begin + DestDynArray.Init(fTypeInfo,Dest); + DestDynArray.Copy(self,ObjArrayByRef); +end; +{$endif DELPHI5OROLDER} + +function TDynArray.IndexOf(const Elem): PtrInt; +var P: PPointerArray; + max: PtrInt; +begin + if fValue<>nil then begin + max := GetCount-1; + P := fValue^; + if @Elem<>nil then + if ElemType=nil then begin + result := AnyScanIndex(P,@Elem,max+1,ElemSize); + exit; + end else + case PTypeKind(ElemType)^ of + tkLString{$ifdef FPC},tkLStringOld{$endif}: + for result := 0 to max do + if AnsiString(P^[result])=AnsiString(Elem) then exit; + tkWString: + for result := 0 to max do + if WideString(P^[result])=WideString(Elem) then exit; + {$ifdef HASVARUSTRING} + tkUString: + for result := 0 to max do + if UnicodeString(P^[result])=UnicodeString(Elem) then exit; + {$endif} + {$ifndef NOVARIANTS} + tkVariant: + for result := 0 to max do + if SortDynArrayVariantComp(PVarDataStaticArray(P)^[result], + TVarData(Elem),false)=0 then exit; + {$endif} + tkRecord{$ifdef FPC},tkObject{$endif}: + // RecordEquals() works with packed records containing binary and string types + for result := 0 to max do + if RecordEquals(P^,Elem,ElemType) then + exit else + inc(PByte(P),ElemSize); + tkInterface: + for result := 0 to max do + if P^[result]=pointer(Elem) then exit; + else + for result := 0 to max do + if ManagedTypeCompare(pointer(P),@Elem,ElemType)>0 then + exit else + inc(PByte(P),ElemSize); + end; + end; + result := -1; +end; + +procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger); +begin + fValue := @aValue; + fTypeInfo := aTypeInfo; + if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo() + raise ESynException.CreateUTF8('TDynArray.Init: % is %, expected tkDynArray', + [ArrayTypeShort^,ToText(PTypeKind(aTypeInfo)^)^]); + {$ifdef HASALIGNTYPEDATA} + aTypeInfo := FPCTypeInfoOverName(aTypeInfo); + {$else} + inc(PByte(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen); + {$endif} + fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; + fElemType := PTypeInfo(aTypeInfo)^.elType; + if fElemType<>nil then begin // inlined DeRef() + {$ifndef HASDIRECTTYPEINFO} + // FPC compatibility: if you have a GPF here at startup, your 3.1 trunk + // revision seems older than June 2016 + // -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc + // or in your project's options + fElemType := PPointer(fElemType)^; + {$endif HASDIRECTTYPEINFO} + {$ifdef FPC} + if not (PTypeKind(fElemType)^ in tkManagedTypes) then + fElemType := nil; // as with Delphi + {$endif FPC} + end; + {$ifdef DYNARRAYELEMTYPE2} // disabled not to break backward compatibility + fElemType2 := PTypeInfo(aTypeInfo)^.elType2; + {$endif} + fCountP := aCountPointer; + if fCountP<>nil then + fCountP^ := 0; + fCompare := nil; + fParser := DYNARRAY_PARSERUNKNOWN; + fKnownSize := 0; + fSorted := false; + fKnownType := djNone; + fIsObjArray := oaUnknown; +end; + +procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; + aCountPointer: PInteger; aCaseInsensitive: boolean); +var Comp: TDynArraySortCompare; +begin + Init(aTypeInfo,aValue,aCountPointer); + Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; + if @Comp=nil then + raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%', + [ArrayTypeShort^,ToText(aKind)^]); + fCompare := Comp; + fKnownType := aKind; + fKnownSize := KNOWNTYPE_SIZE[aKind]; +end; + +procedure TDynArray.UseExternalCount(var aCountPointer: Integer); +begin + fCountP := @aCountPointer; +end; + +function TDynArray.HasCustomJSONParser: boolean; +begin + if fParser=DYNARRAY_PARSERUNKNOWN then + fParser := GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType); + result := cardinal(fParser)nil); + if result then + fIsObjArray := oaTrue else + fIsObjArray := oaFalse; +end; + +procedure TDynArray.SetIsObjArray(aValue: boolean); +begin + if aValue then + fIsObjArray := oaTrue else + fIsObjArray := oaFalse; +end; + +procedure TDynArray.InternalSetLength(OldLength,NewLength: PtrUInt); +var p: PDynArrayRec; + NeededSize, minLength: PtrUInt; + pp: pointer; +begin // this method is faster than default System.DynArraySetLength() function + p := fValue^; + // check that new array length is not just a finalize in disguise + if NewLength=0 then begin + if p<>nil then begin // FastDynArrayClear() with ObjArray support + dec(p); + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin + if OldLength<>0 then + if ElemType<>nil then + FastFinalizeArray(fValue^,ElemType,OldLength) else + if GetIsObjArray then + RawObjectsClear(fValue^,OldLength); + FreeMem(p); + end; + fValue^ := nil; + end; + exit; + end; + // calculate the needed size of the resulting memory structure on heap + NeededSize := NewLength*ElemSize+SizeOf(TDynArrayRec); + {$ifndef CPU64} + if NeededSize>1024*1024*1024 then // max workable memory block is 1 GB + raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern', + [ArrayTypeShort^,NewLength]); + {$endif} + // if not shared (refCnt=1), resize; if shared, create copy (not thread safe) + if p=nil then begin + p := AllocMem(NeededSize); // RTL/OS will return zeroed memory + OldLength := NewLength; // no FillcharFast() below + end else begin + dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin + if NewLengthnil then // release managed types in trailing items + FastFinalizeArray(pointer(PAnsiChar(p)+NeededSize),ElemType,OldLength-NewLength) else + if GetIsObjArray then // FreeAndNil() of resized objects list + RawObjectsClear(pointer(PAnsiChar(p)+NeededSize),OldLength-NewLength); + ReallocMem(p,NeededSize); + end else begin // make copy + GetMem(p,NeededSize); + minLength := OldLength; + if minLength>NewLength then + minLength := NewLength; + pp := PAnsiChar(p)+SizeOf(TDynArrayRec); + if ElemType<>nil then begin + FillCharFast(pp^,minLength*elemSize,0); + CopyArray(pp,fValue^,ElemType,minLength); + end else + MoveFast(fValue^^,pp^,minLength*elemSize); + end; + end; + // set refCnt=1 and new length to the heap header + with p^ do begin + refCnt := 1; + {$ifdef FPC} + high := newLength-1; + {$else} + length := newLength; + {$endif} + end; + inc(PByte(p),SizeOf(p^)); // p^ = start of dynamic aray items + fValue^ := p; + // reset new allocated elements content to zero + if NewLength>OldLength then begin + OldLength := OldLength*elemSize; + FillCharFast(PAnsiChar(p)[OldLength],NewLength*ElemSize-OldLength,0); + end; +end; + +procedure TDynArray.SetCount(aCount: PtrInt); +const MINIMUM_SIZE = 64; +var oldlen, extcount, arrayptr, capa, delta: PtrInt; +begin + arrayptr := PtrInt(fValue); + extcount := PtrInt(fCountP); + fSorted := false; + if arrayptr=0 then + exit; // avoid GPF if void + arrayptr := PPtrInt(arrayptr)^; + if extcount<>0 then begin // fCountP^ as external capacity + oldlen := PInteger(extcount)^; + delta := aCount-oldlen; + if delta=0 then + exit; + PInteger(extcount)^ := aCount; // store new length + if arrayptr=0 then begin // void array + if (delta>0) and (aCount0 then begin // size-up + if capa>=aCount then + exit; // no need to grow + capa := NextGrow(capa); + if capa>aCount then + aCount := capa; // grow by chunks + end else // size-down + if (aCount>0) and ((capa<=MINIMUM_SIZE) or (capa-aCount realloc + InternalSetLength(oldlen,aCount); +end; + +function TDynArray.GetCapacity: PtrInt; +begin // capacity = length(DynArray) + result := PtrInt(fValue); + if result<>0 then begin + result := PPtrInt(result)^; + if result<>0 then + result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; + end; +end; + +procedure TDynArray.SetCapacity(aCapacity: PtrInt); +var oldlen,capa: PtrInt; +begin + if fValue=nil then + exit; + capa := GetCapacity; + if fCountP<>nil then begin + oldlen := fCountP^; + if oldlen>aCapacity then + fCountP^ := aCapacity; + end else + oldlen := capa; + if capa<>aCapacity then + InternalSetLength(oldlen,aCapacity); +end; + +procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare); +begin + if @aCompare<>@fCompare then begin + @fCompare := @aCompare; + fSorted := false; + end; +end; + +procedure TDynArray.Slice(var Dest; aCount, aFirstIndex: cardinal); +var n: Cardinal; + D: PPointer; + P: PAnsiChar; +begin + if fValue=nil then + exit; // avoid GPF if void + n := GetCount; + if aFirstIndex>=n then + aCount := 0 else + if aCount>=n-aFirstIndex then + aCount := n-aFirstIndex; + DynArray(ArrayType,Dest).SetCapacity(aCount); + if aCount>0 then begin + D := @Dest; + P := PAnsiChar(fValue^)+aFirstIndex*ElemSize; + if ElemType=nil then + MoveFast(P^,D^^,aCount*ElemSize) else + CopyArray(D^,P,ElemType,aCount); + end; +end; + +function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer; +var c, n: integer; + PS,PD: pointer; +begin + result := 0; + if fValue=nil then + exit; // avoid GPF if void + c := DynArrayLength(pointer(DynArrayVar)); + if aStartIndex>=c then + exit; // nothing to copy + if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(c)) then + aCount := c-aStartIndex; + if aCount<=0 then + exit; + result := aCount; + n := GetCount; + SetCount(n+aCount); + PS := pointer(PtrUInt(DynArrayVar)+cardinal(aStartIndex)*ElemSize); + PD := pointer(PtrUInt(fValue^)+cardinal(n)*ElemSize); + if ElemType=nil then + MoveFast(PS^,PD^,cardinal(aCount)*ElemSize) else + CopyArray(PD,PS,ElemType,aCount); +end; + +procedure TDynArray.ElemClear(var Elem); +begin + if @Elem=nil then + exit; // avoid GPF + if ElemType<>nil then + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(@Elem,ElemType) else + if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then + TObject(Elem).Free; + FillCharFast(Elem,ElemSize,0); // always +end; + +function TDynArray.ElemLoad(Source,SourceMax: PAnsiChar): RawByteString; +begin + if (Source<>nil) and (ElemType=nil) then + SetString(result,Source,ElemSize) else begin + SetString(result,nil,ElemSize); + FillCharFast(pointer(result)^,ElemSize,0); + ElemLoad(Source,pointer(result)^); + end; +end; + +procedure TDynArray.ElemLoadClear(var ElemTemp: RawByteString); +begin + ElemClear(pointer(ElemTemp)); + ElemTemp := ''; +end; + +procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar); +begin + if Source<>nil then // avoid GPF + if ElemType=nil then begin + if (SourceMax=nil) or (Source+ElemSize<=SourceMax) then + MoveFast(Source^,Elem,ElemSize); + end else + ManagedTypeLoad(@Elem,Source,ElemType,SourceMax); +end; + +function TDynArray.ElemSave(const Elem): RawByteString; +var itemsize: integer; +begin + if ElemType=nil then + SetString(result,PAnsiChar(@Elem),ElemSize) else begin + SetString(result,nil,ManagedTypeSaveLength(@Elem,ElemType,itemsize)); + if result<>'' then + ManagedTypeSave(@Elem,pointer(result),ElemType,itemsize); + end; +end; + +function TDynArray.ElemLoadFind(Source, SourceMax: PAnsiChar): integer; +var tmp: array[0..2047] of byte; + data: pointer; +begin + result := -1; + if (Source=nil) or (ElemSize>SizeOf(tmp)) then + exit; + if ElemType=nil then + data := Source else begin + FillCharFast(tmp,ElemSize,0); + ManagedTypeLoad(@tmp,Source,ElemType,SourceMax); + if Source=nil then + exit; + data := @tmp; + end; + try + if @fCompare=nil then + result := IndexOf(data^) else + result := Find(data^); + finally + if ElemType<>nil then + {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(data,ElemType); + end; +end; + + +{ TDynArrayLoadFrom } + +function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; Source: PAnsiChar; + SourceMaxLen: PtrInt): boolean; +var fake: pointer; +begin + result := false; + Position := nil; // force Step() to return false if called aterwards + if Source=nil then + exit; + if SourceMaxLen=0 then + PositionEnd := nil else + PositionEnd := Source+SourceMaxLen; + DynArray.Init(ArrayTypeInfo,fake); // just to retrieve RTTI + Count := DynArray.LoadFromHeader(PByte(Source),PByte(PositionEnd)); + if Count<0 then + exit; + Hash := pointer(Source); + Position := @Hash[1]; + Current := 0; + result := true; +end; + +function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; +begin + result := Init(ArrayTypeInfo,pointer(Source),length(Source)); +end; + +function TDynArrayLoadFrom.Step(out Elem): boolean; +begin + result := false; + if (Position<>nil) and (Currentnil) and (Position+DynArray.ElemSize>PositionEnd) then + exit; + MoveFast(Position^,Elem,DynArray.ElemSize); + inc(Position,DynArray.ElemSize); + end else begin + ManagedTypeLoad(@Elem,Position,DynArray.ElemType,PositionEnd); + if Position=nil then + exit; + end; + inc(Current); + result := true; + end; +end; + +function TDynArrayLoadFrom.FirstField(out Field): boolean; +begin + if (Position<>nil) and (Currentnil) and (Hash32(@Hash[1],Position-PAnsiChar(@Hash[1]))=Hash[0]); +end; + + +{ TDynArrayHasher } + +function HashFile(const FileName: TFileName; Hasher: THasher): cardinal; +var buf: array[word] of cardinal; // 256KB of buffer + read: integer; + f: THandle; +begin + if not Assigned(Hasher) then + Hasher := DefaultHasher; + result := 0; + f := FileOpenSequentialRead(FileName); + if PtrInt(f)>=0 then begin + repeat + read := FileRead(f,buf,SizeOf(buf)); + if read<=0 then + break; + result := Hasher(result,@buf,read); + until false; + FileClose(f); + end; +end; + +function HashAnsiString(const Elem; Hasher: THasher): cardinal; +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,Pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^); +end; + +function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; +var tmp: array[byte] of AnsiChar; // avoid slow heap allocation +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,tmp,UpperCopy255Buf(tmp, + pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^)-tmp); +end; + +{$ifdef UNICODE} + +function HashUnicodeString(const Elem; Hasher: THasher): cardinal; +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2); +end; + +function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; +var tmp: array[byte] of AnsiChar; // avoid slow heap allocation +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp); +end; + +{$endif UNICODE} + +function HashSynUnicode(const Elem; Hasher: THasher): cardinal; +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2); +end; + +function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; +var tmp: array[byte] of AnsiChar; // avoid slow heap allocation +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp); +end; + +function HashWideString(const Elem; Hasher: THasher): cardinal; +begin // WideString internal size is in bytes, not WideChar + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2); +end; + +function HashWideStringI(const Elem; Hasher: THasher): cardinal; +var tmp: array[byte] of AnsiChar; // avoid slow heap allocation +begin + if PtrUInt(Elem)=0 then + result := 0 else + result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp); +end; + +function HashPtrUInt(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(PtrUInt)); +end; + +function HashPointer(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(pointer)); +end; + +function HashByte(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(byte)); +end; + +function HashWord(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(word)); +end; + +function HashInteger(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(integer)); +end; + +function HashInt64(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(Int64)); +end; + +function Hash128(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(THash128)); +end; + +function Hash256(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(THash256)); +end; + +function Hash512(const Elem; Hasher: THasher): cardinal; +begin + result := Hasher(0,@Elem,SizeOf(THash512)); +end; + +{$ifndef NOVARIANTS} +function VariantHash(const value: variant; CaseInsensitive: boolean; + Hasher: THasher): cardinal; +var Up: array[byte] of AnsiChar; // avoid heap allocation + vt: cardinal; + procedure ComplexType; + var tmp: RawUTF8; + begin // slow but always working conversion to string + VariantSaveJSON(value,twNone,tmp); + if CaseInsensitive then + result := Hasher(vt,Up,UpperCopy255(Up,tmp)-Up) else + result := Hasher(vt,pointer(tmp),length(tmp)); + end; +begin + if not Assigned(Hasher) then + Hasher := DefaultHasher; + vt := TVarData(value).VType; + with TVarData(value) do + case vt of + varNull, varEmpty: + result := vt; // good enough for void values + varShortInt, varByte: + result := Hasher(vt,@VByte,1); + varSmallint, varWord, varBoolean: + result := Hasher(vt,@VWord,2); + varLongWord, varInteger, varSingle: + result := Hasher(vt,@VLongWord,4); + varInt64, varDouble, varDate, varCurrency, varWord64: + result := Hasher(vt,@VInt64,SizeOf(Int64)); + varString: + if CaseInsensitive then + result := Hasher(vt,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else + result := Hasher(vt,VString,length(RawUTF8(VString))); + varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: + if CaseInsensitive then + result := Hasher(vt,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else + result := Hasher(vt,VAny,StrLenW(VOleStr)*2); + else + ComplexType; + end; +end; + +function HashVariant(const Elem; Hasher: THasher): cardinal; +begin + result := VariantHash(variant(Elem),false,Hasher); +end; + +function HashVariantI(const Elem; Hasher: THasher): cardinal; +begin + result := VariantHash(variant(Elem),true,Hasher); +end; +{$endif NOVARIANTS} + +procedure TDynArrayHasher.Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; + aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; + aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); +begin + DynArray := aDynArray; + if @aHasher=nil then + Hasher := DefaultHasher else + Hasher := aHasher; + HashElement := aHashElement; + EventHash := aEventHash; + if (@HashElement=nil) and (@EventHash=nil) then // fallback to first field RTTI + HashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; + Compare := aCompare; + EventCompare := aEventCompare; + if (@Compare=nil) and (@EventCompare=nil) then + Compare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; + CountTrigger := 32; + Clear; +end; + +procedure TDynArrayHasher.InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; + aCaseInsensitive: boolean); +var cmp: TDynArraySortCompare; + hsh: TDynArrayHashOne; +begin + cmp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; + hsh := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind]; + if (@hsh=nil) or (@cmp=nil) then + raise ESynException.CreateUTF8('TDynArrayHasher.InitSpecific: %?',[ToText(aKind)^]); + Init(aDynArray,hsh,nil,nil,cmp,nil,aCaseInsensitive) +end; + +procedure TDynArrayHasher.Clear; +begin + HashTable := nil; + HashTableSize := 0; + ScanCounter := 0; + if Assigned(HashElement) or Assigned(EventHash) then + State := [hasHasher] else + byte(State) := 0; +end; + +function TDynArrayHasher.HashOne(Elem: pointer): cardinal; +begin + if Assigned(EventHash) then + result := EventHash(Elem^) else + if Assigned(HashElement) then + result := HashElement(Elem^,Hasher) else + result := 0; // will be ignored afterwards for sure +end; + +const // primes reduce memory consumption and enhance distribution + _PRIMES: array[0..38{$ifndef CPU32DELPHI}+15{$endif}] of integer = ( + {$ifndef CPU32DELPHI} 31, 127, 251, 499, 797, 1259, 2011, 3203, 5087, 8089, + 12853, 20399, 81649, 129607, 205759, {$endif} + // following HASH_PO2=2^18=262144 for Delphi Win32 + 326617, 411527, 518509, 653267, 823117, 1037059, 1306601, 1646237, + 2074129, 2613229, 3292489, 4148279, 5226491, 6584983, 8296553, 10453007, + 13169977, 16593127, 20906033, 26339969, 33186281, 41812097, 52679969, + 66372617, 83624237, 105359939, 132745199, 167248483, 210719881, 265490441, + 334496971, 421439783, 530980861, 668993977, 842879579, 1061961721, + 1337987929, 1685759167, 2123923447); + +function NextPrime(v: integer): integer; {$ifdef HASINLINE}inline;{$endif} +var i: PtrInt; + P: PIntegerArray; +begin + P := @_PRIMES; + for i := 0 to high(_PRIMES) do begin + result := P^[i]; + if result>v then + exit; + end; +end; + +function TDynArrayHasher.HashTableIndex(aHashCode: cardinal): cardinal; +begin + result := HashTableSize; + {$ifdef CPU32DELPHI} // Delphi Win32 is not efficient with 64-bit multiplication + if result>HASH_PO2 then + result := aHashCode mod result else + result := aHashCode and (result-1); + {$else} // FPC or dcc64 compile next line as very optimized asm + result := (QWord(aHashCode)*result)shr 32; + // see https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction + {$endif CPU32DELPHI} +end; + +function TDynArrayHasher.Find(aHashCode: cardinal; aForAdd: boolean): integer; +var first,last: integer; + ndx,siz: PtrInt; + P: PAnsiChar; +begin + P := DynArray^.Value^; + siz := DynArray^.ElemSize; + if not(canHash in State) then begin // Count=0 or Count search once from HashTable[0] to HashTable[first-1] + if result=first then + break else begin + result := 0; + last := first; + end; + until false; + RaiseFatalCollision('Find',aHashCode); +end; + +function TDynArrayHasher.FindOrNew(aHashCode: cardinal; Elem: pointer; + aHashTableIndex: PInteger): integer; +var first,last,ndx,cmp: integer; + P: PAnsiChar; +begin + if not(canHash in State) then begin // e.g. Countnil then + aHashTableIndex^ := result; + result := ndx; + exit; + end; + // hash or slot collision -> search next item + {$ifdef DYNARRAYHASHCOLLISIONCOUNT} + inc(FindCollisions); + {$endif} + //inc(TDynArrayHashedCollisionCount); + inc(result); + if result=last then + // reached the end -> search once from HashTable[0] to HashTable[first-1] + if result=first then + break else begin + result := 0; + last := first; + end; + until false; + RaiseFatalCollision('FindOrNew',aHashCode); +end; + +procedure TDynArrayHasher.HashAdd(aHashCode: cardinal; var result: integer); +var n: integer; +begin // on input: HashTable[result] slot is already computed + n := DynArray^.Count; + if HashTableSize=0 then + RaiseFatalCollision('HashAdd',aHashCode); + end; + HashTable[-result-1] := n+1; // store Index+1 (0 means void slot) + result := n; +end; // on output: result holds the position in fValue[] + + +// brute force O(n) indexes fix after deletion (much faster than full ReHash) +procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt); +{$ifdef CPUX64ASM} // SSE2 simd is 25x faster than "if P^>deleted then dec(P^)" +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=P, edx=deleted, r8=count (Linux: rdi,esi,rdx) +{$endif FPC} +{$ifdef Linux} + mov r8, rdx + mov rcx, rdi + mov rdx, rsi +{$endif Linux} + xor eax, eax // reset eax high bits for setg al below + movq xmm0, rdx // xmm0 = 128-bit of quad deleted + pshufd xmm0, xmm0, 0 + test cl, 3 + jnz @1 // paranoid: a dword dynamic array is always dword-aligned + // ensure P is 256-bit aligned (for avx2) +@align: test cl, 31 + jz @ok + cmp dword ptr[rcx], edx + setg al // P[]>deleted -> al=1, 0 otherwise + sub dword ptr[rcx], eax // branchless dec(P[]) + add rcx, 4 + dec r8 + jmp @align +@ok: {$ifdef FPC} // AVX2 asm is not supported by Delphi (even 10.3) :( + test byte ptr[rip+CPUIDX64], 1 shl cpuAVX2 + jz @sse2 + vpshufd ymm0, ymm0, 0 // shuffle to ymm0 128-bit low lane + vperm2f128 ymm0, ymm0, ymm0, 0 // copy to ymm0 128-bit high lane + // avx process of 128 bytes (32 indexes) per loop iteration + align 16 +@avx2: sub r8, 32 + vmovdqa ymm1, [rcx] // 4 x 256-bit process = 4 x 8 integers + vmovdqa ymm3, [rcx + 32] + vmovdqa ymm5, [rcx + 64] + vmovdqa ymm7, [rcx + 96] + vpcmpgtd ymm2, ymm1, ymm0 // compare P[]>deleted -> -1, 0 otherwise + vpcmpgtd ymm4, ymm3, ymm0 + vpcmpgtd ymm6, ymm5, ymm0 + vpcmpgtd ymm8, ymm7, ymm0 + vpaddd ymm1, ymm1, ymm2 // adjust by adding -1 / 0 + vpaddd ymm3, ymm3, ymm4 + vpaddd ymm5, ymm5, ymm6 + vpaddd ymm7, ymm7, ymm8 + vmovdqa [rcx], ymm1 + vmovdqa [rcx + 32], ymm3 + vmovdqa [rcx + 64], ymm5 + vmovdqa [rcx + 96], ymm7 + add rcx, 128 + cmp r8, 32 + jae @avx2 + vzeroupper + jmp @2 + {$endif FPC} + // SSE2 process of 64 bytes (16 indexes) per loop iteration +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@sse2: sub r8, 16 + movaps xmm1, dqword [rcx] // 4 x 128-bit process = 4 x 4 integers + movaps xmm3, dqword [rcx + 16] + movaps xmm5, dqword [rcx + 32] + movaps xmm7, dqword [rcx + 48] + movaps xmm2, xmm1 // keep copy for paddd below + movaps xmm4, xmm3 + movaps xmm6, xmm5 + movaps xmm8, xmm7 + pcmpgtd xmm1, xmm0 // quad compare P[]>deleted -> -1, 0 otherwise + pcmpgtd xmm3, xmm0 + pcmpgtd xmm5, xmm0 + pcmpgtd xmm7, xmm0 + paddd xmm1, xmm2 // quad adjust by adding -1 / 0 + paddd xmm3, xmm4 + paddd xmm5, xmm6 + paddd xmm7, xmm8 + movaps dqword [rcx], xmm1 // quad store back + movaps dqword [rcx + 16], xmm3 + movaps dqword [rcx + 32], xmm5 + movaps dqword [rcx + 48], xmm7 + add rcx, 64 + cmp r8, 16 + jae @sse2 + jmp @2 + // trailing indexes +@1: dec r8 + cmp dword ptr[rcx + r8 * 4], edx + setg al + sub dword ptr[rcx + r8 * 4], eax +@2: test r8, r8 + jnz @1 +end; +{$else} +begin + repeat + dec(count,8); + dec(P[0],ord(P[0]>deleted)); // branchless code is 10x faster than if :) + dec(P[1],ord(P[1]>deleted)); + dec(P[2],ord(P[2]>deleted)); + dec(P[3],ord(P[3]>deleted)); + dec(P[4],ord(P[4]>deleted)); + dec(P[5],ord(P[5]>deleted)); + dec(P[6],ord(P[6]>deleted)); + dec(P[7],ord(P[7]>deleted)); + P := @P[8]; + until count<8; + while count>0 do begin + dec(count); + dec(P[count],ord(P[count]>deleted)); + end; +end; +{$endif CPUX64ASM} // SSE2 asm is invalid prior to Delphi XE7 (to be refined) + +// with x86_64/sse2 for 200,000 items: adjust=200.57ms (11.4GB/s) hash=2.46ms +// -> TDynArray.Delete move() takes more time than the HashTable update :) + +{ some numbers, with CITIES_MAX=200000, deleting 1/128 entries + first column (3..23) is the max number of indexes[] chunk to rehash +1. naive loop + for i := 0 to HashTableSize-1 do + if HashTable[i]>aArrayIndex then + dec(HashTable[i]); + 3 #257 adjust=7.95ms 191.7MB hash=8us + 8 #384 adjust=11.93ms 255.8MB hash=10us + 11 #1019 adjust=32.09ms 332.8MB hash=26us + 13 #16259 adjust=511.10ms 379.2MB hash=230us + 13 #32515 adjust=1.01s 383.6MB/s hash=440us + 14 #33531 adjust=1.04s 382.2MB hash=459us + 17 #46612 adjust=1.44s 386.3MB hash=639us + 17 #65027 adjust=1.97s 396.3MB/s hash=916us + 17 #97539 adjust=2.79s 419.9MB/s hash=1.37ms + 18 #109858 adjust=3.05s 431.2MB hash=1.51ms + 18 #130051 adjust=3.44s 454.1MB/s hash=1.75ms + 18 #162563 adjust=3.93s 496.9MB/s hash=2.14ms + 23 #172723 adjust=4.05s 511.7MB hash=2.26ms + 23 #195075 adjust=4.27s 548.6MB/s hash=2.47ms +2. branchless pure pascal code is about 10x faster! + 3 #257 adjust=670us 2.2GB hash=8us + 8 #384 adjust=1ms 2.9GB hash=9us + 11 #1019 adjust=2.70ms 3.8GB hash=21us + 13 #16259 adjust=43.65ms 4.3GB hash=210us + 13 #32515 adjust=87.75ms 4.3GB/s hash=423us + 14 #33531 adjust=90.44ms 4.3GB hash=441us + 17 #46612 adjust=127.68ms 4.2GB hash=627us + 17 #65027 adjust=179.64ms 4.2GB/s hash=908us + 17 #97539 adjust=267.44ms 4.2GB/s hash=1.35ms + 18 #109858 adjust=301.27ms 4.2GB hash=1.50ms + 18 #130051 adjust=355.37ms 4.2GB/s hash=1.74ms + 18 #162563 adjust=438.79ms 4.3GB/s hash=2.11ms + 23 #172723 adjust=465.23ms 4.3GB hash=2.23ms + 23 #195075 adjust=520.85ms 4.3GB/s hash=2.45ms +3. SSE2 simd assembly makes about 3x improvement + 3 #257 adjust=290us 5.1GB hash=8us + 8 #384 adjust=427us 6.9GB hash=10us + 11 #1019 adjust=1.11ms 9.3GB hash=20us + 13 #16259 adjust=18.33ms 10.3GB hash=219us + 13 #32515 adjust=36.32ms 10.5GB/s hash=435us + 14 #33531 adjust=37.39ms 10.4GB hash=452us + 17 #46612 adjust=51.70ms 10.5GB hash=622us + 17 #65027 adjust=72.47ms 10.5GB/s hash=893us + 17 #97539 adjust=107ms 10.6GB/s hash=1.32ms + 18 #109858 adjust=120.08ms 10.7GB hash=1.46ms + 18 #130051 adjust=140.50ms 10.8GB/s hash=1.71ms + 18 #162563 adjust=171.44ms 11.1GB/s hash=2.10ms + 23 #172723 adjust=181.02ms 11.1GB hash=2.22ms + 23 #195075 adjust=201.53ms 11.3GB/s hash=2.44ms +4. AVX2 simd assembly gives some additional 40% (consistent on my iCore3 cpu) + 3 #257 adjust=262us 5.6GB hash=8us + 8 #384 adjust=383us 7.7GB hash=10us + 11 #1019 adjust=994us 10.4GB hash=21us + 13 #16259 adjust=16.34ms 11.5GB hash=248us + 13 #32515 adjust=32.12ms 11.8GB/s hash=464us + 14 #33531 adjust=33.06ms 11.8GB hash=484us + 17 #46612 adjust=45.49ms 11.9GB hash=678us + 17 #65027 adjust=62.36ms 12.2GB/s hash=966us + 17 #97539 adjust=90.80ms 12.6GB/s hash=1.43ms + 18 #109858 adjust=101.82ms 12.6GB hash=1.59ms + 18 #130051 adjust=117.37ms 13GB/s hash=1.83ms + 18 #162563 adjust=140.08ms 13.6GB/s hash=2.23ms + 23 #172723 adjust=147.20ms 13.7GB hash=2.34ms + 23 #195075 adjust=161.73ms 14.1GB/s hash=2.57ms +} +procedure TDynArrayHasher.HashDelete(aArrayIndex,aHashTableIndex: integer; aHashCode: cardinal); +var first,next,last,ndx,i,n: integer; + P: PAnsiChar; + indexes: array[0..511] of cardinal; // to be rehashed +begin + // retrieve hash table entries to be recomputed + first := aHashTableIndex; + last := HashTableSize; + next := first; + n := 0; + repeat + HashTable[next] := 0; // Clear slots + inc(next); + if next=last then + if next=first then + RaiseFatalCollision('HashDelete down',aHashCode) else begin + next := 0; + last := first; + end; + ndx := HashTable[next]-1; // stored index+1 + if ndx<0 then + break; // stop at void entry + if n=high(indexes) then // typical 0..23 + RaiseFatalCollision('HashDelete indexes overflow',aHashCode); + indexes[n] := ndx; + inc(n); + until false; + // ReHash collided entries - note: item is not yet deleted in Value^[] + for i := 0 to n-1 do begin + P := PAnsiChar(DynArray^.Value^)+indexes[i]*DynArray^.ElemSize; + ndx := FindOrNew(HashOne(P),P,nil); + if ndx<0 then + HashTable[-ndx-1] := indexes[i]+1; // ignore ndx>=0 dups (like ReHash) + end; + // adjust all stored indexes + DynArrayHashTableAdjust(pointer(HashTable),aArrayIndex,HashTableSize); +end; + +function TDynArrayHasher.FindBeforeAdd(Elem: pointer; + out wasAdded: boolean; aHashCode: cardinal): integer; +var n: integer; +begin + wasAdded := false; + if not(canHash in State) then begin + n := DynArray^.Count; + if n=0 then + exit; // item found + if not(canHash in State) then begin + wasadded := true; + result := n; + exit; + end; + end; + end; + if not(canHash in State) then + ReHash({forced=}true); // hash previous CountTrigger items + result := FindOrNew(aHashCode,Elem,nil); + if result<0 then begin // found no matching item + wasAdded := true; + HashAdd(aHashCode,result); + end; +end; + +function TDynArrayHasher.FindBeforeDelete(Elem: pointer): integer; +var hc: cardinal; + ht: integer; +begin + if canHash in State then begin + hc := HashOne(Elem); + result := FindOrNew(hc,Elem,@ht); + if result<0 then + result := -1 else + HashDelete(result,ht,hc); + end else + result := Scan(Elem); +end; + +procedure TDynArrayHasher.RaiseFatalCollision(const caller: RawUTF8; + aHashCode: cardinal); +begin // a dedicated sub-procedure reduces code size + raise ESynException.CreateUTF8('TDynArrayHasher.% fatal collision: '+ + 'aHashCode=% HashTableSize=% Count=% Capacity=% ArrayType=% KnownType=%', + [caller,CardinalToHexShort(aHashCode),HashTableSize,DynArray^.Count, + DynArray^.Capacity,DynArray^.ArrayTypeShort^,ToText(DynArray^.KnownType)^]); +end; + +function TDynArrayHasher.GetHashFromIndex(aIndex: PtrInt): cardinal; +var P: pointer; +begin + P := DynArray^.ElemPtr(aIndex); + if P<>nil then + result := HashOne(P) else + result := 0; +end; + +procedure TDynArrayHasher.SetEventHash(const event: TEventDynArrayHashOne); +begin + EventHash := event; + Clear; +end; + +function TDynArrayHasher.Scan(Elem: pointer): integer; +var P: PAnsiChar; + i,max: integer; + siz: PtrInt; +begin + result := -1; + max := DynArray^.Count-1; + P := DynArray^.Value^; + siz := DynArray^.ElemSize; + if Assigned(EventCompare) then // custom comparison + for i := 0 to max do + if EventCompare(P^,Elem^)=0 then begin + result := i; + break; + end else + inc(P,siz) else + if Assigned(Compare) then + for i := 0 to max do + if Compare(P^,Elem^)=0 then begin + result := i; + break; + end else + inc(P,siz); + // enable hashing if Scan() called 2*CountTrigger + if (hasHasher in State) and (max>7) then begin + inc(ScanCounter); + if ScanCounter>=CountTrigger*2 then begin + CountTrigger := 2; // rather use hashing from now on + ReHash(false); // set HashTable[] and canHash + end; + end; +end; + +function TDynArrayHasher.Find(Elem: pointer): integer; +begin + result := Find(Elem,HashOne(Elem)); +end; + +function TDynArrayHasher.Find(Elem: pointer; aHashCode: cardinal): integer; +begin + result := FindOrNew(aHashCode,Elem,nil); // fallback to Scan() if needed + if result<0 then + result := -1; // for coherency with most search methods +end; + +function TDynArrayHasher.ReHash(forced: boolean): integer; +var i, n, cap, siz, ndx: integer; + P: PAnsiChar; + hc: cardinal; +begin + result := 0; + n := DynArray^.Count; + if not (Assigned(HashElement) or Assigned(EventHash)) or + (not forced and ((n=0) or (n=0 then + inc(result) else // found duplicated value + HashTable[-ndx-1] := i; // store index+1 (0 means void entry) + inc(P,DynArray^.ElemSize); + end; +end; + + +{ TDynArrayHashed } + +{$ifdef UNDIRECTDYNARRAY} // some Delphi 2009+ wrapper definitions + +function TDynArrayHashed.GetCount: PtrInt; +begin + result := InternalDynArray.GetCount; +end; +procedure TDynArrayHashed.SetCount(aCount: PtrInt); +begin + InternalDynArray.SetCount(aCount); +end; +function TDynArrayHashed.GetCapacity: PtrInt; +begin + result := InternalDynArray.GetCapacity; +end; +procedure TDynArrayHashed.SetCapacity(aCapacity: PtrInt); +begin + InternalDynArray.SetCapacity(aCapacity); +end; +function TDynArrayHashed.Value: PPointer; +begin + result := InternalDynArray.fValue; +end; +function TDynArrayHashed.ElemSize: PtrUInt; +begin + result := InternalDynArray.fElemSize; +end; +function TDynArrayHashed.ElemType: Pointer; +begin + result := InternalDynArray.fElemType; +end; +procedure TDynArrayHashed.ElemCopy(const A; var B); +begin + InternalDynArray.ElemCopy(A,B); +end; +function TDynArrayHashed.ElemPtr(index: PtrInt): pointer; +begin + result := InternalDynArray.ElemPtr(index); +end; +procedure TDynArrayHashed.ElemCopyAt(index: PtrInt; var Dest); +begin + InternalDynArray.ElemCopyAt(index,Dest); +end; +function TDynArrayHashed.KnownType: TDynArrayKind; +begin + result := InternalDynArray.KnownType; +end; +procedure TDynArrayHashed.Clear; +begin + InternalDynArray.SetCount(0); +end; +function TDynArrayHashed.Add(const Elem): integer; +begin + result := InternalDynArray.Add(Elem); +end; +procedure TDynArrayHashed.Delete(aIndex: PtrInt); +begin + InternalDynArray.Delete(aIndex); +end; +function TDynArrayHashed.SaveTo: RawByteString; +begin + result := InternalDynArray.SaveTo; +end; +function TDynArrayHashed.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom; + NoCheckHash: boolean; SourceMax: PAnsiChar): PAnsiChar; +begin + result := InternalDynArray.LoadFrom(Source,AfterEach,NoCheckHash,SourceMax); +end; +function TDynArrayHashed.LoadFromBinary(const Buffer: RawByteString; NoCheckHash: boolean): boolean; +begin + result := InternalDynArray.LoadFromBinary(Buffer,NoCheckHash); +end; +function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar; +begin + result := InternalDynArray.SaveTo(Dest); +end; +function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean; + reformat: TTextWriterJSONFormat): RawUTF8; +begin + result := InternalDynArray.SaveToJSON(EnumSetsAsText,reformat); +end; +procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare); +begin + InternalDynArray.Sort(aCompare); +end; +procedure TDynArrayHashed.CreateOrderedIndex(var aIndex: TIntegerDynArray; + aCompare: TDynArraySortCompare); +begin + InternalDynArray.CreateOrderedIndex(aIndex,aCompare); +end; +function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; +begin + result := InternalDynArray.LoadFromJSON(P,aEndOfObject{$ifndef NOVARIANTS}, + CustomVariantOptions{$endif}); +end; +function TDynArrayHashed.SaveToLength: integer; +begin + result := InternalDynArray.SaveToLength; +end; + +{$endif UNDIRECTDYNARRAY} + +procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue; + aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; + aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean); +begin + {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} + Init(aTypeInfo,aValue,aCountPointer); + fHash.Init(@self,aHashElement,nil,aHasher,aCompare,nil,aCaseInsensitive); + {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetCompare(fHash.Compare); +end; + +procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue; + aKind: TDynArrayKind; aCountPointer: PInteger; aCaseInsensitive: boolean); +begin + {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} + Init(aTypeInfo,aValue,aCountPointer); + fHash.InitSpecific(@self,aKind,aCaseInsensitive); + {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin + fCompare := fHash.Compare; + fKnownType := aKind; + fKnownSize := KNOWNTYPE_SIZE[aKind]; + end; +end; + +function TDynArrayHashed.Scan(const Elem): integer; +begin + result := fHash.Scan(@Elem); +end; + +function TDynArrayHashed.FindHashed(const Elem): integer; +begin + result := fHash.FindOrNew(fHash.HashOne(@Elem),@Elem); + if result<0 then + result := -1; // for coherency with most methods +end; + +function TDynArrayHashed.FindFromHash(const Elem; aHashCode: cardinal): integer; +begin // overload FindHashed() trigger F2084 Internal Error: C2130 on Delphi XE3 + result := fHash.FindOrNew(aHashCode,@Elem); // fallback to Scan() if needed + if result<0 then + result := -1; // for coherency with most methods +end; + +function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; + noAddEntry: boolean): integer; +begin + result := FindHashedForAdding(Elem,wasAdded,fHash.HashOne(@Elem),noAddEntry); +end; + +function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; + aHashCode: cardinal; noAddEntry: boolean): integer; +begin + result := fHash.FindBeforeAdd(@Elem,wasAdded,aHashCode); + if wasAdded and not noAddEntry then + SetCount(result+1); // reserve space for a void element in array +end; + +function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer; +var ndx,j: integer; + added: boolean; + aName_: RawUTF8; +begin + if aName='' then + aName := '_'; + ndx := FindHashedForAdding(aName,added); + if not added then begin // force unique column name + aName_ := aName+'_'; + j := 1; + repeat + aName := aName_+UInt32ToUTF8(j); + ndx := FindHashedForAdding(aName,added); + inc(j); + until added; + end; + result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; + PRawUTF8(result)^ := aName; // store unique name at 1st elem position +end; + +function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger): pointer; +begin + result := AddUniqueName(aName,'',[],aNewIndex); +end; + +function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; + const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const; aNewIndex: PInteger): pointer; +var ndx: integer; + added: boolean; +begin + ndx := FindHashedForAdding(aName,added); + if added then begin + if aNewIndex<>nil then + aNewIndex^ := ndx; + result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; + PRawUTF8(result)^ := aName; // store unique name at 1st elem position + end else + if ExceptionMsg='' then + raise ESynException.CreateUTF8('Duplicated [%] name',[aName]) else + raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs); +end; + +function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer; +begin + result := fHash.FindOrNew(fHash.HashOne(@ElemtoFill),@ElemToFill); + if result<0 then + result := -1 else + ElemCopy(PAnsiChar(Value^)[cardinal(result)*ElemSize],ElemToFill); +end; + +procedure TDynArrayHashed.SetEventHash(const event: TEventDynArrayHashOne); +begin + fHash.SetEventHash(event); +end; + +function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; +var hc: cardinal; +label doh; +begin + if canHash in fHash.State then begin +doh:hc := fHash.HashOne(@Elem); + result := fHash.FindOrNew(hc,@Elem); + if (result<0) and AddIfNotExisting then begin + fHash.HashAdd(hc,result); // ReHash only if necessary + SetCount(result+1); // add new item + end; + end else begin + result := fHash.Scan(@Elem); + if result<0 then begin + if AddIfNotExisting then + if canHash in fHash.State then // Scan triggered ReHash + goto doh else begin + result := Add(Elem); // regular Add + exit; + end; + end; + end; + if result>=0 then + ElemCopy(Elem,PAnsiChar(Value^)[cardinal(result)*ElemSize]); // update +end; + +function TDynArrayHashed.FindHashedAndDelete(const Elem; FillDeleted: pointer; + noDeleteEntry: boolean): integer; +begin + result := fHash.FindBeforeDelete(@Elem); + if result>=0 then begin + if FillDeleted<>nil then + ElemCopyAt(result,FillDeleted^); + if not noDeleteEntry then + Delete(result); + end; +end; + +function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): Cardinal; +begin + result := fHash.GetHashFromIndex(aIndex); +end; + +function TDynArrayHashed.ReHash(forAdd: boolean): integer; +begin + result := fHash.ReHash(forAdd); +end; + + +function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger): TDynArray; +begin + result.Init(aTypeInfo,aValue,aCountPointer); +end; + +function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; + var Count, ElemSize: integer; NoHash32Check: boolean): pointer; +var Hash: PCardinalArray absolute Source; + info: PTypeInfo; +begin + result := nil; + info := GetTypeInfo(aTypeInfo,tkDynArray); + if info=nil then + exit; // invalid type information + ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; + if (info^.ElType<>nil) or (Source=nil) or + (Source[0]<>AnsiChar(ElemSize)) or (Source[1]<>#0) then + exit; // invalid type information or Source content + inc(Source,2); + Count := FromVarUInt32(PByte(Source)); // dynamic array count + if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*ElemSize)=Hash[0])) then + result := @Hash[1]; // returns valid Source content +end; + +function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; + NoHash32Check: boolean): PIntegerArray; +var Hash: PCardinalArray absolute Source; +begin + result := nil; + if (Source=nil) or (Source[0]<>#4) or (Source[1]<>#0) then + exit; // invalid Source content + inc(Source,2); + Count := FromVarUInt32(PByte(Source)); // dynamic array count + if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*4)=Hash[0])) then + result := @Hash[1]; // returns valid Source content +end; + +function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; + Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; +var Count, Len: PtrInt; +begin + if (Value=nil) or (ValueLen=0) or + (Source=nil) or (Source[0]<>AnsiChar(SizeOf(PtrInt))) + {$ifndef FPC}or (Source[1]<>AnsiChar(tkLString)){$endif} then begin + result := -1; + exit; // invalid Source or Value content + end; + inc(Source,2); + Count := FromVarUInt32(PByte(Source)); // dynamic array count + inc(Source,SizeOf(cardinal)); // ignore Hash32 security checksum + for result := 0 to Count-1 do begin + Len := FromVarUInt32(PByte(Source)); + if CaseSensitive then begin + if (Len=ValueLen) and CompareMemFixed(Value,Source,Len) then + exit; + end else + if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then + exit; + inc(Source,Len); + end; + result := -1; +end; + + +{ TObjectDynArrayWrapper } + +constructor TObjectDynArrayWrapper.Create(var aValue; aOwnObjects: boolean); +begin + fValue := @aValue; + fOwnObjects := aOwnObjects; +end; + +destructor TObjectDynArrayWrapper.Destroy; +begin + Clear; + inherited; +end; + +function TObjectDynArrayWrapper.Find(Instance: TObject): integer; +var P: PObjectArray; +begin + P := fValue^; + if P<>nil then + for result := 0 to fCount-1 do + if P[result]=Instance then + exit; + result := -1; +end; + +function TObjectDynArrayWrapper.Add(Instance: TObject): integer; +var cap: integer; +begin + cap := length(TObjectDynArray(fValue^)); + if cap<=fCount then + SetLength(TObjectDynArray(fValue^),NextGrow(cap)); + result := fCount; + TObjectDynArray(fValue^)[result] := Instance; + inc(fCount); +end; + +procedure TObjectDynArrayWrapper.Delete(Index: integer); +var P: PObjectArray; +begin + P := fValue^; + if (P=nil) or (cardinal(Index)>=cardinal(fCount)) then + exit; // avoid Out of range + if fOwnObjects then + P[Index].Free; + dec(fCount); + if fCount>Index then + MoveFast(P[Index+1],P[Index],(fCount-Index)*SizeOf(pointer)); +end; + +procedure TObjectDynArrayWrapper.Clear; +var i: PtrInt; + P: PObjectArray; +begin + P := fValue^; + if P<>nil then begin + if fOwnObjects then + for i := fCount-1 downto 0 do + try + P[i].Free; + except + on Exception do; + end; + TObjectDynArray(fValue^) := nil; // set capacity to 0 + fCount := 0; + end else + if fCount>0 then + raise ESynException.Create('You MUST define your IObjectDynArray field '+ + 'BEFORE the corresponding dynamic array'); +end; + +procedure TObjectDynArrayWrapper.Slice; +begin + SetLength(TObjectDynArray(fValue^),fCount); +end; + +function TObjectDynArrayWrapper.Count: integer; +begin + result := fCount; +end; + +function TObjectDynArrayWrapper.Capacity: integer; +begin + result := length(TObjectDynArray(fValue^)); +end; + +procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare); +begin + if (@Compare<>nil) and (fCount>0) then + QuickSortPtr(0,fCount-1,Compare,fValue^); +end; + +function NewSynLocker: PSynLocker; +begin + result := AllocMem(SizeOf(result^)); + result^.Init; +end; + +function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; +var a: TPointerDynArray absolute aPtrArray; +begin + result := length(a); + SetLength(a,result+1); + a[result] := aItem; +end; + +function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; +var a: TPointerDynArray absolute aPtrArray; + n: integer; +begin + n := length(a); + result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); + if result>=0 then + exit; + SetLength(a,n+1); + a[n] := aItem; + result := n; +end; + +procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger); +var a: TPointerDynArray absolute aPtrArray; + n: integer; +begin + if aCount=nil then + n := length(a) else + n := aCount^; + if cardinal(aIndex)>=cardinal(n) then + exit; // out of range + dec(n); + if n>aIndex then + MoveFast(a[aIndex+1],a[aIndex],(n-aIndex)*SizeOf(pointer)); + if aCount=nil then + SetLength(a,n) else + aCount^ := n; +end; + +function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): integer; +var a: TPointerDynArray absolute aPtrArray; + n: integer; +begin + if aCount=nil then + n := length(a) else + n := aCount^; + result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); + if result<0 then + exit; + dec(n); + if n>result then + MoveFast(a[result+1],a[result],(n-result)*SizeOf(pointer)); + if aCount=nil then + SetLength(a,n) else + aCount^ := n; +end; + +function PtrArrayFind(var aPtrArray; aItem: pointer): integer; +var a: TPointerDynArray absolute aPtrArray; +begin + result := PtrUIntScanIndex(pointer(a),length(a),PtrUInt(aItem)); +end; + +{ wrapper functions to T*ObjArr types } + +function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; +var a: TObjectDynArray absolute aObjArray; +begin + result := length(a); + SetLength(a,result+1); + a[result] := aItem; +end; + +function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; +var n: PtrInt; + s: TObjectDynArray absolute aSourceObjArray; + d: TObjectDynArray absolute aDestObjArray; +begin + result := length(d); + n := length(s); + SetLength(d,result+n); + MoveFast(s[0],d[result],n*SizeOf(pointer)); + inc(result,n); +end; + +function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; +begin + result := ObjArrayAddFrom(aDestObjArray,aSourceObjArray); + TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership +end; + +function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; +var a: TObjectDynArray absolute aObjArray; +begin + result := aObjArrayCount; + if result=length(a) then + SetLength(a,NextGrow(result)); + a[result] := aItem; + inc(aObjArrayCount); +end; + +procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); +var a: TObjectDynArray absolute aObjArray; + n: PtrInt; +begin + n := length(a); + if not PtrUIntScanExists(pointer(a),n,PtrUInt(aItem)) then begin + SetLength(a,n+1); + a[n] := aItem; + end; +end; + +function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; +var n, i: PtrInt; + s: TObjectDynArray absolute aSourceObjArray; + d: TObjectDynArray absolute aDestObjArray; +begin + result := length(d); + n := length(s); + if n=0 then + exit; + SetLength(d,result+n); + for i := 0 to n-1 do + if not PtrUIntScanExists(pointer(d),result,PtrUInt(s[i])) then begin + d[result] := s[i]; + inc(result); + end; + if result<>length(d) then + SetLength(d,result); +end; + +procedure ObjArraySetLength(var aObjArray; aLength: integer); +begin + SetLength(TObjectDynArray(aObjArray),aLength); +end; + +function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; +begin + result := PtrUIntScanIndex(pointer(aObjArray), + length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); +end; + +function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; +begin + result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); +end; + +function ObjArrayCount(const aObjArray): integer; +var i: PtrInt; + a: TObjectDynArray absolute aObjArray; +begin + result := 0; + for i := 0 to length(a)-1 do + if a[i]<>nil then + inc(result); +end; + +procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; + aContinueOnException: boolean; aCount: PInteger); +var n: PtrInt; + a: TObjectDynArray absolute aObjArray; +begin + if aCount=nil then + n := length(a) else + n := aCount^; + if cardinal(aItemIndex)>=cardinal(n) then + exit; // out of range + if aContinueOnException then + try + a[aItemIndex].Free; + except + end else + a[aItemIndex].Free; + dec(n); + if n>aItemIndex then + MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(TObject)); + if aCount=nil then + SetLength(a,n) else + aCount^ := n; +end; + +function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; +begin + result := PtrUIntScanIndex(pointer(aObjArray), + length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); + if result>=0 then + ObjArrayDelete(aObjArray,result); +end; + +function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; +begin + result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); + if result>=0 then + ObjArrayDelete(aObjArray,result,false,@aCount); +end; + +procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); +begin + if @Compare<>nil then + QuickSortPtr(0,length(TObjectDynArray(aObjArray))-1,Compare,pointer(aObjArray)); +end; + +procedure RawObjectsClear(o: PObject; n: integer); +var obj: TObject; +begin + if n>0 then + repeat + obj := o^; + if obj<>nil then begin // inlined FreeAndNil(o^) + o^ := nil; + obj.Destroy; + end; + inc(o); + dec(n); + until n=0; +end; + +procedure ObjArrayClear(var aObjArray); +var a: TObjectDynArray absolute aObjArray; +begin + if a=nil then + exit; + RawObjectsClear(pointer(aObjArray),length(a)); + a := nil; +end; + +procedure ObjArrayClear(var aObjArray; aCount: integer); +var a: TObjectDynArray absolute aObjArray; + n: integer; +begin + n := length(a); + if n=0 then + exit; + if n>aCount then + aCount := n; + RawObjectsClear(pointer(aObjArray),aCount); + a := nil; +end; + +procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; + aCount: PInteger); +var n,i: PtrInt; + a: TObjectDynArray absolute aObjArray; +begin + if aCount=nil then + n := length(a) else begin + n := aCount^; + aCount^ := 0; + end; + if n=0 then + exit; + if aContinueOnException then + for i := 0 to n-1 do + try + a[i].Free; + except + end + else + RawObjectsClear(pointer(a),n); + a := nil; +end; + +function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions): RawUTF8; +var temp: TTextWriterStackBuffer; +begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + if woEnumSetsAsText in aOptions then + CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; + AddObjArrayJSON(aObjArray,aOptions); + SetText(result); + finally + Free; + end; +end; + + +procedure ObjArrayObjArrayClear(var aObjArray); +var i: PtrInt; + a: TPointerDynArray absolute aObjArray; +begin + if a<>nil then begin + for i := 0 to length(a)-1 do + ObjArrayClear(a[i]); + a := nil; + end; +end; + +procedure ObjArraysClear(const aObjArray: array of pointer); +var i: PtrInt; +begin + for i := 0 to high(aObjArray) do + if aObjArray[i]<>nil then + ObjArrayClear(aObjArray[i]^); +end; + +{$ifndef DELPHI5OROLDER} + +function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; +var a: TInterfaceDynArray absolute aInterfaceArray; +begin + result := length(a); + SetLength(a,result+1); + a[result] := aItem; +end; + +procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); +var a: TInterfaceDynArray absolute aInterfaceArray; + n: PtrInt; +begin + if PtrUIntScanExists(pointer(aInterfaceArray), + length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)) then + exit; + n := length(a); + SetLength(a,n+1); + a[n] := aItem; +end; + +function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; +begin + result := PtrUIntScanIndex(pointer(aInterfaceArray), + length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)); +end; + +procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); +var n: PtrInt; + a: TInterfaceDynArray absolute aInterfaceArray; +begin + n := length(a); + if PtrUInt(aItemIndex)>=PtrUInt(n) then + exit; // out of range + a[aItemIndex] := nil; + dec(n); + if n>aItemIndex then + MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(IInterface)); + TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength() + SetLength(a,n); +end; + +function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; +begin + result := InterfaceArrayFind(aInterfaceArray,aItem); + if result>=0 then + InterfaceArrayDelete(aInterfaceArray,result); +end; + +{$endif DELPHI5OROLDER} + + +{ TInterfacedObjectWithCustomCreate } + +constructor TInterfacedObjectWithCustomCreate.Create; +begin // nothing to do by default - overridden constructor may add custom code +end; + +procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean); +begin + if Release then + _Release else + _AddRef; +end; + + +{ TAutoLock } + +type + /// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod + TAutoLock = class(TInterfacedObject) + protected + fLock: PSynLocker; + public + constructor Create(aLock: PSynLocker); + destructor Destroy; override; + end; + +constructor TAutoLock.Create(aLock: PSynLocker); +begin + fLock := aLock; + fLock^.Lock; +end; + +destructor TAutoLock.Destroy; +begin + fLock^.UnLock; +end; + + +{ TSynLocker } + +const + SYNLOCKER_VTYPENOCLEAR = [varEmpty..varDate,varBoolean, + varShortInt..varWord64,varUnknown]; + +procedure TSynLocker.Init; +begin + fLockCount := 0; + PaddingUsedCount := 0; + InitializeCriticalSection(fSection); + fInitialized := true; +end; + +procedure TSynLocker.Done; +var i: PtrInt; +begin + for i := 0 to PaddingUsedCount-1 do + if not(integer(Padding[i].VType) in SYNLOCKER_VTYPENOCLEAR) then + VarClear(variant(Padding[i])); + DeleteCriticalSection(fSection); + fInitialized := false; +end; + +procedure TSynLocker.DoneAndFreeMem; +begin + Done; + FreeMem(@self); +end; + +function TSynLocker.GetIsLocked: boolean; +begin + result := fLockCount <> 0; +end; + +procedure TSynLocker.Lock; +begin + EnterCriticalSection(fSection); + inc(fLockCount); +end; + +procedure TSynLocker.UnLock; +begin + dec(fLockCount); + LeaveCriticalSection(fSection); +end; + +function TSynLocker.TryLock: boolean; +begin + result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}; + if result then + inc(fLockCount); +end; + +function TSynLocker.TryLockMS(retryms: integer): boolean; +begin + repeat + result := TryLock; + if result or (retryms <= 0) then + break; + SleepHiRes(1); + dec(retryms); + until false; +end; + +function TSynLocker.ProtectMethod: IUnknown; +begin + result := TAutoLock.Create(@self); +end; + +{$ifndef NOVARIANTS} + +function TSynLocker.GetVariant(Index: integer): Variant; +begin + if cardinal(Index)=PaddingUsedCount then + PaddingUsedCount := Index+1; + variant(Padding[Index]) := Value; + finally + UnLock; + end; +end; + +function TSynLocker.GetInt64(Index: integer): Int64; +begin + if cardinal(Index)=cardinal(PaddingUsedCount)) or + not VariantToInt64(variant(Padding[index]),result) then + result := 0; +end; + +procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64); +begin + if cardinal(Index)<=high(Padding) then begin + if Index>=PaddingUsedCount then + PaddingUsedCount := Index+1; + variant(Padding[Index]) := Value; + end; +end; + +function TSynLocker.GetPointer(Index: integer): Pointer; +begin + if cardinal(Index)=PaddingUsedCount then + PaddingUsedCount := Index+1; + with Padding[index] do begin + if not(integer(VType) in SYNLOCKER_VTYPENOCLEAR) then + VarClear(PVariant(@VType)^); + VType := varUnknown; + VUnknown := Value; + end; + finally + UnLock; + end; +end; + +function TSynLocker.GetUTF8(Index: integer): RawUTF8; +var wasString: Boolean; +begin + if cardinal(Index)=PaddingUsedCount then + PaddingUsedCount := Index+1; + RawUTF8ToVariant(Value,Padding[Index],varString); + finally + UnLock; + end; +end; + +function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64; +begin + if cardinal(Index)<=high(Padding) then + try + Lock; + result := 0; + if Index nil then + SourceName := Source.ClassName else + SourceName := 'nil'; + raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]); +end; + +procedure TSynPersistent.AssignTo(Dest: TSynPersistent); +begin + Dest.AssignError(Self); +end; + +procedure TSynPersistent.Assign(Source: TSynPersistent); +begin + if Source<>nil then + Source.AssignTo(Self) else + AssignError(nil); +end; + +{$ifdef FPC_OR_PUREPASCAL} +class function TSynPersistent.NewInstance: TObject; +begin // bypass vmtIntfTable and vmt^.vInitTable (FPC management operators) + {$ifdef FPC_X64MM} + result := _AllocMem(InstanceSize); + {$else} + GetMem(pointer(result),InstanceSize); // InstanceSize is inlined + FillCharFast(pointer(result)^,InstanceSize,0); + {$endif} + PPointer(result)^ := pointer(self); // store VMT +end; // no benefit of rewriting FreeInstance/CleanupInstance +{$else} +class function TSynPersistent.NewInstance: TObject; +asm + push eax // class + mov eax, [eax].vmtInstanceSize + push eax // size + call System.@GetMem + pop edx // size + push eax // self + mov cl, 0 + call dword ptr[FillcharFast] + pop eax // self + pop edx // class + mov [eax], edx // store VMT +end; // TSynPersistent has no interface -> bypass vmtIntfTable + +procedure TSynPersistent.FreeInstance; +asm + push ebx + mov ebx, eax +@loop: mov ebx, [ebx] // handle three VMT levels per iteration + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jz @end + mov ebx, [ebx] + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jz @end + mov ebx, [ebx] + mov edx, [ebx].vmtInitTable + mov ebx, [ebx].vmtParent + test edx, edx + jnz @clr + test ebx, ebx + jnz @loop +@end: pop ebx + jmp System.@FreeMem + // TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self) + // BTW, TMonitor.Destroy is private, so unreachable +@clr: push offset @loop // parent has never any vmtInitTable -> @loop + jmp RecordClear // eax=self edx=typeinfo +end; +{$endif FPC_OR_PUREPASCAL} + + +{ TSynPersistentLock } + +constructor TSynPersistentLock.Create; +begin + inherited Create; + fSafe := NewSynLocker; +end; + +destructor TSynPersistentLock.Destroy; +begin + inherited Destroy; + fSafe^.DoneAndFreeMem; +end; + + +{ TSynList } + +function TSynList.Add(item: pointer): integer; +begin + result := ObjArrayAddCount(fList,item,fCount); +end; + +procedure TSynList.Clear; +begin + fList := nil; + fCount := 0; +end; + +procedure TSynList.Delete(index: integer); +begin + PtrArrayDelete(fList,index,@fCount); + if (fCount>64) and (length(fList)>fCount*2) then + SetLength(fList,fCount); // reduce capacity when half list is void +end; + +function TSynList.Exists(item: pointer): boolean; +begin + result := PtrUIntScanExists(pointer(fList),fCount,PtrUInt(item)); +end; + +function TSynList.Get(index: Integer): pointer; +begin + if cardinal(index)=0 then + Delete(result); +end; + + +{ TSynObjectList } + +constructor TSynObjectList.Create(aOwnObjects: boolean); +begin + fOwnObjects := aOwnObjects; + inherited Create; +end; + +procedure TSynObjectList.Delete(index: integer); +begin + if cardinal(index)>=cardinal(fCount) then + exit; + if fOwnObjects then + TObject(fList[index]).Free; + inherited Delete(index); +end; + +procedure TSynObjectList.Clear; +begin + if fOwnObjects then + RawObjectsClear(pointer(fList),fCount); + inherited Clear; +end; + +procedure TSynObjectList.ClearFromLast; +var i: PtrInt; +begin + if fOwnObjects then + for i := fCount-1 downto 0 do + TObject(fList[i]).Free; + inherited Clear; +end; + +destructor TSynObjectList.Destroy; +begin + Clear; + inherited Destroy; +end; + + +{ TSynObjectListLocked } + +constructor TSynObjectListLocked.Create(AOwnsObjects: Boolean); +begin + inherited Create(AOwnsObjects); + fSafe.Init; +end; + +destructor TSynObjectListLocked.Destroy; +begin + inherited Destroy; + fSafe.Done; +end; + +function TSynObjectListLocked.Add(item: pointer): integer; +begin + Safe.Lock; + try + result := inherited Add(item); + finally + Safe.UnLock; + end; +end; + +function TSynObjectListLocked.Remove(item: pointer): integer; +begin + Safe.Lock; + try + result := inherited Remove(item); + finally + Safe.UnLock; + end; +end; + +function TSynObjectListLocked.Exists(item: pointer): boolean; +begin + Safe.Lock; + try + result := inherited Exists(item); + finally + Safe.UnLock; + end; +end; + +procedure TSynObjectListLocked.Clear; +begin + Safe.Lock; + try + inherited Clear; + finally + Safe.UnLock; + end; +end; + +procedure TSynObjectListLocked.ClearFromLast; +begin + Safe.Lock; + try + inherited ClearFromLast; + finally + Safe.UnLock; + end; +end; + + +{ ****************** text buffer and JSON functions and classes ********* } + +{ TTextWriter } + +procedure TTextWriter.Add(c: AnsiChar); +begin + if B>=BEnd then + FlushToStream; + inc(B); + B^ := c; +end; + +procedure TTextWriter.AddOnce(c: AnsiChar); +begin + if (B>=fTempBuf) and (B^=c) then + exit; // no duplicate + if B>=BEnd then + FlushToStream; + inc(B); + B^ := c; +end; + +procedure TTextWriter.Add(c1, c2: AnsiChar); +begin + if BEnd-B<=1 then + FlushToStream; + B[1] := c1; + B[2] := c2; + inc(B,2); +end; + +procedure TTextWriter.CancelLastChar; +begin + if B>=fTempBuf then // Add() methods append at B+1 + dec(B); +end; + +function TTextWriter.LastChar: AnsiChar; +begin + if B>=fTempBuf then + result := B^ else + result := #0; +end; + +procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar); +begin + if (B>=fTempBuf) and (B^=aCharToCancel) then + dec(B); +end; + +function TTextWriter.PendingBytes: PtrUInt; +begin + result := B-fTempBuf+1; +end; + +procedure TTextWriter.CancelLastComma; +begin + if (B>=fTempBuf) and (B^=',') then + dec(B); +end; + +procedure TTextWriter.Add(Value: PtrInt); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; + Len: PtrInt; +begin + if BEnd-B<=24 then + FlushToStream; + if PtrUInt(Value)<=high(SmallUInt32UTF8) then begin + P := pointer(SmallUInt32UTF8[Value]); + Len := PStrLen(P-_STRLEN)^; + end else begin + P := StrInt32(@tmp[23],value); + Len := @tmp[23]-P; + end; + MoveSmall(P,B+1,Len); + inc(B,Len); +end; + +{$ifndef CPU64} // Add(Value: PtrInt) already implemented it +procedure TTextWriter.Add(Value: Int64); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; + Len: integer; +begin + if BEnd-B<=24 then + FlushToStream; + if Value<0 then begin + P := StrUInt64(@tmp[23],-Value)-1; + P^ := '-'; + Len := @tmp[23]-P; + end else + if Value<=high(SmallUInt32UTF8) then begin + P := pointer(SmallUInt32UTF8[Value]); + Len := PStrLen(P-_STRLEN)^; + end else begin + P := StrUInt64(@tmp[23],Value); + Len := @tmp[23]-P; + end; + MoveSmall(P,B+1,Len); + inc(B,Len); +end; +{$endif CPU64} + +procedure TTextWriter.AddCurr64(const Value: Int64); +var tmp: array[0..31] of AnsiChar; + P: PAnsiChar; + Len: PtrInt; +begin + if BEnd-B<=31 then + FlushToStream; + P := StrCurr64(@tmp[31],Value); + Len := @tmp[31]-P; + if Len>4 then + if P[Len-1]='0' then + if P[Len-2]='0' then + if P[Len-3]='0' then + if P[Len-4]='0' then + dec(Len,5) else + dec(Len,3) else + dec(Len,2) else + dec(Len); + MoveSmall(P,B+1,Len); + inc(B,Len); +end; + +procedure TTextWriter.AddCurr64(const Value: currency); +begin + AddCurr64(PInt64(@Value)^); +end; + +procedure TTextWriter.AddTimeLog(Value: PInt64); +begin + if BEnd-B<=31 then + FlushToStream; + inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T')); +end; + +procedure TTextWriter.AddUnixTime(Value: PInt64); +begin // inlined UnixTimeToDateTime() + AddDateTime(Value^/SecsPerDay+UnixDateDelta); +end; + +procedure TTextWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean); +begin // inlined UnixMSTimeToDateTime() + AddDateTime(Value^/MSecsPerDay+UnixDateDelta,WithMS); +end; + +procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar; + QuoteChar: AnsiChar; WithMS: boolean); +begin + if (Value^=0) and (QuoteChar=#0) then + exit; + if BEnd-B<=26 then + FlushToStream; + inc(B); + if QuoteChar<>#0 then + B^ := QuoteChar else + dec(B); + if Value^<>0 then begin + inc(B); + if trunc(Value^)<>0 then + B := DateToIso8601PChar(Value^,B,true); + if frac(Value^)<>0 then + B := TimeToIso8601PChar(Value^,B,true,FirstChar,WithMS); + dec(B); + end; + if twoDateTimeWithZ in fCustomOptions then begin + inc(B); + B^ := 'Z'; + end; + if QuoteChar<>#0 then begin + inc(B); + B^ := QuoteChar; + end; +end; + +procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean); +begin + if Value=0 then + exit; + if BEnd-B<=24 then + FlushToStream; + inc(B); + if trunc(Value)<>0 then + B := DateToIso8601PChar(Value,B,true); + if frac(Value)<>0 then + B := TimeToIso8601PChar(Value,B,true,'T',WithMS); + if twoDateTimeWithZ in fCustomOptions then + B^ := 'Z' else + dec(B); +end; + +procedure TTextWriter.AddDateTimeMS(const Value: TDateTime; Expanded: boolean; + FirstTimeChar: AnsiChar; const TZD: RawUTF8); +var T: TSynSystemTime; +begin + if Value=0 then + exit; + T.FromDateTime(Value); + Add(DTMS_FMT[Expanded], [UInt4DigitsToShort(T.Year), + UInt2DigitsToShortFast(T.Month),UInt2DigitsToShortFast(T.Day),FirstTimeChar, + UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute), + UInt2DigitsToShortFast(T.Second),UInt3DigitsToShort(T.MilliSecond),TZD]); +end; + +procedure TTextWriter.AddU(Value: cardinal); +var tmp: array[0..23] of AnsiChar; + P: PAnsiChar; + Len: PtrInt; +begin + if BEnd-B<=24 then + FlushToStream; + if Value<=high(SmallUInt32UTF8) then begin + P := pointer(SmallUInt32UTF8[Value]); + Len := PStrLen(P-_STRLEN)^; + end else begin + P := StrUInt32(@tmp[23],Value); + Len := @tmp[23]-P; + end; + MoveSmall(P,B+1,Len); + inc(B,Len); +end; + +procedure TTextWriter.AddQ(Value: QWord); +var tmp: array[0..23] of AnsiChar; + V: Int64Rec absolute Value; + P: PAnsiChar; + Len: PtrInt; +begin + if BEnd-B<=32 then + FlushToStream; + if (V.Hi=0) and (V.Lo<=high(SmallUInt32UTF8)) then begin + P := pointer(SmallUInt32UTF8[V.Lo]); + Len := PStrLen(P-_STRLEN)^; + end else begin + P := StrUInt64(@tmp[23],Value); + Len := @tmp[23]-P; + end; + MoveSmall(P,B+1,Len); + inc(B,Len); +end; + +procedure TTextWriter.AddQHex(Value: QWord); +begin + AddBinToHexDisplayQuoted(@Value,SizeOf(Value)); +end; + +procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean); +var tmp: ShortString; +begin + AddShort(ExtendedToJSON(tmp,Value,precision,noexp)^); +end; + +procedure TTextWriter.AddDouble(Value: double; noexp: boolean); +var tmp: ShortString; +begin + AddShort(DoubleToJSON(tmp,Value,noexp)^); +end; + +procedure TTextWriter.AddSingle(Value: single; noexp: boolean); +var tmp: ShortString; +begin + AddShort(ExtendedToJSON(tmp,Value,SINGLE_PRECISION,noexp)^); +end; + +procedure TTextWriter.Add(Value: boolean); +var PS: PShortString; +begin + if Value then // normalize: boolean may not be in the expected [0,1] range + PS := @BOOL_STR[true] else + PS := @BOOL_STR[false]; + AddShort(PS^); +end; + +procedure TTextWriter.AddFloatStr(P: PUTF8Char); +begin + if StrLen(P)>127 then + exit; // clearly invalid input + if BEnd-B<=127 then + FlushToStream; + inc(B); + if P<>nil then + B := FloatStrCopy(P,B)-1 else + B^ := '0'; +end; + +procedure TTextWriter.Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); +begin + if BEnd-B<=36 then + FlushToStream; + GUIDToText(B+1,@guid); + inc(B,36); +end; + +procedure TTextWriter.AddCR; +begin + if BEnd-B<=1 then + FlushToStream; + PWord(B+1)^ := 13+10 shl 8; // CR + LF + inc(B,2); +end; + +procedure TTextWriter.AddCRAndIndent; +var ntabs: cardinal; +begin + if B^=#9 then + exit; // we most probably just added an indentation level + ntabs := fHumanReadableLevel; + if ntabs>=cardinal(fTempBufSize) then + exit; // avoid buffer overflow + if BEnd-B<=Integer(ntabs)+1 then + FlushToStream; + PWord(B+1)^ := 13+10 shl 8; // CR + LF + FillCharFast(B[3],ntabs,9); // #9=tab + inc(B,ntabs+2); +end; + +procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer); +var n: integer; +begin + repeat + n := BEnd-B; + if aCount99 then + PCardinal(B+1)^ := $3030+ord(',')shl 16 else // '00,' if overflow + PCardinal(B+1)^ := TwoDigitLookupW[Value]+ord(',')shl 16; + inc(B,3); +end; + +procedure TTextWriter.Add4(Value: PtrUInt); +begin + if BEnd-B<=5 then + FlushToStream; + if Value>9999 then + PCardinal(B+1)^ := $30303030 else // '0000,' if overflow + YearToPChar(Value,B+1); + inc(B,5); + B^ := ','; +end; + +procedure TTextWriter.AddCurrentLogTime(LocalTime: boolean); +var time: TSynSystemTime; +begin + FromGlobalTime(LocalTime,time); + time.AddLogTime(self); +end; + +procedure TTextWriter.AddCurrentNCSALogTime(LocalTime: boolean); +var time: TSynSystemTime; +begin + FromGlobalTime(LocalTime,time); + if BEnd-B<=21 then + FlushToStream; + inc(B,time.ToNCSAText(B+1)); +end; + +function Value3Digits(V: PtrUInt; P: PUTF8Char; W: PWordArray): PtrUInt; + {$ifdef HASINLINE}inline;{$endif} +begin + result := V div 100; + PWord(P+1)^ := W[V-result*100]; + V := result; + result := result div 10; + P^ := AnsiChar(V-result*10+48); +end; + +procedure TTextWriter.AddMicroSec(MS: cardinal); +var W: PWordArray; +begin // in 00.000.000 TSynLog format + if BEnd-B<=17 then + FlushToStream; + B[3] := '.'; + B[7] := '.'; + inc(B); + W := @TwoDigitLookupW; + MS := Value3Digits(Value3Digits(MS,B+7,W),B+3,W); + if MS>99 then + MS := 99; + PWord(B)^:= W[MS]; + inc(B,9); +end; + +procedure TTextWriter.Add3(Value: PtrUInt); +var V: PtrUInt; +begin + if BEnd-B<=4 then + FlushToStream; + if Value>999 then + PCardinal(B+1)^ := $303030 else begin// '0000,' if overflow + V := Value div 10; + PCardinal(B+1)^ := TwoDigitLookupW[V]+(Value-V*10+48)shl 16; + end; + inc(B,4); + B^ := ','; +end; + +procedure TTextWriter.AddCSVInteger(const Integers: array of Integer); +var i: PtrInt; +begin + if length(Integers)=0 then + exit; + for i := 0 to high(Integers) do begin + Add(Integers[i]); + Add(','); + end; + CancelLastComma; +end; + +procedure TTextWriter.AddCSVDouble(const Doubles: array of double); +var i: PtrInt; +begin + if length(Doubles)=0 then + exit; + for i := 0 to high(Doubles) do begin + AddDouble(Doubles[i]); + Add(','); + end; + CancelLastComma; +end; + +procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8); +var i: PtrInt; +begin + if length(Values)=0 then + exit; + for i := 0 to high(Values) do begin + Add('"'); + AddJSONEscape(pointer(Values[i])); + Add('"',','); + end; + CancelLastComma; +end; + +procedure TTextWriter.AddCSVConst(const Values: array of const); +var i: PtrInt; +begin + if length(Values)=0 then + exit; + for i := 0 to high(Values) do begin + AddJSONEscape(Values[i]); + Add(','); + end; + CancelLastComma; +end; + +procedure TTextWriter.Add(const Values: array of const); +var i: PtrInt; +begin + for i := 0 to high(Values) do + AddJSONEscape(Values[i]); +end; + +procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions); +var i: PtrInt; +begin + if Value<>nil then + if Value.InheritsFrom(Exception) then + Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else + if Value.InheritsFrom(TRawUTF8List) then + with TRawUTF8List(Value) do begin + self.Add('['); + for i := 0 to fCount-1 do begin + self.Add('"'); + self.AddJSONEscape(pointer(fValue[i])); + self.Add('"',','); + end; + self.CancelLastComma; + self.Add(']'); + exit; + end else + if Value.InheritsFrom(TStrings) then + with TStrings(Value) do begin + self.Add('['); + for i := 0 to Count-1 do begin + self.Add('"'); + {$ifdef UNICODE} + self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i])); + {$else} + self.AddJSONEscapeAnsiString(Strings[i]); + {$endif} + self.Add('"',','); + end; + self.CancelLastComma; + self.Add(']'); + exit; + end else + if not(woFullExpand in Options) or + not(Value.InheritsFrom(TList) + {$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then + Value := nil; + if Value=nil then begin + AddShort('null'); + exit; + end; + Add('{'); + AddInstanceName(Value,':'); + Add('['); + if Value.InheritsFrom(TList) then + for i := 0 to TList(Value).Count-1 do + AddInstanceName(TList(Value).List[i],',') + {$ifndef LVCL} else + if Value.InheritsFrom(TCollection) then + for i := 0 to TCollection(Value).Count-1 do + AddInstanceName(TCollection(Value).Items[i],',') {$endif} ; + CancelLastComma; + Add(']','}'); +end; + +function TTextWriter.InternalJSONWriter: TTextWriter; +begin + if fInternalJSONWriter=nil then + fInternalJSONWriter := DefaultTextWriterSerializer.CreateOwnedStream else + fInternalJSONWriter.CancelAll; + result := fInternalJSONWriter; +end; + +procedure TTextWriter.AddJSONEscape(Source: TTextWriter); +begin + if Source.fTotalFileSize=0 then + AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else + AddJSONEscape(Pointer(Source.Text)); +end; + +procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter); +begin + if Source.fTotalFileSize=0 then + AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else + AddNoJSONEscapeUTF8(Source.Text); +end; + +procedure TTextWriter.AddRawJSON(const json: RawJSON); +begin + if json='' then + AddShort('null') else + AddNoJSONEscape(pointer(json),length(json)); +end; + +procedure TTextWriter.WriteObjectAsString(Value: TObject; + Options: TTextWriterWriteObjectOptions); +begin + Add('"'); + InternalJSONWriter.WriteObject(Value,Options); + AddJSONEscape(fInternalJSONWriter); + Add('"'); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializer(aTypeInfo: pointer; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); +begin + GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,aReader,aWriter); +end; + +class procedure TTextWriter.UnRegisterCustomJSONSerializer(aTypeInfo: pointer); +begin + GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,nil,nil); +end; + +class function TTextWriter.GetCustomJSONParser(var DynArray: TDynArray; + out CustomReader: TDynArrayJSONCustomReader; + out CustomWriter: TDynArrayJSONCustomWriter): boolean; +begin + result := DynArray.HasCustomJSONParser; // use var above since may set fParser + if result then + with GlobalJSONCustomParsers.fParser[DynArray.fParser] do begin + CustomReader := Reader; + CustomWriter := Writer; + end; +end; + +{$ifndef NOVARIANTS} +class procedure TTextWriter.RegisterCustomJSONSerializerForVariant( + aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; + aWriter: TDynArrayJSONCustomWriter); +begin // here we register TCustomVariantTypeClass info instead of TypeInfo() + GlobalJSONCustomParsers.RegisterCallbacksVariant(aClass,aReader,aWriter); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; + aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); +var aClass: TCustomVariantType; +begin + if FindCustomVariantType(aVarType,aClass) then + RegisterCustomJSONSerializerForVariant(aClass,aReader,aWriter); +end; +{$endif NOVARIANTS} + +class function TTextWriter.RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; + const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; +begin + result := GlobalJSONCustomParsers.RegisterFromText(aTypeInfo,aRTTIDefinition); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerFromText( + const aTypeInfoTextDefinitionPairs: array of const); +var n,i: integer; + def: RawUTF8; +begin + n := length(aTypeInfoTextDefinitionPairs); + if (n=0) or (n and 1=1) then + exit; + n := n shr 1; + if n=0 then + exit; + for i := 0 to n-1 do + if (aTypeInfoTextDefinitionPairs[i*2].VType<>vtPointer) or + not VarRecToUTF8IsString(aTypeInfoTextDefinitionPairs[i*2+1],def) then + raise ESynException.Create('RegisterCustomJSONSerializerFromText[?]') else + GlobalJSONCustomParsers.RegisterFromText( + aTypeInfoTextDefinitionPairs[i*2].VPointer,def); +end; + +class function TTextWriter.RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; + aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean; +var ndx: integer; +begin + result := false; + if aTypeInfo=nil then + exit; + case PTypeKind(aTypeInfo)^ of + tkRecord{$ifdef FPC},tkObject{$endif}: + ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); + tkDynArray: + ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); + else + exit; + end; + if (ndx>=0) and + (GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser<>nil) then begin + GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser.Options := aOptions; + result := true; + end; +end; + +class function TTextWriter.RegisterCustomJSONSerializerSetOptions( + const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; + aAddIfNotExisting: boolean): boolean; +var i: integer; +begin + result := true; + for i := 0 to high(aTypeInfo) do + if not RegisterCustomJSONSerializerSetOptions(aTypeInfo[i],aOptions,aAddIfNotExisting) then + result := false; +end; + +class function TTextWriter.RegisterCustomJSONSerializerFindParser( + aTypeInfo: pointer; aAddIfNotExisting: boolean): TJSONRecordAbstract; +var ndx: integer; +begin + result := nil; + if aTypeInfo=nil then + exit; + case PTypeKind(aTypeInfo)^ of + tkRecord{$ifdef FPC},tkObject{$endif}: + ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); + tkDynArray: + ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); + else + exit; + end; + if ndx>=0 then + result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser; +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( + aTypeInfo: pointer; const aTypeName: RawUTF8); +begin + JSONSerializerFromTextSimpleTypeAdd(aTypeName,aTypeInfo,0,0); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( + const aTypeInfos: array of pointer); +var i: integer; +begin + for i := 0 to high(aTypeInfos) do + RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfos[i],''); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( + aTypeInfo: pointer; aDataSize, aFieldSize: integer); +begin + JSONSerializerFromTextSimpleTypeAdd('',aTypeInfo,aDataSize,aFieldSize); +end; + +class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( + const aTypeInfoDataFieldSize: array of const); +var n,i: integer; + s1,s2: Int64; +begin + n := length(aTypeInfoDataFieldSize); + if n mod 3=0 then + for i := 0 to (n div 3)-1 do + if (aTypeInfoDataFieldSize[i*3].VType<>vtPointer) or + not VarRecToInt64(aTypeInfoDataFieldSize[i*3+1],s1) or + not VarRecToInt64(aTypeInfoDataFieldSize[i*3+2],s2) then + raise ESynException.CreateUTF8('RegisterCustomJSONSerializerFromTextBinaryType[%]',[i]) else + JSONSerializerFromTextSimpleTypeAdd('',aTypeInfoDataFieldSize[i*3].VPointer,s1,s2); +end; + +procedure TTextWriter.AddRecordJSON(const Rec; TypeInfo: pointer); +var customWriter: TDynArrayJSONCustomWriter; +begin + if (self=nil) or (@Rec=nil) or (TypeInfo=nil) or + not(PTypeKind(TypeInfo)^ in tkRecordTypes) then + raise ESynException.CreateUTF8('Invalid %.AddRecordJSON(%)',[self,TypeInfo]); + if GlobalJSONCustomParsers.RecordSearch(TypeInfo,customWriter,nil) then + customWriter(self,Rec) else + WrRecord(Rec,TypeInfo); +end; + +procedure TTextWriter.AddVoidRecordJSON(TypeInfo: pointer); +var tmp: TBytes; + info: PTypeInfo; +begin + info := GetTypeInfo(TypeInfo,tkRecordKinds); + if (self=nil) or (info=nil) then + raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]); + SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif}); + AddRecordJSON(tmp[0],TypeInfo); +end; + +{$ifndef NOVARIANTS} +procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind); +var CustomVariantType: TCustomVariantType; + vt: cardinal; +begin + vt := TVarData(Value).VType; + with TVarData(Value) do + case vt of + varEmpty, + varNull: AddShort('null'); + varSmallint: Add(VSmallint); + varShortInt: Add(VShortInt); + varByte: AddU(VByte); + varWord: AddU(VWord); + varLongWord: AddU(VLongWord); + varInteger: Add(VInteger); + varInt64: Add(VInt64); + varWord64: AddQ(VInt64); + varSingle: AddSingle(VSingle); + varDouble: AddDouble(VDouble); + varDate: AddDateTime(@VDate,'T','"'); + varCurrency: AddCurr64(VInt64); + varBoolean: Add(VBoolean); // 'true'/'false' + varVariant: AddVariant(PVariant(VPointer)^,Escape); + varString: begin + if Escape=twJSONEscape then + Add('"'); + {$ifdef HASCODEPAGE} + AddAnyAnsiString(RawByteString(VString),Escape); + {$else} // VString is expected to be a RawUTF8 + Add(VString,length(RawUTF8(VString)),Escape); + {$endif} + if Escape=twJSONEscape then + Add('"'); + end; + varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin + if Escape=twJSONEscape then + Add('"'); + AddW(VAny,0,Escape); + if Escape=twJSONEscape then + Add('"'); + end; + else + if vt=varVariant or varByRef then + AddVariant(PVariant(VPointer)^,Escape) else + if vt=varByRef or varString then begin + if Escape=twJSONEscape then + Add('"'); + {$ifdef HASCODEPAGE} + AddAnyAnsiString(PRawByteString(VAny)^,Escape); + {$else} // VString is expected to be a RawUTF8 + Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape); + {$endif} + if Escape=twJSONEscape then + Add('"'); + end else + if {$ifdef HASVARUSTRING}(vt=varByRef or varUString) or {$endif} + (vt=varByRef or varOleStr) then begin + if Escape=twJSONEscape then + Add('"'); + AddW(PPointer(VAny)^,0,Escape); + if Escape=twJSONEscape then + Add('"'); + end else + if FindCustomVariantType(vt,CustomVariantType) then + if CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then + TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else + GlobalJSONCustomParsers.VariantWrite(CustomVariantType,self,Value,Escape) else + raise ESynException.CreateUTF8('%.AddVariant VType=%',[self,vt]); + end; +end; +{$endif NOVARIANTS} + +procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArrayHashed); +begin + AddDynArrayJson(PDynArray(@aDynArray)^); +end; + +procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue); +var DynArray: TDynArray; +begin + DynArray.Init(aTypeInfo,pointer(@aValue)^); + AddDynArrayJSON(DynArray); +end; + +procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); +begin + Add('"'); + InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue); + AddJSONEscape(fInternalJSONWriter); + Add('"'); +end; + +procedure TTextWriter.AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions); +var i: integer; + a: TObjectDynArray absolute aObjArray; +begin + Add('['); + for i := 0 to length(a)-1 do begin + WriteObject(a[i],aOptions); + Add(','); + end; + CancelLastComma; + Add(']'); +end; + +procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue); +var max, i: Integer; + PS: PShortString; + customWriter: TDynArrayJSONCustomWriter; + DynArray: TDynArray; + procedure AddPS; overload; + begin + Add('"'); + if twoTrimLeftEnumSets in fCustomOptions then + AddTrimLeftLowerCase(PS) else + AddShort(PS^); + Add('"'); + end; + procedure AddPS(bool: boolean); overload; + begin + AddPS; + Add(':'); + Add(bool); + end; +begin + case PTypeKind(aTypeInfo)^ of + tkClass: + WriteObject(TObject(aValue),[woFullExpand]); + tkEnumeration: + if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin + PS := GetEnumName(aTypeInfo,byte(aValue)); + AddPS(true); + end else + if twoEnumSetsAsTextInRecord in fCustomOptions then begin + PS := GetEnumName(aTypeInfo,byte(aValue)); + AddPS; + end else + AddU(byte(aValue)); + tkSet: + if GetSetInfo(aTypeInfo,max,PS) then + if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin + Add('{'); + for i := 0 to max do begin + AddPS(GetBitPtr(@aValue,i)); + Add(','); + inc(PByte(PS),PByte(PS)^+1); // next + end; + CancelLastComma; + Add('}'); + end else + if twoEnumSetsAsTextInRecord in fCustomOptions then begin + Add('['); + if (twoFullSetsAsStar in fCustomOptions) and + GetAllBits(cardinal(aValue),max+1) then + AddShort('"*"') else begin + for i := 0 to max do begin + if GetBitPtr(@aValue,i) then begin + AddPS; + Add(','); + end; + inc(PByte(PS),PByte(PS)^+1); // next + end; + CancelLastComma; + end; + Add(']'); + end else + if max<8 then + AddU(byte(aValue)) else + if max<16 then + AddU(word(aValue)) else + if max<32 then + AddU(cardinal(aValue)) else + Add(Int64(aValue)) + else AddShort('null'); + tkRecord{$ifdef FPC},tkObject{$endif}: // inlined AddRecordJSON() + if GlobalJSONCustomParsers.RecordSearch(aTypeInfo,customWriter,nil) then + customWriter(self,aValue) else + WrRecord(aValue,aTypeInfo); + tkDynArray: begin + DynArray.Init(aTypeInfo,(@aValue)^); + AddDynArrayJSON(DynArray); + end; +{$ifndef NOVARIANTS} + tkVariant: + AddVariant(variant(aValue),twJSONEscape); +{$endif} + else + AddShort('null'); + end; +end; + +function TTextWriter.AddJSONReformat(JSON: PUTF8Char; + Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char; +var objEnd: AnsiChar; + Name,Value: PUTF8Char; + NameLen,ValueLen: integer; +begin + result := nil; + if JSON=nil then + exit; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + case JSON^ of + '[': begin // array + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + if JSON^=']' then begin + Add('['); + inc(JSON); + end else begin + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + inc(fHumanReadableLevel); + Add('['); + repeat + if JSON=nil then + exit; + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + JSON := AddJSONReformat(JSON,Format,@objEnd); + if objEnd=']' then + break; + Add(objEnd); + until false; + dec(fHumanReadableLevel); + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + end; + Add(']'); + end; + '{': begin // object + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + Add('{'); + inc(fHumanReadableLevel); + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + if JSON^='}' then + repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else + repeat + Name := GetJSONPropName(JSON,@NameLen); + if Name=nil then + exit; + if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and + JsonPropNameValid(Name) then + AddNoJSONEscape(Name,NameLen) else begin + Add('"'); + AddJSONEscape(Name); + Add('"'); + end; + if Format in [jsonCompact,jsonUnquotedPropNameCompact] then + Add(':') else + Add(':',' '); + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + JSON := AddJSONReformat(JSON,Format,@objEnd); + if objEnd='}' then + break; + Add(objEnd); + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + until false; + dec(fHumanReadableLevel); + if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then + AddCRAndIndent; + Add('}'); + end; + '"': begin // string + Value := JSON; + JSON := GotoEndOfJSONString(JSON); + if JSON^<>'"' then + exit; + inc(JSON); + AddNoJSONEscape(Value,JSON-Value); + end; + else begin // numeric or true/false/null + Value := GetJSONField(JSON,result,nil,EndOfObject,@ValueLen); // let wasString=nil + if Value=nil then + AddShort('null') else begin + while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen); + AddNoJSONEscape(Value,ValueLen); + end; + exit; + end; + end; + if JSON<>nil then begin + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if EndOfObject<>nil then + EndOfObject^ := JSON^; + if JSON^<>#0 then + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + end; + result := JSON; +end; + +function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName,EndOfObject: PUTF8Char): PUTF8Char; +var objEnd: AnsiChar; + Name,Value: PUTF8Char; + n,c: integer; +begin + result := nil; + if JSON=nil then + exit; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + case JSON^ of + '[': begin + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + if JSON^=']' then + JSON := GotoNextNotSpace(JSON+1) else begin + n := 0; + repeat + if JSON=nil then + exit; + Add('<'); + if ArrayName=nil then + Add(n) else + AddXmlEscape(ArrayName); + Add('>'); + JSON := AddJSONToXML(JSON,nil,@objEnd); + Add('<','/'); + if ArrayName=nil then + Add(n) else + AddXmlEscape(ArrayName); + Add('>'); + inc(n); + until objEnd=']'; + end; + end; + '{': begin + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + if JSON^='}' then + repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else begin + repeat + Name := GetJSONPropName(JSON); + if Name=nil then + exit; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if JSON^='[' then // arrays are written as list of items, without root + JSON := AddJSONToXML(JSON,Name,@objEnd) else begin + Add('<'); + AddXmlEscape(Name); + Add('>'); + JSON := AddJSONToXML(JSON,Name,@objEnd); + Add('<','/'); + AddXmlEscape(Name); + Add('>'); + end; + until objEnd='}'; + end; + end; + else begin + Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil + if Value=nil then + AddShort('null') else begin + c := PInteger(Value)^ and $ffffff; + if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then + inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8 + AddXmlEscape(Value); + end; + exit; + end; + end; + if JSON<>nil then begin + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if EndOfObject<>nil then + EndOfObject^ := JSON^; + if JSON^<>#0 then + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + end; + result := JSON; +end; + +procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArray); +var i,n: PtrInt; + P: Pointer; + T: TDynArrayKind; + tmp: RawByteString; + customWriter: TDynArrayJSONCustomWriter; + customParser: TJSONRecordAbstract; + nested: TDynArray; + hr: boolean; +begin // code below must match TDynArray.LoadFromJSON + n := aDynArray.Count-1; + if n<0 then begin + Add('[',']'); + exit; + end; + if aDynArray.HasCustomJSONParser then + with GlobalJSONCustomParsers.fParser[aDynArray.fParser] do begin + customWriter := Writer; + customParser := RecordCustomParser; + end else begin + customWriter := nil; + customParser := nil; + end; + if Assigned(customWriter) then + T := djCustom else + T := aDynArray.GuessKnownType({exacttype=}true); + P := aDynArray.fValue^; + Add('['); + case T of + djNone: + if (aDynArray.ElemType<>nil) and + (PTypeKind(aDynArray.ElemType)^=tkDynArray) then begin + for i := 0 to n do begin + nested.Init(aDynArray.ElemType,P^); + AddDynArrayJSON(nested); + Add(','); + inc(PByte(P),aDynArray.ElemSize); + end; + end else begin + tmp := aDynArray.SaveTo; + WrBase64(pointer(tmp),length(tmp),{withMagic=}true); + end; + djCustom: begin + if customParser=nil then + hr := false else + hr := soWriteHumanReadable in customParser.Options; + if hr then + Inc(fHumanReadableLevel); + for i := 0 to n do begin + customWriter(self,P^); + Add(','); + inc(PByte(P),aDynArray.ElemSize); + end; + if hr then begin + dec(fHumanReadableLevel); + CancelLastComma; + AddCRAndIndent; + end; + end; + {$ifndef NOVARIANTS} + djVariant: + for i := 0 to n do begin + AddVariant(PVariantArray(P)^[i],twJSONEscape); + Add(','); + end; + {$endif} + djRawUTF8: + for i := 0 to n do begin + Add('"'); + AddJSONEscape(PPointerArray(P)^[i]); + Add('"',','); + end; + djRawByteString: + for i := 0 to n do begin + WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),{withMagic=}true); + Add(','); + end; + djInteger: + for i := 0 to n do begin + Add(PIntegerArray(P)^[i]); + Add(','); + end; + djInt64: + for i := 0 to n do begin + Add(PInt64Array(P)^[i]); + Add(','); + end; + djQWord: + for i := 0 to n do begin + AddQ(PQwordArray(P)^[i]); + Add(','); + end; + else // slightly less efficient for less-used types + if T in DJ_STRING then + for i := 0 to n do begin + Add('"'); + case T of + djTimeLog: AddTimeLog(@PInt64Array(P)^[i]); + djDateTime: AddDateTime(@PDoubleArray(P)^[i],'T',#0,false); + djDateTimeMS: AddDateTime(@PDoubleArray(P)^[i],'T',#0,true); + djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]); + djWinAnsi: AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US); + djString: + {$ifdef UNICODE} + AddJSONEscapeW(PPointerArray(P)^[i]); + {$else} + AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0); + {$endif} + djHash128: AddBinToHexDisplayLower(@PHash128Array(P)[i],SizeOf(THash128)); + djHash256: AddBinToHexDisplayLower(@PHash256Array(P)[i],SizeOf(THash256)); + djHash512: AddBinToHexDisplayLower(@PHash512Array(P)[i],SizeOf(THash512)); + djInterface: AddPointer(PPtrIntArray(P)^[i]); + else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); + end; + Add('"',','); + end else + for i := 0 to n do begin + case T of + djBoolean: Add(PBooleanArray(P)^[i]); + djByte: AddU(PByteArray(P)^[i]); + djWord: AddU(PWordArray(P)^[i]); + djCardinal: AddU(PCardinalArray(P)^[i]); + djSingle: AddSingle(PSingleArray(P)^[i]); + djDouble: AddDouble(PDoubleArray(P)^[i]); + djCurrency: AddCurr64(PInt64Array(P)^[i]); + else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); + end; + Add(','); + end; + end; + CancelLastComma; + Add(']'); +end; + +procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const; + Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions); +var ValuesIndex: integer; + F: PUTF8Char; +label write; +begin // we put const char > #127 as #??? -> asiatic MBCS codepage OK + if Format='' then + exit; + if (Format='%') and (high(Values)>=0) then begin + Add(Values[0],Escape); + exit; + end; + ValuesIndex := 0; + F := pointer(Format); + repeat + repeat + case ord(F^) of + 0: exit; + ord('%'): break; + {$ifdef OLDTEXTWRITERFORMAT} + 164: AddCR; // currency sign -> add CR,LF + 167: if B^=',' then dec(B); // section sign to ignore next comma + ord('|'): begin + inc(F); // |% -> % + goto write; + end; + ord('$'),163,181: // dollar, pound, micro sign + break; // process command value + {$endif} + else begin +write: if B>=BEnd then + FlushToStream; + B[1] := F^; + inc(B); + end; + end; + inc(F); + until false; + // add next value as text + if ValuesIndex<=high(Values) then // missing value will display nothing + case ord(F^) of + ord('%'): + Add(Values[ValuesIndex],Escape,WriteObjectOptions); + {$ifdef OLDTEXTWRITERFORMAT} + ord('$'): with Values[ValuesIndex] do + if Vtype=vtInteger then Add2(VInteger); + 163: with Values[ValuesIndex] do // pound sign + if Vtype=vtInteger then Add4(VInteger); + 181: with Values[ValuesIndex] do // micro sign + if Vtype=vtInteger then Add3(VInteger); + {$endif} + end; + inc(F); + inc(ValuesIndex); + until false; +end; + +procedure TTextWriter.AddLine(const Text: shortstring); +var L: PtrInt; +begin + L := ord(Text[0]); + if BEnd-B<=L+2 then + FlushToStream; + inc(B); + if L>0 then begin + MoveFast(Text[1],B^,L); + inc(B,L); + end; + PWord(B)^ := 13+10 shl 8; // CR + LF + inc(B); +end; + +procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: integer); +begin + if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then + exit; + if BEnd-B<=BinBytes*2 then + FlushToStream; + BinToHexDisplay(Bin,PAnsiChar(B+1),BinBytes); + inc(B,BinBytes*2); +end; + +procedure TTextWriter.AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); +begin + if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then + exit; + if BEnd-B<=BinBytes*2 then + FlushToStream; + BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); + inc(B,BinBytes*2); +end; + +procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); +begin + if cardinal(BinBytes*2+2)>=cardinal(fTempBufSize) then + exit; + if BEnd-B<=BinBytes*2+2 then + FlushToStream; + B[1] := '"'; + BinToHexDisplayLower(Bin,PAnsiChar(B+2),BinBytes); + inc(B,BinBytes*2); + B[2] := '"'; + inc(B,2); +end; + +procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); +begin + if (BinBytes<=0) or (cardinal(BinBytes*2-1)>=cardinal(fTempBufSize)) then + exit; + repeat // append hexa chars up to the last non zero byte + dec(BinBytes); + until (BinBytes=0) or (PByteArray(Bin)[BinBytes]<>0); + inc(BinBytes); + if BEnd-B<=BinBytes*2 then + FlushToStream; + BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); + inc(B,BinBytes*2); +end; + +procedure TTextWriter.AddPointer(P: PtrUInt); +begin + AddBinToHexDisplayMinChars(@P,SizeOf(P)); +end; + +procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: integer); +var ChunkBytes: PtrInt; +begin + if BinBytes<=0 then + exit; + if B>=BEnd then + FlushToStream; + inc(B); + repeat + // guess biggest size to be added into buf^ at once + ChunkBytes := (BEnd-B) shr 1; // div 2, *2 -> two hexa chars per byte + if BinBytes special one below: + WriteToStream(fTempBuf,B-fTempBuf); + B := fTempBuf; + until false; + dec(B); // allow CancelLastChar +end; + +procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; + TextMaxLen: PtrInt); +var BMax: PUTF8Char; + c: AnsiChar; +begin + if TextMaxLen<=0 then + TextMaxLen := maxInt else + if TextMaxLen>5 then + dec(TextMaxLen,5); + BMax := BEnd-3; + if B>=BMax then begin + FlushToStream; + BMax := BEnd-3; + end; + inc(B); + B^ := Quote; + inc(B); + if Text<>nil then + repeat + if B0 then begin + c := Text^; + inc(Text); + if c=#0 then + break; + B^ := c; + inc(B); + if c<>Quote then + continue; + B^ := c; + inc(B); + end else begin + PCardinal(B)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; + inc(B,3); + break; + end; + end else begin + FlushToStream; + BMax := BEnd-3; + end; + until false; + B^ := Quote; +end; + +const + HTML_ESC: array[hfAnyWhere..high(TTextWriterHTMLFormat)] of TSynAnsicharSet = ( + [#0,'&','"','<','>'],[#0,'&','<','>'],[#0,'&','"']); + +procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat); +var B: PUTF8Char; + esc: ^TSynAnsicharSet; +begin + if Text=nil then + exit; + if Fmt=hfNone then begin + AddNoJSONEscape(Text); + exit; + end; + esc := @HTML_ESC[Fmt]; + repeat + B := Text; + while not(Text^ in esc^) do + inc(Text); + AddNoJSONEscape(B,Text-B); + case Text^ of + #0: exit; + '<': AddShort('<'); + '>': AddShort('>'); + '&': AddShort('&'); + '"': AddShort('"'); + end; + inc(Text); + until Text^=#0; +end; + +procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; + Fmt: TTextWriterHTMLFormat); +var B: PUTF8Char; + esc: ^TSynAnsicharSet; +begin + if (Text=nil) or (TextLen<=0) then + exit; + if Fmt=hfNone then begin + AddNoJSONEscape(Text,TextLen); + exit; + end; + inc(TextLen,PtrInt(Text)); // TextLen = final PtrInt(Text) + esc := @HTML_ESC[Fmt]; + repeat + B := Text; + while (PtrInt(Text)': AddShort('>'); + '&': AddShort('&'); + '"': AddShort('"'); + end; + inc(Text); + until false; +end; + +procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat); +begin + AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt); +end; + +procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat); +begin + AddHtmlEscape(pointer(Text),length(Text),Fmt); +end; + +procedure TTextWriter.AddXmlEscape(Text: PUTF8Char); +const XML_ESCAPE: TSynByteSet = + [0..31,ord('<'),ord('>'),ord('&'),ord('"'),ord('''')]; +var i,beg: PtrInt; +begin + if Text=nil then + exit; + i := 0; + repeat + beg := i; + if not(ord(Text[i]) in XML_ESCAPE) then begin + repeat // it is faster to handle all not-escaped chars at once + inc(i); + until ord(Text[i]) in XML_ESCAPE; + AddNoJSONEscape(Text+beg,i-beg); + end; + repeat + case Text[i] of + #0: exit; + #1..#8,#11,#12,#14..#31: + ; // ignore invalid character - see http://www.w3.org/TR/xml/#NT-Char + #9,#10,#13: begin // characters below ' ', #9 e.g. -> // ' ' + AddShort('&#x'); + AddByteToHex(ord(Text[i])); + Add(';'); + end; + '<': AddShort('<'); + '>': AddShort('>'); + '&': AddShort('&'); + '"': AddShort('"'); + '''': AddShort('''); + else break; // should match XML_ESCAPE[] constant above + end; + inc(i); + until false; + until false; +end; + +procedure TTextWriter.AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); +begin + if Text<>nil then + while Text^<>#0 do begin + if Text^=Orig then + Add(Replaced) else + Add(Text^); + inc(Text); + end; +end; + +procedure TTextWriter.AddByteToHex(Value: byte); +begin + if BEnd-B<=1 then + FlushToStream; + PWord(B+1)^ := TwoDigitsHexWB[Value]; + inc(B,2); +end; + +procedure TTextWriter.AddInt18ToChars3(Value: cardinal); +begin + if BEnd-B<=3 then + FlushToStream; + PCardinal(B+1)^ := ((Value shr 12) and $3f)+ + ((Value shr 6) and $3f)shl 8+ + (Value and $3f)shl 16+$202020; + //assert(Chars3ToInt18(B+1)=Value); + inc(B,3); +end; + +function Int18ToChars3(Value: cardinal): RawUTF8; +begin + FastSetString(result,nil,3); + PCardinal(result)^ := ((Value shr 12) and $3f)+ + ((Value shr 6) and $3f)shl 8+ + (Value and $3f)shl 16+$202020; +end; + +procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); +begin + FastSetString(result,nil,3); + PCardinal(result)^ := ((Value shr 12) and $3f)+ + ((Value shr 6) and $3f)shl 8+ + (Value and $3f)shl 16+$202020; +end; + +function Chars3ToInt18(P: pointer): cardinal; +begin + result := PCardinal(P)^-$202020; + result := ((result shr 16)and $3f)+ + ((result shr 8) and $3f)shl 6+ + (result and $3f)shl 12; +end; + +procedure TTextWriter.AddNoJSONEscape(P: Pointer); +begin + AddNoJSONEscape(P,StrLen(PUTF8Char(P))); +end; + +procedure TTextWriter.AddNoJSONEscape(P: Pointer; Len: PtrInt); +var i: PtrInt; +begin + if (P<>nil) and (Len>0) then begin + inc(B); // allow CancelLastChar + repeat + i := BEnd-B+1; // guess biggest size to be added into buf^ at once + if Len0 then begin + MoveFast(P^,B^,i); + inc(B,i); + end; + if i=Len then + break; + inc(PByte(P),i); + dec(Len,i); + // FlushInc writes B-buf+1 -> special one below: + WriteToStream(fTempBuf,B-fTempBuf); + B := fTempBuf; + until false; + dec(B); // allow CancelLastChar + end; +end; + +procedure TTextWriter.AddNoJSONEscapeUTF8(const text: RawByteString); +begin + AddNoJSONEscape(pointer(text),length(text)); +end; + +procedure TTextWriter.AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); +var PEnd: PtrUInt; + BMax: PUTF8Char; +begin + if WideChar=nil then + exit; + BMax := BEnd-7; // ensure enough space for biggest Unicode glyph as UTF-8 + if WideCharCount=0 then + repeat + if B>=BMax then begin + FlushToStream; + BMax := BEnd-7; // B may have been resized -> recompute BMax + end; + if WideChar^=0 then + break; + if WideChar^<=126 then begin + B[1] := AnsiChar(ord(WideChar^)); + inc(WideChar); + inc(B); + end else + inc(B,UTF16CharToUtf8(B+1,WideChar)); + until false else begin + PEnd := PtrUInt(WideChar)+PtrUInt(WideCharCount)*SizeOf(WideChar^); + repeat + if B>=BMax then begin + FlushToStream; + BMax := BEnd-7; + end; + if WideChar^=0 then + break; + if WideChar^<=126 then begin + B[1] := AnsiChar(ord(WideChar^)); + inc(WideChar); + inc(B); + if PtrUInt(WideChar)nil then + case Escape of + twNone: AddNoJSONEscape(P,StrLen(P)); + twJSONEscape: AddJSONEscape(P); + twOnSameLine: AddOnSameLine(P); + end; +end; + +procedure TTextWriter.Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); +begin + if P<>nil then + case Escape of + twNone: AddNoJSONEscape(P,Len); + twJSONEscape: AddJSONEscape(P,Len); + twOnSameLine: AddOnSameLine(P,Len); + end; +end; + +procedure TTextWriter.AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); +begin + if P<>nil then + case Escape of + twNone: AddNoJSONEscapeW(P,Len); + twJSONEscape: AddJSONEScapeW(P,Len); + twOnSameLine: AddOnSameLineW(P,Len); + end; +end; + +procedure TTextWriter.AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); +begin + AddAnyAnsiBuffer(pointer(s),length(s),Escape,0); +end; + +procedure TTextWriter.AddAnyAnsiString(const s: RawByteString; + Escape: TTextWriterKind; CodePage: Integer); +var L: integer; +begin + L := length(s); + if L=0 then + exit; + if (L>2) and (PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC) then begin + AddNoJSONEscape(pointer(s),L); // identified as a BLOB content + exit; + end; + if CodePage<0 then + {$ifdef HASCODEPAGE} + CodePage := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; + {$else} + CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert + {$endif} + AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage); +end; + +procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; + Escape: TTextWriterKind; CodePage: Integer); +var B: PUTF8Char; +begin + if Len>0 then + case CodePage of + CP_UTF8: // direct write of RawUTF8 content + if Escape<>twJSONEscape then + Add(PUTF8Char(P),Len,Escape) else + Add(PUTF8Char(P),0,Escape); + CP_RAWBYTESTRING: + Add(PUTF8Char(P),Len,Escape); // direct write of RawByteString content + CP_UTF16: + AddW(PWord(P),0,Escape); // direct write of UTF-16 content + CP_SQLRAWBLOB: begin + AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3); + WrBase64(P,Len,{withMagic=}false); + end; + else begin + // first handle trailing 7 bit ASCII chars, by quad + B := pointer(P); + if Len>=4 then + repeat + if PCardinal(P)^ and $80808080<>0 then + break; // break on first non ASCII quad + inc(P,4); + dec(Len,4); + until Len<4; + if (Len>0) and (P^<#128) then + repeat + inc(P); + dec(Len); + until (Len=0) or (P^>=#127); + if P<>pointer(B) then + Add(B,P-B,Escape); + if Len=0 then + exit; + // rely on explicit conversion for all remaining ASCII characters + TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape); + end; + end; +end; + +var + /// fast 256-byte branchless lookup table + // - 0 indicates no escape needed + // - 1 indicates #0 (end of string) + // - 2 should be escaped as \u00xx + // - b,t,n,f,r,\," as escaped character for #8,#9,#10,#12,#13,\," + JSON_ESCAPE: TNormTableByte; + +function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; +var tab: PNormTableByte; +begin + result := true; + tab := @JSON_ESCAPE; + if PLen>0 then + repeat + if tab[ord(P^)]<>0 then + exit; + inc(P); + dec(PLen); + until PLen=0; + result := false; +end; + +function NeedsJsonEscape(const Text: RawUTF8): boolean; +begin + result := NeedsJsonEscape(pointer(Text),length(Text)); +end; + +function NeedsJsonEscape(P: PUTF8Char): boolean; +var tab: PNormTableByte; + esc: byte; +begin + result := false; + if P=nil then + exit; + tab := @JSON_ESCAPE; + repeat + esc := tab[ord(P^)]; + if esc=0 then + inc(P) else + if esc=1 then + exit else // #0 reached + break; + until false; + result := true; +end; + +procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; + AnsiToWide: PWordArray; Escape: TTextWriterKind); +var c: cardinal; + esc: byte; +begin + while SourceChars>0 do begin + c := byte(Source^); + if c<=$7F then begin + if c=0 then + exit; + if B>=BEnd then + FlushToStream; + case Escape of + twNone: begin + inc(B); + B^ := AnsiChar(c); + end; + twJSONEscape: begin + esc := JSON_ESCAPE[c]; + if esc=0 then begin // no escape needed + inc(B); + B^ := AnsiChar(c); + end else + if esc=1 then // #0 + exit else + if esc=2 then begin // #7 e.g. -> \u0007 + AddShort('\u00'); + AddByteToHex(c); + end else + Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," + end; + twOnSameLine: begin + inc(B); + if c<32 then + B^ := ' ' else + B^ := AnsiChar(c); + end; + end + end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets + if BEnd-B<=3 then + FlushToStream; + c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char + if c>$7ff then begin + B[1] := AnsiChar($E0 or (c shr 12)); + B[2] := AnsiChar($80 or ((c shr 6) and $3F)); + B[3] := AnsiChar($80 or (c and $3F)); + inc(B,3); + end else begin + B[1] := AnsiChar($C0 or (c shr 6)); + B[2] := AnsiChar($80 or (c and $3F)); + inc(B,2); + end; + end; + dec(SourceChars); + inc(Source); + end; +end; + +procedure TTextWriter.AddOnSameLine(P: PUTF8Char); +begin + if P<>nil then + while P^<>#0 do begin + if B>=BEnd then + FlushToStream; + if P^<' ' then + B[1] := ' ' else + B[1] := P^; + inc(P); + inc(B); + end; +end; + +procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt); +var i: PtrInt; +begin + if P<>nil then + for i := 0 to Len-1 do begin + if B>=BEnd then + FlushToStream; + if P[i]<' ' then + B[1] := ' ' else + B[1] := P[i]; + inc(B); + end; +end; + +procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt); +var PEnd: PtrUInt; +begin + if P=nil then exit; + if Len=0 then + PEnd := 0 else + PEnd := PtrUInt(P)+PtrUInt(Len)*SizeOf(WideChar); + while (Len=0) or (PtrUInt(P) UTF-8 encode + inc(B,UTF16CharToUtf8(B+1,P)); + end; + end; +end; + +procedure TTextWriter.AddJSONEscape(P: Pointer; Len: PtrInt); +var i,start: PtrInt; + {$ifdef CPUX86NOTPIC}tab: TNormTableByte absolute JSON_ESCAPE; + {$else}tab: PNormTableByte;{$endif} +label noesc; +begin + if P=nil then + exit; + if Len=0 then + dec(Len); // -1 = no end + i := 0; + {$ifndef CPUX86NOTPIC} tab := @JSON_ESCAPE; {$endif} + if tab[PByteArray(P)[i]]=0 then begin +noesc:start := i; + if Len<0 then + repeat // fastest loop is for AddJSONEscape(P,nil) + inc(i); + until tab[PByteArray(P)[i]]<>0 else + repeat + inc(i); + until (i>=Len) or (tab[PByteArray(P)[i]]<>0); + inc(PByte(P),start); + dec(i,start); + if Len>=0 then + dec(Len,start); + if BEnd-B<=i then + AddNoJSONEscape(P,i) else begin + MoveFast(P^,B[1],i); + inc(B,i); + end; + if (Len>=0) and (i>=Len) then + exit; + end; + repeat + if BEnd-B<=10 then + FlushToStream; + case tab[PByteArray(P)[i]] of + 0: goto noesc; + 1: exit; // #0 + 2: begin // characters below ' ', #7 e.g. -> // 'u0007' + PCardinal(B+1)^ := ord('\')+ord('u')shl 8+ord('0')shl 16+ord('0')shl 24; + inc(B,4); + PWord(B+1)^ := TwoDigitsHexWB[PByteArray(P)[i]]; + end; + else // escaped as \ + b,t,n,f,r,\," + PWord(B+1)^ := (integer(tab[PByteArray(P)[i]]) shl 8) or ord('\'); + end; + inc(i); + inc(B,2); + until (Len>=0) and (i>=Len); +end; + +procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt); +var i,c,s: PtrInt; + esc: byte; +begin + if P=nil then + exit; + if Len=0 then + Len := MaxInt; + i := 0; + while i0) then + break; + inc(i); + until i>=Len; + if i<>s then + AddNoJSONEscapeW(@PWordArray(P)[s],i-s); + if i>=Len then + exit; + c := PWordArray(P)[i]; + if c=0 then + exit; + esc := JSON_ESCAPE[c]; + if esc=1 then // #0 + exit else + if esc=2 then begin // characters below ' ', #7 e.g. -> \u0007 + AddShort('\u00'); + AddByteToHex(c); + end else + Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," + inc(i); + end; +end; + +procedure TTextWriter.AddJSONEscape(const V: TVarRec); +begin + with V do + case VType of + vtPointer: AddShort('null'); + vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif} + vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin + Add('"'); + case VType of + vtString: if VString^[0]<>#0 then AddJSONEscape(@VString^[1],ord(VString^[0])); + vtAnsiString: AddJSONEscape(VAnsiString); + {$ifdef HASVARUSTRING} + vtUnicodeString: AddJSONEscapeW( + pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString))); + {$endif} + vtPChar: AddJSONEscape(VPChar); + vtChar: AddJSONEscape(@VChar,1); + vtWideChar: AddJSONEscapeW(@VWideChar,1); + vtWideString: AddJSONEscapeW(VWideString); + vtClass: AddClassName(VClass); + end; + Add('"'); + end; + vtBoolean: Add(VBoolean); // 'true'/'false' + vtInteger: Add(VInteger); + vtInt64: Add(VInt64^); + {$ifdef FPC} + vtQWord: AddQ(V.VQWord^); + {$endif} + vtExtended: AddDouble(VExtended^); + vtCurrency: AddCurr64(VInt64^); + vtObject: WriteObject(VObject); + {$ifndef NOVARIANTS} + vtVariant: AddVariant(VVariant^,twJSONEscape); + {$endif} + end; +end; + +procedure TTextWriter.AddJSONString(const Text: RawUTF8); +begin + Add('"'); + AddJSONEscape(pointer(Text)); + Add('"'); +end; + +procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind; + WriteObjectOptions: TTextWriterWriteObjectOptions); +begin + with V do + case VType of + vtInteger: Add(VInteger); + vtBoolean: if VBoolean then Add('1') else Add('0'); // normalize + vtChar: Add(@VChar,1,Escape); + vtExtended: AddDouble(VExtended^); + vtCurrency: AddCurr64(VInt64^); + vtInt64: Add(VInt64^); + {$ifdef FPC} + vtQWord: AddQ(VQWord^); + {$endif} + {$ifndef NOVARIANTS} + vtVariant: AddVariant(VVariant^,Escape); + {$endif} + vtString: if VString^[0]<>#0 then Add(@VString^[1],ord(VString^[0]),Escape); + vtInterface, + vtPointer: AddBinToHexDisplayMinChars(@VPointer,SizeOf(VPointer)); + vtPChar: Add(PUTF8Char(VPChar),Escape); + vtObject: WriteObject(VObject,WriteObjectOptions); + vtClass: AddClassName(VClass); + vtWideChar: AddW(@VWideChar,1,Escape); + vtPWideChar: + AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape); + vtAnsiString: + if VAnsiString<>nil then + Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8 + vtWideString: + if VWideString<>nil then + AddW(VWideString,length(WideString(VWideString)),Escape); + {$ifdef HASVARUSTRING} + vtUnicodeString: + if VUnicodeString<>nil then // convert to UTF-8 + AddW(VUnicodeString,length(UnicodeString(VUnicodeString)),Escape); + {$endif} + end; +end; + +{$ifndef NOVARIANTS} +procedure TTextWriter.AddJSON(const Format: RawUTF8; const Args,Params: array of const); +var temp: variant; +begin + _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,temp); + AddVariant(temp,twJSONEscape); +end; +{$endif} + +procedure TTextWriter.AddJSONArraysAsJSONObject(keys,values: PUTF8Char); +var k,v: PUTF8Char; +begin + if (keys=nil) or (keys^<>'[') or (values=nil) or (values^<>'[') then begin + AddShort('null'); + exit; + end; + inc(keys); // jump initial [ + inc(values); + Add('{'); + repeat + k := GotoEndJSONItem(keys); + v := GotoEndJSONItem(values); + if (k=nil) or (v=nil) then + break; // invalid JSON input + AddNoJSONEscape(keys,k-keys); + Add(':'); + AddNoJSONEscape(values,v-values); + Add(','); + if (k^<>',') or (v^<>',') then + break; // reached the end of the input JSON arrays + keys := k+1; + values := v+1; + until false; + CancelLastComma; + Add('}'); +end; + +procedure TTextWriter.AddJSONEscape(const NameValuePairs: array of const); +var a: integer; +procedure WriteValue; +begin + case VarRecAsChar(NameValuePairs[a]) of + ord('['): begin + Add('['); + while a'' then + {$ifdef UNICODE} + AddNoJSONEscapeW(pointer(s),0); + {$else} + AddAnsiString(s,twNone); + {$endif} +end; + +procedure TTextWriter.AddJSONEscapeString(const s: string); +begin + if s<>'' then + {$ifdef UNICODE} + AddJSONEscapeW(pointer(s),Length(s)); + {$else} + AddAnyAnsiString(s,twJSONEscape,0); + {$endif} +end; + +procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString); +begin + AddAnyAnsiString(s,twJSONEscape,0); +end; + +procedure TTextWriter.AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); +begin + if PropNameLen=0 then + exit; // paranoid check + if BEnd-B<=PropNameLen+3 then + FlushToStream; + if twoForceJSONExtended in CustomOptions then begin + MoveSmall(PropName,B+1,PropNameLen); + inc(B,PropNameLen+1); + B^ := ':'; + end else begin + B[1] := '"'; + MoveSmall(PropName,B+2,PropNameLen); + inc(B,PropNameLen+2); + PWord(B)^ := ord('"')+ord(':')shl 8; + inc(B); + end; +end; + +procedure TTextWriter.AddPropName(const PropName: ShortString); +begin + AddProp(@PropName[1],ord(PropName[0])); +end; + +procedure TTextWriter.AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); +begin + AddProp(@PropName[1],ord(PropName[0])); + AddJSONString(Text); + Add(','); +end; + +procedure TTextWriter.AddPropJSONInt64(const PropName: shortstring; Value: Int64); +begin + AddProp(@PropName[1],ord(PropName[0])); + Add(Value); + Add(','); +end; + +procedure TTextWriter.AddFieldName(const FieldName: RawUTF8); +begin + AddProp(Pointer(FieldName),length(FieldName)); +end; + +procedure TTextWriter.AddClassName(aClass: TClass); +begin + if aClass<>nil then + AddShort(PShortString(PPointer(PtrInt(PtrUInt(aClass))+vmtClassName)^)^); +end; + +procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar); +begin + Add('"'); + if Instance=nil then + AddShort('void') else + AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); + Add('('); + AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); + Add(')','"'); + if SepChar<>#0 then + Add(SepChar); +end; + +procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar; + IncludeUnitName, IncludePointer: boolean); +var info: PTypeInfo; +begin + if IncludeUnitName then begin + info := PPointer(PPtrInt(Instance)^+vmtTypeInfo)^; + if info<>nil then begin // avoid GPF if no RTTI for this class + AddShort(PShortString(@GetTypeInfo(info)^.UnitNameLen)^); + Add('.'); + end; + end; + AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); + if IncludePointer then begin + Add('('); + AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); + Add(')'); + end; + if SepChar<>#0 then + Add(SepChar); +end; + +procedure TTextWriter.AddShort(const Text: ShortString); +var L: PtrInt; +begin + L := ord(Text[0]); + if L=0 then + exit; + if BEnd-B<=L then + FlushToStream; + MoveFast(Text[1],B[1],L); + inc(B,L); +end; + +procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8); +var L: integer; + P,B: PUTF8Char; + quote: AnsiChar; +begin + L := length(QuotedString); + if L>0 then begin + quote := QuotedString[1]; + if (quote in ['''','"']) and (QuotedString[L]=quote) then begin + Add('"'); + P := pointer(QuotedString); + inc(P); + repeat + B := P; + while P[0]<>quote do inc(P); + if P[1]<>quote then + break; // end quote + inc(P); + AddJSONEscape(B,P-B); + inc(P); // ignore double quote + until false; + if P-B<>0 then + AddJSONEscape(B,P-B); + Add('"'); + end else + AddNoJSONEscape(pointer(QuotedString),length(QuotedString)); + end; +end; + +procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString); +var P: PAnsiChar; + L: integer; +begin + L := length(Text^); + P := @Text^[1]; + while (L>0) and (P^ in ['a'..'z']) do begin + inc(P); + dec(L); + end; + if L=0 then + AddShort(Text^) else + AddNoJSONEscape(P,L); +end; + +procedure TTextWriter.AddTrimSpaces(const Text: RawUTF8); +begin + AddTrimSpaces(pointer(Text)); +end; + +procedure TTextWriter.AddTrimSpaces(P: PUTF8Char); +var c: AnsiChar; +begin + if P<>nil then + repeat + c := P^; + inc(P); + if c>' ' then + Add(c); + until c=#0; +end; + +procedure TTextWriter.AddString(const Text: RawUTF8); +var L: PtrInt; +begin + L := PtrInt(Text); + if L=0 then + exit; + L := PStrLen(L-_STRLEN)^; + if L0 then begin + if len0 then + if L*count>fTempBufSize then + for i := 1 to count do + AddString(Text) else begin + if BEnd-B<=L*count then + FlushToStream; + for i := 1 to count do begin + MoveFast(pointer(Text)^,B[1],L); + inc(B,L); + end; + end; +end; + +procedure TTextWriter.CancelAll; +begin + if self=nil then + exit; // avoid GPF + if fTotalFileSize<>0 then + fTotalFileSize := fStream.Seek(fInitialStreamPosition,soBeginning); + B := fTempBuf-1; +end; + +procedure TTextWriter.SetBuffer(aBuf: pointer; aBufSize: integer); +begin + if aBufSize<=16 then + raise ESynException.CreateUTF8('%.SetBuffer(size=%)',[self,aBufSize]); + if aBuf=nil then + GetMem(fTempBuf,aBufSize) else begin + fTempBuf := aBuf; + Include(fCustomOptions,twoBufferIsExternal); + end; + fTempBufSize := aBufSize; + B := fTempBuf-1; // Add() methods will append at B+1 + BEnd := fTempBuf+fTempBufSize-16; // -16 to avoid buffer overwrite/overread + if DefaultTextWriterTrimEnum then + Include(fCustomOptions,twoTrimLeftEnumSets); +end; + +constructor TTextWriter.Create(aStream: TStream; aBufSize: integer); +begin + SetStream(aStream); + if aBufSize<256 then + aBufSize := 256; + SetBuffer(nil,aBufSize); +end; + +constructor TTextWriter.Create(aStream: TStream; aBuf: pointer; aBufSize: integer); +begin + SetStream(aStream); + SetBuffer(aBuf,aBufSize); +end; + +constructor TTextWriter.CreateOwnedStream(aBufSize: integer); +begin + Create(TRawByteStringStream.Create,aBufSize); + Include(fCustomOptions,twoStreamIsOwned); +end; + +constructor TTextWriter.CreateOwnedStream(aBuf: pointer; aBufSize: integer); +begin + SetStream(TRawByteStringStream.Create); + SetBuffer(aBuf,aBufSize); + Include(fCustomOptions,twoStreamIsOwned); +end; + +constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; + aBufSize: integer); +begin + if aBufSize>SizeOf(aStackBuf) then // too small -> allocate on heap + CreateOwnedStream(aBufSize) else + CreateOwnedStream(@aStackBuf,SizeOf(aStackBuf)); +end; + +constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName; + aBufSize: integer); +begin + DeleteFile(aFileName); + Create(TFileStream.Create(aFileName,fmCreate or fmShareDenyWrite),aBufSize); + Include(fCustomOptions,twoStreamIsOwned); +end; + +destructor TTextWriter.Destroy; +begin + if twoStreamIsOwned in fCustomOptions then + fStream.Free; + if not (twoBufferIsExternal in fCustomOptions) then + FreeMem(fTempBuf); + fInternalJSONWriter.Free; + inherited; +end; + +class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); +begin + DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText; +end; + +procedure TTextWriter.SetStream(aStream: TStream); +begin + if fStream<>nil then + if twoStreamIsOwned in fCustomOptions then begin + FreeAndNil(fStream); + Exclude(fCustomOptions,twoStreamIsOwned); + end; + if aStream<>nil then begin + fStream := aStream; + fInitialStreamPosition := fStream.Seek(0,soCurrent); + fTotalFileSize := fInitialStreamPosition; + end; +end; + +procedure TTextWriter.FlushToStream; +var i: PtrInt; + s: PtrUInt; +begin + i := B-fTempBuf+1; + if i<=0 then + exit; + WriteToStream(fTempBuf,i); + if not (twoFlushToStreamNoAutoResize in fCustomOptions) then begin + s := fTotalFileSize-fInitialStreamPosition; + if (fTempBufSize<49152) and (s>PtrUInt(fTempBufSize)*4) then + s := fTempBufSize*2 else // tune small (stack-alloc?) buffer + if (fTempBufSize<1 shl 20) and (s>40 shl 20) then + s := 1 shl 20 else // 40MB -> 1MB buffer + s := 0; + if s>0 then begin + fTempBufSize := s; + if twoBufferIsExternal in fCustomOptions then // use heap, not stack + exclude(fCustomOptions,twoBufferIsExternal) else + FreeMem(fTempBuf); // with big content comes bigger buffer + GetMem(fTempBuf,fTempBufSize); + BEnd := fTempBuf+(fTempBufSize-16); + end; + end; + B := fTempBuf-1; +end; + +procedure TTextWriter.WriteToStream(data: pointer; len: PtrUInt); +begin + if Assigned(fOnFlushToStream) then + fOnFlushToStream(data,len); + fStream.WriteBuffer(data^,len); + inc(fTotalFileSize,len); +end; + +function TTextWriter.GetTextLength: PtrUInt; +begin + if self=nil then + result := 0 else + result := PtrUInt(B-fTempBuf+1)+fTotalFileSize-fInitialStreamPosition; +end; + +function TTextWriter.Text: RawUTF8; +begin + SetText(result); +end; + +procedure TTextWriter.ForceContent(const text: RawUTF8); +begin + CancelAll; + if (fInitialStreamPosition=0) and fStream.InheritsFrom(TRawByteStringStream) then + TRawByteStringStream(fStream).fDataString := text else + fStream.WriteBuffer(pointer(text)^,length(text)); + fTotalFileSize := fInitialStreamPosition+cardinal(length(text)); +end; + +procedure TTextWriter.FlushFinal; +begin + Include(fCustomOptions,twoFlushToStreamNoAutoResize); + FlushToStream; +end; + +procedure TTextWriter.SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat); +var Len: cardinal; +begin + FlushFinal; + Len := fTotalFileSize-fInitialStreamPosition; + if Len=0 then + result := '' else + if fStream.InheritsFrom(TRawByteStringStream) then + with TRawByteStringStream(fStream) do + if fInitialStreamPosition=0 then begin + {$ifdef HASCODEPAGE} // FPC expects this + SetCodePage(fDataString,CP_UTF8,false); + {$endif} + result := fDataString; + fDataString := ''; + end else + FastSetString(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else + if fStream.InheritsFrom(TCustomMemoryStream) then + with TCustomMemoryStream(fStream) do + FastSetString(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin + FastSetString(result,nil,Len); + fStream.Seek(fInitialStreamPosition,soBeginning); + fStream.Read(pointer(result)^,Len); + end; + if reformat<>jsonCompact then begin // reformat using the very same instance + CancelAll; + AddJSONReformat(pointer(result),reformat,nil); + SetText(result); + end; +end; + +procedure TTextWriter.WrRecord(const Rec; TypeInfo: pointer); +var L: integer; + tmp: RawByteString; +begin + L := RecordSaveLength(Rec,TypeInfo); + SetString(tmp,nil,L); + if L<>0 then + RecordSave(Rec,pointer(tmp),TypeInfo); + WrBase64(pointer(tmp),L,{withMagic=}true); +end; + +procedure TTextWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); +var trailing, main, n: PtrUInt; +begin + if withMagic then + if Len<=0 then begin + AddShort('null'); // JSON null is better than "" for BLOBs + exit; + end else + AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); + if len>0 then begin + n := Len div 3; + trailing := Len-n*3; + dec(Len,trailing); + if BEnd-B>integer(n+1) shl 2 then begin + // will fit in available space in Buf -> fast in-buffer Base64 encoding + n := Base64EncodeMain(@B[1],P,Len); + inc(B,n*4); + inc(P,n*3); + end else begin + // bigger than available space in Buf -> do it per chunk + FlushToStream; + while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3 + n := ((fTempBufSize-4)shr 2)*3; + if Len0 then begin + Base64EncodeTrailing(@B[1],P,trailing); + inc(B,4); + end; + end; + if withMagic then + Add('"'); +end; + + +{ TTextWriterWithEcho } + +procedure TTextWriterWithEcho.AddEndOfLine(aLevel: TSynLogInfo=sllNone); +var i: integer; +begin + if BEnd-B<=1 then + FlushToStream; + if twoEndOfLineCRLF in fCustomOptions then begin + PWord(B+1)^ := 13+10 shl 8; // CR + LF + inc(B,2); + end else begin + B[1] := #10; // LF + inc(B); + end; + if fEchos<>nil then begin + fEchoStart := EchoFlush; + for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below + try + fEchos[i](self,aLevel,fEchoBuf); + except // remove callback in case of exception during echoing in user code + MultiEventRemove(fEchos,i); + end; + fEchoBuf := ''; + end; +end; + +procedure TTextWriterWithEcho.FlushToStream; +begin + if fEchos<>nil then begin + EchoFlush; + fEchoStart := 0; + end; + inherited FlushToStream; +end; + +procedure TTextWriterWithEcho.EchoAdd(const aEcho: TOnTextWriterEcho); +begin + if self<>nil then + if MultiEventAdd(fEchos,TMethod(aEcho)) then + if fEchos<>nil then + fEchoStart := B-fTempBuf+1; // ignore any previous buffer +end; + +procedure TTextWriterWithEcho.EchoRemove(const aEcho: TOnTextWriterEcho); +begin + if self<>nil then + MultiEventRemove(fEchos,TMethod(aEcho)); +end; + +function TTextWriterWithEcho.EchoFlush: PtrInt; +var L,LI: PtrInt; + P: PByteArray; +begin + result := B-fTempBuf+1; + L := result-fEchoStart; + P := @PByteArray(fTempBuf)[fEchoStart]; + while (L>0) and (P[L-1] in [10,13]) do // trim right CR/LF chars + dec(L); + LI := length(fEchoBuf); // fast append to fEchoBuf + SetLength(fEchoBuf,LI+L); + MoveFast(P^,PByteArray(fEchoBuf)[LI],L); +end; + +procedure TTextWriterWithEcho.EchoReset; +begin + fEchoBuf := ''; +end; + +function TTextWriterWithEcho.GetEndOfLineCRLF: boolean; +begin + result := twoEndOfLineCRLF in fCustomOptions; +end; + +procedure TTextWriterWithEcho.SetEndOfLineCRLF(aEndOfLineCRLF: boolean); +begin + if aEndOfLineCRLF then + include(fCustomOptions,twoEndOfLineCRLF) else + exclude(fCustomOptions,twoEndOfLineCRLF); +end; + + + +function JSONEncode(const NameValuePairs: array of const): RawUTF8; +var temp: TTextWriterStackBuffer; +begin + if high(NameValuePairs)<1 then + result := '{}' else // return void JSON object on error + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + AddJSONEscape(NameValuePairs); + SetText(result); + finally + Free + end; +end; + +{$ifndef NOVARIANTS} +function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; +var temp: TTextWriterStackBuffer; +begin + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + AddJSON(Format,Args,Params); + SetText(result); + finally + Free + end; +end; +{$endif} + +function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + W := TTextWriter.CreateOwnedStream(temp); + try + W.Add('['); + W.AddCSVDouble(Values); + W.Add(']'); + W.SetText(result); + finally + W.Free + end; +end; + +function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + W := TTextWriter.CreateOwnedStream(temp); + try + W.Add('['); + W.AddCSVUTF8(Values); + W.Add(']'); + W.SetText(result); + finally + W.Free + end; +end; + +function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + W := TTextWriter.CreateOwnedStream(temp); + try + W.Add('['); + W.AddCSVInteger(Values); + W.Add(']'); + W.SetText(result); + finally + W.Free + end; +end; + +function JSONEncodeArrayOfConst(const Values: array of const; + WithoutBraces: boolean): RawUTF8; +begin + JSONEncodeArrayOfConst(Values,WithoutBraces,result); +end; + +procedure JSONEncodeArrayOfConst(const Values: array of const; + WithoutBraces: boolean; var result: RawUTF8); +var temp: TTextWriterStackBuffer; +begin + if length(Values)=0 then + if WithoutBraces then + result := '' else + result := '[]' else + with DefaultTextWriterSerializer.CreateOwnedStream(temp) do + try + if not WithoutBraces then + Add('['); + AddCSVConst(Values); + if not WithoutBraces then + Add(']'); + SetText(result); + finally + Free + end; +end; + +procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; + var result: RawUTF8); +var temp: TTextWriterStackBuffer; +begin + if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then + // unescape SQL quoted string value into a valid JSON string + with TTextWriter.CreateOwnedStream(temp) do + try + Add('{','"'); + AddNoJSONEscapeUTF8(Name); + Add('"',':'); + AddQuotedStringAsJSON(SQLValue); + Add('}'); + SetText(result); + finally + Free; + end else + // Value is a number or null/true/false + result := '{"'+Name+'":'+SQLValue+'}'; +end; + +{ TValuePUTF8Char } + +procedure TValuePUTF8Char.ToUTF8(var Text: RawUTF8); +begin + FastSetString(Text,Value,ValueLen); +end; + +function TValuePUTF8Char.ToUTF8: RawUTF8; +begin + FastSetString(result,Value,ValueLen); +end; + +function TValuePUTF8Char.ToString: string; +begin + UTF8DecodeToString(Value,ValueLen,result); +end; + +function TValuePUTF8Char.ToInteger: PtrInt; +begin + result := GetInteger(Value); +end; + +function TValuePUTF8Char.ToCardinal: PtrUInt; +begin + result := GetCardinal(Value); +end; + +function TValuePUTF8Char.Idem(const Text: RawUTF8): boolean; +begin + if length(Text)=ValueLen then + result := IdemPropNameUSameLen(pointer(Text),Value,ValueLen) else + result := false; +end; + +procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); +begin + JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray); +end; + +procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); +begin + JSONDecode(UniqueRawUTF8(RawUTF8(JSON)),Names,Values,HandleValuesAsObjectOrArray); +end; + +function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; + Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char; +var n, i: PtrInt; + namelen, valuelen: integer; + name, value: PUTF8Char; + EndOfObject: AnsiChar; +begin + result := nil; + if Values=nil then + exit; // avoid GPF + n := length(Names); + FillCharFast(Values[0],n*SizeOf(Values[0]),0); + dec(n); + if P=nil then + exit; + while P^<>'{' do + if P^=#0 then + exit else + inc(P); + inc(P); // jump { + repeat + name := GetJSONPropName(P,@namelen); + if name=nil then + exit; // invalid JSON content + value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray,true,@valuelen); + if not(EndOfObject in [',','}']) then + exit; // invalid item separator + for i := 0 to n do + if (Values[i].Value=nil) and IdemPropNameU(Names[i],name,namelen) then begin + Values[i].Value := value; + Values[i].ValueLen := valuelen; + break; + end; + until (P=nil) or (EndOfObject='}'); + if P=nil then // result=nil indicates failure -> points to #0 for end of text + result := @NULCHAR else + result := P; +end; + +function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8; + wasString: PBoolean; HandleValuesAsObjectOrArray: Boolean): RawUTF8; +var P, Name, Value: PUTF8Char; + NameLen, ValueLen: integer; + EndOfObject: AnsiChar; +begin + result := ''; + P := pointer(JSON); + if P=nil then + exit; + while P^<>'{' do + if P^=#0 then + exit else + inc(P); + inc(P); // jump { + repeat + Name := GetJSONPropName(P,@NameLen); + if Name=nil then + exit; // invalid JSON content + Value := GetJSONFieldOrObjectOrArray( + P,wasString,@EndOfObject,HandleValuesAsObjectOrArray,true,@ValueLen); + if not(EndOfObject in [',','}']) then + exit; // invalid item separator + if IdemPropNameU(aName,Name,NameLen) then begin + FastSetString(result,Value,ValueLen); + exit; + end; + until (P=nil) or (EndOfObject='}'); +end; + +function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; + HandleValuesAsObjectOrArray: Boolean): PUTF8Char; +var n: PtrInt; + field: TNameValuePUTF8Char; + EndOfObject: AnsiChar; +begin + {$ifdef FPC} + Values := nil; + {$endif} + result := nil; + n := 0; + if P<>nil then begin + while P^<>'{' do + if P^=#0 then + exit else + inc(P); + inc(P); // jump { + repeat + field.Name := GetJSONPropName(P,@field.NameLen); + if field.Name=nil then + exit; // invalid JSON content + field.Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject, + HandleValuesAsObjectOrArray,true,@field.ValueLen); + if not(EndOfObject in [',','}']) then + exit; // invalid item separator + if n=length(Values) then + SetLength(Values,n+32); + Values[n] := field; + inc(n); + until (P=nil) or (EndOfObject='}'); + end; + SetLength(Values,n); + if P=nil then // result=nil indicates failure -> points to #0 for end of text + result := @NULCHAR else + result := P; +end; + +function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; + out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; +begin + result := nil; + // retrieve string field + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + if P^<>'"' then exit; + Field := P+1; + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; // here P^ should be '"' + FieldLen := P-Field; + // check valid JSON delimiter + repeat inc(P) until (P^>' ') or (P^=#0); + if ExpectNameField then begin + if P^<>':' then + exit; // invalid name field + end else + if not (P^ in ['}',',']) then + exit; // invalid value field + result := P; // return either ':' for name field, either '}',',' for value +end; + +// decode a JSON field into an UTF-8 encoded buffer, stored inplace of input buffer +function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; + wasString: PBoolean; EndOfObject: PUTF8Char; Len: PInteger): PUTF8Char; +var D: PUTF8Char; + c4,surrogate,j: integer; + c: AnsiChar; + b: byte; + jsonset: PJsonCharSet; + {$ifdef CPUX86NOTPIC} tab: TNormTableByte absolute ConvertHexToBin; + {$else} tab: PNormTableByte; {$endif} +label slash,num,lit; +begin // see http://www.ietf.org/rfc/rfc4627.txt + if wasString<>nil then + wasString^ := false; // not a string by default + if Len<>nil then + Len^ := 0; // avoid buffer overflow on parsing error + PDest := nil; // PDest=nil indicates parsing error (e.g. unexpected #0 end) + result := nil; + if P=nil then exit; + if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' '; + case P^ of + '"': begin // " -> unescape P^ into D^ + if wasString<>nil then + wasString^ := true; + inc(P); + result := P; + D := P; + repeat + c := P^; + if c=#0 then exit else + if c='"' then break else + if c='\' then goto slash; + inc(P); + D^ := c; + inc(D); + continue; +slash:inc(P); // unescape JSON string + c := P^; + if (c='"') or (c='\') then begin +lit: inc(P); + D^ := c; // most common case + inc(D); + continue; + end else + if c=#0 then + exit else // to avoid potential buffer overflow issue on \#0 + if c='b' then + c := #8 else + if c='t' then + c := #9 else + if c='n' then + c := #10 else + if c='f' then + c := #12 else + if c='r' then + c := #13 else + if c='u' then begin + // inlined decoding of '\u0123' UTF-16 codepoint(s) into UTF-8 + {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} + c4 := tab[ord(P[1])]; + if c4<=15 then begin + b := tab[ord(P[2])]; + if b<=15 then begin + c4 := c4 shl 4; + c4 := c4 or b; + b := tab[ord(P[3])]; + if b<=15 then begin + c4 := c4 shl 4; + c4 := c4 or b; + b := tab[ord(P[4])]; + if b<=15 then begin + c4 := c4 shl 4; + c4 := c4 or b; + case c4 of + 0: begin + D^ := '?'; // \u0000 is an invalid value + inc(D); + end; + 1..$7f: begin + D^ := AnsiChar(c4); + inc(D); + end; + $80..$7ff: begin + D[0] := AnsiChar($C0 or (c4 shr 6)); + D[1] := AnsiChar($80 or (c4 and $3F)); + inc(D,2); + end; + UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX: + if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin + inc(P,6); // optimistic conversion (no check) + surrogate := (ConvertHexToBin[ord(P[1])] shl 12)+ + (ConvertHexToBin[ord(P[2])] shl 8)+ + (ConvertHexToBin[ord(P[3])] shl 4)+ + ConvertHexToBin[ord(P[4])]; + case c4 of // inlined UTF16CharToUtf8() + UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: + c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN); + UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: + c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN); + end; + case c4 of + 0..$7ff: b := 2; + $800..$ffff: b := 3; + $10000..$1FFFFF: b := 4; + $200000..$3FFFFFF: b := 5; + else b := 6; + end; + for j := b-1 downto 1 do begin + D[j] := AnsiChar((c4 and $3f)+$80); + c4 := c4 shr 6; + end; + D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]); + inc(D,b); + end else begin + D^ := '?'; // unexpected surrogate without its pair + inc(D); + end; + else begin + D[0] := AnsiChar($E0 or (c4 shr 12)); + D[1] := AnsiChar($80 or ((c4 shr 6) and $3F)); + D[2] := AnsiChar($80 or (c4 and $3F)); + inc(D,3); + end; + end; + inc(P,5); + continue; + end; + end; + end; + end; + c := '?'; // bad formated hexa number -> '?0123' + end; + goto lit; + until false; + // here P^='"' + D^ := #0; // make zero-terminated + if Len<>nil then + Len^ := D-result; + inc(P); + if P^=#0 then + exit; + end; + '0': + if P[1] in ['0'..'9'] then // 0123 excluded by JSON! + exit else // leave PDest=nil for unexpected end + goto num;// may be 0.123 + '-','1'..'9': begin // numerical field: all chars before end of field +num:result := P; + jsonset := @JSON_CHARS; + repeat + if not (jcDigitFloatChar in jsonset[P^]) then + break; + inc(P); + until false; + if P^=#0 then + exit; + if Len<>nil then + Len^ := P-result; + if P^<=' ' then begin + P^ := #0; // force numerical field with no trailing ' ' + inc(P); + end; + end; + 'n': + if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin + result := nil; // null -> returns nil and wasString=false + if Len<>nil then + Len^ := 0; // when result is converted to string + inc(P,4); + end else + exit; + 'f': + if (PInteger(P+1)^=FALSE_LOW2) and (jcEndOfJSONValueField in JSON_CHARS[P[5]]) then begin + result := P; // false -> returns 'false' and wasString=false + if Len<>nil then + Len^ := 5; + inc(P,5); + end else + exit; + 't': + if (PInteger(P)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin + result := P; // true -> returns 'true' and wasString=false + if Len<>nil then + Len^ := 4; + inc(P,4); + end else + exit; + else + exit; // PDest=nil to indicate error + end; + jsonset := @JSON_CHARS; + while not (jcEndOfJSONField in jsonset[P^]) do begin + if P^=#0 then + exit; // leave PDest=nil for unexpected end + inc(P); + end; + if EndOfObject<>nil then + EndOfObject^ := P^; + P^ := #0; // make zero-terminated + PDest := @P[1]; + if P[1]=#0 then + PDest := nil; +end; + +function GetJSONPropName(var P: PUTF8Char; Len: PInteger): PUTF8Char; +var Name: PUTF8Char; + wasString: boolean; + c, EndOfObject: AnsiChar; + tab: PJsonCharSet; +begin // should match GotoNextJSONObjectOrArray() and JsonPropNameValid() + result := nil; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + Name := P; // put here to please some versions of Delphi compiler + c := P^; + if c='"' then begin + Name := GetJSONField(P,P,@wasString,@EndOfObject,Len); + if (Name=nil) or not wasString or (EndOfObject<>':') then + exit; + end else + if c = '''' then begin // single quotes won't handle nested quote character + inc(P); + Name := P; + while P^<>'''' do + if P^<' ' then + exit else + inc(P); + if Len<>nil then + Len^ := P-Name; + P^ := #0; + repeat inc(P) until (P^>' ') or (P^=#0); + if P^<>':' then + exit; + inc(P); + end else begin // e.g. '{age:{$gt:18}}' + tab := @JSON_CHARS; + if not (jcJsonIdentifierFirstChar in tab[c]) then + exit; + repeat + inc(P); + until not (jcJsonIdentifier in tab[P^]); + if Len<>nil then + Len^ := P-Name; + if (P^<=' ') and (P^<>#0) then begin + P^ := #0; + inc(P); + end; + while (P^<=' ') and (P^<>#0) do inc(P); + if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs + exit; + P^ := #0; + inc(P); + end; + result := Name; +end; + +procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); +var Name: PAnsiChar; + c: AnsiChar; + tab: PJsonCharSet; +begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName() + PropName[0] := #0; + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + Name := pointer(P); + c := P^; + if c='"' then begin + inc(Name); + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + SetString(PropName,Name,P-Name); // note: won't unescape JSON strings + repeat inc(P) until (P^>' ') or (P^=#0); + if P^<>':' then begin + PropName[0] := #0; + exit; + end; + inc(P); + end else + if c='''' then begin // single quotes won't handle nested quote character + inc(P); + inc(Name); + while P^<>'''' do + if P^<' ' then + exit else + inc(P); + SetString(PropName,Name,P-Name); + repeat inc(P) until (P^>' ') or (P^=#0); + if P^<>':' then begin + PropName[0] := #0; + exit; + end; + inc(P); + end else begin // e.g. '{age:{$gt:18}}' + tab := @JSON_CHARS; + if not (jcJsonIdentifierFirstChar in tab[c]) then + exit; + repeat + inc(P); + until not (jcJsonIdentifier in tab[P^]); + SetString(PropName,Name,P-Name); + while (P^<=' ') and (P^<>#0) do inc(P); + if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs + PropName[0] := #0; + exit; + end; + inc(P); + end; +end; + +function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; +var c: AnsiChar; + tab: PJsonCharSet; +label s; +begin // should match GotoNextJSONObjectOrArray() + while (P^<=' ') and (P^<>#0) do inc(P); + result := nil; + if P=nil then + exit; + c := P^; + if c='"' then begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; +s: repeat inc(P) until (P^>' ') or (P^=#0); + if P^<>':' then + exit; + end else + if c='''' then begin // single quotes won't handle nested quote character + inc(P); + while P^<>'''' do + if P^<' ' then + exit else + inc(P); + goto s; + end else begin // e.g. '{age:{$gt:18}}' + tab := @JSON_CHARS; + if not (jcJsonIdentifierFirstChar in tab[c]) then + exit; + repeat + inc(P); + until not (jcJsonIdentifier in tab[P^]); + if (P^<=' ') and (P^<>#0) then + inc(P); + while (P^<=' ') and (P^<>#0) do inc(P); + if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs + exit; + end; + repeat inc(P) until (P^>' ') or (P^=#0); + result := P; +end; + +function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean; + EndOfObject: PUTF8Char; HandleValuesAsObjectOrArray: Boolean; + NormalizeBoolean: Boolean; Len: PInteger): PUTF8Char; +var Value: PUTF8Char; + wStr: boolean; +begin + result := nil; + if P=nil then + exit; + while ord(P^) in [1..32] do inc(P); + if HandleValuesAsObjectOrArray and (P^ in ['{','[']) then begin + Value := P; + P := GotoNextJSONObjectOrArray(P); + if P=nil then + exit; // invalid content + if Len<>nil then + Len^ := P-Value; + if wasString<>nil then + wasString^ := false; // was object or array + while ord(P^) in [1..32] do inc(P); + if EndOfObject<>nil then + EndOfObject^ := P^; + P^ := #0; // make zero-terminated + if P[1]=#0 then + P := nil else + inc(P); + result := Value; + end else begin + result := GetJSONField(P,P,@wStr,EndOfObject,Len); + if wasString<>nil then + wasString^ := wStr; + if not wStr and NormalizeBoolean and (result<>nil) then begin + if PInteger(result)^=TRUE_LOW then + result := pointer(SmallUInt32UTF8[1]) else // normalize true -> 1 + if PInteger(result)^=FALSE_LOW then + result := pointer(SmallUInt32UTF8[0]) else // normalize false -> 0 + exit; + if Len<>nil then + Len^ := 1; + end; + end; +end; + +function IsString(P: PUTF8Char): boolean; // test if P^ is a "string" value +begin + if P=nil then begin + result := false; + exit; + end; + while (P^<=' ') and (P^<>#0) do inc(P); + if (P[0] in ['0'..'9']) or // is first char numeric? + ((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin + // check if P^ is a true numerical value + repeat inc(P) until not (P^ in ['0'..'9']); // check digits + if P^='.' then + repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits + if ((P^='e') or (P^='E')) and (P[1] in ['0'..'9','+','-']) then begin + inc(P); + if P^='+' then inc(P) else + if P^='-' then inc(P); + while (P^>='0') and (P^<='9') do inc(P); + end; + while (P^<=' ') and (P^<>#0) do inc(P); + result := (P^<>#0); + exit; + end else + result := true; // don't begin with a numerical value -> must be a string +end; + +function IsStringJSON(P: PUTF8Char): boolean; // test if P^ is a "string" value +var c4: integer; + c: AnsiChar; + tab: PJsonCharSet; +begin + if P=nil then begin + result := false; + exit; + end; + while (P^<=' ') and (P^<>#0) do inc(P); + tab := @JSON_CHARS; + c4 := PInteger(P)^; + if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (jcEndOfJSONValueField in tab[P[4]])) or + ((c4=FALSE_LOW) and (P[4]='e') and (jcEndOfJSONValueField in tab[P[5]])) then begin + result := false; // constants are no string + exit; + end; + c := P^; + if (jcDigitFirstChar in tab[c]) and + (((c>='1') and (c<='9')) or // is first char numeric? + ((c='0') and ((P[1]<'0') or (P[1]>'9'))) or // '012' excluded by JSON + ((c='-') and (P[1]>='0') and (P[1]<='9'))) then begin + // check if c is a true numerical value + repeat inc(P) until (P^<'0') or (P^>'9'); // check digits + if P^='.' then + repeat inc(P) until (P^<'0') or (P^>'9'); // check fractional digits + if ((P^='e') or (P^='E')) and (jcDigitChar in tab[P[1]]) then begin + inc(P); + c := P^; + if c='+' then inc(P) else + if c='-' then inc(P); + while (P^>='0') and (P^<='9') do inc(P); + end; + while (P^<=' ') and (P^<>#0) do inc(P); + result := (P^<>#0); + exit; + end else + result := true; // don't begin with a numerical value -> must be a string +end; + +function IsValidJSON(const s: RawUTF8): boolean; +begin + result := IsValidJSON(pointer(s),length(s)); +end; + +function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; +var B: PUTF8Char; +begin + result := false; + if (P=nil) or (len<=0) or (StrLen(P)<>len) then + exit; + B := P; + P := GotoEndJSONItem(B,{strict=}true); + result := (P<>nil) and (P-B=len); +end; + +procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; + EndOfObject: PAnsiChar); +var B: PUTF8Char; +begin + result := ''; + if P=nil then + exit; + B := GotoNextNotSpace(P); + P := GotoEndJSONItem(B); + if P=nil then + exit; + FastSetString(RawUTF8(result),B,P-B); + while (P^<=' ') and (P^<>#0) do inc(P); + if EndOfObject<>nil then + EndOfObject^ := P^; + if P^<>#0 then //if P^=',' then + repeat inc(P) until (P^>' ') or (P^=#0); +end; + +function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; + wasString: PBoolean; EndOfObject: PUTF8Char): boolean; +var V: PUTF8Char; + VLen: integer; +begin + V := GetJSONFieldOrObjectOrArray(P,wasstring,EndOfObject,true,true,@VLen); + if V=nil then // parsing error + result := false else begin + FastSetString(output,V,VLen); + result := true; + end; +end; + +function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char; +var tab: PJsonCharSet; +label Prop; +begin // should match GetJSONPropName() + result := nil; + repeat + case P^ of + '{','[': begin + if PMax=nil then + P := GotoNextJSONObjectOrArray(P) else + P := GotoNextJSONObjectOrArrayMax(P,PMax); + if P=nil then exit; + end; + ':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only + ',': inc(P); // comma appears in both JSON objects and arrays + '}': if EndChar='}' then break else exit; + ']': if EndChar=']' then break else exit; + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + inc(P); + end; + '-','+','0'..'9': begin // '0123' excluded by JSON, but not here + tab := @JSON_CHARS; + repeat + inc(P); + until not (jcDigitFloatChar in tab[P^]); + end; + 't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop; + 'f': if PInteger(P+1)^=FALSE_LOW2 then inc(P,5) else goto Prop; + 'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop; + '''': begin // single-quoted identifier + repeat inc(P); if P^<=' ' then exit; until P^=''''; + repeat inc(P) until (P^>' ') or (P^=#0); + if P^<>':' then exit; + end; + '/': begin + repeat // allow extended /regex/ syntax + inc(P); + if P^=#0 then + exit; + until P^='/'; + repeat inc(P) until (P^>' ') or (P^=#0); + end; + else begin +Prop: tab := @JSON_CHARS; + if not (jcJsonIdentifierFirstChar in tab[P^]) then + exit; + repeat + inc(P); + until not (jcJsonIdentifier in tab[P^]); + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='(' then begin // handle e.g. "born":isodate("1969-12-31") + inc(P); + while (P^<=' ') and (P^<>#0) do inc(P); + if P^='"' then begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + end; + inc(P); + while (P^<=' ') and (P^<>#0) do inc(P); + if P^<>')' then + exit; + inc(P); + end + else + if P^<>':' then exit; + end; + end; + while (P^<=' ') and (P^<>#0) do inc(P); + if (PMax<>nil) and (P>=PMax) then + exit; + until P^=EndChar; + result := P+1; +end; + +function GotoEndJSONItem(P: PUTF8Char; strict: boolean): PUTF8Char; +var tab: PJsonCharSet; +label pok,ok; +begin + result := nil; // to notify unexpected end + if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + case P^ of + #0: exit; + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + inc(P); + goto ok; + end; + '[': begin + repeat inc(P) until (P^>' ') or (P^=#0); + P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); + goto pok; + end; + '{': begin + repeat inc(P) until (P^>' ') or (P^=#0); + P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); +pok:if P=nil then + exit; +ok: while (P^<=' ') and (P^<>#0) do inc(P); + result := P; + exit; + end; + end; + if strict then + case P^ of + 't': if PInteger(P)^=TRUE_LOW then begin inc(P,4); goto ok; end; + 'f': if PInteger(P+1)^=FALSE_LOW2 then begin inc(P,5); goto ok; end; + 'n': if PInteger(P)^=NULL_LOW then begin inc(P,4); goto ok; end; + '-','+','0'..'9': begin + tab := @JSON_CHARS; + repeat inc(P) until not (jcDigitFloatChar in tab[P^]); + goto ok; + end; + end else begin // not strict + tab := @JSON_CHARS; + repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} + inc(P); + until jcEndOfJSONFieldOr0 in tab[P^]; + if P^=#0 then exit; // unexpected end + end; + if P^=#0 then + exit; + result := P; +end; + +function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal; + EndOfObject: PAnsiChar): PUTF8Char; +var tab: PJsonCharSet; +label pok,n; +begin + result := nil; // to notify unexpected end + while NumberOfItemsToJump>0 do begin + while (P^<=' ') and (P^<>#0) do inc(P); + // get a field + case P^ of + #0: exit; + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; // P^ should be '"' here + end; + '[': begin + repeat inc(P) until (P^>' ') or (P^=#0); + P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); + goto pok; + end; + '{': begin + repeat inc(P) until (P^>' ') or (P^=#0); + P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); +pok: if P=nil then + exit; + while (P^<=' ') and (P^<>#0) do inc(P); + goto n; + end; + end; + tab := @JSON_CHARS; + repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} + inc(P); + until jcEndOfJSONFieldOr0 in tab[P^]; +n: if P^=#0 then + exit; + if EndOfObject<>nil then + EndOfObject^ := P^; + inc(P); + dec(NumberOfItemsToJump); + end; + result := P; +end; + +function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; +var EndChar: AnsiChar; +begin // should match GetJSONPropName() + result := nil; // mark error or unexpected end (#0) + while (P^<=' ') and (P^<>#0) do inc(P); + case P^ of + '[': EndChar := ']'; + '{': EndChar := '}'; + else exit; + end; + repeat inc(P) until (P^>' ') or (P^=#0); + result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); +end; + +function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; +begin // should match GetJSONPropName() + while (P^<=' ') and (P^<>#0) do inc(P); + result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); +end; + +function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; +var EndChar: AnsiChar; +begin // should match GetJSONPropName() + result := nil; // mark error or unexpected end (#0) + while (P^<=' ') and (P^<>#0) do inc(P); + case P^ of + '[': EndChar := ']'; + '{': EndChar := '}'; + else exit; + end; + repeat inc(P) until (P^>' ') or (P^=#0); + result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar); +end; + +function JSONArrayCount(P: PUTF8Char): integer; +var n: integer; +begin + result := -1; + n := 0; + P := GotoNextNotSpace(P); + if P^<>']' then + repeat + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArray(P); + if P=nil then + exit; // invalid content + end; + end; + while not (P^ in [#0,',',']']) do inc(P); + inc(n); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + until false; + if P^=']' then + result := n; +end; + +function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; +var n,max: integer; +begin + result := false; + max := 0; + n := 0; + P := GotoNextNotSpace(P); + if P^<>']' then + repeat + if max=n then begin + max := NextGrow(max); + SetLength(Values,max); + end; + Values[n] := P; + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArray(P); + if P=nil then + exit; // invalid content + end; + end; + while not (P^ in [#0,',',']']) do inc(P); + inc(n); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + until false; + if P^=']' then begin + SetLength(Values,n); + result := true; + end else + Values := nil; +end; + +function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; +begin + if P<>nil then begin + P := GotoNextNotSpace(P); + if P^='[' then begin + P := GotoNextNotSpace(P+1); + if P^<>']' then + repeat + if Index<=0 then begin + result := P; + exit; + end; + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + break; // invalid content + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArray(P); + if P=nil then + break; // invalid content + end; + end; + while not (P^ in [#0,',',']']) do inc(P); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + dec(Index); + until false; + end; + end; + result := nil; +end; + +function JSONArrayCount(P,PMax: PUTF8Char): integer; +var n: integer; +begin + result := -1; + n := 0; + P := GotoNextNotSpace(P); + if P^<>']' then + while P'"' then + exit; + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArrayMax(P,PMax); + if P=nil then + exit; // invalid content or PMax reached + end; + end; + while not (P^ in [#0,',',']']) do inc(P); + inc(n); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + end; + if P^=']' then + result := n; +end; + +function JSONObjectPropCount(P: PUTF8Char): integer; +var n: integer; +begin + result := -1; + n := 0; + P := GotoNextNotSpace(P); + if P^<>'}' then + repeat + P := GotoNextJSONPropName(P); + if P=nil then + exit; + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit; + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArray(P); + if P=nil then + exit; // invalid content + end; + end; + while not (P^ in [#0,',','}']) do inc(P); + inc(n); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + until false; + if P^='}' then + result := n; +end; + +function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; + PropNameFound: PRawUTF8): PUTF8Char; +var name: shortstring; // no memory allocation nor P^ modification + PropNameLen: integer; + PropNameUpper: array[byte] of AnsiChar; +begin + if P<>nil then begin + P := GotoNextNotSpace(P); + PropNameLen := length(PropName); + if PropNameLen<>0 then begin + if PropName[PropNameLen]='*' then begin + UpperCopy255Buf(PropNameUpper,pointer(PropName),PropNameLen-1)^ := #0; + PropNameLen := 0; + end; + if P^='{' then + P := GotoNextNotSpace(P+1); + if P^<>'}' then + repeat + GetJSONPropName(P,name); + if (name[0]=#0) or (name[0]>#200) then + break; + while (P^<=' ') and (P^<>#0) do inc(P); + if PropNameLen=0 then begin + name[ord(name[0])+1] := #0; // make ASCIIZ + if IdemPChar(@name[1],PropNameUpper) then begin + if PropNameFound<>nil then + FastSetString(PropNameFound^,@name[1],ord(name[0])); + result := P; + exit; + end; + end else + if IdemPropName(name,pointer(PropName),PropNameLen) then begin + result := P; + exit; + end; + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + break; // invalid content + inc(P); + end; + '{','[': begin + P := GotoNextJSONObjectOrArray(P); + if P=nil then + break; // invalid content + end; + end; + while not (P^ in [#0,',','}']) do inc(P); + if P^<>',' then break; + repeat inc(P) until (P^>' ') or (P^=#0); + until false; + end; + end; + result := nil; +end; + +function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; +var objName: RawUTF8; +begin + result := nil; + if (JsonObject=nil) or (PropPath=nil) then + exit; + repeat + GetNextItem(PropPath,'.',objName); + if objName='' then + exit; + JsonObject := JsonObjectItem(JsonObject,objName); + if JsonObject=nil then + exit; + until PropPath=nil; // found full name scope + result := JsonObject; +end; + +function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; +var itemName,objName,propNameFound,objPath: RawUTF8; + start,ending,obj: PUTF8Char; + WR: TTextWriter; + temp: TTextWriterStackBuffer; + procedure AddFromStart(const name: RaWUTF8); + begin + start := GotoNextNotSpace(start); + ending := GotoEndJSONItem(start); + if ending=nil then + exit; + if WR=nil then begin + WR := TTextWriter.CreateOwnedStream(temp); + WR.Add('{'); + end else + WR.Add(','); + WR.AddFieldName(name); + while (ending>start) and (ending[-1]<=' ') do dec(ending); // trim right + WR.AddNoJSONEscape(start,ending-start); + end; +begin + result := ''; + if (JsonObject=nil) or (PropPath=nil) then + exit; + WR := nil; + try + repeat + GetNextItem(PropPath,',',itemName); + if itemName='' then + break; + if itemName[length(itemName)]<>'*' then begin + start := JsonObjectByPath(JsonObject,pointer(itemName)); + if start<>nil then + AddFromStart(itemName); + end else begin + objPath := ''; + obj := pointer(itemName); + repeat + GetNextItem(obj,'.',objName); + if objName='' then + exit; + propNameFound := ''; + JsonObject := JsonObjectItem(JsonObject,objName,@propNameFound); + if JsonObject=nil then + exit; + if obj=nil then begin // found full name scope + start := JsonObject; + repeat + AddFromStart(objPath+propNameFound); + ending := GotoNextNotSpace(ending); + if ending^<>',' then + break; + propNameFound := ''; + start := JsonObjectItem(GotoNextNotSpace(ending+1),objName,@propNameFound); + until start=nil; + break; + end else + objPath := objPath+objName+'.'; + until false; + end; + until PropPath=nil; + if WR<>nil then begin + WR.Add('}'); + WR.SetText(result); + end; + finally + WR.Free; + end; +end; + +function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; +var wk,wv: TTextWriter; + kb,ke,vb,ve: PUTF8Char; + temp1,temp2: TTextWriterStackBuffer; +begin + result := false; + if (JSON=nil) or (JSON^<>'{') then + exit; + wk := TTextWriter.CreateOwnedStream(temp1); + wv := TTextWriter.CreateOwnedStream(temp2); + try + wk.Add('['); + wv.Add('['); + kb := JSON+1; + repeat + ke := GotoEndJSONItem(kb); + if (ke=nil) or (ke^<>':') then + exit; // invalid input content + vb := ke+1; + ve := GotoEndJSONItem(vb); + if (ve=nil) or not(ve^ in [',','}']) then + exit; + wk.AddNoJSONEscape(kb,ke-kb); + wk.Add(','); + wv.AddNoJSONEscape(vb,ve-vb); + wv.Add(','); + kb := ve+1; + until ve^='}'; + wk.CancelLastComma; + wk.Add(']'); + wk.SetText(keys); + wv.CancelLastComma; + wv.Add(']'); + wv.SetText(values); + result := true; + finally + wv.Free; + wk.Free; + end; +end; + +function TryRemoveComment(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} +begin + result := P + 1; + case result^ of + '/': begin // this is // comment - replace by ' ' + dec(result); + repeat + result^ := ' '; + inc(result) + until result^ in [#0, #10, #13]; + if result^<>#0 then inc(result); + end; + '*': begin // this is /* comment - replace by ' ' but keep CRLF + result[-1] := ' '; + repeat + if not(result^ in [#10, #13]) then + result^ := ' '; // keep CRLF for correct line numbering (e.g. for error) + inc(result); + if PWord(result)^=ord('*')+ord('/')shl 8 then begin + PWord(result)^ := $2020; + inc(result,2); + break; + end; + until result^=#0; + end; + end; +end; + +procedure RemoveCommentsFromJSON(P: PUTF8Char); +var PComma: PUTF8Char; +begin // replace comments by ' ' characters which will be ignored by parser + if P<>nil then + while P^<>#0 do begin + case P^ of + '"': begin + P := GotoEndOfJSONString(P); + if P^<>'"' then + exit else + Inc(P); + end; + '/': P := TryRemoveComment(P); + ',': begin // replace trailing comma by space for strict JSON parsers + PComma := P; + repeat inc(P) until (P^>' ') or (P^=#0); + if P^='/' then + P := TryRemoveComment(P); + while (P^<=' ') and (P^<>#0) do inc(P); + if P^ in ['}', ']'] then + PComma^ := ' '; // see https://github.com/synopse/mORMot/pull/349 + end; + else + inc(P); + end; + end; +end; + +procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; + out result: RawUTF8); +var i,j,L: integer; + temp: TTextWriterStackBuffer; +begin + if P=nil then + result := Header else + with TTextWriter.CreateOwnedStream(temp) do + try + AddNoJSONEscape(pointer(Header),length(Header)); + L := length(NameSpace); + if L<>0 then + AddNoJSONEscape(pointer(NameSpace),L); + AddJSONToXML(P); + if L<>0 then + for i := 1 to L do + if NameSpace[i]='<' then begin + for j := i+1 to L do + if NameSpace[j] in [' ','>'] then begin + Add('<','/'); + AddStringCopy(NameSpace,i+1,j-i-1); + Add('>'); + break; + end; + break; + end; + SetText(result); + finally + Free; + end; +end; + +function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8; + const NameSpace: RawUTF8): RawUTF8; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); + try + JSONBufferToXML(tmp.buf,Header,NameSpace,result); + finally + tmp.Done; + end; +end; + +procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; + Format: TTextWriterJSONFormat); +var temp: array[word] of byte; // 64KB buffer +begin + if P<>nil then + with TTextWriter.CreateOwnedStream(@temp,SizeOf(temp)) do + try + AddJSONReformat(P,Format,nil); + SetText(result); + finally + Free; + end; +end; + +function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); + try + JSONBufferReformat(tmp.buf,result,Format); + finally + tmp.Done; + end; +end; + +function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; + Format: TTextWriterJSONFormat): boolean; +var F: TFileStream; + temp: array[word] of word; // 128KB +begin + try + F := TFileStream.Create(Dest,fmCreate); + try + with TTextWriter.Create(F,@temp,SizeOf(temp)) do + try + AddJSONReformat(P,Format,nil); + FlushFinal; + finally + Free; + end; + result := true; + finally + F.Free; + end; + except + on Exception do + result := false; + end; +end; + +function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; + Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; +var tmp: TSynTempBuffer; +begin + tmp.Init(JSON); + try + result := JSONBufferReformatToFile(tmp.buf,Dest,Format); + finally + tmp.Done; + end; +end; + + +procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); +type TUnits = (kb,mb,gb,tb,pb,eb,b); +const TXT: array[boolean,TUnits] of RawUTF8 = + ((' KB',' MB',' GB',' TB',' PB',' EB','% B'), ('KB','MB','GB','TB','PB','EB','%B')); +var hi,rem: cardinal; + u: TUnits; +begin + if bytes<1 shl 10-(1 shl 10) div 10 then begin + FormatShort16(TXT[nospace,b],[integer(bytes)],result); + exit; + end; + if bytes<1 shl 20-(1 shl 20) div 10 then begin + u := kb; + rem := bytes; + hi := bytes shr 10; + end else + if bytes<1 shl 30-(1 shl 30) div 10 then begin + u := mb; + rem := bytes shr 10; + hi := bytes shr 20; + end else + if bytes0 then + rem := rem div 102; + if rem=10 then begin + rem := 0; + inc(hi); // round up as expected by (most) human beings + end; + if rem<>0 then + FormatShort16('%.%%',[hi,rem,TXT[nospace,u]],result) else + FormatShort16('%%',[hi,TXT[nospace,u]],result); +end; + +function KB(bytes: Int64): TShort16; +begin + KB(bytes,result,{nospace=}false); +end; + +function KBNoSpace(bytes: Int64): TShort16; +begin + KB(bytes,result,{nospace=}true); +end; + +function KB(bytes: Int64; nospace: boolean): TShort16; +begin + KB(bytes,result,nospace); +end; + +function KB(const buffer: RawByteString): TShort16; +begin + KB(length(buffer),result,{nospace=}false); +end; + +procedure KBU(bytes: Int64; var result: RawUTF8); +var tmp: TShort16; +begin + KB(bytes,tmp,{nospace=}false); + FastSetString(result,@tmp[1],ord(tmp[0])); +end; + +function IntToThousandString(Value: integer; const ThousandSep: TShort4): shortstring; +var i,L,Len: cardinal; +begin + str(Value,result); + L := length(result); + Len := L+1; + if Value<0 then + dec(L,2) else // ignore '-' sign + dec(L); + for i := 1 to L div 3 do + insert(ThousandSep,result,Len-i*3); +end; + +function MicroSecToString(Micro: QWord): TShort16; +begin + MicroSecToString(Micro,result); +end; + +procedure MicroSecToString(Micro: QWord; out result: TShort16); + procedure TwoDigitToString(value: cardinal; const u: shortstring; var result: TShort16); + var d100: TDiv100Rec; + begin + if value<100 then + FormatShort16('0.%%',[UInt2DigitsToShortFast(value),u],result) else begin + Div100(value,d100); + if d100.m=0 then + FormatShort16('%%',[d100.d,u],result) else + FormatShort16('%.%%',[d100.d,UInt2DigitsToShortFast(d100.m),u],result); + end; + end; + procedure TimeToString(value: cardinal; const u: shortstring; var result: TShort16); + var d: cardinal; + begin + d := value div 60; + FormatShort16('%%%',[d,u,UInt2DigitsToShortFast(value-(d*60))],result); + end; +begin + if Int64(Micro)<=0 then + result := '0us' else + if Micro<1000 then + FormatShort16('%us',[Micro],result) else + if Micro<1000000 then + TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10,'ms',result) else + if Micro<60000000 then + TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10000,'s',result) else + if Micro0) or (fTime<>0); +end; + +procedure TPrecisionTimer.Resume; +begin + if fStart=0 then + {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart); +end; + +procedure TPrecisionTimer.Pause; +begin + if fStart=0 then + exit; + {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStop); + FromExternalQueryPerformanceCounters(fStop-fStart); + inc(fPauseCount); +end; + +procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord); +begin + fLastTime := MicroSeconds; + inc(fTime,MicroSeconds); + fStart := 0; // indicates time has been computed +end; + +function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; +begin // mimics Pause from already known elapsed time + {$ifdef LINUX} + FromExternalMicroSeconds(CounterDiff); + {$else} + if fWinFreq=0 then + QueryPerformanceFrequency(fWinFreq); + if fWinFreq<>0 then + FromExternalMicroSeconds((CounterDiff*1000000)div PQWord(@fWinFreq)^); + {$endif LINUX} + result := fLastTime; +end; + +function TPrecisionTimer.Stop: TShort16; +begin + if fStart<>0 then + Pause; + MicroSecToString(fTime,result); +end; + +function TPrecisionTimer.StopInMicroSec: TSynMonitorTotalMicroSec; +begin + if fStart<>0 then + Pause; + result := fTime; +end; + +function TPrecisionTimer.Time: TShort16; +begin + if fStart<>0 then + Pause; + MicroSecToString(fTime,result); +end; + +function TPrecisionTimer.LastTime: TShort16; +begin + if fStart<>0 then + Pause; + MicroSecToString(fLastTime,result); +end; + +function TPrecisionTimer.ByCount(Count: QWord): TShort16; +begin + if Count=0 then // avoid div per 0 exception + result := '0' else begin + if fStart<>0 then + Pause; + MicroSecToString(fTime div Count,result); + end; +end; + +function TPrecisionTimer.PerSec(const Count: QWord): QWord; +begin + if fStart<>0 then + Pause; + if fTime<=0 then // avoid negative value in case of incorrect Start/Stop sequence + result := 0 else // avoid div per 0 exception + result := (Count*1000000) div fTime; +end; + +function TPrecisionTimer.SizePerSec(Size: QWord): shortstring; +begin + FormatShort('% in % i.e. %/s',[KB(Size),Stop,KB(PerSec(Size))],result); +end; + + +type + /// a class used internaly by TPrecisionTimer.ProfileMethod + TPrecisionTimerProfiler = class(TInterfacedObject) + protected + fTimer: PPrecisionTimer; + public + constructor Create(aTimer: PPrecisionTimer); + destructor Destroy; override; + end; + +constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer); +begin + fTimer := aTimer; +end; + +destructor TPrecisionTimerProfiler.Destroy; +begin + if fTimer<>nil then + fTimer^.Pause; + inherited; +end; + + +function TPrecisionTimer.ProfileCurrentMethod: IUnknown; +begin + Resume; + result := TPrecisionTimerProfiler.Create(@self); +end; + + +{ TLocalPrecisionTimer } + +function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8; +begin + result := fTimer.ByCount(Count); +end; + +procedure TLocalPrecisionTimer.Pause; +begin + fTimer.Pause; +end; + +function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal; +begin + result := fTimer.PerSec(Count); +end; + +procedure TLocalPrecisionTimer.Resume; +begin + fTimer.Resume; +end; + +procedure TLocalPrecisionTimer.Start; +begin + fTimer.Start; +end; + +function TLocalPrecisionTimer.Stop: TShort16; +begin + result := fTimer.Stop; +end; + +constructor TLocalPrecisionTimer.CreateAndStart; +begin + inherited; + fTimer.Start; +end; + +{ TSynMonitorTime } + +function TSynMonitorTime.GetAsText: TShort16; +begin + MicroSecToString(fMicroSeconds,result); +end; + +function TSynMonitorTime.PerSecond(const Count: QWord): QWord; +begin + if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then + result := 0 else // avoid negative or div per 0 + result := (Count*1000000) div fMicroSeconds; +end; + + +{ TSynMonitorOneTime } + +function TSynMonitorOneTime.GetAsText: TShort16; +begin + MicroSecToString(fMicroSeconds,result); +end; + +function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord; +begin + if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then + result := 0 else + result := (Count*QWord(1000000)) div fMicroSeconds; +end; + + +{ TSynMonitorSizeParent } + +constructor TSynMonitorSizeParent.Create(aTextNoSpace: boolean); +begin + inherited Create; + fTextNoSpace := aTextNoSpace; +end; + +{ TSynMonitorSize } + +function TSynMonitorSize.GetAsText: TShort16; +begin + KB(fBytes,result,fTextNoSpace); +end; + +{ TSynMonitorOneSize } + +function TSynMonitorOneSize.GetAsText: TShort16; +begin + KB(fBytes,result,fTextNoSpace); +end; + +{ TSynMonitorThroughput } + +function TSynMonitorThroughput.GetAsText: TShort16; +begin + FormatShort16('%/s',[KB(fBytesPerSec,fTextNoSpace)],result); +end; + + +{ TSynMonitor } + +constructor TSynMonitor.Create; +begin + inherited Create; + fTotalTime := TSynMonitorTime.Create; + fLastTime := TSynMonitorOneTime.Create; + fMinimalTime := TSynMonitorOneTime.Create; + fAverageTime := TSynMonitorOneTime.Create; + fMaximalTime := TSynMonitorOneTime.Create; +end; + +constructor TSynMonitor.Create(const aName: RawUTF8); +begin + Create; + fName := aName; +end; + +destructor TSynMonitor.Destroy; +begin + fMaximalTime.Free; + fAverageTime.Free; + fMinimalTime.Free; + fLastTime.Free; + fTotalTime.Free; + inherited Destroy; +end; + +procedure TSynMonitor.Lock; +begin + fSafe^.Lock; +end; + +procedure TSynMonitor.UnLock; +begin + fSafe^.UnLock; +end; + +procedure TSynMonitor.Changed; +begin // do nothing by default - overriden classes may track modified changes +end; + +procedure TSynMonitor.ProcessStart; +begin + if fProcessing then + raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); + fSafe^.Lock; + try + InternalTimer.Resume; + fTaskStatus := taskNotStarted; + fProcessing := true; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.ProcessDoTask; +begin + fSafe^.Lock; + try + inc(fTaskCount); + fTaskStatus := taskStarted; + Changed; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.ProcessStartTask; +begin + if fProcessing then + raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); + fSafe^.Lock; + try + InternalTimer.Resume; + fProcessing := true; + inc(fTaskCount); + fTaskStatus := taskStarted; + Changed; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.ProcessEnd; +begin + fSafe^.Lock; + try + InternalTimer.Pause; + LockedFromProcessTimer; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.LockedFromProcessTimer; +begin + fTotalTime.MicroSec := InternalTimer.TimeInMicroSec; + if fTaskStatus=taskStarted then begin + fLastTime.MicroSec := InternalTimer.LastTimeInMicroSec; + if (fMinimalTime.MicroSec=0) or + (InternalTimer.LastTimeInMicroSecfMaximalTime.MicroSec then + fMaximalTime.MicroSec := InternalTimer.LastTimeInMicroSec; + fTaskStatus := taskNotStarted; + end; + LockedPerSecProperties; + fProcessing := false; + Changed; +end; + +function TSynMonitor.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; +begin + fSafe^.Lock; + try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd + inc(fTaskCount); + fTaskStatus := taskStarted; + result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff); + LockedFromProcessTimer; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); +begin + fSafe^.Lock; + try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd + inc(fTaskCount); + fTaskStatus := taskStarted; + InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed); + LockedFromProcessTimer; + finally + fSafe^.UnLock; + end; +end; + +class procedure TSynMonitor.InitializeObjArray(var ObjArr; Count: integer); +var i: integer; +begin + ObjArrayClear(ObjArr); + SetLength(TPointerDynArray(ObjArr),Count); + for i := 0 to Count-1 do + TPointerDynArray(ObjArr)[i] := Create; +end; + +procedure TSynMonitor.ProcessError(const info: variant); +begin + fSafe^.Lock; + try + if not VarIsEmptyOrNull(info) then + inc(fInternalErrors); + fLastInternalError := info; + Changed; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); +begin + ProcessError({$ifndef NOVARIANTS}RawUTF8ToVariant{$endif}(FormatUTF8(Fmt,Args))); +end; + +procedure TSynMonitor.ProcessErrorRaised(E: Exception); +begin + {$ifndef NOVARIANTS}if E.InheritsFrom(ESynException) then + ProcessError(_ObjFast([E,ObjectToVariant(E,true)])) else{$endif} + ProcessErrorFmt('%: %', [E,E.Message]); +end; + +procedure TSynMonitor.ProcessErrorNumber(info: integer); +begin + ProcessError(info); +end; + +procedure TSynMonitor.LockedPerSecProperties; +begin + if fTaskCount=0 then + exit; // avoid division per zero + fPerSec := fTotalTime.PerSecond(fTaskCount); + fAverageTime.MicroSec := fTotalTime.MicroSec div fTaskCount; +end; + +procedure TSynMonitor.Sum(another: TSynMonitor); +begin + if (self=nil) or (another=nil) then + exit; + fSafe^.Lock; + another.fSafe^.Lock; + try + LockedSum(another); + finally + another.fSafe^.UnLock; + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.LockedSum(another: TSynMonitor); +begin + fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec; + if (fMinimalTime.MicroSec=0) or + (another.fMinimalTime.MicroSecfMaximalTime.MicroSec then + fMaximalTime.MicroSec := another.fMaximalTime.MicroSec; + inc(fTaskCount,another.fTaskCount); + if another.Processing then + fProcessing := true; // if any thread is active, whole daemon is active + inc(fInternalErrors,another.Errors); +end; + +procedure TSynMonitor.WriteDetailsTo(W: TTextWriter); +begin + fSafe^.Lock; + try + W.WriteObject(self); + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter); +begin + fSafe^.Lock; + try + LockedPerSecProperties; // may not have been calculated after Sum() + WriteDetailsTo(W); + finally + fSafe^.UnLock; + end; +end; + +function TSynMonitor.ComputeDetailsJSON: RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + W := DefaultTextWriterSerializer.CreateOwnedStream(temp); + try + ComputeDetailsTo(W); + W.SetText(result); + finally + W.Free; + end; +end; + +{$ifndef NOVARIANTS} +function TSynMonitor.ComputeDetails: variant; +begin + _Json(ComputeDetailsJSON,result,JSON_OPTIONS_FAST); +end; +{$endif} + + +{ TSynMonitorWithSize} + +constructor TSynMonitorWithSize.Create; +begin + inherited Create; + fSize := TSynMonitorSize.Create({nospace=}false); + fThroughput := TSynMonitorThroughput.Create({nospace=}false); +end; + +destructor TSynMonitorWithSize.Destroy; +begin + inherited Destroy; + fThroughput.Free; + fSize.Free; +end; + +procedure TSynMonitorWithSize.LockedPerSecProperties; +begin + inherited LockedPerSecProperties; + fThroughput.BytesPerSec := fTotalTime.PerSecond(fSize.Bytes); +end; + +procedure TSynMonitorWithSize.AddSize(const Bytes: QWord); +begin + fSafe^.Lock; + try + fSize.Bytes := fSize.Bytes+Bytes; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitorWithSize.LockedSum(another: TSynMonitor); +begin + inherited LockedSum(another); + if another.InheritsFrom(TSynMonitorWithSize) then + AddSize(TSynMonitorWithSize(another).Size.Bytes); +end; + + +{ TSynMonitorInputOutput } + +constructor TSynMonitorInputOutput.Create; +begin + inherited Create; + fInput := TSynMonitorSize.Create({nospace=}false); + fOutput := TSynMonitorSize.Create({nospace=}false); + fInputThroughput := TSynMonitorThroughput.Create({nospace=}false); + fOutputThroughput := TSynMonitorThroughput.Create({nospace=}false); +end; + +destructor TSynMonitorInputOutput.Destroy; +begin + fOutputThroughput.Free; + fOutput.Free; + fInputThroughput.Free; + fInput.Free; + inherited Destroy; +end; + +procedure TSynMonitorInputOutput.LockedPerSecProperties; +begin + inherited LockedPerSecProperties; + fInputThroughput.BytesPerSec := fTotalTime.PerSecond(fInput.Bytes); + fOutputThroughput.BytesPerSec := fTotalTime.PerSecond(fOutput.Bytes); +end; + +procedure TSynMonitorInputOutput.AddSize(const Incoming, Outgoing: QWord); +begin + fSafe^.Lock; + try + fInput.Bytes := fInput.Bytes+Incoming; + fOutput.Bytes := fOutput.Bytes+Outgoing; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitorInputOutput.LockedSum(another: TSynMonitor); +begin + inherited LockedSum(another); + if another.InheritsFrom(TSynMonitorInputOutput) then begin + fInput.Bytes := fInput.Bytes+TSynMonitorInputOutput(another).Input.Bytes; + fOutput.Bytes := fOutput.Bytes+TSynMonitorInputOutput(another).Output.Bytes; + end; +end; + + +{ TSynMonitorServer } + +procedure TSynMonitorServer.ClientConnect; +begin + if self=nil then + exit; + fSafe^.Lock; + try + inc(fClientsCurrent); + if fClientsCurrent>fClientsMax then + fClientsMax := fClientsCurrent; + Changed; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitorServer.ClientDisconnect; +begin + if self=nil then + exit; + fSafe^.Lock; + try + if fClientsCurrent>0 then + dec(fClientsCurrent); + Changed; + finally + fSafe^.UnLock; + end; +end; + +procedure TSynMonitorServer.ClientDisconnectAll; +begin + if self=nil then + exit; + fSafe^.Lock; + try + fClientsCurrent := 0; + Changed; + finally + fSafe^.UnLock; + end; +end; + +function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount; +begin + if self=nil then begin + result := 0; + exit; + end; + fSafe^.Lock; + try + result := fClientsCurrent; + finally + fSafe^.UnLock; + end; +end; + +function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer; +begin + if self=nil then begin + result := 0; + exit; + end; + fSafe^.Lock; + try + inc(fCurrentRequestCount,diff); + result := fCurrentRequestCount; + finally + fSafe^.UnLock; + end; +end; + + +{ ******************* cross-cutting classes and functions ***************** } + +{ TSynInterfacedObject } + +function TSynInterfacedObject._AddRef: {$ifdef FPC}longint{$else}integer{$endif}; +begin + result := VirtualAddRef; +end; + +function TSynInterfacedObject._Release: {$ifdef FPC}longint{$else}integer{$endif}; +begin + result := VirtualRelease; +end; + +{$ifdef FPC} +function TSynInterfacedObject.QueryInterface( + {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; + out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +{$else} +function TSynInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +{$endif} +begin + result := VirtualQueryInterface(IID,Obj); +end; + +function TSynInterfacedObject.VirtualQueryInterface(const IID: TGUID; out Obj): HResult; +begin + result := E_NOINTERFACE; +end; + +{$ifdef CPUINTEL} +{$ifndef DELPHI5OROLDER} + +{ TSynFPUException } + +function TSynFPUException.VirtualAddRef: integer; +begin + if fRefCount=0 then begin + {$ifndef CPU64} + fSaved8087 := Get8087CW; + Set8087CW(fExpected8087); // set FPU exceptions mask + {$else} + fSavedMXCSR := GetMXCSR; + SetMXCSR(fExpectedMXCSR); // set FPU exceptions mask + {$endif} + end; + inc(fRefCount); + result := 1; // should never be 0 (mark release of TSynFPUException instance) +end; + +function TSynFPUException.VirtualRelease: integer; +begin + dec(fRefCount); + if fRefCount=0 then + {$ifndef CPU64} + Set8087CW(fSaved8087); + {$else} + SetMXCSR(fSavedMXCSR); + {$endif} + result := 1; // should never be 0 (mark release of TSynFPUException instance) +end; + +threadvar + GlobalSynFPUExceptionDelphi, + GlobalSynFPUExceptionLibrary: TSynFPUException; + +{$ifndef CPU64} +constructor TSynFPUException.Create(Expected8087Flag: word); +begin // $1372=Delphi $137F=library (mask all exceptions) + inherited Create; + fExpected8087 := Expected8087Flag; +end; +{$else} +constructor TSynFPUException.Create(ExpectedMXCSR: word); +begin // $1920=Delphi $1FA0=library (mask all exceptions) + inherited Create; + fExpectedMXCSR := ExpectedMXCSR; +end; +{$endif} + +class function TSynFPUException.ForLibraryCode: IUnknown; +var obj: TSynFPUException; +begin + result := GlobalSynFPUExceptionLibrary; + if result<>nil then + exit; + {$ifndef CPU64} + obj := TSynFPUException.Create($137F); + {$else} + obj := TSynFPUException.Create($1FA0); + {$endif} + GarbageCollector.Add(obj); + GlobalSynFPUExceptionLibrary := obj; + result := obj; +end; + +class function TSynFPUException.ForDelphiCode: IUnknown; +var obj: TSynFPUException; +begin + result := GlobalSynFPUExceptionDelphi; + if result<>nil then + exit; + {$ifndef CPU64} + obj := TSynFPUException.Create($1372); + {$else} + obj := TSynFPUException.Create($1920); + {$endif} + GarbageCollector.Add(obj); + GlobalSynFPUExceptionDelphi := obj; + result := obj; +end; + +{$endif DELPHI5OROLDER} +{$endif CPUINTEL} + + +{ TAutoFree } + +constructor TAutoFree.Create(var localVariable; obj: TObject); +begin + fObject := obj; + TObject(localVariable) := obj; +end; + +class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree; +begin + result := Create(localVariable,obj); +end; + +class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree; +begin + result := Create(varObjPairs); +end; + +constructor TAutoFree.Create(const varObjPairs: array of pointer); +var n,i: integer; +begin + n := length(varObjPairs); + if (n=0) or (n and 1=1) then + exit; + n := n shr 1; + if n=0 then + exit; + SetLength(fObjectList,n); + for i := 0 to n-1 do begin + fObjectList[i] := varObjPairs[i*2+1]; + PPointer(varObjPairs[i*2])^ := fObjectList[i]; + end; +end; + +procedure TAutoFree.Another(var localVariable; obj: TObject); +var n: integer; +begin + n := length(fObjectList); + SetLength(fObjectList,n+1); + fObjectList[n] := obj; + TObject(localVariable) := obj; +end; + +destructor TAutoFree.Destroy; +var i: integer; +begin + if fObjectList<>nil then + for i := high(fObjectList) downto 0 do // release FILO + fObjectList[i].Free; + fObject.Free; + inherited; +end; + + +{ TAutoLocker } + +constructor TAutoLocker.Create; +begin + fSafe.Init; +end; + +destructor TAutoLocker.Destroy; +begin + fSafe.Done; + inherited; +end; + +function TAutoLocker.ProtectMethod: IUnknown; +begin + result := TAutoLock.Create(@fSafe); +end; + +procedure TAutoLocker.Enter; +begin + fSafe.Lock; +end; + +procedure TAutoLocker.Leave; +begin + fSafe.UnLock; +end; + +function TAutoLocker.Safe: PSynLocker; +begin + result := @fSafe; +end; + +{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( +{$ifndef NOVARIANTS} + +{ TLockedDocVariant } + +constructor TLockedDocVariant.Create; +begin + Create(JSON_OPTIONS_FAST); +end; + +constructor TLockedDocVariant.Create(FastStorage: boolean); +begin + Create(JSON_OPTIONS[FastStorage]); +end; + +constructor TLockedDocVariant.Create(options: TDocVariantOptions); +begin + fLock := TAutoLocker.Create; + fValue.Init(options); +end; + +destructor TLockedDocVariant.Destroy; +begin + inherited; + fLock.Free; +end; + +function TLockedDocVariant.Lock: TAutoLocker; +begin + result := fLock; +end; + +function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean; +var i: integer; +begin + fLock.Enter; + try + i := fValue.GetValueIndex(Name); + if i<0 then + result := false else begin + Value := fValue.Values[i]; + result := true; + end; + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; +var i: integer; +begin + result := true; + fLock.Enter; + try + i := fValue.GetValueIndex(Name); + if i<0 then + result := false else + Value := fValue.Values[i]; + finally + if result then + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.ReplaceAndUnlock( + const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); +begin // caller made fLock.Enter + try + SetValue(Name,Value); + LocalValue := Value; + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8; + var Obj: variant): boolean; +var i: integer; +begin + result := true; + fLock.Enter; + try + i := fValue.GetValueIndex(Name); + if i<0 then + result := false else + _ObjAddProps([Name,fValue.Values[i]],Obj); + finally + if result then + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8; + const Value: variant; + var Obj: variant); +begin // caller made fLock.Enter + try + SetValue(Name,Value); + _ObjAddProps([Name,Value],Obj); + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.AddExistingProp(const Name: RawUTF8; + var Obj: variant): boolean; +var i: integer; +begin + result := true; + fLock.Enter; + try + i := fValue.GetValueIndex(Name); + if i<0 then + result := false else + _ObjAddProps([Name,fValue.Values[i]],Obj); + finally + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8; + const Value: variant; var Obj: variant); +begin + fLock.Enter; + try + SetValue(Name,Value); + _ObjAddProps([Name,Value],Obj); + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant; +begin + fLock.Enter; + try + fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name), + dvoNameCaseSensitive in fValue.Options,result,false); + finally + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.SetValue(const Name: RawUTF8; + const Value: Variant); +begin + fLock.Enter; + try + fValue.AddOrUpdateValue(Name,Value); + finally + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.AddItem(const Value: variant); +begin + fLock.Enter; + try + fValue.AddItem(Value); + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.Copy: variant; +begin + VarClear(result); + fLock.Enter; + try + TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST); + finally + fLock.Leave; + end; +end; + +procedure TLockedDocVariant.Clear; +var opt: TDocVariantOptions; +begin + fLock.Enter; + try + opt := fValue.Options; + fValue.Clear; + fValue.Init(opt); + finally + fLock.Leave; + end; +end; + +function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8; +var tmp: RawUTF8; +begin + fLock.Enter; + try + VariantSaveJSON(variant(fValue),twJSONEscape,tmp); + finally + fLock.Leave; + end; + if HumanReadable then + JSONBufferReformat(pointer(tmp),result) else + result := tmp; +end; + +{$endif NOVARIANTS} +{$endif DELPHI5OROLDER} + + +function GetDelphiCompilerVersion: RawUTF8; +begin + result := +{$ifdef FPC} + 'Free Pascal' + {$ifdef VER2_6_4}+' 2.6.4'{$endif} + {$ifdef VER3_0_0}+' 3.0.0'{$endif} + {$ifdef VER3_0_1}+' 3.0.1'{$endif} + {$ifdef VER3_0_2}+' 3.0.2'{$endif} + {$ifdef VER3_1_1}+' 3.1.1'{$endif} + {$ifdef VER3_2} +' 3.2' {$endif} + {$ifdef VER3_3_1}+' 3.3.1'{$endif} +{$else} + {$ifdef VER130} 'Delphi 5'{$endif} + {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer + {$if defined(KYLIX3)}'Kylix 3' + {$elseif defined(VER140)}'Delphi 6' + {$elseif defined(VER150)}'Delphi 7' + {$elseif defined(VER160)}'Delphi 8' + {$elseif defined(VER170)}'Delphi 2005' + {$elseif defined(VER185)}'Delphi 2007' + {$elseif defined(VER180)}'Delphi 2006' + {$elseif defined(VER200)}'Delphi 2009' + {$elseif defined(VER210)}'Delphi 2010' + {$elseif defined(VER220)}'Delphi XE' + {$elseif defined(VER230)}'Delphi XE2' + {$elseif defined(VER240)}'Delphi XE3' + {$elseif defined(VER250)}'Delphi XE4' + {$elseif defined(VER260)}'Delphi XE5' + {$elseif defined(VER265)}'AppMethod 1' + {$elseif defined(VER270)}'Delphi XE6' + {$elseif defined(VER280)}'Delphi XE7' + {$elseif defined(VER290)}'Delphi XE8' + {$elseif defined(VER300)}'Delphi 10 Seattle' + {$elseif defined(VER310)}'Delphi 10.1 Berlin' + {$elseif defined(VER320)}'Delphi 10.2 Tokyo' + {$elseif defined(VER330)}'Delphi 10.3 Rio' + {$elseif defined(VER340)}'Delphi 10.4 Sydney' + {$elseif defined(VER350)}'Delphi 11 Alexandria' + {$elseif defined(VER360)}'Delphi 11.1 Next' + {$ifend} + {$endif CONDITIONALEXPRESSIONS} +{$endif FPC} +{$ifdef CPU64} +' 64 bit' {$else} +' 32 bit' {$endif} +end; + + +{ TRawUTF8List } + +constructor TRawUTF8List.Create(aOwnObjects, aNoDuplicate, aCaseSensitive: boolean); +begin + if aOwnObjects then + include(fFlags,fObjectsOwned); + if aNoDuplicate then + include(fFlags,fNoDuplicate); + if aCaseSensitive then + include(fFlags,fCaseSensitive); + Create(fFlags); +end; + +constructor TRawUTF8List.Create(aFlags: TRawUTF8ListFlags); +begin + fNameValueSep := '='; + fFlags := aFlags; + fValues.InitSpecific(TypeInfo(TRawUTF8DynArray),fValue,djRawUTF8,@fCount, + not (fCaseSensitive in aFlags)); + fSafe.Init; +end; + +destructor TRawUTF8List.Destroy; +begin + SetCapacity(0); + inherited; + fSafe.Done; +end; + +procedure TRawUTF8List.SetCaseSensitive(Value: boolean); +begin + if (self=nil) or (fCaseSensitive in fFlags=Value) then + exit; + fSafe.Lock; + try + if Value then + include(fFlags,fCaseSensitive) else + exclude(fFlags,fCaseSensitive); + fValues.Hasher.InitSpecific(@fValues,djRawUTF8,not Value); + Changed; + finally + fSafe.UnLock; + end; +end; + +procedure TRawUTF8List.SetCapacity(const capa: PtrInt); +begin + if self<>nil then begin + fSafe.Lock; + try + if capa<=0 then begin // clear + if fObjects<>nil then begin + if fObjectsOwned in fFlags then + RawObjectsClear(pointer(fObjects),fCount); + fObjects := nil; + end; + fValues.Clear; + if fNoDuplicate in fFlags then + fValues.Hasher.Clear; + Changed; + end else begin // resize + if capanil then begin + if fObjectsOwned in fFlags then + RawObjectsClear(@fObjects[capa],fCount-capa-1); + SetLength(fObjects,capa); + end; + fValues.Count := capa; + if fNoDuplicate in fFlags then + fValues.ReHash; + Changed; + end; + if capa>length(fValue) then begin // resize up + SetLength(fValue,capa); + if fObjects<>nil then + SetLength(fObjects,capa); + end; + end; + finally + fSafe.UnLock; + end; + end; +end; + +function TRawUTF8List.Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean): PtrInt; +begin + result := AddObject(aText,nil,aRaiseExceptionIfExisting); +end; + +function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject; + aRaiseExceptionIfExisting: boolean; aFreeAndReturnExistingObject: PPointer): PtrInt; +var added: boolean; + obj: TObject; +begin + result := -1; + if self=nil then + exit; + fSafe.Lock; + try + if fNoDuplicate in fFlags then begin + result := fValues.FindHashedForAdding(aText,added,{noadd=}true); + if not added then begin + obj := GetObject(result); + if (obj=aObject) and (obj<>nil) then + exit; // found identical aText/aObject -> behave as if added + if aFreeAndReturnExistingObject<>nil then begin + aObject.Free; + aFreeAndReturnExistingObject^ := obj; + end; + if aRaiseExceptionIfExisting then + raise ESynException.CreateUTF8('%.Add duplicate [%]',[self,aText]); + result := -1; + exit; + end; + end; + result := fValues.Add(aText); + if (fObjects<>nil) or (aObject<>nil) then begin + if result>=length(fObjects) then + SetLength(fObjects,length(fValue)); // same capacity + if aObject<>nil then + fObjects[result] := aObject; + end; + if Assigned(fOnChange) then + Changed; + finally + fSafe.UnLock; + end; +end; + +procedure TRawUTF8List.AddObjectUnique(const aText: RawUTF8; + aObjectToAddOrFree: PPointer); +begin + if fNoDuplicate in fFlags then + AddObject(aText,aObjectToAddOrFree^,{raiseexc=}false, + {freeandreturnexisting=}aObjectToAddOrFree); +end; + +procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List); +var i: PtrInt; +begin + if List<>nil then begin + BeginUpdate; // includes Safe.Lock + try + for i := 0 to List.fCount-1 do + AddObject(List.fValue[i],List.GetObject(i)); + finally + EndUpdate; + end; + end; +end; + +procedure TRawUTF8List.BeginUpdate; +begin + if InterLockedIncrement(fOnChangeLevel)>1 then + exit; + fSafe.Lock; + fOnChangeBackupForBeginUpdate := fOnChange; + fOnChange := OnChangeHidden; + exclude(fFlags,fOnChangeTrigerred); +end; + +procedure TRawUTF8List.EndUpdate; +begin + if (fOnChangeLevel<=0) or (InterLockedDecrement(fOnChangeLevel)>0) then + exit; // allows nested BeginUpdate..EndUpdate calls + fOnChange := fOnChangeBackupForBeginUpdate; + if (fOnChangeTrigerred in fFlags) and Assigned(fOnChange) then + Changed; + exclude(fFlags,fOnChangeTrigerred); + fSafe.UnLock; +end; + +procedure TRawUTF8List.Changed; +begin + if Assigned(fOnChange) then + try + fOnChange(self); + except // ignore any exception in user code (may not trigger fSafe.UnLock) + end; +end; + +procedure TRawUTF8List.Clear; +begin + SetCapacity(0); // will also call Changed +end; + +procedure TRawUTF8List.InternalDelete(Index: PtrInt); +begin // caller ensured Index is correct + fValues.Delete(Index); // includes dec(fCount) + if PtrUInt(Index)Index then + MoveFast(fObjects[Index+1],fObjects[Index],(fCount-Index)*SizeOf(pointer)); + fObjects[fCount] := nil; + end; + if Assigned(fOnChange) then + Changed; +end; + +procedure TRawUTF8List.Delete(Index: PtrInt); +begin + if (self<>nil) and (PtrUInt(Index)=0 then + InternalDelete(result); + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt; +begin + fSafe.Lock; + try + result := IndexOfName(Name); + Delete(result); + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt; +begin + if self<>nil then begin + fSafe.Lock; + try + if fNoDuplicate in fFlags then + result := fValues.FindHashed(aText) else + result := FindRawUTF8(pointer(fValue),aText,fCount,fCaseSensitive in fFlags); + finally + fSafe.UnLock; + end; + end else + result := -1; +end; + +function TRawUTF8List.Get(Index: PtrInt): RawUTF8; +begin + if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then + result := '' else + result := fValue[Index]; +end; + +function TRawUTF8List.GetCapacity: PtrInt; +begin + if self=nil then + result := 0 else + result := length(fValue); +end; + +function TRawUTF8List.GetCount: PtrInt; +begin + if self=nil then + result := 0 else + result := fCount; +end; + +function TRawUTF8List.GetTextPtr: PPUtf8CharArray; +begin + if self=nil then + result := nil else + result := pointer(fValue); +end; + +function TRawUTF8List.GetObjectPtr: PPointerArray; +begin + if self=nil then + result := nil else + result := pointer(fObjects); +end; + +function TRawUTF8List.GetName(Index: PtrInt): RawUTF8; +begin + result := Get(Index); + if result='' then + exit; + Index := PosExChar(NameValueSep,result); + if Index=0 then + result := '' else + SetLength(result,Index-1); +end; + +function TRawUTF8List.GetObject(Index: PtrInt): pointer; +begin + if (self<>nil) and (fObjects<>nil) and (PtrUInt(Index)nil) and (fObjects<>nil) then begin + fSafe.Lock; + try + ndx := IndexOf(aText); + if ndx0 then begin + MoveFast(pointer(fValue[i])^,P^,Len); + inc(P,Len); + end; + inc(i); + if i>=fCount then + Break; + if DelimLen>0 then begin + MoveSmall(pointer(Delimiter),P,DelimLen); + inc(P,DelimLen); + end; + until false; + finally + fSafe.UnLock; + end; +end; + +procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8); +var W: TTextWriter; + i: PtrInt; + temp: TTextWriterStackBuffer; +begin + if (self=nil) or (fCount=0) then + exit; + fSafe.Lock; + try + W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); + try + i := 0; + repeat + W.AddString(fValue[i]); + inc(i); + if i>=fCount then + Break; + W.AddString(Delimiter); + until false; + W.FlushFinal; + finally + W.Free; + end; + finally + fSafe.UnLock; + end; +end; + +procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8); +var FS: TFileStream; +begin + FS := TFileStream.Create(FileName,fmCreate); + try + SaveToStream(FS,Delimiter); + finally + FS.Free; + end; +end; + +function TRawUTF8List.GetTextCRLF: RawUTF8; +begin + result := GetText; +end; + +function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8; +begin + fSafe.Lock; + try + result := GetValueAt(IndexOfName(Name)); + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8; +begin + if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then + result := '' else + result := Get(Index); + if result='' then + exit; + Index := PosExChar(NameValueSep,result); + if Index=0 then + result := '' else + result := copy(result,Index+1,maxInt); +end; + +function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt; +var UpperName: array[byte] of AnsiChar; +begin + if self<>nil then begin + PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep); + for result := 0 to fCount-1 do + if IdemPChar(Pointer(fValue[result]),UpperName) then + exit; + end; + result := -1; +end; + +function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt; +begin + if (self<>nil) and (fObjects<>nil) then begin + fSafe.Lock; + try + result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject)); + finally + fSafe.UnLock; + end + end else + result := -1; +end; + +function TRawUTF8List.Contains(const aText: RawUTF8; aFirstIndex: integer): PtrInt; +var i: PtrInt; // use a temp variable to make oldest Delphi happy :( +begin + result := -1; + if self<>nil then begin + fSafe.Lock; + try + for i := aFirstIndex to fCount-1 do + if PosEx(aText,fValue[i])>0 then begin + result := i; + exit; + end; + finally + fSafe.UnLock; + end; + end; +end; + +procedure TRawUTF8List.OnChangeHidden(Sender: TObject); +begin + if self<>nil then + include(fFlags,fOnChangeTrigerred); +end; + +procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8); +begin + if (self<>nil) and (PtrUInt(Index)nil) and (PtrUInt(Index)0 then begin + if TextFileKind(Map)=isUTF8 then begin // ignore UTF-8 BOM + P := pointer(Map.Buffer+3); + SetTextPtr(P,P+Map.Size-3,#13#10); + end else begin + P := pointer(Map.Buffer); + SetTextPtr(P,P+Map.Size,#13#10); + end; + end; + finally + Map.UnMap; + end; +end; + +procedure TRawUTF8List.SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); +var DelimLen: PtrInt; + DelimFirst: AnsiChar; + PBeg, DelimNext: PUTF8Char; + Line: RawUTF8; +begin + DelimLen := length(Delimiter); + BeginUpdate; // also makes fSafe.Lock + try + Clear; + if (P<>nil) and (DelimLen>0) and (P=PEnd then + break; + inc(P,DelimLen); + until P>=PEnd; + end; + finally + EndUpdate; + end; +end; + +procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8); +begin + SetText(Value,#13#10); +end; + +procedure TRawUTF8List.SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); +var n: integer; +begin + BeginUpdate; // also makes fSafe.Lock + try + Clear; + n := length(aText); + if n=0 then + exit; + SetCapacity(n); + fCount := n; + fValue := aText; + fObjects := aObject; + if fNoDuplicate in fFlags then + fValues.ReHash; + finally + EndUpdate; + end; +end; + +procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8); +var i: PtrInt; + txt: RawUTF8; +begin + txt := Name+RawUTF8(NameValueSep)+Value; + fSafe.Lock; + try + i := IndexOfName(Name); + if i<0 then + AddObject(txt,nil) else + if fValue[i]<>txt then begin + fValue[i] := txt; + if fNoDuplicate in fFlags then + fValues.Hasher.Clear; // invalidate internal hash table + Changed; + end; + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.GetCaseSensitive: boolean; +begin + result := (self<>nil) and (fCaseSensitive in fFlags); +end; + +function TRawUTF8List.GetNoDuplicate: boolean; +begin + result := (self<>nil) and (fNoDuplicate in fFlags); +end; + +function TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8; + ThenDelete: boolean): boolean; +var i: PtrInt; +begin + result := false; + fSafe.Lock; + try + i := IndexOfName(Name); + if i>=0 then begin + Value := GetValueAt(i); // copy value + if ThenDelete then + Delete(i); // optionally delete + result := true; + end; + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject): boolean; +begin + result := false; + if fCount=0 then + exit; + fSafe.Lock; + try + if fCount>0 then begin + aText := fValue[0]; + if aObject<>nil then + if fObjects<>nil then + aObject^ := fObjects[0] else + aObject^ := nil; + Delete(0); + result := true; + end; + finally + fSafe.UnLock; + end; +end; + +function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject): boolean; +var last: PtrInt; +begin + result := false; + if fCount=0 then + exit; + fSafe.Lock; + try + last := fCount-1; + if last>=0 then begin + aText := fValue[last]; + if aObject<>nil then + if fObjects<>nil then + aObject^ := fObjects[last] else + aObject^ := nil; + Delete(last); + result := true; + end; + finally + fSafe.UnLock; + end; +end; + + +{ TObjectListHashedAbstract} + +constructor TObjectListHashedAbstract.Create(aFreeItems: boolean); +begin + inherited Create; + fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount); + fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetIsObjArray(aFreeItems); +end; + +destructor TObjectListHashedAbstract.Destroy; +begin + fHash.Clear; // will free items if needed + inherited; +end; + +procedure TObjectListHashedAbstract.Delete(aIndex: integer); +begin + if (self<>nil) and + fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}Delete(aIndex) then + fHash.fHash.Clear; +end; + +procedure TObjectListHashedAbstract.Delete(aObject: TObject); +begin + Delete(IndexOf(aObject)); +end; + +{ TObjectListHashed } + +function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer; +begin + wasAdded := false; + if self<>nil then begin + result := fHash.FindHashedForAdding(aObject,wasAdded); + if wasAdded then + fList[result] := aObject; + end else + result := -1; +end; + +function TObjectListHashed.IndexOf(aObject: TObject): integer; +begin + if (self<>nil) and (fCount>0) then + result := fHash.FindHashed(aObject) else + result := -1; +end; + +procedure TObjectListHashed.Delete(aObject: TObject); +begin + fHash.FindHashedAndDelete(aObject); +end; + +{ TObjectListPropertyHashed } + +constructor TObjectListPropertyHashed.Create( + aSubPropAccess: TObjectListPropertyHashedAccessProp; + aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; + aFreeItems: boolean); +begin + inherited Create(aFreeItems); + fSubPropAccess := aSubPropAccess; + if Assigned(aHashElement) then + fHash.fHash.HashElement := aHashElement; + if Assigned(aCompare) then + fHash.fHash.Compare := aCompare; + fHash.EventCompare := IntComp; + fHash.EventHash := IntHash; +end; + +function TObjectListPropertyHashed.IntHash(const Elem): cardinal; +var O: TObject; +begin + O := fSubPropAccess(TObject(Elem)); + result := fHash.fHash.HashElement(O,fHash.fHash.Hasher); +end; + +function TObjectListPropertyHashed.IntComp(const A,B): integer; +var O: TObject; +begin + O := fSubPropAccess(TObject(A)); + result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B); +end; + +function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer; +begin + wasAdded := false; + if self<>nil then begin + result := fHash.FindHashedForAdding(aObject,wasAdded, + fHash.fHash.HashElement(aObject,fHash.fHash.Hasher)); + if wasAdded then + fList[result] := aObject; + end else + result := -1; +end; + +function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer; +var h: cardinal; +begin + if fCount>0 then begin + h := fHash.fHash.HashElement(aObject,fHash.fHash.Hasher); + result := fHash.fHash.FindOrNew(h,@aObject); // fallback to Scan() if needed + if result>=0 then + exit else // found + result := -1; // for consistency + end else + result := -1; +end; + +{ TPointerClassHashed } + +constructor TPointerClassHashed.Create(aInfo: pointer); +begin + fInfo := aInfo; +end; + +{ TPointerClassHash } + +function PointerClassHashProcess(aObject: TPointerClassHashed): pointer; +begin + if aObject=nil then // may happen for Rehash after SetCount(n+1) + result := nil else + result := aObject.Info; +end; + +constructor TPointerClassHash.Create; +begin + inherited Create(@PointerClassHashProcess); +end; + +function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed; +var wasAdded: boolean; + i: integer; +begin + i := inherited Add(aInfo,wasAdded); + if wasAdded then + result := @List[i] else + result := nil; +end; + +function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed; +var i: integer; + p: ^TPointerClassHashed; +begin + if self<>nil then begin + if fCount<64 then begin // brute force is faster for small count + p := pointer(List); + for i := 1 to fCount do begin + result := p^; + if result.fInfo=aInfo then + exit; + inc(p); + end; + end else begin + i := IndexOf(aInfo); // use hashing + if i>=0 then begin + result := TPointerClassHashed(List[i]); + exit; + end; + end; + end; + result := nil; +end; + +{ TPointerClassHashLocked } + +constructor TPointerClassHashLocked.Create; +begin + inherited Create; + fSafe.Init; +end; + +destructor TPointerClassHashLocked.Destroy; +begin + fSafe.Done; + inherited Destroy; +end; + +function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed; +begin + if self=nil then + result := nil else begin + fSafe.Lock; + try + result := inherited Find(aInfo); + finally + fSafe.UnLock; + end; + end; +end; + +function TPointerClassHashLocked.TryAddLocked(aInfo: pointer; + out aNewEntry: PPointerClassHashed): boolean; +var wasAdded: boolean; + i: integer; +begin + fSafe.Lock; + i := inherited Add(aInfo,wasAdded); + if wasAdded then begin + aNewEntry := @List[i]; + result := true; // caller should call Unlock + end else begin + fSafe.UnLock; + result := false; + end; +end; + +procedure TPointerClassHashLocked.Unlock; +begin + fSafe.UnLock; +end; + + +{ TSynDictionary } + +const + DIC_KEYCOUNT = 0; + DIC_KEY = 1; + DIC_VALUECOUNT = 2; + DIC_VALUE = 3; + DIC_TIMECOUNT = 4; + DIC_TIMESEC = 5; + DIC_TIMETIX = 6; + +function TSynDictionary.KeyFullHash(const Elem): cardinal; +begin + result := fKeys.fHash.Hasher(0,@Elem,fKeys.ElemSize); +end; + +function TSynDictionary.KeyFullCompare(const A,B): integer; +var i: PtrInt; +begin + + for i := 0 to fKeys.ElemSize-1 do begin + result := TByteArray(A)[i]-TByteArray(B)[i]; + if result<>0 then + exit; + end; + result := 0; +end; + +constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer; + aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress); +begin + inherited Create; + fSafe.Padding[DIC_KEYCOUNT].VType := varInteger; + fSafe.Padding[DIC_KEY].VType := varUnknown; + fSafe.Padding[DIC_VALUECOUNT].VType := varInteger; + fSafe.Padding[DIC_VALUE].VType := varUnknown; + fSafe.Padding[DIC_TIMECOUNT].VType := varInteger; + fSafe.Padding[DIC_TIMESEC].VType := varInteger; + fSafe.Padding[DIC_TIMETIX].VType := varInteger; + fSafe.PaddingUsedCount := DIC_TIMETIX+1; + fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil, + @fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive); + if not Assigned(fKeys.HashElement) then + fKeys.EventHash := KeyFullHash; + if not Assigned(fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare) then + fKeys.EventCompare := KeyFullCompare; + fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny, + @fSafe.Padding[DIC_VALUECOUNT].VInteger); + fTimeouts.Init(TypeInfo(TIntegerDynArray),fTimeOut,@fSafe.Padding[DIC_TIMECOUNT].VInteger); + if aCompressAlgo=nil then + aCompressAlgo := AlgoSynLZ; + fCompressAlgo := aCompressAlgo; + fSafe.Padding[DIC_TIMESEC].VInteger := aTimeoutSeconds; +end; + +function TSynDictionary.ComputeNextTimeOut: cardinal; +begin + result := fSafe.Padding[DIC_TIMESEC].VInteger; + if result<>0 then + result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result; +end; + +function TSynDictionary.GetCapacity: integer; +begin + fSafe.Lock; + result := fKeys.GetCapacity; + fSafe.UnLock; +end; + +procedure TSynDictionary.SetCapacity(const Value: integer); +begin + fSafe.Lock; + fKeys.Capacity := Value; + fValues.Capacity := Value; + if fSafe.Padding[DIC_TIMESEC].VInteger>0 then + fTimeOuts.Capacity := Value; + fSafe.UnLock; +end; + +function TSynDictionary.GetTimeOutSeconds: cardinal; +begin + result := fSafe.Padding[DIC_TIMESEC].VInteger; +end; + +procedure TSynDictionary.SetTimeouts; +var i: PtrInt; + timeout: cardinal; +begin + if fSafe.Padding[DIC_TIMESEC].VInteger=0 then + exit; + fTimeOuts.SetCount(fSafe.Padding[DIC_KEYCOUNT].VInteger); + timeout := ComputeNextTimeOut; + for i := 0 to fSafe.Padding[DIC_TIMECOUNT].VInteger-1 do + fTimeOut[i] := timeout; +end; + +function TSynDictionary.DeleteDeprecated: integer; +var i: PtrInt; + now: cardinal; +begin + result := 0; + if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry + (fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[] + exit; + now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; + if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then + exit; // no need to search more often than every second + fSafe.Lock; + try + fSafe.Padding[DIC_TIMETIX].VInteger := now; + for i := fSafe.Padding[DIC_TIMECOUNT].VInteger-1 downto 0 do + if (now>fTimeOut[i]) and (fTimeOut[i]<>0) and + (not Assigned(fOnCanDelete) or + fOnCanDelete(fKeys.ElemPtr(i)^,fValues.ElemPtr(i)^,i)) then begin + fKeys.Delete(i); + fValues.Delete(i); + fTimeOuts.Delete(i); + inc(result); + end; + if result>0 then + fKeys.Rehash; // mandatory after fKeys.Delete(i) + finally + fSafe.UnLock; + end; +end; + +procedure TSynDictionary.DeleteAll; +begin + if self=nil then + exit; + fSafe.Lock; + try + fKeys.Clear; + fKeys.Hasher.Clear; // mandatory to avoid GPF + fValues.Clear; + if fSafe.Padding[DIC_TIMESEC].VInteger>0 then + fTimeOuts.Clear; + finally + fSafe.UnLock; + end; +end; + +destructor TSynDictionary.Destroy; +begin + fKeys.Clear; + fValues.Clear; + inherited Destroy; +end; + +function TSynDictionary.Add(const aKey, aValue): integer; +var added: boolean; + tim: cardinal; +begin + fSafe.Lock; + try + result := fKeys.FindHashedForAdding(aKey,added); + if added then begin + with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do + ElemCopyFrom(aKey,result); // fKey[result] := aKey; + if fValues.Add(aValue)<>result then + raise ESynException.CreateUTF8('%.Add fValues.Add',[self]); + tim := ComputeNextTimeOut; + if tim>0 then + fTimeOuts.Add(tim); + end else + result := -1; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.AddOrUpdate(const aKey, aValue): integer; +var added: boolean; + tim: cardinal; +begin + fSafe.Lock; + try + tim := ComputeNextTimeOut; + result := fKeys.FindHashedForAdding(aKey,added); + if added then begin + with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do + ElemCopyFrom(aKey,result); // fKey[result] := aKey + if fValues.Add(aValue)<>result then + raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]); + if tim<>0 then + fTimeOuts.Add(tim); + end else begin + fValues.ElemCopyFrom(aValue,result,{ClearBeforeCopy=}true); + if tim<>0 then + fTimeOut[result] := tim; + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.Clear(const aKey): integer; +begin + fSafe.Lock; + try + result := fKeys.FindHashed(aKey); + if result>=0 then begin + fValues.ElemClear(fValues.ElemPtr(result)^); + if fSafe.Padding[DIC_TIMESEC].VInteger>0 then + fTimeOut[result] := 0; + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.Delete(const aKey): integer; +begin + fSafe.Lock; + try + result := fKeys.FindHashedAndDelete(aKey); + if result>=0 then begin + fValues.Delete(result); + if fSafe.Padding[DIC_TIMESEC].VInteger>0 then + fTimeOuts.Delete(result); + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.DeleteAt(aIndex: integer): boolean; +begin + if cardinal(aIndex)tkDynArray) then + raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays', + [self,fValues.ArrayTypeShort^]); + fSafe.Lock; + try + ndx := fKeys.FindHashed(aKey); + if ndx<0 then + exit; + nested.Init(fValues.ElemType,fValues.ElemPtr(ndx)^); + case aAction of + iaFind: + result := nested.Find(aArrayValue)>=0; + iaFindAndDelete: + result := nested.FindAndDelete(aArrayValue)>=0; + iaFindAndUpdate: + result := nested.FindAndUpdate(aArrayValue)>=0; + iaFindAndAddIfNotExisting: + result := nested.FindAndAddIfNotExisting(aArrayValue)>=0; + iaAdd: + result := nested.Add(aArrayValue)>=0; + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.FindInArray(const aKey, aArrayValue): boolean; +begin + result := InArray(aKey,aArrayValue,iaFind); +end; + +function TSynDictionary.FindKeyFromValue(const aValue; out aKey; + aUpdateTimeOut: boolean): boolean; +var ndx: integer; +begin + fSafe.Lock; + try + ndx := fValues.IndexOf(aValue); + result := ndx>=0; + if result then begin + fKeys.ElemCopyAt(ndx,aKey); + if aUpdateTimeOut then + SetTimeoutAtIndex(ndx); + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.DeleteInArray(const aKey, aArrayValue): boolean; +begin + result := InArray(aKey,aArrayValue,iaFindAndDelete); +end; + +function TSynDictionary.UpdateInArray(const aKey, aArrayValue): boolean; +begin + result := InArray(aKey,aArrayValue,iaFindAndUpdate); +end; + +function TSynDictionary.AddInArray(const aKey, aArrayValue): boolean; +begin + result := InArray(aKey,aArrayValue,iaAdd); +end; + +function TSynDictionary.AddOnceInArray(const aKey, aArrayValue): boolean; +begin + result := InArray(aKey,aArrayValue,iaFindAndAddIfNotExisting); +end; + +function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): integer; +var tim: cardinal; +begin // caller is expected to call fSafe.Lock/Unlock + if self=nil then + result := -1 else + result := fKeys.FindHashed(aKey); + if aUpdateTimeOut and (result>=0) then begin + tim := fSafe.Padding[DIC_TIMESEC].VInteger; + if tim>0 then // inlined fTimeout[result] := GetTimeout + fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; + end; +end; + +function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean; aIndex: PInteger): pointer; +var ndx: PtrInt; +begin + ndx := Find(aKey,aUpdateTimeOut); + if aIndex<>nil then + aIndex^ := ndx; + if ndx<0 then + result := nil else + result := pointer(PtrUInt(fValues.fValue^)+PtrUInt(ndx)*fValues.ElemSize); +end; + +function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean; + aIndex: PInteger): pointer; +var ndx: integer; + tim: cardinal; +begin + tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout + if tim<>0 then + tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; + ndx := fKeys.FindHashedForAdding(aKey,added); + if added then begin + with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do + ElemCopyFrom(aKey,ndx); // fKey[i] := aKey + fValues.SetCount(ndx+1); // reserve new place for associated value + if tim>0 then + fTimeOuts.Add(tim); + end else + if tim>0 then + fTimeOut[ndx] := tim; + if aIndex<>nil then + aIndex^ := ndx; + result := fValues.ElemPtr(ndx); +end; + +function TSynDictionary.FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean): boolean; +var ndx: integer; +begin + fSafe.Lock; + try + ndx := Find(aKey, aUpdateTimeOut); + if ndx>=0 then begin + fValues.ElemCopyAt(ndx,aValue); + result := true; + end else + result := false; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.FindAndExtract(const aKey; out aValue): boolean; +var ndx: integer; +begin + fSafe.Lock; + try + ndx := fKeys.FindHashedAndDelete(aKey); + if ndx>=0 then begin + fValues.ElemCopyAt(ndx,aValue); + fValues.Delete(ndx); + if fSafe.Padding[DIC_TIMESEC].VInteger>0 then + fTimeOuts.Delete(ndx); + result := true; + end else + result := false; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.Exists(const aKey): boolean; +begin + fSafe.Lock; + try + result := fKeys.FindHashed(aKey)>=0; + finally + fSafe.UnLock; + end; +end; + +{$ifndef DELPHI5OROLDER} +procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean); +begin + fSafe.Lock; + try + fValues.CopyTo(Dest,ObjArrayByRef); + finally + fSafe.UnLock; + end; +end; +{$endif DELPHI5OROLDER} + +function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer): integer; +var k,v: PAnsiChar; + i,n,ks,vs: integer; +begin + result := 0; + fSafe.Lock; + try + n := fSafe.Padding[DIC_KEYCOUNT].VInteger; + if (n=0) or not Assigned(OnEach) then + exit; + k := fKeys.Value^; + ks := fKeys.ElemSize; + v := fValues.Value^; + vs := fValues.ElemSize; + for i := 0 to n-1 do begin + inc(result); + if not OnEach(k^,v^,i,n,Opaque) then + break; + inc(k,ks); + inc(v,vs); + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.ForEach(const OnMatch: TSynDictionaryEvent; + KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; + Opaque: pointer): integer; +var k,v: PAnsiChar; + i,n,ks,vs: integer; +begin + fSafe.Lock; + try + result := 0; + if not Assigned(OnMatch) or + (NOT (Assigned(KeyCompare) or + Assigned(ValueCompare))) then + exit; + n := fSafe.Padding[DIC_KEYCOUNT].VInteger; + k := fKeys.Value^; + ks := fKeys.ElemSize; + v := fValues.Value^; + vs := fValues.ElemSize; + for i := 0 to n-1 do begin + if (Assigned(KeyCompare) and (KeyCompare(k^,aKey)=0)) or + (Assigned(ValueCompare) and (ValueCompare(v^,aValue)=0)) then begin + inc(result); + if not OnMatch(k^,v^,i,n,Opaque) then + break; + end; + inc(k,ks); + inc(v,vs); + end; + finally + fSafe.UnLock; + end; +end; + +procedure TSynDictionary.SetTimeoutAtIndex(aIndex: integer); +var tim: cardinal; +begin + if cardinal(aIndex) >= cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then + exit; + tim := fSafe.Padding[DIC_TIMESEC].VInteger; + if tim > 0 then + fTimeOut[aIndex] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; +end; + +function TSynDictionary.Count: integer; +begin + {$ifdef NOVARIANTS} + result := RawCount; + {$else} + result := fSafe.LockedInt64[DIC_KEYCOUNT]; + {$endif} +end; + +function TSynDictionary.RawCount: integer; +begin + result := fSafe.Padding[DIC_KEYCOUNT].VInteger; +end; + +procedure TSynDictionary.SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean); +var k,v: RawUTF8; +begin + fSafe.Lock; + try + fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SaveToJSON(k,EnumSetsAsText); + fValues.SaveToJSON(v,EnumSetsAsText); + finally + fSafe.UnLock; + end; + W.AddJSONArraysAsJSONObject(pointer(k),pointer(v)); +end; + +function TSynDictionary.SaveToJSON(EnumSetsAsText: boolean): RawUTF8; +var W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + W := DefaultTextWriterSerializer.CreateOwnedStream(temp); + try + SaveToJSON(W,EnumSetsAsText); + W.SetText(result); + finally + W.Free; + end; +end; + +function TSynDictionary.SaveValuesToJSON(EnumSetsAsText: boolean): RawUTF8; +begin + fSafe.Lock; + try + fValues.SaveToJSON(result,EnumSetsAsText); + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.LoadFromJSON(const JSON: RawUTF8 + {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): boolean; +begin // pointer(JSON) is not modified in-place thanks to JSONObjectAsJSONArrays() + result := LoadFromJSON(pointer(JSON){$ifndef NOVARIANTS},CustomVariantOptions{$endif}); +end; + +function TSynDictionary.LoadFromJSON(JSON: PUTF8Char{$ifndef NOVARIANTS}; + CustomVariantOptions: PDocVariantOptions{$endif}): boolean; +var k,v: RawUTF8; // private copy of the JSON input, expanded as Keys/Values arrays +begin + result := false; + if not JSONObjectAsJSONArrays(JSON,k,v) then + exit; + fSafe.Lock; + try + if fKeys.LoadFromJSON(pointer(k),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then + if fValues.LoadFromJSON(pointer(v),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then + if fKeys.Count=fValues.Count then begin + SetTimeouts; + fKeys.Rehash; // warning: duplicated keys won't be identified + result := true; + end; + finally + fSafe.UnLock; + end; +end; + +function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean; +var plain: RawByteString; + P,PEnd: PAnsiChar; +begin + result := false; + plain := fCompressAlgo.Decompress(binary); + P := pointer(plain); + if P=nil then + exit; + PEnd := P+length(plain); + fSafe.Lock; + try + P := fKeys.LoadFrom(P,nil,{checkhash=}false,PEnd); + if P<>nil then + P := fValues.LoadFrom(P,nil,{checkhash=}false,PEnd); + if (P<>nil) and (fKeys.Count=fValues.Count) then begin + SetTimeouts; // set ComputeNextTimeOut for all items + fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary + result := true; + end; + finally + fSafe.UnLock; + end; +end; + +class function TSynDictionary.OnCanDeleteSynPersistentLock(const aKey, aValue; + aIndex: integer): boolean; +begin + result := not TSynPersistentLock(aValue).Safe^.IsLocked; +end; + +class function TSynDictionary.OnCanDeleteSynPersistentLocked(const aKey, aValue; + aIndex: integer): boolean; +begin + result := not TSynPersistentLock(aValue).Safe.IsLocked; +end; + +function TSynDictionary.SaveToBinary(NoCompression: boolean): RawByteString; +var tmp: TSynTempBuffer; + trigger: integer; +begin + fSafe.Lock; + try + result := ''; + if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then + exit; + tmp.Init(fKeys.SaveToLength+fValues.SaveToLength); + if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-PAnsiChar(tmp.buf)=tmp.len then begin + if NoCompression then + trigger := maxInt else + trigger := 128; + result := fCompressAlgo.Compress(tmp.buf,tmp.len,trigger); + end; + tmp.Done; + finally + fSafe.UnLock; + end; +end; + + +{ TMemoryMap } + +function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64): boolean; +var Available: Int64; +begin + fBuf := nil; + fBufSize := 0; + {$ifdef MSWINDOWS} + fMap := 0; + {$endif} + fFileLocal := false; + fFile := aFile; + fFileSize := FileSeek64(fFile,0,soFromEnd); + if fFileSize=0 then begin + result := true; // handle 0 byte file without error (but no memory map) + exit; + end; + result := false; + if (fFileSize<=0) {$ifdef CPU32}or (fFileSize>maxInt){$endif} then + /// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors) + exit; + if aCustomSize=0 then + fBufSize := fFileSize else begin + Available := fFileSize-aCustomOffset; + if Available<0 then + exit; + if aCustomSize>Available then + fBufSize := Available; + fBufSize := aCustomSize; + end; + {$ifdef MSWINDOWS} + with PInt64Rec(@fFileSize)^ do + fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil); + if fMap=0 then + raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0'); + with PInt64Rec(@aCustomOffset)^ do + fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize); + if fBuf=nil then begin + // Windows failed to find a contiguous VA space -> fall back on direct read + CloseHandle(fMap); + fMap := 0; + {$else} + if aCustomOffset<>0 then + if aCustomOffset and (SystemInfo.dwPageSize-1)<>0 then + raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with SystemInfo.dwPageSize=%', + [aCustomOffset,SystemInfo.dwPageSize]) else + aCustomOffset := aCustomOffset div SystemInfo.dwPageSize; + fBuf := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}( + nil,fBufSize,PROT_READ,MAP_SHARED,fFile,aCustomOffset); + if fBuf=MAP_FAILED then begin + fBuf := nil; + {$endif} + end else + result := true; +end; + +procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt); +begin + fBuf := aBuffer; + fFileSize := aBufferSize; + fBufSize := aBufferSize; + {$ifdef MSWINDOWS} + fMap := 0; + {$endif} + fFile := 0; + fFileLocal := false; +end; + +function TMemoryMap.Map(const aFileName: TFileName): boolean; +var F: THandle; +begin + result := false; + // Memory-mapped file access does not go through the cache manager so + // using FileOpenSequentialRead() is pointless here + F := FileOpen(aFileName,fmOpenRead or fmShareDenyNone); + if PtrInt(F)<0 then + exit; + if Map(F) then + result := true else + FileClose(F); + fFileLocal := result; +end; + +procedure TMemoryMap.UnMap; +begin + {$ifdef MSWINDOWS} + if fMap<>0 then begin + UnmapViewOfFile(fBuf); + CloseHandle(fMap); + fMap := 0; + end; + {$else} + if (fBuf<>nil) and (fBufSize>0) and (fFile<>0) then + {$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize); + {$endif} + fBuf := nil; + fBufSize := 0; + if fFile<>0 then begin + if fFileLocal then + FileClose(fFile); + fFile := 0; + end; +end; + + +{ TSynMemoryStream } + +constructor TSynMemoryStream.Create(const aText: RawByteString); +begin + inherited Create; + SetPointer(pointer(aText),length(aText)); +end; + +constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt); +begin + inherited Create; + SetPointer(Data,DataLen); +end; + +function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint; +begin + {$ifdef FPC} + result := 0; // makes FPC compiler happy + {$endif} + raise EStreamError.CreateFmt('Unexpected %s.Write',[ClassNameShort(self)^]); +end; + + +{ TSynMemoryStreamMapped } + +constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName; + aCustomSize: PtrUInt; aCustomOffset: Int64); +begin + fFileName := aFileName; + // Memory-mapped file access does not go through the cache manager so + // using FileOpenSequentialRead() is pointless here + fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone); + Create(fFileStream.Handle,aCustomSize,aCustomOffset); +end; + +constructor TSynMemoryStreamMapped.Create(aFile: THandle; + aCustomSize: PtrUInt; aCustomOffset: Int64); +begin + if not fMap.Map(aFile,aCustomSize,aCustomOffset) then + raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]); + inherited Create(fMap.fBuf,fMap.fBufSize); +end; + +destructor TSynMemoryStreamMapped.Destroy; +begin + fMap.UnMap; + fFileStream.Free; + inherited; +end; + +function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64; +{$ifdef MSWINDOWS} +var R64: packed record Lo, Hi: integer; end absolute Result; +begin + Result := Offset; + R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin)); + if (R64.Lo=-1) and (GetLastError<>0) then + R64.Hi := -1; // so result=-1 +end; +{$else} +begin + {$ifdef FPC} + result := FPLSeek(Handle,Offset,Origin); + {$else} + {$ifdef KYLIX3} + result := LibC.lseek64(Handle,Offset,Origin); + {$else} + // warning: this won't handle file size > 2 GB :( + result := FileSeek(Handle,Offset,Origin); + {$endif} + {$endif} +end; +{$endif} + +function PropNameValid(P: PUTF8Char): boolean; +var tab: PTextCharSet; +begin + result := false; + tab := @TEXT_CHARS; + if (P=nil) or not (tcIdentifierFirstChar in tab[P^]) then + exit; // first char must be alphabetical + repeat + inc(P); // following chars can be alphanumerical + if tcIdentifier in tab[P^] then + continue; + if P^=#0 then + break; + exit; + until false; + result := true; +end; + +function PropNamesValid(const Values: array of RawUTF8): boolean; +var i,j: integer; + tab: PTextCharSet; +begin + result := false; + tab := @TEXT_CHARS; + for i := 0 to high(Values) do + for j := 1 to length(Values[i]) do + if not (tcIdentifier in tab[Values[i][j]]) then + exit; + result := true; +end; + +function JsonPropNameValid(P: PUTF8Char): boolean; +var tab: PJsonCharSet; +begin + tab := @JSON_CHARS; + if (P<>nil) and (jcJsonIdentifierFirstChar in tab[P^]) then begin + repeat + inc(P); + until not(jcJsonIdentifier in tab[P^]); + result := P^ = #0; + end else + result := false; +end; + +function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; +var i: PtrInt; +begin + i := 0; + repeat + result := PtrInt(P1[i])-PtrInt(P2[i]); + if result=0 then begin + inc(i); + if inil then begin + f := PInt64(FieldName)^; + result := (f and $ffdfdf=(ord('I')+ord('D')shl 8)) or (f and $ffdfdfdfdfdf= + (ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24+Int64(ord('D')) shl 32)) + end +{$else} +begin + if FieldName<>nil then + result := (PInteger(FieldName)^ and $ffdfdf=ord('I')+ord('D')shl 8) or + ((PIntegerArray(FieldName)^[0] and $dfdfdfdf= + ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and + (PIntegerArray(FieldName)^[1] and $ffdf=ord('D'))) +{$endif} else result := false; +end; + +function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; +begin + case FieldLen of + 2: result := + PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8; + 5: result := + (PInteger(FieldName)^ and $dfdfdfdf= + ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and + (ord(FieldName[4]) and $df=ord('D')); + else result := false; + end; +end; + +function IsRowIDShort(const FieldName: shortstring): boolean; +begin + result := + (PInteger(@FieldName)^ and $DFDFFF= + 2+ord('I')shl 8+ord('D')shl 16) or + ((PIntegerArray(@FieldName)^[0] and $dfdfdfff= + 5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and + (PIntegerArray(@FieldName)^[1] and $dfdf= + ord('I')+ord('D')shl 8)); +end; + +function GotoNextSqlIdentifier(P: PUtf8Char; tab: PTextCharSet): PUtf8Char; + {$ifdef HASINLINE} inline; {$endif} +begin + while tcCtrlNot0Comma in tab[P^] do inc(P); // in [#1..' ', ';'] + if PWord(P)^=ord('/')+ord('*') shl 8 then begin // ignore e.g. '/*nocache*/' + repeat + inc(P); + if PWord(P)^ = ord('*')+ord('/') shl 8 then begin + inc(P, 2); + break; + end; + until P^ = #0; + while tcCtrlNot0Comma in tab[P^] do inc(P); + end; + result := P; +end; + +function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; +var B: PUTF8Char; + tab: PTextCharSet; +begin + tab := @TEXT_CHARS; + P := GotoNextSqlIdentifier(P, tab); + B := P; + while tcIdentifier in tab[P^] do inc(P); // go to end of field name + FastSetString(Prop,B,P-B); + P := GotoNextSqlIdentifier(P, tab); + result := Prop<>''; +end; + +function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; +var B: PUTF8Char; + tab: PTextCharSet; +begin + tab := @TEXT_CHARS; + while tcCtrlNotLF in tab[P^] do inc(P); + B := P; + while tcIdentifier in tab[P^] do inc(P); // go to end of field name + SetString(Prop,PAnsiChar(B),P-B); + while tcCtrlNotLF in TEXT_CHARS[P^] do inc(P); + result := Prop<>''; +end; + + +type + TSynLZHead = packed record + Magic: cardinal; + CompressedSize: integer; + HashCompressed: cardinal; + UnCompressedSize: integer; + HashUncompressed: cardinal; + end; + PSynLZHead = ^TSynLZHead; + TSynLZTrailer = packed record + HeaderRelativeOffset: cardinal; + Magic: cardinal; + end; + PSynLZTrailer = ^TSynLZTrailer; + +function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; +begin + if (P=nil) or (Len<=SizeOf(TSynLZTrailer)) then + result := 0 else + with PSynLZTrailer(P+Len-SizeOf(TSynLZTrailer))^ do + if (Magic=aMagic) and (HeaderRelativeOffset0 then // '' is compressed and uncompressed to '' + if Compress then begin + len := SynLZcompressdestlen(DataLen)+8; + SetString(result,nil,len); + P := pointer(result); + PCardinal(P)^ := Hash32(pointer(Data),DataLen); + len := SynLZcompress1(pointer(Data),DataLen,P+8); + PCardinal(P+4)^ := Hash32(pointer(P+8),len); + SetString(Data,P,len+8); + end else begin + result := ''; + P := pointer(Data); + if (DataLen<=8) or (Hash32(pointer(P+8),DataLen-8)<>PCardinal(P+4)^) then + exit; + len := SynLZdecompressdestlen(P+8); + SetLength(result,len); + if (len<>0) and ((SynLZDecompress1(P+8,DataLen-8,pointer(result))<>len) or + (Hash32(pointer(result),len)<>PCardinal(P)^)) then begin + result := ''; + exit; + end else + SetString(Data,PAnsiChar(pointer(result)),len); + end; + result := 'synlz'; +end; + +function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer; +var DataLen: integer; + S,D: pointer; + Head: TSynLZHead; + Trailer: TSynLZTrailer; + tmp: TSynTempBuffer; +begin + if Dest=nil then begin + result := 0; + exit; + end; + if Source<>nil then begin + S := Source.Memory; + DataLen := Source.Size; + end else begin + S := nil; + DataLen := 0; + end; + tmp.Init(SynLZcompressdestlen(DataLen)); + try + Head.Magic := Magic; + Head.UnCompressedSize := DataLen; + Head.HashUncompressed := Hash32(S,DataLen); + result := SynLZcompress1(S,DataLen,tmp.buf); + if result>tmp.len then + raise ESynException.Create('StreamLZ: SynLZ compression overflow'); + if result>DataLen then begin + result := DataLen; // compression not worth it + D := S; + end else + D := tmp.buf; + Head.CompressedSize := result; + Head.HashCompressed := Hash32(D,result); + Dest.WriteBuffer(Head,SizeOf(Head)); + Dest.WriteBuffer(D^,Head.CompressedSize); + Trailer.HeaderRelativeOffset := result+(SizeOf(Head)+SizeOf(Trailer)); + Trailer.Magic := Magic; + Dest.WriteBuffer(Trailer,SizeOf(Trailer)); + result := Head.CompressedSize+(SizeOf(Head)+SizeOf(Trailer)); + finally + tmp.Done; + end; +end; + +function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; + Magic: cardinal): integer; +var F: TFileStream; +begin + F := TFileStream.Create(DestFile,fmCreate); + try + result := StreamSynLZ(Source,F,Magic); + finally + F.Free; + end; +end; + +function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; +var src,dst: RawByteString; + S,D: THandleStream; + Head: TSynLZHead; + Count,Max: Int64; +begin + result := false; + if FileExists(Source) then + try + S := FileStreamSequentialRead(Source); + try + DeleteFile(Dest); + Max := 128 shl 20; // 128 MB default compression chunk + D := TFileStream.Create(Dest,fmCreate); + try + Head.Magic := Magic; + Count := S.Size; + while Count>0 do begin + if Count>Max then + Head.UnCompressedSize := Max else + Head.UnCompressedSize := Count; + if src='' then + SetString(src,nil,Head.UnCompressedSize); + if dst='' then + SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize)); + Head.UnCompressedSize := S.Read(pointer(src)^,Head.UnCompressedSize); + {$ifdef MSWINDOWS} + if (Head.UnCompressedSize<=0) and + (GetLastError=ERROR_NO_SYSTEM_RESOURCES) then begin + Max := 32 shl 20; // we observed a 32MB chunk size limitation on XP + Head.UnCompressedSize := S.Read(pointer(src)^,Max); + end; + {$endif MSWINDOWS} + if Head.UnCompressedSize<=0 then + exit; // read error + Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize); + Head.CompressedSize := + SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst)); + Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize); + if (D.Write(Head,SizeOf(Head))<>SizeOf(Head)) or + (D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then + exit; + dec(Count,Head.UnCompressedSize); + end; + finally + D.Free; + end; + result := FileSetDateFrom(Dest,S.Handle); + finally + S.Free; + end; + except + on Exception do + result := false; + end; +end; + +function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; +var src,dst: RawByteString; + S,D: THandleStream; + Count: Int64; + Head: TSynLZHead; +begin + result := false; + if FileExists(Source) then + try + S := FileStreamSequentialRead(Source); + try + DeleteFile(Dest); + D := TFileStream.Create(Dest,fmCreate); + try + Count := S.Size; + while Count>0 do begin + if S.Read(Head,SizeOf(Head))<>SizeOf(Head) then + exit; + dec(Count,SizeOf(Head)); + if (Head.Magic<>Magic) or + (Head.CompressedSize>Count) then + exit; + if Head.CompressedSize>length(src) then + SetString(src,nil,Head.CompressedSize); + if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then + exit; + dec(Count,Head.CompressedSize); + if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or + (SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then + exit; + if Head.UnCompressedSize>length(dst) then + SetString(dst,nil,Head.UnCompressedSize); + if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or + (Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then + exit; + if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then + exit; + end; + finally + D.Free; + end; + result := FileSetDateFrom(Dest,S.Handle); + finally + S.Free; + end; + except + on Exception do + result := false; + end; +end; + +function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; +var S: TFileStream; + Head: TSynLZHead; +begin + result := false; + if FileExists(Name) then + try + S := TFileStream.Create(Name,fmOpenRead or fmShareDenyNone); + try + if S.Read(Head,SizeOf(Head))=SizeOf(Head) then + if Head.Magic=Magic then + result := true; // only check magic, since there may be several chunks + finally + S.Free; + end; + except + on Exception do + result := false; + end; +end; + +function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; +var S: TStream; +begin + try + S := TSynMemoryStreamMapped.Create(Source); + try + result := StreamUnSynLZ(S,Magic); + finally + S.Free; + end; + except + on E: Exception do + result := nil; + end; +end; + +function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; +var S,D: PAnsiChar; + sourcePosition,resultSize,sourceSize: Int64; + Head: TSynLZHead; + Trailer: TSynLZTrailer; + buf: RawByteString; + stored: boolean; +begin + result := nil; + if Source=nil then + exit; + sourceSize := Source.Size; + {$ifndef CPU64} + if sourceSize>maxInt then + exit; // result TMemoryStream should stay in memory! + {$endif} + sourcePosition := Source.Position; + if sourceSize-sourcePositionSizeOf(Head)) or + (Head.Magic<>Magic) then begin + // Source not positioned as expected -> try from the end + Source.Position := sourceSize-SizeOf(Trailer); + if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or + (Trailer.Magic<>Magic) then + exit; + sourcePosition := sourceSize-Trailer.HeaderRelativeOffset; + Source.Position := sourcePosition; + if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or + (Head.Magic<>Magic) then + exit; + end; + inc(sourcePosition,SizeOf(Head)); + if sourcePosition+Head.CompressedSize>sourceSize then + exit; + if Source.InheritsFrom(TCustomMemoryStream) then begin + S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition); + Source.Seek(Head.CompressedSize,soCurrent); + end else begin + if Head.CompressedSize>length(Buf) then + SetString(Buf,nil,Head.CompressedSize); + S := pointer(Buf); + Source.Read(S^,Head.CompressedSize); + end; + inc(sourcePosition,Head.CompressedSize); + if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or + (Trailer.Magic<>Magic) then + // trailer not available in old .synlz layout, or in FileSynLZ multiblocks + Source.Position := sourcePosition else + sourceSize := 0; // should be monoblock + // Source stream will now point after all data + stored := (Head.CompressedSize=Head.UnCompressedSize) and + (Head.HashCompressed=Head.HashUncompressed); + if not stored then + if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then + exit; + if Hash32(pointer(S),Head.CompressedSize)<>Head.HashCompressed then + exit; + if result=nil then + result := THeapMemoryStream.Create else begin + {$ifndef CPU64} + if resultSize+Head.UnCompressedSize>maxInt then begin + FreeAndNil(result); // result TMemoryStream should stay in memory! + break; + end; + {$endif CPU64} + end; + result.Size := resultSize+Head.UnCompressedSize; + D := PAnsiChar(result.Memory)+resultSize; + inc(resultSize,Head.UnCompressedSize); + if stored then + MoveFast(S^,D^,Head.CompressedSize) else + if SynLZDecompress1(S,Head.CompressedSize,D)<>Head.UnCompressedSize then + FreeAndNil(result) else + if Hash32(pointer(D),Head.UnCompressedSize)<>Head.HashUncompressed then + FreeAndNil(result); + until (result=nil) or (sourcePosition>=sourceSize); +end; + + +{ TAlgoCompress } + +const + COMPRESS_STORED = #0; + COMPRESS_SYNLZ = 1; + +var + SynCompressAlgos: TSynObjectList; + +constructor TAlgoCompress.Create; +var existing: TAlgoCompress; +begin + inherited Create; + if SynCompressAlgos=nil then + GarbageCollectorFreeAndNil(SynCompressAlgos,TSynObjectList.Create) else begin + existing := Algo(AlgoID); + if existing<>nil then + raise ESynException.CreateUTF8('%.Create: AlgoID=% already registered by %', + [self,AlgoID,existing.ClassType]); + end; + SynCompressAlgos.Add(self); +end; + +class function TAlgoCompress.Algo(const Comp: RawByteString): TAlgoCompress; +begin + result := Algo(Pointer(Comp),Length(Comp)); +end; + +class function TAlgoCompress.Algo(const Comp: TByteDynArray): TAlgoCompress; +begin + result := Algo(Pointer(Comp),Length(Comp)); +end; + +class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; +begin + if (Comp<>nil) and (CompLen>9) then + if ord(Comp[4])<=1 then // inline-friendly Comp[4]<=COMPRESS_SYNLZ + result := AlgoSynLZ else // COMPRESS_STORED is also handled as SynLZ + result := Algo(ord(Comp[4])) else + result := nil; +end; + +class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; +begin + if (Comp<>nil) and (CompLen>9) then begin + IsStored := Comp[4]=COMPRESS_STORED; + result := Algo(ord(Comp[4])); + end else begin + IsStored := false; + result := nil; + end; +end; + +class function TAlgoCompress.Algo(AlgoID: byte): TAlgoCompress; +var i: integer; + ptr: ^TAlgoCompress; +begin + if AlgoID<=COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ + result := AlgoSynLZ else begin + if SynCompressAlgos<>nil then begin + ptr := pointer(SynCompressAlgos.List); + inc(ptr); // ignore List[0] = AlgoSynLZ + for i := 2 to SynCompressAlgos.Count do + if ptr^.AlgoID=AlgoID then begin + result := ptr^; + exit; + end + else + inc(ptr); + end; + result := nil; + end; +end; + +class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer; +begin + result := Algo(Comp).DecompressHeader(pointer(Comp),length(Comp)); +end; + +function TAlgoCompress.AlgoName: TShort16; +var s: PShortString; + i: integer; +begin + if self=nil then + result := 'none' else begin + s := ClassNameShort(self); + if IdemPChar(@s^[1],'TALGO') then begin + result[0] := AnsiChar(ord(s^[0])-5); + inc(PByte(s),5); + end else + result[0] := s^[0]; + if result[0]>#16 then + result[0] := #16; + for i := 1 to ord(result[0]) do + result[i] := NormToLower[s^[i]]; + end; +end; + +function TAlgoCompress.AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; +begin + result := crc32c(Previous,Data,DataLen); +end; + +function TAlgoCompress.Compress(const Plain: RawByteString; CompressionSizeTrigger: integer; + CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; +begin + result := Compress(pointer(Plain),Length(Plain),CompressionSizeTrigger, + CheckMagicForCompressed,BufferOffset); +end; + +function TAlgoCompress.Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer; + CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; +var len: integer; + R: PAnsiChar; + crc: cardinal; + tmp: array[0..16383] of AnsiChar; // big enough to resize Result in-place +begin + if (self=nil) or (PlainLen=0) or (Plain=nil) then begin + result := ''; + exit; + end; + crc := AlgoHash(0,Plain,PlainLen); + if (PlainLenSizeOf(tmp) then begin + SetString(result,nil,len); + R := pointer(result); + end else + R := @tmp; + inc(R,BufferOffset); + PCardinal(R)^ := crc; + len := AlgoCompress(Plain,PlainLen,R+9); + if len+64>=PlainLen then begin // store if compression was not worth it + R[4] := COMPRESS_STORED; + PCardinal(R+5)^ := crc; + MoveFast(Plain^,R[9],PlainLen); + len := PlainLen; + end else begin + R[4] := AnsiChar(AlgoID); + PCardinal(R+5)^ := AlgoHash(0,R+9,len); + end; + if R=@tmp[BufferOffset] then + SetString(result,tmp,len+BufferOffset+9) else + SetLength(result,len+BufferOffset+9); // MM may not move the data + end; +end; + +function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; + CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; +var len: integer; +begin + result := 0; + if (self=nil) or (PlainLen=0) or (CompLen=CompressionSizeTrigger) and + not(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin + len := CompressDestLen(PlainLen); + if CompLen=PlainLen then begin // store if compression not worth it + R[4] := COMPRESS_STORED; + PCardinal(R+5)^ := crc; + MoveFast(Plain^,R[9],PlainLen); + len := PlainLen; + end else begin + R[4] := AnsiChar(AlgoID); + PCardinal(R+5)^ := AlgoHash(0,R+9,len); + end; + SetLength(result,len+9); + end; +end; + +function TAlgoCompress.CompressToBytes(const Plain: RawByteString; + CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray; +begin + result := CompressToBytes(pointer(Plain),Length(Plain), + CompressionSizeTrigger,CheckMagicForCompressed); +end; + +function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString; +begin + Decompress(pointer(Comp),length(Comp),result); +end; + +procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; + out Result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer); +var len: integer; + dec: PAnsiChar; +begin + len := DecompressHeader(Comp,CompLen,Load); + if len=0 then + exit; + SetString(result,nil,len+BufferOffset); + dec := pointer(result); + if not DecompressBody(Comp,dec+BufferOffset,CompLen,len,Load) then + result := ''; +end; + +function TAlgoCompress.Decompress(const Comp: RawByteString; + Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; +begin + Decompress(pointer(Comp),length(Comp),result,Load,BufferOffset); +end; + +function TAlgoCompress.TryDecompress(const Comp: RawByteString; + out Dest: RawByteString; Load: TAlgoCompressLoad): boolean; +var len: integer; +begin + result := Comp=''; + if result then + exit; + len := DecompressHeader(pointer(Comp),length(Comp),Load); + if len=0 then + exit; // invalid crc32c + SetString(Dest,nil,len); + if DecompressBody(pointer(Comp),pointer(Dest),length(Comp),len,Load) then + result := true else + Dest := ''; +end; + +function TAlgoCompress.Decompress(const Comp: RawByteString; + out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; +begin + result := Decompress(pointer(Comp),length(Comp),PlainLen,tmp,Load); +end; + +function TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; + out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; +begin + result := nil; + PlainLen := DecompressHeader(Comp,CompLen,Load); + if PlainLen=0 then + exit; + if Comp[4]=COMPRESS_STORED then + result := Comp+9 else begin + if PlainLen > length(tmp) then + SetString(tmp,nil,PlainLen); + if DecompressBody(Comp,pointer(tmp),CompLen,PlainLen,Load) then + result := pointer(tmp); + end; +end; + +function TAlgoCompress.DecompressPartial(Comp, Partial: PAnsiChar; + CompLen, PartialLen, PartialLenMax: integer): integer; +var BodyLen: integer; +begin + result := 0; + if (self=nil) or (CompLen<=9) or (Comp=nil) or (PartialLenMaxBodyLen then + PartialLen := BodyLen; + if Comp[4]=COMPRESS_STORED then + MoveFast(Comp[9],Partial[0],PartialLen) else + if AlgoDecompressPartial(Comp+9,CompLen-9,Partial,PartialLen,PartialLenMax)aclNoCrcFast) and (AlgoHash(0,Comp+9,CompLen-9)<>PCardinal(Comp+5)^)) then + exit; + if Comp[4]=COMPRESS_STORED then begin + if PCardinal(Comp)^=PCardinal(Comp+5)^ then + result := CompLen-9; + end else + if Comp[4]=AnsiChar(AlgoID) then + result := AlgoDecompressDestLen(Comp+9); +end; + +function TAlgoCompress.DecompressBody(Comp, Plain: PAnsiChar; + CompLen, PlainLen: integer; Load: TAlgoCompressLoad): boolean; +begin + result := false; + if (self=nil) or (PlainLen<=0) then + exit; + if Comp[4]=COMPRESS_STORED then + MoveFast(Comp[9],Plain[0],PlainLen) else + if Comp[4]=AnsiChar(AlgoID) then + case Load of + aclNormal: + if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) or + (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then + exit; + aclSafeSlow: + if (AlgoDecompressPartial(Comp+9,CompLen-9,Plain,PlainLen,PlainLen)<>PlainLen) or + (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then + exit; + aclNoCrcFast: + if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) then + exit; + end; + result := true; +end; + + +{ TAlgoSynLZ } + +function TAlgoSynLZ.AlgoID: byte; +begin + result := COMPRESS_SYNLZ; // =1 +end; + +function TAlgoSynLZ.AlgoCompress(Plain: pointer; PlainLen: integer; + Comp: pointer): integer; +begin + result := SynLZcompress1(Plain,PlainLen,Comp); +end; + +function TAlgoSynLZ.AlgoCompressDestLen(PlainLen: integer): integer; +begin + result := SynLZcompressdestlen(PlainLen); +end; + +function TAlgoSynLZ.AlgoDecompress(Comp: pointer; CompLen: integer; + Plain: pointer): integer; +begin + result := SynLZdecompress1(Comp,CompLen,Plain); +end; + +function TAlgoSynLZ.AlgoDecompressDestLen(Comp: pointer): integer; +begin + result := SynLZdecompressdestlen(Comp); +end; + +function TAlgoSynLZ.AlgoDecompressPartial(Comp: pointer; + CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; +begin + result := SynLZdecompress1partial(Comp,CompLen,Partial,PartialLen); +end; + +// deprecated wrapper methods - use SynLZ global variable instead + +function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer; + CheckMagicForCompressed: boolean): RawByteString; +begin + result := AlgoSynLZ.Compress(pointer(Data),length(Data),CompressionSizeTrigger, + CheckMagicForCompressed); +end; + +procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; + CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean); +begin + result := AlgoSynLZ.Compress(P,PLen,CompressionSizeTrigger,CheckMagicForCompressed); +end; + +function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; + CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; +begin + result := AlgoSynLZ.Compress(P,Dest,PLen,DestLen,CompressionSizeTrigger,CheckMagicForCompressed); +end; + +function SynLZDecompress(const Data: RawByteString): RawByteString; +begin + AlgoSynLZ.Decompress(pointer(Data),Length(Data),result); +end; + +function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; +begin + result := AlgoSynLZ.DecompressHeader(P,PLen); +end; + +function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; + SafeDecompression: boolean): boolean; +begin + result := AlgoSynLZ.DecompressBody(P,Body,PLen,BodyLen,ALGO_SAFE[SafeDecompression]); +end; + +function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; +begin + result := AlgoSynLZ.DecompressPartial(P,Partial,PLen,PartialLen,PartialLen); +end; + +procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; + SafeDecompression: boolean); +begin + AlgoSynLZ.Decompress(P,PLen,Result); +end; + +function SynLZDecompress(const Data: RawByteString; out Len: integer; + var tmp: RawByteString): pointer; +begin + result := AlgoSynLZ.Decompress(pointer(Data),length(Data),Len,tmp); +end; + +function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; + var tmp: RawByteString): pointer; +begin + result := AlgoSynLZ.Decompress(P,PLen,Len,tmp); +end; + +function SynLZCompressToBytes(const Data: RawByteString; + CompressionSizeTrigger: integer): TByteDynArray; +begin + result := AlgoSynLZ.CompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger); +end; + +function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray; +begin + result := AlgoSynLZ.CompressToBytes(P,PLen,CompressionSizeTrigger); +end; + +function SynLZDecompress(const Data: TByteDynArray): RawByteString; +begin + AlgoSynLZ.Decompress(pointer(Data),length(Data),result); +end; + + +{ TAlgoCompressWithNoDestLen } + +function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer; + PlainLen: integer; Comp: pointer): integer; +begin + Comp := ToVarUInt32(PlainLen,Comp); // deflate don't store PlainLen + result := RawProcess(Plain,Comp,PlainLen,AlgoCompressDestLen(PlainLen),0,doCompress); + if result>0 then + inc(result,ToVarUInt32Length(PlainLen)); +end; + +function TAlgoCompressWithNoDestLen.AlgoDecompress(Comp: pointer; + CompLen: integer; Plain: pointer): integer; +var start: PAnsiChar; +begin + start := Comp; + result := FromVarUInt32(PByte(Comp)); + if RawProcess(Comp,Plain,CompLen+(Start-Comp),result,0,doUnCompress)<>result then + result := 0; +end; + +function TAlgoCompressWithNoDestLen.AlgoDecompressDestLen(Comp: pointer): integer; +begin + if Comp=nil then + result := 0 else + result := FromVarUInt32(PByte(Comp)); +end; + +function TAlgoCompressWithNoDestLen.AlgoDecompressPartial(Comp: pointer; + CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; +var start: PAnsiChar; +begin + start := Comp; + result := FromVarUInt32(PByte(Comp)); + if PartialLenMax>result then + PartialLenMax := result; + result := RawProcess(Comp,Partial,CompLen+(Start-Comp),PartialLen,PartialLenMax,doUncompressPartial); +end; + + +{ ESynException } + +constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const); +var msg: string; +begin + FormatString(Format,Args,msg); + inherited Create(msg); +end; + +constructor ESynException.CreateLastOSError( + const Format: RawUTF8; const Args: array of const; const Trailer: RawUtf8); +var tmp: RawUTF8; + error: integer; +begin + error := GetLastError; + FormatUTF8(Format,Args,tmp); + CreateUTF8('% % [%] %',[Trailer,error,SysErrorMessage(error),tmp]); +end; + +{$ifndef NOEXCEPTIONINTERCEPT} +function ESynException.CustomLog(WR: TTextWriter; + const Context: TSynLogExceptionContext): boolean; +begin + if Assigned(TSynLogExceptionToStrCustom) then + result := TSynLogExceptionToStrCustom(WR,Context) else + if Assigned(DefaultSynLogExceptionToStr) then + result := DefaultSynLogExceptionToStr(WR,Context) else + result := false; +end; +{$endif} + + +{ TMemoryMapText } + +constructor TMemoryMapText.Create; +begin +end; + +constructor TMemoryMapText.Create(aFileContent: PUTF8Char; aFileSize: integer); +begin + Create; + fMap.Map(aFileContent,aFileSize); + LoadFromMap; +end; + +constructor TMemoryMapText.Create(const aFileName: TFileName); +begin + Create; + fFileName := aFileName; + if fMap.Map(aFileName) then + LoadFromMap; +end; // invalid file or unable to memory map its content -> Count := 0 + +destructor TMemoryMapText.Destroy; +begin + Freemem(fLines); + fMap.UnMap; + inherited; +end; + +procedure TMemoryMapText.SaveToStream(Dest: TStream; const Header: RawUTF8); +var i: integer; + W: TTextWriter; + temp: TTextWriterStackBuffer; +begin + i := length(Header); + if i>0 then + Dest.WriteBuffer(pointer(Header)^,i); + if fMap.Size>0 then + Dest.WriteBuffer(fMap.Buffer^,fMap.Size); + if fAppendedLinesCount=0 then + exit; + W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); + try + if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then + W.Add(#10); + for i := 0 to fAppendedLinesCount-1 do begin + W.AddString(fAppendedLines[i]); + W.Add(#10); + end; + W.FlushFinal; + finally + W.Free; + end; +end; + +procedure TMemoryMapText.SaveToFile(FileName: TFileName; const Header: RawUTF8); +var FS: TFileStream; +begin + FS := TFileStream.Create(FileName,fmCreate); + try + SaveToStream(FS,Header); + finally + FS.Free; + end; +end; + +function TMemoryMapText.GetLine(aIndex: integer): RawUTF8; +begin + if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then + result := '' else + FastSetString(result,fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd)); +end; + +function TMemoryMapText.GetString(aIndex: integer): string; +begin + if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then + result := '' else + UTF8DecodeToString(fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd),result); +end; + +function GetLineContains(p, pEnd, up: PUTF8Char): boolean; +var + i: PtrInt; + {$ifdef CPUX86NOTPIC} table: TNormTable absolute NormToUpperAnsi7Byte; + {$else} table: PNormTable; {$endif} +label + Fnd1, LF1, Fnd2, LF2, Ok; // ugly but fast +begin + if (p<>nil) and (up<>nil) then begin + {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} + if pEnd=nil then + repeat + if p^<=#13 then + goto LF1 + else if table[p^]=up^ then + goto Fnd1; + inc(p); + continue; +LF1: if (p^=#0) or (p^=#13) or (p^=#10) then + break; + inc(p); + continue; +Fnd1: i := 0; + repeat + inc(i); + if up[i]<>#0 then + if up[i]=table[p[i]] then + continue else + break else begin +Ok: result := true; // found + exit; + end; + until false; + inc(p); + until false + else + repeat + if p>=pEnd then + break; + if p^<=#13 then + goto LF2 + else if table[p^]=up^ then + goto Fnd2; + inc(p); + continue; +LF2: if (p^=#13) or (p^=#10) then + break; + inc(p); + continue; +Fnd2: i := 0; + repeat + inc(i); + if up[i]=#0 then + goto Ok; + if p+i>=pEnd then + break; + until up[i]<>table[p[i]]; + inc(p); + until false; + end; + result := false; +end; + +function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8; + aIndex: Integer): Boolean; +begin + if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then + result := false else + result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch)); +end; + +function TMemoryMapText.LineSize(aIndex: integer): integer; +begin + result := GetLineSize(fLines[aIndex],fMapEnd); +end; + +function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; +begin + if P<>nil then + while (P#10) and (P^<>#13) do + if aMinimalCount=0 then begin + result := false; + exit; + end else begin + dec(aMinimalCount); + inc(P); + end; + result := true; +end; + +function TMemoryMapText.LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean; +begin + result := GetLineSizeSmallerThan(fLines[aIndex],fMapEnd,aMinimalCount); +end; + +procedure TMemoryMapText.ProcessOneLine(LineBeg, LineEnd: PUTF8Char); +begin + if fCount=fLinesMax then begin + fLinesMax := NextGrow(fLinesMax); + ReallocMem(fLines,fLinesMax*SizeOf(pointer)); + end; + fLines[fCount] := LineBeg; + inc(fCount); +end; + +procedure TMemoryMapText.LoadFromMap(AverageLineLength: integer=32); + procedure ParseLines(P,PEnd: PUTF8Char); + var PBeg: PUTF8Char; + begin // generated asm is much better with a local proc + while P#13) and (P^<>#10) do + inc(P); + ProcessOneLine(PBeg,P); + if P+1>=PEnd then + break; + if P[0]=#13 then + if P[1]=#10 then + inc(P,2) else // ignore #13#10 + inc(P) else // ignore #13 + inc(P); // ignore #10 + end; + end; +var P: PUTF8Char; +begin + fLinesMax := fMap.fFileSize div AverageLineLength+8; + GetMem(fLines,fLinesMax*SizeOf(pointer)); + P := pointer(fMap.Buffer); + fMapEnd := P+fMap.Size; + if TextFileKind(Map)=isUTF8 then + inc(PByte(P),3); // ignore UTF-8 BOM + ParseLines(P,fMapEnd); + if fLinesMax>fCount+16384 then + Reallocmem(fLines,fCount*SizeOf(pointer)); // size down only if worth it +end; + +procedure TMemoryMapText.AddInMemoryLine(const aNewLine: RawUTF8); +var P: PUTF8Char; +begin + if aNewLine='' then + exit; + AddRawUTF8(fAppendedLines,fAppendedLinesCount,aNewLine); + P := pointer(fAppendedLines[fAppendedLinesCount-1]); + ProcessOneLine(P,P+StrLen(P)); +end; + +procedure TMemoryMapText.AddInMemoryLinesClear; +begin + dec(fCount,fAppendedLinesCount); + fAppendedLinesCount := 0; + fAppendedLines := nil; +end; + + +{ TRawByteStringStream } + +constructor TRawByteStringStream.Create(const aString: RawByteString); +begin + fDataString := aString; +end; + +function TRawByteStringStream.Read(var Buffer; Count: Integer): Longint; +begin + if Count<=0 then + Result := 0 else begin + Result := Length(fDataString)-fPosition; + if Result>Count then + Result := Count; + MoveFast(PByteArray(fDataString)[fPosition],Buffer,Result); + inc(fPosition, Result); + end; +end; + +function TRawByteStringStream.Seek(Offset: Integer; Origin: Word): Longint; +begin + case Origin of + soFromBeginning: fPosition := Offset; + soFromCurrent: fPosition := fPosition+Offset; + soFromEnd: fPosition := Length(fDataString)-Offset; + end; + if fPosition>Length(fDataString) then + fPosition := Length(fDataString) else + if fPosition<0 then + fPosition := 0; + result := fPosition; +end; + +procedure TRawByteStringStream.SetSize(NewSize: Integer); +begin + SetLength(fDataString, NewSize); + if fPosition>NewSize then + fPosition := NewSize; +end; + +function TRawByteStringStream.Write(const Buffer; Count: Integer): Longint; +begin + if Count<=0 then + Result := 0 else begin + Result := Count; + SetLength(fDataString,fPosition+Result); + MoveFast(Buffer,PByteArray(fDataString)[fPosition],Result); + inc(FPosition,Result); + end; +end; + + +{ TFakeWriterStream } + +function TFakeWriterStream.Read(var Buffer; Count: Longint): Longint; +begin // do nothing + result := Count; +end; + +function TFakeWriterStream.Write(const Buffer; Count: Longint): Longint; +begin // do nothing + result := Count; +end; + +function TFakeWriterStream.Seek(Offset: Longint; Origin: Word): Longint; +begin + result := Offset; +end; + + +{ TSynNameValue } + +procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt); +var added: boolean; + i: Integer; +begin + i := DynArray.FindHashedForAdding(aName,added); + with List[i] do begin + if added then + Name := aName; + Value := aValue; + Tag := aTag; + end; + if Assigned(fOnAdd) then + fOnAdd(List[i],i); +end; + +procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char; + OnTheFlyConvert: TOnSynNameValueConvertRawUTF8; OnAdd: TOnSynNameValueNotify); +var s: RawUTF8; + i: integer; +begin + Init(false); + fOnAdd := OnAdd; + while (Section<>nil) and (Section^<>'[') do begin + s := GetNextLine(Section,Section); + i := PosExChar('=',s); + if (i>1) and not(s[1] in [';','[']) then + if Assigned(OnTheFlyConvert) then + Add(copy(s,1,i-1),OnTheFlyConvert(copy(s,i+1,1000))) else + Add(copy(s,1,i-1),copy(s,i+1,1000)); + end; +end; + +procedure TSynNameValue.InitFromCSV(CSV: PUTF8Char; NameValueSep,ItemSep: AnsiChar); +var n,v: RawUTF8; +begin + Init(false); + while CSV<>nil do begin + GetNextItem(CSV,NameValueSep,n); + if ItemSep=#10 then + GetNextItemTrimedCRLF(CSV,v) else + GetNextItem(CSV,ItemSep,v); + if n='' then + break; + Add(n,v); + end; +end; + +procedure TSynNameValue.InitFromNamesValues(const Names, Values: array of RawUTF8); +var i: integer; +begin + Init(false); + if high(Names)<>high(Values) then + exit; + DynArray.SetCapacity(length(Names)); + for i := 0 to high(Names) do + Add(Names[i],Values[i]); +end; + +function TSynNameValue.InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean): boolean; +var N,V: PUTF8Char; + nam,val: RawUTF8; + Nlen, Vlen, c: integer; + EndOfObject: AnsiChar; +begin + result := false; + Init(aCaseSensitive); + if JSON=nil then + exit; + while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); + if JSON^<>'{' then + exit; + repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + c := JSONObjectPropCount(JSON); + if c<=0 then + exit; + DynArray.SetCapacity(c); + repeat + N := GetJSONPropName(JSON,@Nlen); + if N=nil then + exit; + V := GetJSONFieldOrObjectOrArray(JSON,nil,@EndOfObject,true,true,@Vlen); + if V=nil then + exit; + FastSetString(nam,N,Nlen); + FastSetString(val,V,Vlen); + Add(nam,val); + until EndOfObject='}'; + result := true; +end; + +procedure TSynNameValue.Init(aCaseSensitive: boolean); +begin + // release dynamic arrays memory before FillcharFast() + List := nil; + DynArray.fHash.Clear; + // initialize hashed storage + FillCharFast(self,SizeOf(self),0); + DynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List, + djRawUTF8,@Count,not aCaseSensitive); +end; + +function TSynNameValue.Find(const aName: RawUTF8): integer; +begin + result := DynArray.FindHashed(aName); +end; + +function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer; +begin + for result := 0 to Count-1 do + if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then + exit; + result := -1; +end; + +function TSynNameValue.FindByValue(const aValue: RawUTF8): integer; +begin + for result := 0 to Count-1 do + if List[result].Value=aValue then + exit; + result := -1; +end; + +function TSynNameValue.Delete(const aName: RawUTF8): boolean; +begin + result := DynArray.FindHashedAndDelete(aName)>=0; +end; + +function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer; +var ndx: integer; +begin + result := 0; + if Limit<1 then + exit; + for ndx := Count-1 downto 0 do + if List[ndx].Value=aValue then begin + DynArray.Delete(ndx); + inc(result); + if result>=Limit then + break; + end; + if result>0 then + DynArray.ReHash; +end; + +function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8; +var i: integer; +begin + if @self=nil then + i := -1 else + i := DynArray.FindHashed(aName); + if i<0 then + result := aDefaultValue else + result := List[i].Value; +end; + +function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64; +var i,err: integer; +begin + i := DynArray.FindHashed(aName); + if i<0 then + result := aDefaultValue else begin + result := {$ifdef CPU64}GetInteger{$else}GetInt64{$endif}(pointer(List[i].Value),err); + if err<>0 then + result := aDefaultValue; + end; +end; + +function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean; +begin + result := Value(aName)='1'; +end; + +function TSynNameValue.ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; + out aEnum; aEnumDefault: byte): boolean; +var v: RawUTF8; + err,i: integer; +begin + result := false; + byte(aEnum) := aEnumDefault; + v := trim(Value(aName,'')); + if v='' then + exit; + i := GetInteger(pointer(v),err); + if (err<>0) or (i<0) then + i := GetEnumNameValue(aEnumTypeInfo,v,true); + if i>=0 then begin + byte(aEnum) := i; + result := true; + end; +end; + +function TSynNameValue.Initialized: boolean; +begin + result := DynArray.Value=@List; +end; + +function TSynNameValue.GetBlobData: RawByteString; +begin + result := DynArray.SaveTo; +end; + +procedure TSynNameValue.SetBlobDataPtr(aValue: pointer); +begin + DynArray.LoadFrom(aValue); + DynArray.ReHash; +end; + +procedure TSynNameValue.SetBlobData(const aValue: RawByteString); +begin + DynArray.LoadFromBinary(aValue); + DynArray.ReHash; +end; + +function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8; +begin + result := Value(aName,''); +end; + +function TSynNameValue.GetInt(const aName: RawUTF8): Int64; +begin + result := ValueInt(aName,0); +end; + +function TSynNameValue.GetBool(const aName: RawUTF8): Boolean; +begin + result := Value(aName)='1'; +end; + +function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8; +var i: integer; + temp: TTextWriterStackBuffer; +begin + with TTextWriter.CreateOwnedStream(temp) do + try + for i := 0 to Count-1 do + if (IgnoreKey='') or (List[i].Name<>IgnoreKey) then begin + AddNoJSONEscapeUTF8(List[i].Name); + AddNoJSONEscapeUTF8(KeySeparator); + AddNoJSONEscapeUTF8(List[i].Value); + AddNoJSONEscapeUTF8(ValueSeparator); + end; + SetText(result); + finally + Free; + end; +end; + +function TSynNameValue.AsJSON: RawUTF8; +var i: integer; + temp: TTextWriterStackBuffer; +begin + with TTextWriter.CreateOwnedStream(temp) do + try + Add('{'); + for i := 0 to Count-1 do + with List[i] do begin + AddProp(pointer(Name),length(Name)); + Add('"'); + AddJSONEscape(pointer(Value)); + Add('"',','); + end; + CancelLastComma; + Add('}'); + SetText(result); + finally + Free; + end; +end; + +procedure TSynNameValue.AsNameValues(out Names,Values: TRawUTF8DynArray); +var i: integer; +begin + SetLength(Names,Count); + SetLength(Values,Count); + for i := 0 to Count-1 do begin + Names[i] := List[i].Name; + Values[i] := List[i].Value; + end; +end; + +{$ifndef NOVARIANTS} +function TSynNameValue.ValueVariantOrNull(const aName: RawUTF8): variant; +var i: integer; +begin + i := Find(aName); + if i<0 then + SetVariantNull(result) else + RawUTF8ToVariant(List[i].Value,result); +end; + +procedure TSynNameValue.AsDocVariant(out DocVariant: variant; + ExtendedJson,ValueAsString,AllowVarDouble: boolean); +var ndx: integer; +begin + if Count>0 then + with TDocVariantData(DocVariant) do begin + Init(JSON_OPTIONS_NAMEVALUE[ExtendedJson],dvObject); + VCount := self.Count; + SetLength(VName,VCount); + SetLength(VValue,VCount); + for ndx := 0 to VCount-1 do begin + VName[ndx] := List[ndx].Name; + if ValueAsString or not GetNumericVariantFromJSON(pointer(List[ndx].Value), + TVarData(VValue[ndx]),AllowVarDouble) then + RawUTF8ToVariant(List[ndx].Value,VValue[ndx]); + end; + end else + TVarData(DocVariant).VType := varNull; +end; + +function TSynNameValue.AsDocVariant(ExtendedJson,ValueAsString: boolean): variant; +begin + AsDocVariant(result,ExtendedJson,ValueAsString); +end; + +function TSynNameValue.MergeDocVariant(var DocVariant: variant; + ValueAsString: boolean; ChangedProps: PVariant; ExtendedJson,AllowVarDouble: Boolean): integer; +var DV: TDocVariantData absolute DocVariant; + i,ndx: integer; + v: variant; + intvalues: TRawUTF8Interning; +begin + if integer(DV.VType)<>DocVariantVType then + TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]); + if ChangedProps<>nil then + TDocVariant.New(ChangedProps^,DV.Options); + if dvoInternValues in DV.Options then + intvalues := DocVariantType.InternValues else + intvalues := nil; + result := 0; // returns number of changed values + for i := 0 to Count-1 do + if List[i].Name<>'' then begin + VarClear(v); + if ValueAsString or not GetNumericVariantFromJSON(pointer(List[i].Value), + TVarData(v),AllowVarDouble) then + RawUTF8ToVariant(List[i].Value,v); + ndx := DV.GetValueIndex(List[i].Name); + if ndx<0 then + ndx := DV.InternalAdd(List[i].Name) else + if SortDynArrayVariantComp(TVarData(v),TVarData(DV.Values[ndx]),false)=0 then + continue; // value not changed -> skip + if ChangedProps<>nil then + PDocVariantData(ChangedProps)^.AddValue(List[i].Name,v); + SetVariantByValue(v,DV.VValue[ndx]); + if intvalues<>nil then + intvalues.UniqueVariant(DV.VValue[ndx]); + inc(result); + end; +end; +{$endif NOVARIANTS} + + +{$ifdef MSWINDOWS} +function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP +{$endif} + +procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); +begin + SetThreadName(GetCurrentThreadId,Format,Args); +end; + +procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; + const Args: array of const); +var name: RawUTF8; +begin + FormatUTF8(Format,Args,name); + name := StringReplaceAll(name,['TSQLRest','', 'TSQL','', 'TWebSocket','WS', + 'TServiceFactory','SF', 'TSyn','', 'Thread','', 'Process','', + 'Background','Bgd', 'Server','Svr', 'Client','Clt', 'WebSocket','WS', + 'Timer','Tmr', 'Thread','Thd']); + SetThreadNameInternal(ThreadID,name); +end; + +procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); +{$ifndef FPC} +{$ifndef NOSETTHREADNAME} +var s: RawByteString; + {$ifndef ISDELPHIXE2} + {$ifdef MSWINDOWS} + info: record + FType: LongWord; // must be 0x1000 + FName: PAnsiChar; // pointer to name (in user address space) + FThreadID: LongWord; // thread ID (-1 indicates caller thread) + FFlags: LongWord; // reserved for future use, must be zero + end; + {$endif} + {$endif} +{$endif NOSETTHREADNAME} +{$endif FPC} +begin +{$ifdef FPC} + {$ifdef LINUX} + if ThreadID<>MainThreadID then // don't change the main process name + SetUnixThreadName(ThreadID, Name); // call pthread_setname_np() + {$endif} +{$else} +{$ifndef NOSETTHREADNAME} + {$ifdef MSWINDOWS} + if not IsDebuggerPresent then + exit; + {$endif MSWINDOWS} + s := CurrentAnsiConvert.UTF8ToAnsi(Name); + {$ifdef ISDELPHIXE2} + TThread.NameThreadForDebugging(s,ThreadID); + {$else} + {$ifdef MSWINDOWS} + info.FType := $1000; + info.FName := pointer(s); + info.FThreadID := ThreadID; + info.FFlags := 0; + try + RaiseException($406D1388,0,SizeOf(info) div SizeOf(LongWord),@info); + except {ignore} end; + {$endif MSWINDOWS} + {$endif ISDELPHIXE2} +{$endif NOSETTHREADNAME} +{$endif FPC} +end; + + +{ MultiEvent* functions } + +function MultiEventFind(const EventList; const Event: TMethod): integer; +var Events: TMethodDynArray absolute EventList; +begin + if Event.Code<>nil then // callback assigned + for result := 0 to length(Events)-1 do + if (Events[result].Code=Event.Code) and + (Events[result].Data=Event.Data) then + exit; + result := -1; +end; + +function MultiEventAdd(var EventList; const Event: TMethod): boolean; +var Events: TMethodDynArray absolute EventList; + n: integer; +begin + result := false; + n := MultiEventFind(EventList,Event); + if n>=0 then + exit; // already registered + result := true; + n := length(Events); + SetLength(Events,n+1); + Events[n] := Event; +end; + +procedure MultiEventRemove(var EventList; const Event: TMethod); +begin + MultiEventRemove(EventList,MultiEventFind(EventList,Event)); +end; + +procedure MultiEventRemove(var EventList; Index: Integer); +var Events: TMethodDynArray absolute EventList; + max: integer; +begin + max := length(Events); + if cardinal(index)nil) and (po^<>nil) then + FreeAndNil(po^); + except + on E: Exception do + ; // just ignore exceptions in client code destructors + end; + FreeAndNil(GarbageCollectorFreeAndNilList); +end; + +procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); +begin + TObject(InstanceVariable) := Instance; + GarbageCollectorFreeAndNilList.Add(@InstanceVariable); +end; + +var + GlobalCriticalSection: TRTLCriticalSection; + +procedure GlobalLock; +begin + EnterCriticalSection(GlobalCriticalSection); +end; + +procedure GlobalUnLock; +begin + LeaveCriticalSection(GlobalCriticalSection); +end; + +{$ifdef CPUINTEL} +function IsXmmYmmOSEnabled: boolean; assembler; {$ifdef FPC} nostackframe; assembler; {$endif} +asm // see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled + xor ecx, ecx // specify control register XCR0 = XFEATURE_ENABLED_MASK + db $0f, $01, $d0 // XGETBV reads XCR0 into EDX:EAX + and eax, 6 // check OS has enabled both XMM (bit 1) and YMM (bit 2) + cmp al, 6 + sete al +end; + +procedure TestIntelCpuFeatures; +var regs: TRegisters; + c: cardinal; +begin + // retrieve CPUID raw flags + regs.edx := 0; + regs.ecx := 0; + GetCPUID(1,regs); + PIntegerArray(@CpuFeatures)^[0] := regs.edx; + PIntegerArray(@CpuFeatures)^[1] := regs.ecx; + GetCPUID(7,regs); + PIntegerArray(@CpuFeatures)^[2] := regs.ebx; + PIntegerArray(@CpuFeatures)^[3] := regs.ecx; + PIntegerArray(@CpuFeatures)^[4] := regs.edx; + {$ifdef DISABLE_SSE42} // paranoid execution on Darwin x64 (as reported by alf) + CpuFeatures := CpuFeatures-[cfSSE42,cfAESNI]; + {$endif DISABLE_SSE42} + if not(cfOSXS in CpuFeatures) or not IsXmmYmmOSEnabled then + CpuFeatures := CpuFeatures-[cfAVX,cfAVX2,cfFMA]; + {$ifndef ABSOLUTEPASCAL} + {$ifdef CPUX64} + {$ifdef WITH_ERMS} + if cfERMS in CpuFeatures then // actually slower than our AVX code -> disabled + include(CPUIDX64,cpuERMS); + {$endif WITH_ERMS} + if cfAVX in CpuFeatures then begin + include(CPUIDX64,cpuAVX); + if cfAVX2 in CpuFeatures then + include(CPUIDX64,cpuAVX2); + end; + {$endif CPUX64} + {$endif ABSOLUTEPASCAL} + // validate accuracy of most used HW opcodes + if cfRAND in CpuFeatures then + try + c := RdRand32; + if RdRand32=c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000 + exclude(CpuFeatures,cfRAND); + except // may trigger an illegal instruction exception on some Ivy Bridge + exclude(CpuFeatures,cfRAND); + end; + if cfSSE42 in CpuFeatures then + try + if crc32cBy4SSE42(0,1)<>3712330424 then + raise ESynException.Create('Invalid crc32cBy4SSE42'); + except // disable now on illegal instruction or incorrect result + exclude(CpuFeatures,cfSSE42); + end; +end; +{$endif CPUINTEL} + +procedure InitFunctionsRedirection; +begin + {$ifdef CPUINTEL} + TestIntelCpuFeatures; + {$endif CPUINTEL} + {$ifndef MSWINDOWS} // now for RedirectCode (RetrieveSystemInfo is too late) + SystemInfo.dwPageSize := getpagesize; // use libc for this value + if SystemInfo.dwPageSize=0 then // should not be 0 + SystemInfo.dwPageSize := 4096; + {$endif MSWINDOWS} + {$ifdef PUREPASCAL} + {$ifndef HASINLINE} + PosEx := @PosExPas; + {$endif HASINLINE} + PosExString := @PosExStringPas; // fast pure pascal process + {$else not PUREPASCAL} + {$ifdef UNICODE} + PosExString := @PosExStringPas; // fast PWideChar process + {$else} + PosExString := @PosEx; // use optimized PAnsiChar i386 asm + {$endif UNICODE} + {$endif PUREPASCAL} + crc32c := @crc32cfast; // now to circumvent Internal Error C11715 for Delphi 5 + crc32cBy4 := @crc32cBy4fast; + {$ifndef CPUX64} + MoveFast := @System.Move; + {$endif CPUX64} + {$ifdef FPC} + {$ifdef CPUX64} + {$ifndef ABSOLUTEPASCAL} + if @System.FillChar<>@FillCharFast then begin + // force to use our optimized x86_64 asm versions + RedirectCode(@System.FillChar,@FillcharFast); + RedirectCode(@System.Move,@MoveFast); + {$ifdef DOPATCHTRTL} + PatchCode(@fpc_ansistr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f + PatchJmp(@fpc_ansistr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f + PatchJmp(@fpc_ansistr_assign,@_ansistr_assign,$3f); // fpclen=$3f + PatchCode(@fpc_ansistr_compare,@_ansistr_compare,$77); // fpclen=$12f + PatchCode(@fpc_ansistr_compare_equal,@_ansistr_compare_equal,$57); // =$cf + PatchCode(@fpc_unicodestr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f + PatchJmp(@fpc_unicodestr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f + PatchJmp(@fpc_unicodestr_assign,@_ansistr_assign,$3f); // fpclen=$3f + PatchCode(@fpc_dynarray_incr_ref,@_dynarray_incr_ref,$17); // fpclen=$2f + PatchJmp(@fpc_dynarray_clear,@_dynarray_decr_ref,$2f,PtrUInt(@_dynarray_decr_ref_free)); + RedirectCode(@fpc_dynarray_decr_ref,@fpc_dynarray_clear); + {$ifdef FPC_HAS_CPSTRING} + {$ifdef LINUX} + if (DefaultSystemCodePage=CP_UTF8) or (DefaultSystemCodePage=0) then begin + RedirectRtl(@_fpc_ansistr_concat,@_ansistr_concat_utf8); + RedirectRtl(@_fpc_ansistr_concat_multi,@_ansistr_concat_multi_utf8); + end; + {$endif LINUX} + {$ifdef FPC_X64MM} + RedirectCode(@fpc_ansistr_setlength,@_ansistr_setlength); + {$endif FPC_X64MM} + {$endif FPC_HAS_CPSTRING} + {$ifdef FPC_X64MM} + RedirectCode(@fpc_getmem,@_Getmem); + RedirectCode(@fpc_freemem,@_Freemem); + {$endif FPC_X64MM} + {$endif DOPATCHTRTL} + end; + {$endif ABSOLUTEPASCAL} + {$else} + FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL + {$endif CPUX64} + {$else Dephi: } + {$ifdef CPUARM} + FillCharFast := @System.FillChar; + {$else} + {$ifndef CPUX64} + Pointer(@FillCharFast) := SystemFillCharAddress; + {$endif CPUX64} + {$ifdef DELPHI5OROLDER} + StrLen := @StrLenX86; + MoveFast := @MoveX87; + FillcharFast := @FillCharX87; + {$else DELPHI5OROLDER} + {$ifdef CPU64} // x86_64 redirection + {$ifdef HASAESNI} + {$ifdef FORCE_STRSSE42} + if cfSSE42 in CpuFeatures then begin + StrLen := @StrLenSSE42; + StrComp := @StrCompSSE42; + end else + {$endif FORCE_STRSSE42} + {$endif HASAESNI} + StrLen := @StrLenSSE2; + {$else} // i386 redirection + {$ifdef CPUINTEL} + if cfSSE2 in CpuFeatures then begin + {$ifdef FORCE_STRSSE42} + if cfSSE42 in CpuFeatures then + StrLen := @StrLenSSE42 else + {$endif FORCE_STRSSE42} + StrLen := @StrLenSSE2; + FillcharFast := @FillCharSSE2; + end else begin + StrLen := @StrLenX86; + FillcharFast := @FillCharX87; + end; + {$ifdef WITH_ERMS} // disabled by default (much slower for small blocks) + if cfERMS in CpuFeatures then begin + MoveFast := @MoveERMSB; + FillcharFast := @FillCharERMSB; + end else {$endif} + MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32-bit CPU + {$endif CPUINTEL} + {$endif CPU64} + {$endif DELPHI5OROLDER} + {$ifndef USEPACKAGES} + // do redirection from RTL to our fastest version + {$ifdef DOPATCHTRTL} + if DebugHook=0 then begin // patch only outside debugging + RedirectCode(SystemFillCharAddress,@FillcharFast); + RedirectCode(@System.Move,@MoveFast); + {$ifdef CPUX86} + RedirectCode(SystemRecordCopyAddress,@RecordCopy); + RedirectCode(SystemFinalizeRecordAddress,@RecordClear); + RedirectCode(SystemInitializeRecordAddress,@_InitializeRecord); + {$ifndef UNICODE} // buggy Delphi 2009+ RTL expects a TMonitor.Destroy call + RedirectCode(@TObject.CleanupInstance,@TObjectCleanupInstance); + {$endif UNICODE} + {$endif} + end; + {$endif DOPATCHTRTL} + {$endif USEPACKAGES} + {$endif CPUARM} + {$endif FPC} + UpperCopy255Buf := @UpperCopy255BufPas; + DefaultHasher := @xxHash32; // faster than crc32cfast for small content + {$ifndef ABSOLUTEPASCAL} + {$ifdef CPUINTEL} + {$ifdef FPC} // StrLen was set above for Delphi + {$ifdef CPUX86} + if cfSSE2 in CpuFeatures then + {$endif CPUX86} + StrLen := @StrLenSSE2; + {$endif FPC} + if cfSSE42 in CpuFeatures then begin + crc32c := @crc32csse42; // seems safe on all targets + crc32cby4 := @crc32cby4sse42; + crcblock := @crcblockSSE42; + crcblocks := @crcblocksSSE42; + {$ifdef FORCE_STRSSE42} // disabled by default: may trigger random GPF + strspn := @strspnSSE42; + strcspn := @strcspnSSE42; + {$ifdef CPU64} + {$ifdef FPC} // done in InitRedirectCode for Delphi + {$ifdef HASAESNI} + StrLen := @StrLenSSE42; + StrComp := @StrCompSSE42; + {$endif HASAESNI} + {$endif FPC} + {$endif CPU64} + {$ifndef PUREPASCAL} + {$ifndef DELPHI5OROLDER} + UpperCopy255Buf := @UpperCopy255BufSSE42; + {$endif DELPHI5OROLDER} + {$endif PUREPASCAL} + {$ifndef PUREPASCAL} + StrComp := @StrCompSSE42; + DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42; + DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42; + {$ifndef UNICODE} + DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42; + {$endif} + DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42; + {$endif PUREPASCAL} + {$endif FORCE_STRSSE42} + DefaultHasher := crc32c; + end; + if cfPOPCNT in CpuFeatures then + GetBitsCountPtrInt := @GetBitsCountSSE42; + {$endif CPUINTEL} + {$endif ABSOLUTEPASCAL} + InterningHasher := DefaultHasher; +end; + +procedure InitSynCommonsConversionTables; +var i,n: integer; + v: byte; + c: AnsiChar; + crc: cardinal; + tmp: array[0..15] of AnsiChar; + P: PAnsiChar; +{$ifdef OWNNORMTOUPPER} + d: integer; +const n2u: array[138..255] of byte = + (83,139,140,141,90,143,144,145,146,147,148,149,150,151,152,153,83,155,140, + 157,90,89,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175, + 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,65,65,65, + 65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,79,79,79,79,215,79,85,85, + 85,85,89,222,223,65,65,65,65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79, + 79,79,79,79,247,79,85,85,85,85,89,222,89); +{$endif OWNNORMTOUPPER} +const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF'; + HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; +begin + JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE; + JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER; + NULL_STR_VAR := 'null'; + BOOL_UTF8[false] := 'false'; + BOOL_UTF8[true] := 'true'; + {$ifdef FPC} + {$ifdef ISFPC27} + {$ifndef MSWINDOWS} + GetACP := GetSystemCodePage; + {$endif MSWINDOWS} + SetMultiByteConversionCodePage(CP_UTF8); + SetMultiByteRTLFileSystemCodePage(CP_UTF8); + {$endif ISFPC27} + {$endif FPC} + {$ifdef KYLIX3} + // if default locale is set to *.UTF-8, which is the case in most modern + // linux default configuration, unicode decode will fail in SysUtils.CheckLocale + setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server + {$endif} +{$ifndef EXTENDEDTOSHORT_USESTR} + {$ifdef ISDELPHIXE} + SettingsUS := TFormatSettings.Create($0409); + {$else} + GetLocaleFormatSettings($0409,SettingsUS); + {$endif} + SettingsUS.DecimalSeparator := '.'; // value may have been overriden :( +{$endif} + for i := 0 to 255 do + NormToNormByte[i] := i; + NormToUpperAnsi7Byte := NormToNormByte; + for i := ord('a') to ord('z') do + dec(NormToUpperAnsi7Byte[i],32); + {$ifdef OWNNORMTOUPPER} + MoveFast(NormToUpperAnsi7,NormToUpper,138); + MoveFast(n2u,NormToUpperByte[138],SizeOf(n2u)); + for i := 0 to 255 do begin + d := NormToUpperByte[i]; + if d in [ord('A')..ord('Z')] then + inc(d,32); + NormToLowerByte[i] := d; + end; + {$endif OWNNORMTOUPPER} + FillcharFast(ConvertHexToBin[0],SizeOf(ConvertHexToBin),255); // all to 255 + v := 0; + for i := ord('0') to ord('9') do begin + ConvertHexToBin[i] := v; + inc(v); + end; + for i := ord('A') to ord('F') do begin + ConvertHexToBin[i] := v; + ConvertHexToBin[i+(ord('a')-ord('A'))] := v; + inc(v); + end; + for i := 0 to 255 do begin + TwoDigitsHex[i][1] := HexChars[i shr 4]; + TwoDigitsHex[i][2] := HexChars[i and $f]; + end; + for i := 0 to 255 do begin + TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4]; + TwoDigitsHexLower[i][2] := HexCharsLower[i and $f]; + end; + MoveFast(TwoDigitLookup[0], TwoDigitByteLookupW[0], SizeOf(TwoDigitLookup)); + for i := 0 to 199 do + dec(PByteArray(@TwoDigitByteLookupW)[i],ord('0')); // '0'..'9' -> 0..9 + FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1 + for i := 0 to high(b64enc) do + ConvertBase64ToBin[b64enc[i]] := i; + ConvertBase64ToBin['='] := -2; // special value for '=' + for i := 0 to high(b64urienc) do + ConvertBase64uriToBin[b64urienc[i]] := i; + for i := high(Baudot2Char) downto 0 do + if Baudot2Char[i]<#128 then + Char2Baudot[Baudot2Char[i]] := i; + for i := ord('a') to ord('z') do + Char2Baudot[AnsiChar(i-32)] := Char2Baudot[AnsiChar(i)]; // A-Z -> a-z + JSON_ESCAPE[0] := 1; // 1 for #0 end of input + for i := 1 to 31 do // 0 indicates no JSON escape needed + JSON_ESCAPE[i] := 2; // 2 should be escaped as \u00xx + JSON_ESCAPE[8] := ord('b'); // others contain the escaped character + JSON_ESCAPE[9] := ord('t'); + JSON_ESCAPE[10] := ord('n'); + JSON_ESCAPE[12] := ord('f'); + JSON_ESCAPE[13] := ord('r'); + JSON_ESCAPE[ord('\')] := ord('\'); + JSON_ESCAPE[ord('"')] := ord('"'); + include(JSON_CHARS[#0], jcEndOfJSONFieldOr0); + for c := low(c) to high(c) do begin + if not (c in [#0,#10,#13]) then + include(TEXT_CHARS[c], tcNot01013); + if c in [#10,#13] then + include(TEXT_CHARS[c], tc1013); + if c in ['0'..'9','a'..'z','A'..'Z'] then + include(TEXT_CHARS[c], tcWord); + if c in ['_','a'..'z','A'..'Z'] then + include(TEXT_CHARS[c], tcIdentifierFirstChar); + if c in ['_','0'..'9','a'..'z','A'..'Z'] then + include(TEXT_CHARS[c], tcIdentifier); + if c in ['_','-','.','0'..'9','a'..'z','A'..'Z'] then + // '~' is part of the RFC 3986 but should be escaped in practice + // see https://blog.synopse.info/?post/2020/08/11/The-RFC%2C-The-URI%2C-and-The-Tilde + include(TEXT_CHARS[c], tcURIUnreserved); + if c in [#1..#9,#11,#12,#14..' '] then + include(TEXT_CHARS[c], tcCtrlNotLF); + if c in [#1..' ',';'] then + include(TEXT_CHARS[c], tcCtrlNot0Comma); + if c in [',',']','}',':'] then begin + include(JSON_CHARS[c], jcEndOfJSONField); + include(JSON_CHARS[c], jcEndOfJSONFieldOr0); + end; + if c in [#0,#9,#10,#13,' ',',','}',']'] then + include(JSON_CHARS[c], jcEndOfJSONValueField); + if c in ['-','0'..'9'] then + include(JSON_CHARS[c], jcDigitFirstChar); + if c in ['-','+','0'..'9'] then + include(JSON_CHARS[c], jcDigitChar); + if c in ['-','+','0'..'9','.','E','e'] then + include(JSON_CHARS[c], jcDigitFloatChar); + if c in ['_','0'..'9','a'..'z','A'..'Z','$'] then + include(JSON_CHARS[c], jcJsonIdentifierFirstChar); + if c in ['_','0'..'9','a'..'z','A'..'Z','.','[',']'] then + include(JSON_CHARS[c], jcJsonIdentifier); + end; + TSynAnsiConvert.Engine(0); // define CurrentAnsi/WinAnsi/UTF8AnsiConvert + for i := 0 to 255 do begin + crc := i; + for n := 1 to 8 do + if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32() + crc := (crc shr 1) xor $82f63b78 else + crc := crc shr 1; + crc32ctab[0,i] := crc; // for crc32cfast() and SymmetricEncrypt/FillRandom + end; + for i := 0 to 255 do begin + crc := crc32ctab[0,i]; + for n := 1 to high(crc32ctab) do begin + crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)]; + crc32ctab[n,i] := crc; + end; + end; + for i := 0 to high(SmallUInt32UTF8) do begin + P := StrUInt32(@tmp[15],i); + FastSetString(SmallUInt32UTF8[i],P,@tmp[15]-P); + end; + KINDTYPE_INFO[djRawUTF8] := TypeInfo(RawUTF8); // for TDynArray.LoadKnownType + KINDTYPE_INFO[djWinAnsi] := TypeInfo(WinAnsiString); + KINDTYPE_INFO[djString] := TypeInfo(String); + KINDTYPE_INFO[djRawByteString] := TypeInfo(RawByteString); + KINDTYPE_INFO[djWideString] := TypeInfo(WideString); + KINDTYPE_INFO[djSynUnicode] := TypeInfo(SynUnicode); + {$ifndef NOVARIANTS}KINDTYPE_INFO[djVariant] := TypeInfo(variant);{$endif} +end; + +initialization + // initialization of internal dynamic functions and tables + InitFunctionsRedirection; + InitializeCriticalSection(GlobalCriticalSection); + GarbageCollectorFreeAndNilList := TSynList.Create; + GarbageCollectorFreeAndNil(GarbageCollector,TSynObjectList.Create); + InitSynCommonsConversionTables; + RetrieveSystemInfo; + SetExecutableVersion(0,0,0,0); + AlgoSynLZ := TAlgoSynLZ.Create; + GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType, + TSynDictionary.Create(TypeInfo(TRawUTF8DynArray), + TypeInfo(TJSONSerializerFromTextSimpleDynArray),true)); + TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( + {$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif},'TGUID'); + TTextWriter.RegisterCustomJSONSerializerFromText([ + TypeInfo(TFindFilesDynArray), + 'Name:string Attr:Integer Size:Int64 Timestamp:TDateTime']); + // some paranoid cross-platform/cross-compiler assertions + {$ifndef NOVARIANTS} + Assert(SizeOf(TVarData)={$ifdef CPU64}24{$else}16{$endif}); // for ExchgVariant + Assert(SizeOf(TDocVariantData)=SizeOf(TVarData)); + DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant)); + DocVariantVType := DocVariantType.VarType; + {$endif NOVARIANTS} + {$ifndef FPC}{$warnings OFF}{$endif} + Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256)); + {$ifndef FPC}{$warnings ON}{$endif} + Assert(SizeOf(THash128Rec)=SizeOf(THash128)); + Assert(SizeOf(THash256Rec)=SizeOf(THash256)); + Assert(SizeOf(TBlock128)=SizeOf(THash128)); + assert(SizeOf(TSynSystemTime)=SizeOf(TSystemTime)); + assert(SizeOf(TSynSystemTime)=SizeOf(THash128)); + Assert(SizeOf(TOperatingSystemVersion)=SizeOf(integer)); + Assert(SizeOf(TSynLocker)>=128,'cpucacheline'); + Assert(SizeOf(TJsonChar)=1); + Assert(SizeOf(TTextChar)=1); + {$ifdef MSWINDOWS} + {$ifndef CPU64} + Assert(SizeOf(TFileTime)=SizeOf(Int64)); // see e.g. FileTimeToInt64 + {$endif CPU64} + {$endif MSWINDOWS} + +finalization + {$ifndef NOVARIANTS} + DocVariantType.Free; + {$endif NOVARIANTS} + GarbageCollectorFree; + DeleteCriticalSection(GlobalCriticalSection); + //writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln; +end. diff --git a/mORMot/SynCrtSock.pas b/mORMot/SynCrtSock.pas new file mode 100644 index 00000000..e33480ce --- /dev/null +++ b/mORMot/SynCrtSock.pas @@ -0,0 +1,13159 @@ +/// classes implementing TCP/UDP/HTTP client and server protocol +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynCrtSock; + +{ + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Alfred Glaenzer (alf) + - Cybexr + - Darian Miller + - EMartin + - Eric Grange + - Eugene Ilyin + - EvaF + - f-vicente + - macc2010 + - Maciej Izak (hnb) + - Marius Maximus + - Mr Yang (ysair) + - Pavel Mashlyakovskii (mpv) + - Willo vd Merwe + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + +} + +{$I Synopse.inc} // define HASINLINE ONLYUSEHTTPSOCKET USELIBCURL SYNCRTDEBUGLOW + +{.$define SYNCRTDEBUGLOW} +// internal use: enable some low-level log messages for HTTP socket debugging + +interface + +uses + SysUtils, // put first to use SynFPCLinux/SynKylix GetTickCount64 +{$ifndef LVCL} + Contnrs, + SyncObjs, // for TEvent (in Classes.pas for LVCL) +{$endif LVCL} +{$ifdef SYNCRTDEBUGLOW} + SynCommons, + SynLog, +{$endif SYNCRTDEBUGLOW} +{$ifdef USELIBCURL} + SynCurl, +{$endif USELIBCURL} +{$ifdef FPC} + dynlibs, +{$endif FPC} +{$ifdef MSWINDOWS} + Windows, + SynWinSock, + {$ifdef USEWININET} + WinInet, + {$endif USEWININET} + {$ifndef DELPHI5OROLDER} + Types, + {$endif DELPHI5OROLDER} +{$else MSWINDOWS} + {$undef USEWININET} + {$ifdef FPC} + SynFPCSock, + SynFPCLinux, + BaseUnix, // for fpgetrlimit/fpsetrlimit + {$ifdef LINUXNOTBSD} + Linux, + {$endif LINUXNOTBSD} + {$else} + {$ifndef DELPHI5OROLDER} + Types, + {$endif DELPHI5OROLDER} + {$endif FPC} + {$ifdef KYLIX3} + KernelIoctl, // for IoctlSocket/ioctl FION* constants + LibC, + SynFPCSock, // shared with Kylix + SynKylix, + {$endif KYLIX3} +{$endif MSWINDOWS} + Classes; + +const + /// the full text of the current Synopse mORMot framework version + // - match the value defined in SynCommons.pas and SynopseCommit.inc + // - we don't supply full version number with build revision, to reduce + // potential attack surface + XPOWEREDPROGRAM = 'mORMot 1.18'; + + /// the running Operating System + XPOWEREDOS = {$ifdef MSWINDOWS} 'Windows' {$else} + {$ifdef LINUXNOTBSD} 'Linux' {$else} 'Posix' {$endif LINUXNOTBSD} + {$endif MSWINDOWS}; + + /// internal HTTP content-type for efficient static file sending + // - detected e.g. by http.sys' THttpApiServer.Request or via the NGINX + // X-Accel-Redirect header's THttpServer.Process (see + // THttpServer.NginxSendFileFrom) for direct sending with no local bufferring + // - the OutCustomHeader should contain the proper 'Content-type: ....' + // corresponding to the file (e.g. by calling GetMimeContentType() function + // from SynCommons supplyings the file name) + // - should match HTML_CONTENT_STATICFILE constant defined in mORMot.pas unit + HTTP_RESP_STATICFILE = '!STATICFILE'; + + /// used to notify e.g. the THttpServerRequest not to wait for any response + // from the client + // - is not to be used in normal HTTP process, but may be used e.g. by + // TWebSocketProtocolRest.ProcessFrame() to avoid to wait for an incoming + // response from the other endpoint + // - should match NORESPONSE_CONTENT_TYPE constant defined in mORMot.pas unit + HTTP_RESP_NORESPONSE = '!NORESPONSE'; + +var + /// THttpRequest timeout default value for DNS resolution + // - leaving to 0 will let system default value be used + HTTP_DEFAULT_RESOLVETIMEOUT: integer = 0; + /// THttpRequest timeout default value for remote connection + // - default is 60 seconds + // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric + HTTP_DEFAULT_CONNECTTIMEOUT: integer = 60000; + /// THttpRequest timeout default value for data sending + // - default is 30 seconds + // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric + // - you can override this value by setting the corresponding parameter in + // THttpRequest.Create() constructor + HTTP_DEFAULT_SENDTIMEOUT: integer = 30000; + /// THttpRequest timeout default value for data receiving + // - default is 30 seconds + // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric + // - you can override this value by setting the corresponding parameter in + // THttpRequest.Create() constructor + HTTP_DEFAULT_RECEIVETIMEOUT: integer = 30000; + +type + {$ifdef HASCODEPAGE} // FPC may expect a CP, e.g. to compare two string constants + SockString = type RawByteString; + {$else} + /// define a 8-bit raw storage string type, used for data buffer management + SockString = type AnsiString; + {$endif} + + /// points to a 8-bit raw storage variable, used for data buffer management + PSockString = ^SockString; + + /// defines a dynamic array of SockString + TSockStringDynArray = array of SockString; + + {$ifdef HASVARUSTRING} + SockUnicode = UnicodeString; + {$else} + /// define the fastest 16-bit Unicode string type of the compiler + SockUnicode = WideString; + {$endif} + +{$ifdef DELPHI5OROLDER} + // not defined in Delphi 5 or older + PPointer = ^Pointer; + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + UTF8String = AnsiString; + UTF8Encode = AnsiString; +{$endif} + +{$ifndef FPC} + /// FPC 64-bit compatibility integer type + {$ifdef CPU64} + PtrInt = NativeInt; + PtrUInt = NativeUInt; + {$else} + PtrInt = integer; + PtrUInt = cardinal; + {$endif} + PPtrInt = ^PtrInt; + PPtrUInt = ^PtrUInt; +{$endif FPC} + + {$M+} + /// exception thrown by the classes of this unit + ECrtSocket = class(Exception) + protected + fLastError: integer; + public + /// will concat the message with the WSAGetLastError information + constructor Create(const Msg: string); overload; + /// will concat the message with the supplied WSAGetLastError information + constructor Create(const Msg: string; Error: integer); overload; + /// will concat the message with the supplied WSAGetLastError information + constructor CreateFmt(const Msg: string; const Args: array of const; Error: integer); overload; + published + /// the associated WSAGetLastError value + property LastError: integer read fLastError; + end; + {$M-} + + TCrtSocketClass = class of TCrtSocket; + + /// the available available network transport layer + // - either TCP/IP, UDP/IP or Unix sockets + TCrtSocketLayer = (cslTCP, cslUDP, cslUNIX); + + /// identify the incoming data availability in TCrtSocket.SockReceivePending + TCrtSocketPending = (cspSocketError, cspNoData, cspDataAvailable); + + PTextFile = ^TextFile; + + {$M+} + /// Fast low-level Socket implementation + // - direct access to the OS (Windows, Linux) network layer API + // - use Open constructor to create a client to be connected to a server + // - use Bind constructor to initialize a server + // - use SockIn and SockOut (after CreateSock*) to read/readln or write/writeln + // as with standard Delphi text files (see SendEmail implementation) + // - even if you do not use read(SockIn^), you may call CreateSockIn then + // read the (binary) content via SockInRead/SockInPending methods, which would + // benefit of the SockIn^ input buffer to maximize reading speed + // - to write data, CreateSockOut and write(SockOut^) is not mandatory: you + // rather may use SockSend() overloaded methods, followed by a SockFlush call + // - in fact, you can decide whatever to use none, one or both SockIn/SockOut + // - since this class rely on its internal optimized buffering system, + // TCP_NODELAY is set to disable the Nagle algorithm + // - our classes are (much) faster than the Indy or Synapse implementation + TCrtSocket = class + protected + fSock: TSocket; + fServer: SockString; + fPort: SockString; + fSockIn: PTextFile; + fSockOut: PTextFile; + fTimeOut: PtrInt; + fBytesIn: Int64; + fBytesOut: Int64; + fSocketLayer: TCrtSocketLayer; + fSockInEofError: integer; + fTLS, fWasBind: boolean; + // updated by every SockSend() call + fSndBuf: SockString; + fSndBufLen: integer; + // set by AcceptRequest() from TVarSin + fRemoteIP: SockString; + // updated during UDP connection, accessed via PeerAddress/PeerPort + fPeerAddr: TSockAddr; + {$ifdef MSWINDOWS} + fSecure: TSChannelClient; + {$endif MSWINDOWS} + procedure SetInt32OptionByIndex(OptName, OptVal: integer); virtual; + public + /// common initialization of all constructors + // - do not call directly, but use Open / Bind constructors instead + constructor Create(aTimeOut: PtrInt=10000); reintroduce; virtual; + /// connect to aServer:aPort + // - you may ask for a TLS secured client connection (only available under + // Windows by now, using the SChannel API) + constructor Open(const aServer, aPort: SockString; aLayer: TCrtSocketLayer=cslTCP; + aTimeOut: cardinal=10000; aTLS: boolean=false); + /// bind to an address + // - aAddr='1234' - bind to a port on all interfaces, the same as '0.0.0.0:1234' + // - aAddr='IP:port' - bind to specified interface only, e.g. '1.2.3.4:1234' + // - aAddr='unix:/path/to/file' - bind to unix domain socket, e.g. 'unix:/run/mormot.sock' + // - aAddr='' - bind to systemd descriptor on linux. See + // http://0pointer.de/blog/projects/socket-activation.html + constructor Bind(const aAddr: SockString; aLayer: TCrtSocketLayer=cslTCP; + aTimeOut: integer=10000); + /// low-level internal method called by Open() and Bind() constructors + // - raise an ECrtSocket exception on error + // - you may ask for a TLS secured client connection (only available under + // Windows by now, using the SChannel API) + procedure OpenBind(const aServer, aPort: SockString; doBind: boolean; + aSock: integer=-1; aLayer: TCrtSocketLayer=cslTCP; aTLS: boolean=false); + /// initialize the instance with the supplied accepted socket + // - is called from a bound TCP Server, just after Accept() + procedure AcceptRequest(aClientSock: TSocket; aClientSin: PVarSin); + /// initialize SockIn for receiving with read[ln](SockIn^,...) + // - data is buffered, filled as the data is available + // - read(char) or readln() is indeed very fast + // - multithread applications would also use this SockIn pseudo-text file + // - by default, expect CR+LF as line feed (i.e. the HTTP way) + procedure CreateSockIn(LineBreak: TTextLineBreakStyle=tlbsCRLF; + InputBufferSize: Integer=1024); + /// initialize SockOut for sending with write[ln](SockOut^,....) + // - data is sent (flushed) after each writeln() - it's a compiler feature + // - use rather SockSend() + SockSendFlush to send headers at once e.g. + // since writeln(SockOut^,..) flush buffer each time + procedure CreateSockOut(OutputBufferSize: Integer=1024); + /// finalize SockIn receiving buffer + // - you may call this method when you are sure that you don't need the + // input buffering feature on this connection any more (e.g. after having + // parsed the HTTP header, then rely on direct socket comunication) + procedure CloseSockIn; + /// finalize SockOut receiving buffer + // - you may call this method when you are sure that you don't need the + // output buffering feature on this connection any more (e.g. after having + // parsed the HTTP header, then rely on direct socket comunication) + procedure CloseSockOut; + /// close and shutdown the connection (called from Destroy) + procedure Close; + /// close the opened socket, and corresponding SockIn/SockOut + destructor Destroy; override; + /// read Length bytes from SockIn buffer + Sock if necessary + // - if SockIn is available, it first gets data from SockIn^.Buffer, + // then directly receive data from socket if UseOnlySockIn=false + // - if UseOnlySockIn=true, it will return the data available in SockIn^, + // and returns the number of bytes + // - can be used also without SockIn: it will call directly SockRecv() + // in such case (assuming UseOnlySockin=false) + function SockInRead(Content: PAnsiChar; Length: integer; + UseOnlySockIn: boolean=false): integer; + /// returns the number of bytes in SockIn buffer or pending in Sock + // - if SockIn is available, it first check from any data in SockIn^.Buffer, + // then call InputSock to try to receive any pending data if the buffer is void + // - if aPendingAlsoInSocket is TRUE, returns the bytes available in both the buffer + // and the socket (sometimes needed, e.g. to process a whole block at once) + // - will wait up to the specified aTimeOutMS value (in milliseconds) for + // incoming data - may wait a little less time on Windows due to a select bug + // - returns -1 in case of a socket error (e.g. broken/closed connection); + // you can raise a ECrtSocket exception to propagate the error + function SockInPending(aTimeOutMS: integer; aPendingAlsoInSocket: boolean=false): integer; + /// check the connection status of the socket + function SockConnected: boolean; + /// simulate writeln() with direct use of Send(Sock, ..) - includes trailing #13#10 + // - useful on multi-treaded environnement (as in THttpServer.Process) + // - no temp buffer is used + // - handle SockString, ShortString, Char, Integer parameters + // - raise ECrtSocket exception on socket error + procedure SockSend(const Values: array of const); overload; + /// simulate writeln() with a single line - includes trailing #13#10 + procedure SockSend(const Line: SockString=''); overload; + /// append P^ data into SndBuf (used by SockSend(), e.g.) - no trailing #13#10 + // - call SockSendFlush to send it through the network via SndLow() + procedure SockSend(P: pointer; Len: integer); overload; + /// flush all pending data to be sent, optionally with some body content + // - raise ECrtSocket on error + procedure SockSendFlush(const aBody: SockString=''); virtual; + /// flush all pending data to be sent + // - returning true on success + function TrySockSendFlush: boolean; + /// how many bytes could be added by SockSend() in the internal buffer + function SockSendRemainingSize: integer; + /// fill the Buffer with Length bytes + // - use TimeOut milliseconds wait for incoming data + // - bypass the SockIn^ buffers + // - raise ECrtSocket exception on socket error + procedure SockRecv(Buffer: pointer; Length: integer); + /// check if there are some pending bytes in the input sockets API buffer + // - returns cspSocketError if the connection is broken or closed + // - warning: on Windows, may wait a little less than TimeOutMS (select bug) + function SockReceivePending(TimeOutMS: integer): TCrtSocketPending; + /// returns the socket input stream as a string + function SockReceiveString: SockString; + /// fill the Buffer with Length bytes + // - use TimeOut milliseconds wait for incoming data + // - bypass the SockIn^ buffers + // - return false on any fatal socket error, true on success + // - call Close if the socket is identified as shutdown from the other side + // - you may optionally set StopBeforeLength=true, then the read bytes count + // are set in Length, even if not all expected data has been received - in + // this case, Close method won't be called + function TrySockRecv(Buffer: pointer; var Length: integer; StopBeforeLength: boolean=false): boolean; + /// call readln(SockIn^,Line) or simulate it with direct use of Recv(Sock, ..) + // - char are read one by one if needed + // - use TimeOut milliseconds wait for incoming data + // - raise ECrtSocket exception on socket error + // - by default, will handle #10 or #13#10 as line delimiter (as normal text + // files), but you can delimit lines using #13 if CROnly is TRUE + procedure SockRecvLn(out Line: SockString; CROnly: boolean=false); overload; + /// call readln(SockIn^) or simulate it with direct use of Recv(Sock, ..) + // - char are read one by one + // - use TimeOut milliseconds wait for incoming data + // - raise ECrtSocket exception on socket error + // - line content is ignored + procedure SockRecvLn; overload; + /// direct send data through network + // - raise a ECrtSocket exception on any error + // - bypass the SockSend() or SockOut^ buffers + procedure SndLow(P: pointer; Len: integer); + /// direct send data through network + // - return false on any error, true on success + // - bypass the SndBuf or SockOut^ buffers + function TrySndLow(P: pointer; Len: integer): boolean; + /// returns the low-level error number + // - i.e. returns WSAGetLastError + function LastLowSocketError: Integer; + /// direct send data through network + // - raise a ECrtSocket exception on any error + // - bypass the SndBuf or SockOut^ buffers + // - raw Data is sent directly to OS: no LF/CRLF is appened to the block + procedure Write(const Data: SockString); + /// direct accept an new incoming connection on a bound socket + // - instance should have been setup as a server via a previous Bind() call + // - returns nil on error or a ResultClass instance on success + // - if ResultClass is nil, will return a plain TCrtSocket, but you may + // specify e.g. THttpServerSocket if you expect incoming HTTP requests + function AcceptIncoming(ResultClass: TCrtSocketClass=nil): TCrtSocket; + /// remote IP address after AcceptRequest() call over TCP + // - is either the raw connection IP to the current server socket, or + // a custom header value set by a local proxy as retrieved by inherited + // THttpServerSocket.GetRequest, searching the header named in + // THttpServerGeneric.RemoteIPHeader (e.g. 'X-Real-IP' for nginx) + property RemoteIP: SockString read fRemoteIP write fRemoteIP; + /// remote IP address of the last packet received (SocketLayer=slUDP only) + function PeerAddress: SockString; + /// remote IP port of the last packet received (SocketLayer=slUDP only) + function PeerPort: integer; + /// set the TCP_NODELAY option for the connection + // - default 1 (true) will disable the Nagle buffering algorithm; it should + // only be set for applications that send frequent small bursts of information + // without getting an immediate response, where timely delivery of data + // is required - so it expects buffering before calling Write() or SndLow() + // - you can set 0 (false) here to enable the Nagle algorithm, if needed + // - see http://www.unixguide.net/network/socketfaq/2.16.shtml + property TCPNoDelay: Integer index TCP_NODELAY write SetInt32OptionByIndex; + /// set the SO_SNDTIMEO option for the connection + // - i.e. the timeout, in milliseconds, for blocking send calls + // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ms740476 + property SendTimeout: Integer index SO_SNDTIMEO write SetInt32OptionByIndex; + /// set the SO_RCVTIMEO option for the connection + // - i.e. the timeout, in milliseconds, for blocking receive calls + // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ms740476 + property ReceiveTimeout: Integer index SO_RCVTIMEO write SetInt32OptionByIndex; + /// set the SO_KEEPALIVE option for the connection + // - 1 (true) will enable keep-alive packets for the connection + // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ee470551 + property KeepAlive: Integer index SO_KEEPALIVE write SetInt32OptionByIndex; + /// set the SO_LINGER option for the connection, to control its shutdown + // - by default (or Linger<0), Close will return immediately to the caller, + // and any pending data will be delivered if possible + // - Linger > 0 represents the time in seconds for the timeout period + // to be applied at Close; under Linux, will also set SO_REUSEADDR; under + // Darwin, set SO_NOSIGPIPE + // - Linger = 0 causes the connection to be aborted and any pending data + // is immediately discarded at Close + property Linger: Integer index SO_LINGER write SetInt32OptionByIndex; + /// after CreateSockIn, use Readln(SockIn^,s) to read a line from the opened socket + property SockIn: PTextFile read fSockIn; + /// after CreateSockOut, use Writeln(SockOut^,s) to send a line to the opened socket + property SockOut: PTextFile read fSockOut; + published + /// low-level socket handle, initialized after Open() with socket + property Sock: TSocket read fSock write fSock; + /// low-level socket type, initialized after Open() with socket + property SocketLayer: TCrtSocketLayer read fSocketLayer; + /// IP address, initialized after Open() with Server name + property Server: SockString read fServer; + /// IP port, initialized after Open() with port number + property Port: SockString read fPort; + /// if higher than 0, read loop will wait for incoming data till + // TimeOut milliseconds (default value is 10000) - used also in SockSend() + property TimeOut: PtrInt read fTimeOut; + /// total bytes received + property BytesIn: Int64 read fBytesIn; + /// total bytes sent + property BytesOut: Int64 read fBytesOut; + end; + {$M-} + + /// event used to compress or uncompress some data during HTTP protocol + // - should always return the protocol name for ACCEPT-ENCODING: header + // e.g. 'gzip' or 'deflate' for standard HTTP format, but you can add + // your own (like 'synlzo' or 'synlz') + // - the data is compressed (if Compress=TRUE) or uncompressed (if + // Compress=FALSE) in the Data variable (i.e. it is modified in-place) + // - to be used with THttpSocket.RegisterCompress method + // - DataRawByteStringtype should be a generic AnsiString/RawByteString, which + // should be in practice a SockString or a RawByteString + THttpSocketCompress = function(var DataRawByteString; Compress: boolean): AnsiString; + + /// used to maintain a list of known compression algorithms + THttpSocketCompressRec = record + /// the compression name, as in ACCEPT-ENCODING: header (gzip,deflate,synlz) + Name: SockString; + /// the function handling compression and decompression + Func: THttpSocketCompress; + /// the size in bytes after which compress will take place + // - will be 1024 e.g. for 'zip' or 'deflate' + // - could be 0 e.g. when encrypting the content, meaning "always compress" + CompressMinSize: integer; + end; + + /// list of known compression algorithms + THttpSocketCompressRecDynArray = array of THttpSocketCompressRec; + + /// identify some items in a list of known compression algorithms + // - filled from ACCEPT-ENCODING: header value + THttpSocketCompressSet = set of 0..31; + + /// parent of THttpClientSocket and THttpServerSocket classes + // - contain properties for implementing HTTP/1.1 using the Socket API + // - handle chunking of body content + // - can optionaly compress and uncompress on the fly the data, with + // standard gzip/deflate or custom (synlzo/synlz) protocols + THttpSocket = class(TCrtSocket) + protected + /// used by RegisterCompress method + fCompress: THttpSocketCompressRecDynArray; + /// set by RegisterCompress method + fCompressAcceptEncoding: SockString; + /// GetHeader set index of protocol in fCompress[], from ACCEPT-ENCODING: + fCompressAcceptHeader: THttpSocketCompressSet; + /// same as HeaderGetValue('CONTENT-ENCODING'), but retrieved during Request + // and mapped into the fCompress[] array + fContentCompress: integer; + /// to call GetBody only once + fBodyRetrieved: boolean; + /// compress the data, adding corresponding headers via SockSend() + // - always add a 'Content-Length: ' header entry (even if length=0) + // - e.g. 'Content-Encoding: synlz' header if compressed using synlz + // - and if Data is not '', will add 'Content-Type: ' header + procedure CompressDataAndWriteHeaders(const OutContentType: SockString; + var OutContent: SockString; OutContentLength: PtrInt = -1); + public + /// TCP/IP prefix to mask HTTP protocol + // - if not set, will create full HTTP/1.0 or HTTP/1.1 compliant content + // - in order to make the TCP/IP stream not HTTP compliant, you can specify + // a prefix which will be put before the first header line: in this case, + // the TCP/IP stream won't be recognized as HTTP, and will be ignored by + // most AntiVirus programs, and increase security - but you won't be able + // to use an Internet Browser nor AJAX application for remote access any more + TCPPrefix: SockString; + /// will contain the first header line: + // - 'GET /path HTTP/1.1' for a GET request with THttpServer, e.g. + // - 'HTTP/1.0 200 OK' for a GET response after Get() e.g. + Command: SockString; + /// will contain all header lines after a Request + // - use HeaderGetValue() to get one HTTP header item value by name + Headers: SockString; + /// will contain the data retrieved from the server, after the Request + Content: SockString; + /// same as HeaderGetValue('CONTENT-LENGTH'), but retrieved during Request + // - is overridden with real Content length during HTTP body retrieval + ContentLength: integer; + /// same as HeaderGetValue('SERVER-INTERNALSTATE'), but retrieved during Request + // - proprietary header, used with our RESTful ORM access + ServerInternalState: integer; + /// same as HeaderGetValue('CONTENT-TYPE'), but retrieved during Request + ContentType: SockString; + /// same as HeaderGetValue('UPGRADE'), but retrieved during Request + Upgrade: SockString; + /// same as HeaderGetValue('X-POWERED-BY'), but retrieved during Request + XPoweredBy: SockString; + /// map the presence of some HTTP headers, but retrieved during Request + HeaderFlags: set of(transferChuked, + connectionClose, connectionUpgrade, connectionKeepAlive, hasRemoteIP); + /// retrieve the HTTP headers into Headers[] and fill most properties below + // - only relevant headers are retrieved, unless HeadersUnFiltered is set + procedure GetHeader(HeadersUnFiltered: boolean=false); + /// retrieve the HTTP body (after uncompression if necessary) into Content + procedure GetBody; + /// add an header 'name: value' entry + procedure HeaderAdd(const aValue: SockString); + /// set all Header values at once, from CRLF delimited text + procedure HeaderSetText(const aText: SockString; + const aForcedContentType: SockString=''); + /// get all Header values at once, as CRLF delimited text + // - you can optionally specify a value to be added as 'RemoteIP: ' header + function HeaderGetText(const aRemoteIP: SockString=''): SockString; + /// HeaderGetValue('CONTENT-TYPE')='text/html', e.g. + // - supplied aUpperName should be already uppercased + function HeaderGetValue(const aUpperName: SockString): SockString; + /// will register a compression algorithm + // - used e.g. to compress on the fly the data, with standard gzip/deflate + // or custom (synlzo/synlz) protocols + // - returns true on success, false if this function or this + // ACCEPT-ENCODING: header was already registered + // - you can specify a minimal size (in bytes) before which the content won't + // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) + // - the first registered algorithm will be the prefered one for compression + function RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024): boolean; + end; + + THttpServer = class; + + /// results of THttpServerSocket.GetRequest virtual method + // - return grError if the socket was not connected any more, or grException + // if any exception occured during the process + // - grOversizedPayload is returned when MaximumAllowedContentLength is reached + // - grRejected is returned when OnBeforeBody returned not 200 + // - grTimeout is returned when HeaderRetrieveAbortDelay is reached + // - grHeaderReceived is returned for GetRequest({withbody=}false) + // - grBodyReceived is returned for GetRequest({withbody=}true) + // - grOwned indicates that this connection is now handled by another thread, + // e.g. asynchronous WebSockets + THttpServerSocketGetRequestResult = ( + grError, grException, grOversizedPayload, grRejected, grTimeout, + grHeaderReceived, grBodyReceived, grOwned); + + /// a genuine identifier for a given client connection on server side + // - maps http.sys ID, or is a genuine 31-bit value from increasing sequence + THttpServerConnectionID = Int64; + + /// a dynamic array of client connection identifiers, e.g. for broadcasting + THttpServerConnectionIDDynArray = array of THttpServerConnectionID; + + /// Socket API based HTTP/1.1 server class used by THttpServer Threads + THttpServerSocket = class(THttpSocket) + protected + fMethod: SockString; + fURL: SockString; + fKeepAliveClient: boolean; + fRemoteConnectionID: THttpServerConnectionID; + fServer: THttpServer; + public + /// create the socket according to a server + // - will register the THttpSocketCompress functions from the server + // - once created, caller should call AcceptRequest() to accept the socket + constructor Create(aServer: THttpServer); reintroduce; + /// main object function called after aClientSock := Accept + Create: + // - get Command, Method, URL, Headers and Body (if withBody is TRUE) + // - get sent data in Content (if withBody=true and ContentLength<>0) + // - returned enumeration will indicates the processing state + function GetRequest(withBody: boolean; headerMaxTix: Int64): THttpServerSocketGetRequestResult; virtual; + /// contains the method ('GET','POST'.. e.g.) after GetRequest() + property Method: SockString read fMethod; + /// contains the URL ('/' e.g.) after GetRequest() + property URL: SockString read fURL; + /// true if the client is HTTP/1.1 and 'Connection: Close' is not set + // - default HTTP/1.1 behavior is "keep alive", unless 'Connection: Close' + // is specified, cf. RFC 2068 page 108: "HTTP/1.1 applications that do not + // support persistent connections MUST include the "close" connection option + // in every message" + property KeepAliveClient: boolean read fKeepAliveClient write fKeepAliveClient; + /// the recognized connection ID, after a call to GetRequest() + // - identifies either the raw connection on the current server, or is + // a custom header value set by a local proxy, e.g. + // THttpServerGeneric.RemoteConnIDHeader='X-Conn-ID' for nginx + property RemoteConnectionID: THttpServerConnectionID read fRemoteConnectionID; + end; + + /// Socket API based REST and HTTP/1.1 compatible client class + // - this component is HTTP/1.1 compatible, according to RFC 2068 document + // - the REST commands (GET/POST/PUT/DELETE) are directly available + // - open connection with the server with inherited Open(server,port) function + // - if KeepAlive>0, the connection is not broken: a further request (within + // KeepAlive milliseconds) will use the existing connection if available, + // or recreate a new one if the former is outdated or reset by server + // (will retry only once); this is faster, uses less resources (especialy + // under Windows), and is the recommended way to implement a HTTP/1.1 server + // - on any error (timeout, connection closed) will retry once to get the value + // - don't forget to use Free procedure when you are finished + THttpClientSocket = class(THttpSocket) + protected + fUserAgent: SockString; + fProcessName: SockString; + procedure RequestSendHeader(const url, method: SockString); virtual; + public + /// common initialization of all constructors + // - this overridden method will set the UserAgent with some default value + // - you can customize the default client timeouts by setting appropriate + // aTimeout parameters (in ms) if you left the 0 default parameters, + // it would use global HTTP_DEFAULT_RECEIVETIMEOUT variable values + constructor Create(aTimeOut: PtrInt=0); override; + /// low-level HTTP/1.1 request + // - called by all Get/Head/Post/Put/Delete REST methods + // - after an Open(server,port), return 200,202,204 if OK, http status error otherwise + // - retry is false by caller, and will be recursively called with true to retry once + function Request(const url, method: SockString; KeepAlive: cardinal; + const header, Data, DataType: SockString; retry: boolean): integer; virtual; + + /// after an Open(server,port), return 200 if OK, http status error otherwise + // - get the page data in Content + function Get(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; + /// after an Open(server,port), return 200 if OK, http status error otherwise + // - get the page data in Content + // - if AuthToken<>'', will add an header with 'Authorization: Bearer '+AuthToken + function GetAuth(const url, AuthToken: SockString; KeepAlive: cardinal=0): integer; + /// after an Open(server,port), return 200 if OK, http status error otherwise - only + // header is read from server: Content is always '', but Headers are set + function Head(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; + /// after an Open(server,port), return 200,201,204 if OK, http status error otherwise + function Post(const url, Data, DataType: SockString; KeepAlive: cardinal=0; + const header: SockString=''): integer; + /// after an Open(server,port), return 200,201,204 if OK, http status error otherwise + function Put(const url, Data, DataType: SockString; KeepAlive: cardinal=0; + const header: SockString=''): integer; + /// after an Open(server,port), return 200,202,204 if OK, http status error otherwise + function Delete(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; + + /// by default, the client is identified as IE 5.5, which is very + // friendly welcome by most servers :( + // - you can specify a custom value here + property UserAgent: SockString read fUserAgent write fUserAgent; + /// the associated process name + property ProcessName: SockString read fProcessName write fProcessName; + end; + + /// class-reference type (metaclass) of a HTTP client socket access + // - may be either THttpClientSocket or THttpClientWebSockets (from + // SynBidirSock unit) + THttpClientSocketClass = class of THttpClientSocket; + + {$ifndef LVCL} + /// event prototype used e.g. by THttpServerGeneric.OnHttpThreadStart + TNotifyThreadEvent = procedure(Sender: TThread) of object; + {$endif} + + {$M+} + TSynThreadPool = class; + + /// a simple TThread with a "Terminate" event run in the thread context + // - the TThread.OnTerminate event is run within Synchronize() so did not + // match our expectations to be able to release the resources in the thread + // context which created them (e.g. for COM objects, or some DB drivers) + // - used internally by THttpServerGeneric.NotifyThreadStart() - you should + // not have to use the protected fOnThreadTerminate event handler + // - also define a Start method for compatibility with older versions of Delphi + TSynThread = class(TThread) + protected + // ensure fOnThreadTerminate is called only if NotifyThreadStart has been done + fStartNotified: TObject; + {$ifndef LVCL} // already available in LVCL + // we defined an fOnThreadTerminate event which would be run in the terminated + // thread context (whereas TThread.OnTerminate is called in the main thread) + // -> see THttpServerGeneric.OnHttpThreadTerminate event property + fOnThreadTerminate: TNotifyThreadEvent; + procedure DoTerminate; override; + {$endif} + public + /// initialize the server instance, in non suspended state + constructor Create(CreateSuspended: boolean); reintroduce; virtual; + {$ifndef HASTTHREADSTART} + /// method to be called when the thread was created as suspended + // - Resume is deprecated in the newest RTL, since some OS - e.g. Linux - + // do not implement this pause/resume feature + // - we define here this method for older versions of Delphi + procedure Start; + {$endif} + /// safe version of Sleep() which won't break the thread process + // - returns TRUE if the thread was Terminated + // - returns FALSE if successfully waited up to MS milliseconds + function SleepOrTerminated(MS: cardinal): boolean; + /// defined as public since may be used to terminate the processing methods + property Terminated; + end; + {$M-} + + /// HTTP response Thread as used by THttpServer Socket API based class + // - Execute procedure get the request and calculate the answer, using + // the thread for a single client connection, until it is closed + // - you don't have to overload the protected THttpServerResp Execute method: + // override THttpServer.Request() function or, if you need a lower-level access + // (change the protocol, e.g.) THttpServer.Process() method itself + THttpServerResp = class(TSynThread) + protected + fServer: THttpServer; + fServerSock: THttpServerSocket; + fClientSock: TSocket; + fClientSin: TVarSin; + fConnectionID: THttpServerConnectionID; + /// main thread loop: read request from socket, send back answer + procedure Execute; override; + public + /// initialize the response thread for the corresponding incoming socket + // - this version will get the request directly from an incoming socket + constructor Create(aSock: TSocket; const aSin: TVarSin; aServer: THttpServer); reintroduce; overload; + /// initialize the response thread for the corresponding incoming socket + // - this version will handle KeepAlive, for such an incoming request + constructor Create(aServerSock: THttpServerSocket; aServer: THttpServer); + reintroduce; overload; virtual; + /// the associated socket to communicate with the client + property ServerSock: THttpServerSocket read fServerSock; + /// the associated main HTTP server instance + property Server: THttpServer read fServer; + /// the unique identifier of this connection + property ConnectionID: THttpServerConnectionID read fConnectionID; + end; + + /// metaclass of HTTP response Thread + THttpServerRespClass = class of THttpServerResp; + + {$ifdef MSWINDOWS} + // I/O completion ports API is the best option under Windows + // under Linux/POSIX, we fallback to a classical event-driven pool + {$define USE_WINIOCP} + {$endif MSWINDOWS} + + /// defines the sub-threads used by TSynThreadPool + TSynThreadPoolWorkThread = class(TSynThread) + protected + fOwner: TSynThreadPool; + fNotifyThreadStartName: AnsiString; + fThreadNumber: integer; + {$ifndef USE_WINIOCP} + fProcessingContext: pointer; + fEvent: TEvent; + {$endif USE_WINIOCP} + procedure NotifyThreadStart(Sender: TSynThread); + procedure DoTask(Context: pointer); // exception-safe call of fOwner.Task() + public + /// initialize the thread + constructor Create(Owner: TSynThreadPool); reintroduce; + /// finalize the thread + destructor Destroy; override; + /// will loop for any pending task, and execute fOwner.Task() + procedure Execute; override; + end; + + TSynThreadPoolWorkThreads = array of TSynThreadPoolWorkThread; + + {$M+} + /// a simple Thread Pool, used e.g. for fast handling HTTP requests + // - implemented over I/O Completion Ports under Windows, or a classical + // Event-driven approach under Linux/POSIX + TSynThreadPool = class + protected + fWorkThread: TSynThreadPoolWorkThreads; + fWorkThreadCount: integer; + fRunningThreads: integer; + fExceptionsCount: integer; + fOnThreadTerminate: TNotifyThreadEvent; + fOnThreadStart: TNotifyThreadEvent; + fTerminated: boolean; + fContentionAbortCount: cardinal; + fContentionTime: Int64; + fContentionCount: cardinal; + fContentionAbortDelay: integer; + {$ifdef USE_WINIOCP} + fRequestQueue: THandle; // IOCSP has its own internal queue + {$else} + fQueuePendingContext: boolean; + fPendingContext: array of pointer; + fPendingContextCount: integer; + fSafe: TRTLCriticalSection; + function GetPendingContextCount: integer; + function PopPendingContext: pointer; + function QueueLength: integer; virtual; + {$endif USE_WINIOCP} + /// end thread on IO error + function NeedStopOnIOError: boolean; virtual; + /// process to be executed after notification + procedure Task(aCaller: TSynThread; aContext: Pointer); virtual; abstract; + procedure TaskAbort(aContext: Pointer); virtual; + public + /// initialize a thread pool with the supplied number of threads + // - abstract Task() virtual method will be called by one of the threads + // - up to 256 threads can be associated to a Thread Pool + // - can optionaly accept aOverlapHandle - a handle previously + // opened for overlapped I/O (IOCP) under Windows + // - aQueuePendingContext=true will store the pending context into + // an internal queue, so that Push() always returns true + constructor Create(NumberOfThreads: Integer=32; + {$ifdef USE_WINIOCP}aOverlapHandle: THandle=INVALID_HANDLE_VALUE + {$else}aQueuePendingContext: boolean=false{$endif}); + /// shut down the Thread pool, releasing all associated threads + destructor Destroy; override; + /// let a task (specified as a pointer) be processed by the Thread Pool + // - returns false if there is no idle thread available in the pool and + // Create(aQueuePendingContext=false) was used (caller should retry later); + // if aQueuePendingContext was true in Create, or IOCP is used, the supplied + // context will be added to an internal list and handled when possible + // - if aWaitOnContention is default false, returns immediately when the + // queue is full; set aWaitOnContention=true to wait up to + // ContentionAbortDelay ms and retry to queue the task + function Push(aContext: pointer; aWaitOnContention: boolean=false): boolean; + {$ifndef USE_WINIOCP} + /// may be called after Push() returned false to see if queue was actually full + // - returns false if QueuePendingContext is false + function QueueIsFull: boolean; + /// parameter as supplied to Create constructor + property QueuePendingContext: boolean read fQueuePendingContext; + {$endif USE_WINIOCP} + /// low-level access to the threads defined in this thread pool + property WorkThread: TSynThreadPoolWorkThreads read fWorkThread; + published + /// how many threads have been defined in this thread pool + property WorkThreadCount: integer read fWorkThreadCount; + /// how many threads are currently running in this thread pool + property RunningThreads: integer read fRunningThreads; + /// how many tasks were rejected due to thread pool contention + // - if this number is high, consider setting a higher number of threads, + // or profile and tune the Task method + property ContentionAbortCount: cardinal read fContentionAbortCount; + /// milliseconds delay to reject a connection due to contention + // - default is 5000, i.e. 5 seconds wait for some room to be available + // in the IOCP or aQueuePendingContext internal list + // - during this delay, no new connection is available (i.e. Accept is not + // called), so that a load balancer could detect the contention and switch + // to another instance in the pool, or a direct client may eventually have + // its connection rejected, so won't start sending data + property ContentionAbortDelay: integer read fContentionAbortDelay + write fContentionAbortDelay; + /// total milliseconds spent waiting for an available slot in the queue + // - contention won't fail immediately, but will retry until ContentionAbortDelay + // - any high number here requires code refactoring of the Task method + property ContentionTime: Int64 read fContentionTime; + /// how many times the pool waited for an available slot in the queue + // - contention won't fail immediately, but will retry until ContentionAbortDelay + // - any high number here may better increase the threads count + // - use this property and ContentionTime to compute the average contention time + property ContentionCount: cardinal read fContentionCount; + {$ifndef USE_WINIOCP} + /// how many input tasks are currently waiting to be affected to threads + property PendingContextCount: integer read GetPendingContextCount; + {$endif} + end; + {$M-} + + /// a simple Thread Pool, used for fast handling HTTP requests of a THttpServer + // - will handle multi-connection with less overhead than creating a thread + // for each incoming request + // - will create a THttpServerResp response thread, if the incoming request is + // identified as HTTP/1.1 keep alive, or HTTP body length is bigger than 1 MB + TSynThreadPoolTHttpServer = class(TSynThreadPool) + protected + fServer: THttpServer; + {$ifndef USE_WINIOCP} + function QueueLength: integer; override; + {$endif} + // here aContext is a THttpServerSocket instance + procedure Task(aCaller: TSynThread; aContext: Pointer); override; + procedure TaskAbort(aContext: Pointer); override; + public + /// initialize a thread pool with the supplied number of threads + // - Task() overridden method processs the HTTP request set by Push() + // - up to 256 threads can be associated to a Thread Pool + constructor Create(Server: THttpServer; NumberOfThreads: Integer=32); reintroduce; + end; + + {$M+} // to have existing RTTI for published properties + THttpServerGeneric = class; + {$M-} + + /// the server-side available authentication schemes + // - as used by THttpServerRequest.AuthenticationStatus + // - hraNone..hraKerberos will match low-level HTTP_REQUEST_AUTH_TYPE enum as + // defined in HTTP 2.0 API and + THttpServerRequestAuthentication = ( + hraNone, hraFailed, hraBasic, hraDigest, hraNtlm, hraNegotiate, hraKerberos); + + /// a generic input/output structure used for HTTP server requests + // - URL/Method/InHeaders/InContent properties are input parameters + // - OutContent/OutContentType/OutCustomHeader are output parameters + THttpServerRequest = class + protected + fRemoteIP, fURL, fMethod, fInHeaders, fInContent, fInContentType, + fAuthenticatedUser, fOutContent, fOutContentType, fOutCustomHeaders: SockString; + fServer: THttpServerGeneric; + fRequestID: integer; + fConnectionID: THttpServerConnectionID; + fConnectionThread: TSynThread; + fUseSSL: boolean; + fAuthenticationStatus: THttpServerRequestAuthentication; + {$ifdef MSWINDOWS} + fHttpApiRequest: Pointer; + fFullURL: SockUnicode; + {$endif} + public + /// low-level property which may be used during requests processing + Status: integer; + /// initialize the context, associated to a HTTP server instance + constructor Create(aServer: THttpServerGeneric; + aConnectionID: THttpServerConnectionID; aConnectionThread: TSynThread); virtual; + /// prepare an incoming request + // - will set input parameters URL/Method/InHeaders/InContent/InContentType + // - will reset output parameters + procedure Prepare(const aURL,aMethod,aInHeaders,aInContent,aInContentType, + aRemoteIP: SockString; aUseSSL: boolean=false); + /// append some lines to the InHeaders input parameter + procedure AddInHeader(additionalHeader: SockString); + {$ifdef MSWINDOWS} + /// input parameter containing the caller Full URL + property FullURL: SockUnicode read fFullURL; + {$endif} + /// input parameter containing the caller URI + property URL: SockString read fURL write fUrl; + /// input parameter containing the caller method (GET/POST...) + property Method: SockString read fMethod write fMethod; + /// input parameter containing the caller message headers + property InHeaders: SockString read fInHeaders write fInHeaders; + /// input parameter containing the caller message body + // - e.g. some GET/POST/PUT JSON data can be specified here + property InContent: SockString read fInContent write fInContent; + // input parameter defining the caller message body content type + property InContentType: SockString read fInContentType write fInContentType; + /// output parameter to be set to the response message body + property OutContent: SockString read fOutContent write fOutContent; + /// output parameter to define the reponse message body content type + // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE', defined + // as STATICFILE_CONTENT_TYPE in mORMot.pas), then OutContent is the UTF-8 + // file name of a file which must be sent to the client via http.sys or + // NGINX's X-Accel-Redirect header (faster than local buffering/sending) + // - if OutContentType is HTTP_RESP_NORESPONSE (i.e. '!NORESPONSE', defined + // as NORESPONSE_CONTENT_TYPE in mORMot.pas), then the actual transmission + // protocol may not wait for any answer - used e.g. for WebSockets + property OutContentType: SockString read fOutContentType write fOutContentType; + /// output parameter to be sent back as the response message header + // - e.g. to set Content-Type/Location + property OutCustomHeaders: SockString read fOutCustomHeaders write fOutCustomHeaders; + /// the associated server instance + // - may be a THttpServer or a THttpApiServer class + property Server: THttpServerGeneric read fServer; + /// the client remote IP, as specified to Prepare() + property RemoteIP: SockString read fRemoteIP write fRemoteIP; + /// a 31-bit sequential number identifying this instance on the server + property RequestID: integer read fRequestID; + /// the ID of the connection which called this execution context + // - e.g. SynBidirSock's TWebSocketProcess.NotifyCallback method would use + // this property to specify the client connection to be notified + // - is set as an Int64 to match http.sys ID type, but will be an + // increasing 31-bit integer sequence for (web)socket-based servers + property ConnectionID: THttpServerConnectionID read fConnectionID; + /// the thread which owns the connection of this execution context + // - depending on the HTTP server used, may not follow ConnectionID + property ConnectionThread: TSynThread read fConnectionThread; + /// is TRUE if the caller is connected via HTTPS + // - only set for THttpApiServer class yet + property UseSSL: boolean read fUseSSL; + /// contains the THttpServer-side authentication status + // - e.g. when using http.sys authentication with HTTP API 2.0 + property AuthenticationStatus: THttpServerRequestAuthentication + read fAuthenticationStatus; + /// contains the THttpServer-side authenticated user name, UTF-8 encoded + // - e.g. when using http.sys authentication with HTTP API 2.0, the + // domain user name is retrieved from the supplied AccessToken + // - could also be set by the THttpServerGeneric.Request() method, after + // proper authentication, so that it would be logged as expected + property AuthenticatedUser: SockString read fAuthenticatedUser; + {$ifdef MSWINDOWS} + /// for THttpApiServer, points to a PHTTP_REQUEST structure + // - not used by now for other servers + property HttpApiRequest: Pointer read fHttpApiRequest; + {$endif} + end; + + /// event handler used by THttpServerGeneric.OnRequest property + // - Ctxt defines both input and output parameters + // - result of the function is the HTTP error code (200 if OK, e.g.) + // - OutCustomHeader will handle Content-Type/Location + // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE' aka + // STATICFILE_CONTENT_TYPE in mORMot.pas), then OutContent is the UTF-8 file + // name of a file which must be sent directly to the client via http.sys or + // NGINX's X-Accel-Redirect; the OutCustomHeader should contain the + // proper 'Content-type: ....' value + TOnHttpServerRequest = function(Ctxt: THttpServerRequest): cardinal of object; + + /// event handler used by THttpServerGeneric.OnAfterResponse property + // - Ctxt defines both input and output parameters + // - Code defines the HTTP response code the (200 if OK, e.g.) + TOnHttpServerAfterResponse = procedure(Ctxt: THttpServerRequest; + const Code: cardinal) of object; + + /// event handler used by THttpServerGeneric.OnBeforeBody property + // - if defined, is called just before the body is retrieved from the client + // - supplied parameters reflect the current input state + // - should return STATUS_SUCCESS=200 to continue the process, or an HTTP + // error code (e.g. STATUS_FORBIDDEN or STATUS_PAYLOADTOOLARGE) to reject + // the request + TOnHttpServerBeforeBody = function(const aURL,aMethod,aInHeaders, + aInContentType,aRemoteIP: SockString; aContentLength: integer; + aUseSSL: boolean): cardinal of object; + + {$M+} + /// abstract class to implement a server thread + // - do not use this class, but rather the THttpServer, THttpApiServer + // or TAsynchFrameServer (as defined in SynBidirSock) + TServerGeneric = class(TSynThread) + protected + fProcessName: SockString; + fOnHttpThreadStart: TNotifyThreadEvent; + procedure SetOnTerminate(const Event: TNotifyThreadEvent); virtual; + procedure NotifyThreadStart(Sender: TSynThread); + public + /// initialize the server instance, in non suspended state + constructor Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; + const ProcessName: SockString); reintroduce; virtual; + end; + + /// abstract class to implement a HTTP server + // - do not use this class, but rather the THttpServer or THttpApiServer + THttpServerGeneric = class(TServerGeneric) + protected + fShutdownInProgress: boolean; + /// optional event handlers for process interception + fOnRequest: TOnHttpServerRequest; + fOnBeforeBody: TOnHttpServerBeforeBody; + fOnBeforeRequest: TOnHttpServerRequest; + fOnAfterRequest: TOnHttpServerRequest; + fOnAfterResponse: TOnHttpServerAfterResponse; + fMaximumAllowedContentLength: cardinal; + /// list of all registered compression algorithms + fCompress: THttpSocketCompressRecDynArray; + /// set by RegisterCompress method + fCompressAcceptEncoding: SockString; + fServerName: SockString; + fCurrentConnectionID: integer; // 31-bit NextConnectionID sequence + fCurrentRequestID: integer; + fCanNotifyCallback: boolean; + fRemoteIPHeader, fRemoteIPHeaderUpper: SockString; + fRemoteConnIDHeader, fRemoteConnIDHeaderUpper: SockString; + function GetAPIVersion: string; virtual; abstract; + procedure SetServerName(const aName: SockString); virtual; + procedure SetOnRequest(const aRequest: TOnHttpServerRequest); virtual; + procedure SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); virtual; + procedure SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); virtual; + procedure SetOnAfterRequest(const aEvent: TOnHttpServerRequest); virtual; + procedure SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); virtual; + procedure SetMaximumAllowedContentLength(aMax: cardinal); virtual; + procedure SetRemoteIPHeader(const aHeader: SockString); virtual; + procedure SetRemoteConnIDHeader(const aHeader: SockString); virtual; + function GetHTTPQueueLength: Cardinal; virtual; abstract; + procedure SetHTTPQueueLength(aValue: Cardinal); virtual; abstract; + function DoBeforeRequest(Ctxt: THttpServerRequest): cardinal; + function DoAfterRequest(Ctxt: THttpServerRequest): cardinal; + procedure DoAfterResponse(Ctxt: THttpServerRequest; + const Code: cardinal); virtual; + function NextConnectionID: integer; // 31-bit internal sequence + public + /// initialize the server instance, in non suspended state + constructor Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; + const ProcessName: SockString); reintroduce; virtual; + /// override this function to customize your http server + // - InURL/InMethod/InContent properties are input parameters + // - OutContent/OutContentType/OutCustomHeader are output parameters + // - result of the function is the HTTP error code (200 if OK, e.g.), + // - OutCustomHeader is available to handle Content-Type/Location + // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE' or + // STATICFILE_CONTENT_TYPE defined in mORMot.pas), then OutContent is the + // UTF-8 file name of a file which must be sent to the client via http.sys or + // NGINX's X-Accel-Redirect (much faster than manual buffering/sending); + // the OutCustomHeader should contain the proper 'Content-type: ....' + // - default implementation is to call the OnRequest event (if existing), + // and will return STATUS_NOTFOUND if OnRequest was not set + // - warning: this process must be thread-safe (can be called by several + // threads simultaneously, but with a given Ctxt instance for each) + function Request(Ctxt: THttpServerRequest): cardinal; virtual; + /// server can send a request back to the client, when the connection has + // been upgraded e.g. to WebSockets + // - InURL/InMethod/InContent properties are input parameters (InContentType + // is ignored) + // - OutContent/OutContentType/OutCustomHeader are output parameters + // - CallingThread should be set to the client's Ctxt.CallingThread + // value, so that the method could know which connnection is to be used - + // it will return STATUS_NOTFOUND (404) if the connection is unknown + // - result of the function is the HTTP error code (200 if OK, e.g.) + // - warning: this void implementation will raise an ECrtSocket exception - + // inherited classes should override it, e.g. as in TWebSocketServerRest + function Callback(Ctxt: THttpServerRequest; aNonBlocking: boolean): cardinal; virtual; + /// will register a compression algorithm + // - used e.g. to compress on the fly the data, with standard gzip/deflate + // or custom (synlzo/synlz) protocols + // - you can specify a minimal size (in bytes) before which the content won't + // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) + // - the first registered algorithm will be the prefered one for compression + procedure RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024); virtual; + /// you can call this method to prepare the HTTP server for shutting down + procedure Shutdown; + /// event handler called by the default implementation of the + // virtual Request method + // - warning: this process must be thread-safe (can be called by several + // threads simultaneously) + property OnRequest: TOnHttpServerRequest read fOnRequest write SetOnRequest; + /// event handler called just before the body is retrieved from the client + // - should return STATUS_SUCCESS=200 to continue the process, or an HTTP + // error code to reject the request immediatly, and close the connection + property OnBeforeBody: TOnHttpServerBeforeBody read fOnBeforeBody write SetOnBeforeBody; + /// event handler called after HTTP body has been retrieved, before OnProcess + // - may be used e.g. to return a STATUS_ACCEPTED (202) status to client and + // continue a long-term job inside the OnProcess handler in the same thread; + // or to modify incoming information before passing it to main businnes logic, + // (header preprocessor, body encoding etc...) + // - if the handler returns > 0 server will send a response immediately, + // unless return code is STATUS_ACCEPTED (202), then OnRequest will be called + // - warning: this handler must be thread-safe (can be called by several + // threads simultaneously) + property OnBeforeRequest: TOnHttpServerRequest read fOnBeforeRequest write SetOnBeforeRequest; + /// event handler called after request is processed but before response + // is sent back to client + // - main purpose is to apply post-processor, not part of request logic + // - if handler returns value > 0 it will override the OnProcess response code + // - warning: this handler must be thread-safe (can be called by several + // threads simultaneously) + property OnAfterRequest: TOnHttpServerRequest read fOnAfterRequest write SetOnAfterRequest; + /// event handler called after response is sent back to client + // - main purpose is to apply post-response analysis, logging, etc. + // - warning: this handler must be thread-safe (can be called by several + // threads simultaneously) + property OnAfterResponse: TOnHttpServerAfterResponse read fOnAfterResponse write SetOnAfterResponse; + /// event handler called after each working Thread is just initiated + // - called in the thread context at first place in THttpServerGeneric.Execute + property OnHttpThreadStart: TNotifyThreadEvent + read fOnHttpThreadStart write fOnHttpThreadStart; + /// event handler called when a working Thread is terminating + // - called in the corresponding thread context + // - the TThread.OnTerminate event will be called within a Synchronize() + // wrapper, so it won't fit our purpose + // - to be used e.g. to call CoUnInitialize from thread in which CoInitialize + // was made, for instance via a method defined as such: + // ! procedure TMyServer.OnHttpThreadTerminate(Sender: TObject); + // ! begin // TSQLDBConnectionPropertiesThreadSafe + // ! fMyConnectionProps.EndCurrentThread; + // ! end; + // - is used e.g. by TSQLRest.EndCurrentThread for proper multi-threading + property OnHttpThreadTerminate: TNotifyThreadEvent read fOnThreadTerminate write SetOnTerminate; + /// reject any incoming request with a body size bigger than this value + // - default to 0, meaning any input size is allowed + // - returns STATUS_PAYLOADTOOLARGE = 413 error if "Content-Length" incoming + // header overflow the supplied number of bytes + property MaximumAllowedContentLength: cardinal read fMaximumAllowedContentLength + write SetMaximumAllowedContentLength; + /// defines request/response internal queue length + // - default value if 1000, which sounds fine for most use cases + // - for THttpApiServer, will return 0 if the system does not support HTTP + // API 2.0 (i.e. under Windows XP or Server 2003) + // - for THttpServer, will shutdown any incoming accepted socket if the + // internal TSynThreadPool.PendingContextCount+ThreadCount exceeds this limit; + // each pending connection is a THttpServerSocket instance in the queue + // - increase this value if you don't have any load-balancing in place, and + // in case of e.g. many 503 HTTP answers or if many "QueueFull" messages + // appear in HTTP.sys log files (normally in + // C:\Windows\System32\LogFiles\HTTPERR\httperr*.log) - may appear with + // thousands of concurrent clients accessing at once the same server - + // see @http://msdn.microsoft.com/en-us/library/windows/desktop/aa364501 + // - you can use this property with a reverse-proxy as load balancer, e.g. + // with nginx configured as such: + // $ location / { + // $ proxy_pass http://balancing_upstream; + // $ proxy_next_upstream error timeout invalid_header http_500 http_503; + // $ proxy_connect_timeout 2; + // $ proxy_set_header Host $host; + // $ proxy_set_header X-Real-IP $remote_addr; + // $ proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for; + // $ proxy_set_header X-Conn-ID $connection + // $ } + // see https://synopse.info/forum/viewtopic.php?pid=28174#p28174 + property HTTPQueueLength: cardinal read GetHTTPQueueLength write SetHTTPQueueLength; + /// TRUE if the inherited class is able to handle callbacks + // - only TWebSocketServer has this ability by now + property CanNotifyCallback: boolean read fCanNotifyCallback; + /// the value of a custom HTTP header containing the real client IP + // - by default, the RemoteIP information will be retrieved from the socket + // layer - but if the server runs behind some proxy service, you should + // define here the HTTP header name which indicates the true remote client + // IP value, mostly as 'X-Real-IP' or 'X-Forwarded-For' + property RemoteIPHeader: SockString read fRemoteIPHeader write SetRemoteIPHeader; + /// the value of a custom HTTP header containing the real client connection ID + // - by default, Ctxt.ConnectionID information will be retrieved from our + // socket layer - but if the server runs behind some proxy service, you should + // define here the HTTP header name which indicates the real remote connection, + // for example as 'X-Conn-ID', setting in nginx config: + // $ proxy_set_header X-Conn-ID $connection + property RemoteConnIDHeader: SockString read fRemoteConnIDHeader write SetRemoteConnIDHeader; + published + /// returns the API version used by the inherited implementation + property APIVersion: string read GetAPIVersion; + /// the Server name, UTF-8 encoded, e.g. 'mORMot/1.18 (Linux)' + // - will be served as "Server: ..." HTTP header + // - for THttpApiServer, when called from the main instance, will propagate + // the change to all cloned instances, and included in any HTTP API 2.0 log + property ServerName: SockString read fServerName write SetServerName; + /// the associated process name + property ProcessName: SockString read fProcessName write fProcessName; + end; + + {$ifndef UNICODE} + ULONGLONG = Int64; + {$endif} + + {$ifdef MSWINDOWS} + + HTTP_OPAQUE_ID = ULONGLONG; + HTTP_REQUEST_ID = HTTP_OPAQUE_ID; + HTTP_URL_GROUP_ID = HTTP_OPAQUE_ID; + HTTP_SERVER_SESSION_ID = HTTP_OPAQUE_ID; + + /// http.sys API 2.0 logging file supported layouts + // - match low-level HTTP_LOGGING_TYPE as defined in HTTP 2.0 API + THttpApiLoggingType = ( + hltW3C, hltIIS, hltNCSA, hltRaw); + + /// http.sys API 2.0 logging file rollover types + // - match low-level HTTP_LOGGING_ROLLOVER_TYPE as defined in HTTP 2.0 API + THttpApiLoggingRollOver = ( + hlrSize, hlrDaily, hlrWeekly, hlrMonthly, hlrHourly); + + /// http.sys API 2.0 logging option flags + // - used to alter the default logging behavior + // - hlfLocalTimeRollover would force the log file rollovers by local time, + // instead of the default GMT time + // - hlfUseUTF8Conversion will use UTF-8 instead of default local code page + // - only one of hlfLogErrorsOnly and hlfLogSuccessOnly flag could be set + // at a time: if neither of them are present, both errors and success will + // be logged, otherwise mutually exclusive flags could be set to force only + // errors or success logging + // - match low-level HTTP_LOGGING_FLAG_* constants as defined in HTTP 2.0 API + THttpApiLoggingFlags = set of ( + hlfLocalTimeRollover, hlfUseUTF8Conversion, + hlfLogErrorsOnly, hlfLogSuccessOnly); + + /// http.sys API 2.0 fields used for W3C logging + // - match low-level HTTP_LOG_FIELD_* constants as defined in HTTP 2.0 API + THttpApiLogFields = set of ( + hlfDate, hlfTime, hlfClientIP, hlfUserName, hlfSiteName, hlfComputerName, + hlfServerIP, hlfMethod, hlfURIStem, hlfURIQuery, hlfStatus, hlfWIN32Status, + hlfBytesSent, hlfBytesRecv, hlfTimeTaken, hlfServerPort, hlfUserAgent, + hlfCookie, hlfReferer, hlfVersion, hlfHost, hlfSubStatus); + + /// http.sys API 2.0 fields used for server-side authentication + // - as used by THttpApiServer.SetAuthenticationSchemes/AuthenticationSchemes + // - match low-level HTTP_AUTH_ENABLE_* constants as defined in HTTP 2.0 API + THttpApiRequestAuthentications = set of ( + haBasic, haDigest, haNtlm, haNegotiate, haKerberos); + + THttpApiServer = class; + + THttpApiServers = array of THttpApiServer; + + /// HTTP server using fast http.sys kernel-mode server + // - The HTTP Server API enables applications to communicate over HTTP without + // using Microsoft Internet Information Server (IIS). Applications can register + // to receive HTTP requests for particular URLs, receive HTTP requests, and send + // HTTP responses. The HTTP Server API includes SSL support so that applications + // can exchange data over secure HTTP connections without IIS. It is also + // designed to work with I/O completion ports. + // - The HTTP Server API is supported on Windows Server 2003 operating systems + // and on Windows XP with Service Pack 2 (SP2). Be aware that Microsoft IIS 5 + // running on Windows XP with SP2 is not able to share port 80 with other HTTP + // applications running simultaneously. + THttpApiServer = class(THttpServerGeneric) + protected + /// the internal request queue + fReqQueue: THandle; + /// contain list of THttpApiServer cloned instances + fClones: THttpApiServers; + // if cloned, fOwner contains the main THttpApiServer instance + fOwner: THttpApiServer; + /// list of all registered URL + fRegisteredUnicodeUrl: array of SockUnicode; + fServerSessionID: HTTP_SERVER_SESSION_ID; + fUrlGroupID: HTTP_URL_GROUP_ID; + fLogData: pointer; + fLogDataStorage: array of byte; + fLoggingServiceName: SockString; + fAuthenticationSchemes: THttpApiRequestAuthentications; + fReceiveBufferSize: cardinal; + procedure SetReceiveBufferSize(Value: cardinal); + function GetRegisteredUrl: SockUnicode; + function GetCloned: boolean; + function GetHTTPQueueLength: Cardinal; override; + procedure SetHTTPQueueLength(aValue: Cardinal); override; + function GetMaxBandwidth: Cardinal; + procedure SetMaxBandwidth(aValue: Cardinal); + function GetMaxConnections: Cardinal; + procedure SetMaxConnections(aValue: Cardinal); + procedure SetOnTerminate(const Event: TNotifyThreadEvent); override; + function GetAPIVersion: string; override; + function GetLogging: boolean; + procedure SetServerName(const aName: SockString); override; + procedure SetOnRequest(const aRequest: TOnHttpServerRequest); override; + procedure SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); override; + procedure SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); override; + procedure SetOnAfterRequest(const aEvent: TOnHttpServerRequest); override; + procedure SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); override; + procedure SetMaximumAllowedContentLength(aMax: cardinal); override; + procedure SetRemoteIPHeader(const aHeader: SockString); override; + procedure SetRemoteConnIDHeader(const aHeader: SockString); override; + procedure SetLoggingServiceName(const aName: SockString); + /// server main loop - don't change directly + // - will call the Request public virtual method with the appropriate + // parameters to retrive the content + procedure Execute; override; + /// retrieve flags for SendHttpResponse + // - if response content type is not HTTP_RESP_STATICFILE + function GetSendResponseFlags(Ctxt: THttpServerRequest): integer; virtual; + /// create a clone + constructor CreateClone(From: THttpApiServer); virtual; + /// free resources (for not cloned server) + procedure DestroyMainThread; virtual; + public + /// initialize the HTTP Service + // - will raise an exception if http.sys is not available e.g. before + // Windows XP SP2) or if the request queue creation failed + // - if you override this contructor, put the AddUrl() methods within, + // and you can set CreateSuspended to FALSE + // - if you will call AddUrl() methods later, set CreateSuspended to TRUE, + // then call explicitely the Resume method, after all AddUrl() calls, in + // order to start the server + constructor Create(CreateSuspended: boolean; QueueName: SockUnicode=''; + OnStart: TNotifyThreadEvent=nil; OnStop: TNotifyThreadEvent=nil; + const ProcessName: SockString=''); reintroduce; + /// release all associated memory and handles + destructor Destroy; override; + /// will clone this thread into multiple other threads + // - could speed up the process on multi-core CPU + // - will work only if the OnProcess property was set (this is the case + // e.g. in TSQLHttpServer.Create() constructor) + // - maximum value is 256 - higher should not be worth it + procedure Clone(ChildThreadCount: integer); + /// register the URLs to Listen On + // - e.g. AddUrl('root','888') + // - aDomainName could be either a fully qualified case-insensitive domain + // name, an IPv4 or IPv6 literal string, or a wildcard ('+' will bound + // to all domain names for the specified port, '*' will accept the request + // when no other listening hostnames match the request for that port) + // - return 0 (NO_ERROR) on success, an error code if failed: under Vista + // and Seven, you could have ERROR_ACCESS_DENIED if the process is not + // running with enough rights (by default, UAC requires administrator rights + // for adding an URL to http.sys registration list) - solution is to call + // the THttpApiServer.AddUrlAuthorize class method during program setup + // - if this method is not used within an overridden constructor, default + // Create must have be called with CreateSuspended = TRUE and then call the + // Resume method after all Url have been added + // - if aRegisterURI is TRUE, the URI will be registered (need adminitrator + // rights) - default is FALSE, as defined by Windows security policy + function AddUrl(const aRoot, aPort: SockString; Https: boolean=false; + const aDomainName: SockString='*'; aRegisterURI: boolean=false; + aContext: Int64=0): integer; + /// un-register the URLs to Listen On + // - this method expect the same parameters as specified to AddUrl() + // - return 0 (NO_ERROR) on success, an error code if failed (e.g. + // -1 if the corresponding parameters do not match any previous AddUrl) + function RemoveUrl(const aRoot, aPort: SockString; Https: boolean=false; + const aDomainName: SockString='*'): integer; + /// will authorize a specified URL prefix + // - will allow to call AddUrl() later for any user on the computer + // - if aRoot is left '', it will authorize any root for this port + // - must be called with Administrator rights: this class function is to be + // used in a Setup program for instance, especially under Vista or Seven, + // to reserve the Url for the server + // - add a new record to the http.sys URL reservation store + // - return '' on success, an error message otherwise + // - will first delete any matching rule for this URL prefix + // - if OnlyDelete is true, will delete but won't add the new authorization; + // in this case, any error message at deletion will be returned + class function AddUrlAuthorize(const aRoot, aPort: SockString; Https: boolean=false; + const aDomainName: SockString='*'; OnlyDelete: boolean=false): string; + /// will register a compression algorithm + // - overridden method which will handle any cloned instances + procedure RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024); override; + /// access to the internal THttpApiServer list cloned by this main instance + // - as created by Clone() method + property Clones: THttpApiServers read fClones; + public { HTTP API 2.0 methods and properties } + /// can be used to check if the HTTP API 2.0 is available + function HasAPI2: boolean; + /// enable HTTP API 2.0 advanced timeout settings + // - all those settings are set for the current URL group + // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used + // so you should better test the availability of the method first: + // ! if aServer.HasAPI2 then + // ! SetTimeOutLimits(....); + // - aEntityBody is the time, in seconds, allowed for the request entity + // body to arrive - default value is 2 minutes + // - aDrainEntityBody is the time, in seconds, allowed for the HTTP Server + // API to drain the entity body on a Keep-Alive connection - default value + // is 2 minutes + // - aRequestQueue is the time, in seconds, allowed for the request to + // remain in the request queue before the application picks it up - default + // value is 2 minutes + // - aIdleConnection is the time, in seconds, allowed for an idle connection; + // is similar to THttpServer.ServerKeepAliveTimeOut - default value is + // 2 minutes + // - aHeaderWait is the time, in seconds, allowed for the HTTP Server API + // to parse the request header - default value is 2 minutes + // - aMinSendRate is the minimum send rate, in bytes-per-second, for the + // response - default value is 150 bytes-per-second + // - any value set to 0 will set the HTTP Server API default value + procedure SetTimeOutLimits(aEntityBody, aDrainEntityBody, + aRequestQueue, aIdleConnection, aHeaderWait, aMinSendRate: cardinal); + /// enable HTTP API 2.0 logging + // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used + // so you should better test the availability of the method first: + // ! if aServer.HasAPI2 then + // ! LogStart(....); + // - this method won't do anything on the cloned instances, but the main + // instance logging state will be replicated to all cloned instances + // - you can select the output folder and the expected logging layout + // - aSoftwareName will set the optional W3C-only software name string + // - aRolloverSize will be used only when aRolloverType is hlrSize + procedure LogStart(const aLogFolder: TFileName; + aType: THttpApiLoggingType=hltW3C; + const aSoftwareName: TFileName=''; + aRolloverType: THttpApiLoggingRollOver=hlrDaily; + aRolloverSize: cardinal=0; + aLogFields: THttpApiLogFields=[hlfDate..hlfSubStatus]; + aFlags: THttpApiLoggingFlags=[hlfUseUTF8Conversion]); + /// disable HTTP API 2.0 logging + // - this method won't do anything on the cloned instances, but the main + // instance logging state will be replicated to all cloned instances + procedure LogStop; + /// enable HTTP API 2.0 server-side authentication + // - once enabled, the client sends an unauthenticated request: it is up to + // the server application to generate the initial 401 challenge with proper + // WWW-Authenticate headers; any further authentication steps will be + // perform in kernel mode, until the authentication handshake is finalized; + // later on, the application can check the AuthenticationStatus property + // of THttpServerRequest and its associated AuthenticatedUser value + // see https://msdn.microsoft.com/en-us/library/windows/desktop/aa364452 + // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used + // so you should better test the availability of the method first: + // ! if aServer.HasAPI2 then + // ! SetAuthenticationSchemes(....); + // - this method will work on the current group, for all instances + // - see HTTPAPI_AUTH_ENABLE_ALL constant to set all available schemes + // - optional Realm parameters can be used when haBasic scheme is defined + // - optional DomainName and Realm parameters can be used for haDigest + procedure SetAuthenticationSchemes(schemes: THttpApiRequestAuthentications; + const DomainName: SockUnicode=''; const Realm: SockUnicode=''); + /// read-only access to HTTP API 2.0 server-side enabled authentication schemes + property AuthenticationSchemes: THttpApiRequestAuthentications + read fAuthenticationSchemes; + /// read-only access to check if the HTTP API 2.0 logging is enabled + // - use LogStart/LogStop methods to change this property value + property Logging: boolean read GetLogging; + /// the current HTTP API 2.0 logging Service name + // - should be UTF-8 encoded, if LogStart(aFlags=[hlfUseUTF8Conversion]) + // - this value is dedicated to one instance, so the main instance won't + // propagate the change to all cloned instances + property LoggingServiceName: SockString + read fLoggingServiceName write SetLoggingServiceName; + /// read-only access to the low-level HTTP API 2.0 Session ID + property ServerSessionID: HTTP_SERVER_SESSION_ID read fServerSessionID; + /// read-only access to the low-level HTTP API 2.0 URI Group ID + property UrlGroupID: HTTP_URL_GROUP_ID read fUrlGroupID; + /// how many bytes are retrieved in a single call to ReceiveRequestEntityBody + // - set by default to 1048576, i.e. 1 MB - practical limit is around 20 MB + // - you may customize this value if you encounter HTTP error STATUS_NOTACCEPTABLE + // (406) from client, corresponding to an ERROR_NO_SYSTEM_RESOURCES (1450) + // exception on server side, when uploading huge data content + property ReceiveBufferSize: cardinal read fReceiveBufferSize write SetReceiveBufferSize; + published + /// TRUE if this instance is in fact a cloned instance for the thread pool + property Cloned: boolean read GetCloned; + /// return the list of registered URL on this server instance + property RegisteredUrl: SockUnicode read GetRegisteredUrl; + /// the maximum allowed bandwidth rate in bytes per second (via HTTP API 2.0) + // - Setting this value to 0 allows an unlimited bandwidth + // - by default Windows not limit bandwidth (actually limited to 4 Gbit/sec). + // - will return 0 if the system does not support HTTP API 2.0 (i.e. + // under Windows XP or Server 2003) + property MaxBandwidth: Cardinal read GetMaxBandwidth write SetMaxBandwidth; + /// the maximum number of HTTP connections allowed (via HTTP API 2.0) + // - Setting this value to 0 allows an unlimited number of connections + // - by default Windows does not limit number of allowed connections + // - will return 0 if the system does not support HTTP API 2.0 (i.e. + // under Windows XP or Server 2003) + property MaxConnections: Cardinal read GetMaxConnections write SetMaxConnections; + end; + + /// low-level API reference to a WebSocket session + WEB_SOCKET_HANDLE = Pointer; + /// WebSocket close status as defined by http://tools.ietf.org/html/rfc6455#section-7.4 + WEB_SOCKET_CLOSE_STATUS = Word; + /// the bit values used to construct the WebSocket frame header for httpapi.dll + // - not equals to WINHTTP_WEB_SOCKET_BUFFER_TYPE from winhttp.dll + WEB_SOCKET_BUFFER_TYPE = ULONG; + + TSynThreadPoolHttpApiWebSocketServer = class; + TSynWebSocketGuard = class; + THttpApiWebSocketServer = class; + THttpApiWebSocketServerProtocol = class; + + /// current state of a THttpApiWebSocketConnection + TWebSocketState = (wsConnecting, wsOpen, + wsClosing, wsClosedByClient, wsClosedByServer, wsClosedByGuard, wsClosedByShutdown); + + /// structure representing a single WebSocket connection + {$ifdef UNICODE} + THttpApiWebSocketConnection = record + {$else} + THttpApiWebSocketConnection = object + {$endif} + private + fOverlapped: TOverlapped; + fState: TWebSocketState; + fProtocol: THttpApiWebSocketServerProtocol; + fOpaqueHTTPRequestId: HTTP_REQUEST_ID; + fWSHandle: WEB_SOCKET_HANDLE; + fLastActionContext: Pointer; + fLastReceiveTickCount: Int64; + fPrivateData: pointer; + fBuffer: SockString; + fCloseStatus: WEB_SOCKET_CLOSE_STATUS; + fIndex: integer; + function ProcessActions(ActionQueue: Cardinal): boolean; + function ReadData(const WebsocketBufferData): integer; + procedure WriteData(const WebsocketBufferData); + procedure BeforeRead; + procedure DoOnMessage(aBufferType: WEB_SOCKET_BUFFER_TYPE; + aBuffer: Pointer; aBufferSize: ULONG); + procedure DoOnConnect; + procedure DoOnDisconnect(); + procedure InternalSend(aBufferType: WEB_SOCKET_BUFFER_TYPE; WebsocketBufferData: pointer); + procedure Ping; + procedure Disconnect; + procedure CheckIsActive; + // call onAccept Method of protocol, and if protocol not accept connection or + // can not be accepted from other reasons return false else return true + function TryAcceptConnection(aProtocol: THttpApiWebSocketServerProtocol; Ctxt: THttpServerRequest; aNeedHeader: boolean): boolean; + public + /// Index of connection in protocol's connection list + property Index: integer read fIndex; + /// Protocol of connection + property Protocol: THttpApiWebSocketServerProtocol read fProtocol; + /// Custom user data + property PrivateData: pointer read fPrivateData write fPrivateData; + /// Access to the current state of this connection + property State: TWebSocketState read fState; + /// Send data to client + procedure Send(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); + /// Close connection + procedure Close(aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG); + end; + + PHttpApiWebSocketConnection = ^THttpApiWebSocketConnection; + + THttpApiWebSocketConnectionVector = array[0..MaxInt div SizeOf(PHttpApiWebSocketConnection) - 1] of PHttpApiWebSocketConnection; + + PHttpApiWebSocketConnectionVector = ^THttpApiWebSocketConnectionVector; + + /// Event handler on THttpApiWebSocketServerProtocol Accept + THttpApiWebSocketServerOnAcceptEvent = function(Ctxt: THttpServerRequest; + var Conn: THttpApiWebSocketConnection): Boolean of object; + /// Event handler on THttpApiWebSocketServerProtocol Message received + THttpApiWebSocketServerOnMessageEvent = procedure(var Conn: THttpApiWebSocketConnection; + aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG) of object; + /// Event handler on THttpApiWebSocketServerProtocol connection + THttpApiWebSocketServerOnConnectEvent = procedure(var Conn: THttpApiWebSocketConnection) of object; + /// Event handler on THttpApiWebSocketServerProtocol disconnection + THttpApiWebSocketServerOnDisconnectEvent = procedure(var Conn: THttpApiWebSocketConnection; + aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG) of object; + + /// Protocol Handler of websocket endpoints events + // - maintains a list of all WebSockets clients for a given protocol + THttpApiWebSocketServerProtocol = class + private + fName: SockString; + fManualFragmentManagement: Boolean; + fOnAccept: THttpApiWebSocketServerOnAcceptEvent; + fOnMessage: THttpApiWebSocketServerOnMessageEvent; + fOnFragment: THttpApiWebSocketServerOnMessageEvent; + fOnConnect: THttpApiWebSocketServerOnConnectEvent; + fOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; + fConnections: PHttpApiWebSocketConnectionVector; + fConnectionsCapacity: Integer; + //Count of used connections. Some of them can be nil(if not used more) + fConnectionsCount: Integer; + fFirstEmptyConnectionIndex: Integer; + fServer: THttpApiWebSocketServer; + fSafe: TRTLCriticalSection; + fPendingForClose: {$ifdef FPC}TFPList{$else}TList{$endif}; + fIndex: integer; + function AddConnection(aConn: PHttpApiWebSocketConnection): Integer; + procedure RemoveConnection(index: integer); + procedure doShutdown; + public + /// initialize the WebSockets process + // - if aManualFragmentManagement is true, onMessage will appear only for whole + // received messages, otherwise OnFragment handler must be passed (for video + // broadcast, for example) + constructor Create(const aName: SockString; aManualFragmentManagement: Boolean; + aServer: THttpApiWebSocketServer; + aOnAccept: THttpApiWebSocketServerOnAcceptEvent; + aOnMessage: THttpApiWebSocketServerOnMessageEvent; + aOnConnect: THttpApiWebSocketServerOnConnectEvent; + aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; + aOnFragment: THttpApiWebSocketServerOnMessageEvent=nil); + /// finalize the process + destructor Destroy; override; + /// text identifier + property Name: SockString read fName; + /// identify the endpoint instance + property Index: integer read fIndex; + /// OnFragment event will be called for each fragment + property ManualFragmentManagement: Boolean read fManualFragmentManagement; + /// event triggerred when a WebSockets client is initiated + property OnAccept: THttpApiWebSocketServerOnAcceptEvent read fOnAccept; + /// event triggerred when a WebSockets message is received + property OnMessage: THttpApiWebSocketServerOnMessageEvent read fOnMessage; + /// event triggerred when a WebSockets client is connected + property OnConnect: THttpApiWebSocketServerOnConnectEvent read fOnConnect; + /// event triggerred when a WebSockets client is gracefully disconnected + property OnDisconnect: THttpApiWebSocketServerOnDisconnectEvent read fOnDisconnect; + /// event triggerred when a non complete frame is received + // - required if ManualFragmentManagement is true + property OnFragment: THttpApiWebSocketServerOnMessageEvent read fOnFragment; + + /// Send message to the WebSocket connection identified by its index + function Send(index: Integer; aBufferType: ULONG; aBuffer: Pointer; aBufferSize: ULONG): boolean; + /// Send message to all connections of this protocol + function Broadcast(aBufferType: ULONG; aBuffer: Pointer; aBufferSize: ULONG): boolean; + /// Close WebSocket connection identified by its index + function Close(index: Integer; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG): boolean; + end; + THttpApiWebSocketServerProtocolDynArray = array of THttpApiWebSocketServerProtocol; + PHttpApiWebSocketServerProtocolDynArray = ^THttpApiWebSocketServerProtocolDynArray; + + /// HTTP & WebSocket server using fast http.sys kernel-mode server + // - can be used like simple THttpApiServer + // - when AddUrlWebSocket is called WebSocket support are added + // in this case WebSocket will receiving the frames in asynchronous + THttpApiWebSocketServer = class(THttpApiServer) + private + fThreadPoolServer: TSynThreadPoolHttpApiWebSocketServer; + fGuard: TSynWebSocketGuard; + fLastConnection: PHttpApiWebSocketConnection; + fPingTimeout: integer; + fRegisteredProtocols: PHttpApiWebSocketServerProtocolDynArray; + fOnWSThreadStart: TNotifyThreadEvent; + fOnWSThreadTerminate: TNotifyThreadEvent; + fSendOverlaped: TOverlapped; + fServiceOverlaped: TOverlapped; + fOnServiceMessage: TThreadMethod; + procedure SetOnWSThreadTerminate(const Value: TNotifyThreadEvent); + function GetProtocol(index: integer): THttpApiWebSocketServerProtocol; + function getProtocolsCount: Integer; + procedure SetOnWSThreadStart(const Value: TNotifyThreadEvent); + protected + function UpgradeToWebSocket(Ctxt: THttpServerRequest): cardinal; + procedure DoAfterResponse(Ctxt: THttpServerRequest; + const Code: cardinal); override; + function GetSendResponseFlags(Ctxt: THttpServerRequest): Integer; override; + constructor CreateClone(From: THttpApiServer); override; + procedure DestroyMainThread; override; + public + /// initialize the HTTPAPI based Server with WebSocket support + // - will raise an exception if http.sys or websocket.dll is not available + // (e.g. before Windows 8) or if the request queue creation failed + // - for aPingTimeout explanation see PingTimeout property documentation + constructor Create(CreateSuspended: Boolean; aSocketThreadsCount: integer=1; + aPingTimeout: integer=0; QueueName: SockUnicode=''; + aOnWSThreadStart: TNotifyThreadEvent=nil; + aOnWSThreadTerminate: TNotifyThreadEvent=nil); reintroduce; + /// prepare the process for a given THttpApiWebSocketServerProtocol + procedure RegisterProtocol(const aName: SockString; aManualFragmentManagement: Boolean; + aOnAccept: THttpApiWebSocketServerOnAcceptEvent; + aOnMessage: THttpApiWebSocketServerOnMessageEvent; + aOnConnect: THttpApiWebSocketServerOnConnectEvent; + aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; + aOnFragment: THttpApiWebSocketServerOnMessageEvent=nil); + /// register the URLs to Listen on using WebSocket + // - aProtocols is an array of a recond with callbacks, server call during + // WebSocket activity + function AddUrlWebSocket(const aRoot, aPort: SockString; Https: boolean=false; + const aDomainName: SockString='*'; aRegisterURI: boolean=false): integer; + function Request(Ctxt: THttpServerRequest): cardinal; override; + /// Ping timeout in seconds. 0 mean no ping. + // - if connection not receive messages longer than this timeout + // TSynWebSocketGuard will send ping frame + // - if connection not receive any messages longer than double of + // this timeout it will be closed + property PingTimeout: integer read fPingTimeout; + /// access to the associated endpoints + property Protocols[index: integer]: THttpApiWebSocketServerProtocol read GetProtocol; + /// access to the associated endpoints count + property ProtocolsCount: Integer read getProtocolsCount; + /// event called when the processing thread starts + property OnWSThreadStart: TNotifyThreadEvent read FOnWSThreadStart + write SetOnWSThreadStart; + /// event called when the processing thread termintes + property OnWSThreadTerminate: TNotifyThreadEvent read FOnWSThreadTerminate + write SetOnWSThreadTerminate; + /// can be called from any thread + // - will send a "service" message to a WebSocketServer to wake up a WebSocket thread + // - When a webSocket thread receives such a message it will call onServiceMessage in the thread context + procedure SendServiceMessage; + /// event called when a service message is raised + property OnServiceMessage: TThreadMethod read fOnServiceMessage write fOnServiceMessage; + end; + + /// a Thread Pool, used for fast handling WebSocket requests + TSynThreadPoolHttpApiWebSocketServer = class(TSynThreadPool) + protected + fServer: THttpApiWebSocketServer; + procedure OnThreadStart(Sender: TThread); + procedure OnThreadTerminate(Sender: TThread); + function NeedStopOnIOError: Boolean; override; + // aContext is a PHttpApiWebSocketConnection, or fServer.fServiceOverlaped + // (SendServiceMessage) or fServer.fSendOverlaped (WriteData) + procedure Task(aCaller: TSynThread; aContext: Pointer); override; + public + /// initialize the thread pool + constructor Create(Server: THttpApiWebSocketServer; NumberOfThreads: Integer=1); reintroduce; + end; + + /// Thread for closing WebSocket connections which not response more than PingTimeout interval + TSynWebSocketGuard = class(TThread) + protected + fServer: THttpApiWebSocketServer; + fSmallWait, fWaitCount: integer; + procedure Execute; override; + public + /// initialize the thread + constructor Create(Server: THttpApiWebSocketServer); reintroduce; + end; + {$endif MSWINDOWS} + + /// meta-class of the THttpServerSocket process + // - used to override THttpServerSocket.GetRequest for instance + THttpServerSocketClass = class of THttpServerSocket; + + /// event handler used by THttpServer.Process to send a local file + // when HTTP_RESP_STATICFILE content-type is returned by the service + // - can be defined e.g. to use NGINX X-Accel-Redirect header + // - should return true if the Context has been modified to serve the file, or + // false so that the file will be manually read and sent from memory + // - any exception during process will be returned as a STATUS_NOTFOUND page + TOnHttpServerSendFile = function(Context: THttpServerRequest; + const LocalFileName: TFileName): boolean of object; + + /// main HTTP server Thread using the standard Sockets API (e.g. WinSock) + // - bind to a port and listen to incoming requests + // - assign this requests to THttpServerResp threads from a ThreadPool + // - it implements a HTTP/1.1 compatible server, according to RFC 2068 specifications + // - if the client is also HTTP/1.1 compatible, KeepAlive connection is handled: + // multiple requests will use the existing connection and thread; + // this is faster and uses less resources, especialy under Windows + // - a Thread Pool is used internaly to speed up HTTP/1.0 connections - a + // typical use, under Linux, is to run this class behind a NGINX frontend, + // configured as https reverse proxy, leaving default "proxy_http_version 1.0" + // and "proxy_request_buffering on" options for best performance, and + // setting KeepAliveTimeOut=0 in the THttpServer.Create constructor + // - under windows, will trigger the firewall UAC popup at first run + // - don't forget to use Free method when you are finished + THttpServer = class(THttpServerGeneric) + protected + /// used to protect Process() call + fProcessCS: TRTLCriticalSection; + fHeaderRetrieveAbortDelay: integer; + fThreadPool: TSynThreadPoolTHttpServer; + fInternalHttpServerRespList: {$ifdef FPC}TFPList{$else}TList{$endif}; + fServerConnectionCount: integer; + fServerConnectionActive: integer; + fServerKeepAliveTimeOut: cardinal; + fSockPort, fTCPPrefix: SockString; + fSock: TCrtSocket; + fThreadRespClass: THttpServerRespClass; + fOnSendFile: TOnHttpServerSendFile; + fNginxSendFileFrom: array of TFileName; + fHTTPQueueLength: cardinal; + fExecuteState: (esNotStarted, esBinding, esRunning, esFinished); + fStats: array[THttpServerSocketGetRequestResult] of integer; + fSocketClass: THttpServerSocketClass; + fHeadersNotFiltered: boolean; + fExecuteMessage: string; + function GetStat(one: THttpServerSocketGetRequestResult): integer; + function GetHTTPQueueLength: Cardinal; override; + procedure SetHTTPQueueLength(aValue: Cardinal); override; + procedure InternalHttpServerRespListAdd(resp: THttpServerResp); + procedure InternalHttpServerRespListRemove(resp: THttpServerResp); + function OnNginxAllowSend(Context: THttpServerRequest; const LocalFileName: TFileName): boolean; + // this overridden version will return e.g. 'Winsock 2.514' + function GetAPIVersion: string; override; + /// server main loop - don't change directly + procedure Execute; override; + /// this method is called on every new client connection, i.e. every time + // a THttpServerResp thread is created with a new incoming socket + procedure OnConnect; virtual; + /// this method is called on every client disconnection to update stats + procedure OnDisconnect; virtual; + /// override this function in order to low-level process the request; + // default process is to get headers, and call public function Request + procedure Process(ClientSock: THttpServerSocket; + ConnectionID: THttpServerConnectionID; ConnectionThread: TSynThread); virtual; + public + /// create a Server Thread, ready to be bound and listening on a port + // - this constructor will raise a EHttpServer exception if binding failed + // - expects the port to be specified as string, e.g. '1234'; you can + // optionally specify a server address to bind to, e.g. '1.2.3.4:1234' + // - can listed on UDS in case port is specified with 'unix:' prefix, e.g. + // 'unix:/run/myapp.sock' + // - on Linux in case aPort is empty string will check if external fd + // is passed by systemd and use it (so called systemd socked activation) + // - you can specify a number of threads to be initialized to handle + // incoming connections. Default is 32, which may be sufficient for most + // cases, maximum is 256. If you set 0, the thread pool will be disabled + // and one thread will be created for any incoming connection + // - you can also tune (or disable with 0) HTTP/1.1 keep alive delay and + // how incoming request Headers[] are pushed to the processing method + // - this constructor won't actually do the port binding, which occurs in + // the background thread: caller should therefore call WaitStarted after + // THttpServer.Create() + constructor Create(const aPort: SockString; OnStart,OnStop: TNotifyThreadEvent; + const ProcessName: SockString; ServerThreadPoolCount: integer=32; + KeepAliveTimeOut: integer=30000; HeadersUnFiltered: boolean=false; + CreateSuspended: boolean = false); reintroduce; virtual; + /// ensure the HTTP server thread is actually bound to the specified port + // - TCrtSocket.Bind() occurs in the background in the Execute method: you + // should call and check this method result just after THttpServer.Create + // - initial THttpServer design was to call Bind() within Create, which + // works fine on Delphi + Windows, but fails with a EThreadError on FPC/Linux + // - raise a ECrtSocket if binding failed within the specified period (if + // port is free, it would be almost immediate) + // - calling this method is optional, but if the background thread didn't + // actually bind the port, the server will be stopped and unresponsive with + // no explicit error message, until it is terminated + procedure WaitStarted(Seconds: integer = 30); virtual; + /// enable NGINX X-Accel internal redirection for HTTP_RESP_STATICFILE + // - will define internally a matching OnSendFile event handler + // - generating "X-Accel-Redirect: " header, trimming any supplied left + // case-sensitive file name prefix, e.g. with NginxSendFileFrom('/var/www'): + // $ # Will serve /var/www/protected_files/myfile.tar.gz + // $ # When passed URI /protected_files/myfile.tar.gz + // $ location /protected_files { + // $ internal; + // $ root /var/www; + // $ } + // - call this method several times to register several folders + procedure NginxSendFileFrom(const FileNameLeftTrim: TFileName); + /// release all memory and handlers + destructor Destroy; override; + /// by default, only relevant headers are added to internal headers list + // - for instance, Content-Length, Content-Type and Content-Encoding are + // stored as fields in this THttpSocket, but not included in its Headers[] + // - set this property to true to include all incoming headers + property HeadersNotFiltered: boolean read fHeadersNotFiltered; + /// access to the main server low-level Socket + // - it's a raw TCrtSocket, which only need a socket to be bound, listening + // and accept incoming request + // - THttpServerSocket are created on the fly for every request, then + // a THttpServerResp thread is created for handling this THttpServerSocket + property Sock: TCrtSocket read fSock; + /// custom event handler used to send a local file for HTTP_RESP_STATICFILE + // - see also NginxSendFileFrom() method + property OnSendFile: TOnHttpServerSendFile read fOnSendFile write fOnSendFile; + published + /// will contain the current number of connections to the server + property ServerConnectionActive: integer + read fServerConnectionActive write fServerConnectionActive; + /// will contain the total number of connections to the server + // - it's the global count since the server started + property ServerConnectionCount: integer + read fServerConnectionCount write fServerConnectionCount; + /// time, in milliseconds, for the HTTP/1.1 connections to be kept alive + // - default is 30000 ms, i.e. 30 seconds + // - setting 0 here (or in KeepAliveTimeOut constructor parameter) will + // disable keep-alive, and fallback to HTTP.1/0 for all incoming requests + // (may be a good idea e.g. behind a NGINX reverse proxy) + // - see THttpApiServer.SetTimeOutLimits(aIdleConnection) parameter + property ServerKeepAliveTimeOut: cardinal + read fServerKeepAliveTimeOut write fServerKeepAliveTimeOut; + /// the bound TCP port, as specified to Create() constructor + // - TCrtSocket.Bind() occurs in the Execute method + property SockPort: SockString read fSockPort; + /// TCP/IP prefix to mask HTTP protocol + // - if not set, will create full HTTP/1.0 or HTTP/1.1 compliant content + // - in order to make the TCP/IP stream not HTTP compliant, you can specify + // a prefix which will be put before the first header line: in this case, + // the TCP/IP stream won't be recognized as HTTP, and will be ignored by + // most AntiVirus programs, and increase security - but you won't be able + // to use an Internet Browser nor AJAX application for remote access any more + property TCPPrefix: SockString read fTCPPrefix write fTCPPrefix; + /// the associated thread pool + // - may be nil if ServerThreadPoolCount was 0 on constructor + property ThreadPool: TSynThreadPoolTHttpServer read fThreadPool; + /// milliseconds delay to reject a connection due to too long header retrieval + // - default is 0, i.e. not checked (typically not needed behind a reverse proxy) + property HeaderRetrieveAbortDelay: integer read fHeaderRetrieveAbortDelay write fHeaderRetrieveAbortDelay; + /// how many invalid HTTP headers have been rejected + property StatHeaderErrors: integer index grError read GetStat; + /// how many invalid HTTP headers raised an exception + property StatHeaderException: integer index grException read GetStat; + /// how many HTTP requests pushed more than MaximumAllowedContentLength bytes + property StatOversizedPayloads: integer index grOversizedPayload read GetStat; + /// how many HTTP requests were rejected by the OnBeforeBody event handler + property StatRejected: integer index grRejected read GetStat; + /// how many HTTP requests were rejected after HeaderRetrieveAbortDelay timeout + property StatHeaderTimeout: integer index grTimeout read GetStat; + /// how many HTTP headers have been processed + property StatHeaderProcessed: integer index grHeaderReceived read GetStat; + /// how many HTTP bodies have been processed + property StatBodyProcessed: integer index grBodyReceived read GetStat; + /// how many HTTP connections were passed to an asynchronous handler + // - e.g. for background WebSockets processing after proper upgrade + property StatOwnedConnections: integer index grOwned read GetStat; + end; + {$M-} + + /// structure used to parse an URI into its components + // - ready to be supplied e.g. to a THttpRequest sub-class + // - used e.g. by class function THttpRequest.Get() + // - will decode standard HTTP/HTTPS urls or Unix sockets URI like + // 'http://unix:/path/to/socket.sock:/url/path' + {$ifdef USERECORDWITHMETHODS}TURI = record + {$else}TURI = object{$endif} + public + /// if the server is accessible via https:// and not plain http:// + Https: boolean; + /// either cslTcp for HTTP/HTTPS or cslUnix for Unix socket URI + Layer: TCrtSocketLayer; + /// if the server is accessible via something else than http:// or https:// + // - e.g. 'ws' or 'wss' for ws:// or wss:// + Scheme: SockString; + /// the server name + // - e.g. 'www.somewebsite.com' or 'path/to/socket.sock' Unix socket URI + Server: SockString; + /// the server port + // - e.g. '80' + Port: SockString; + /// the resource address, including optional parameters + // - e.g. '/category/name/10?param=1' + Address: SockString; + /// fill the members from a supplied URI + // - recognize e.g. 'http://Server:Port/Address', 'https://Server/Address', + // 'Server/Address' (as http), or 'http://unix:/Server:/Address' + // - returns TRUE is at least the Server has been extracted, FALSE on error + function From(aURI: SockString; const DefaultPort: SockString=''): boolean; + /// compute the whole normalized URI + // - e.g. 'https://Server:Port/Address' or 'http://unix:/Server:/Address' + function URI: SockString; + /// the server port, as integer value + function PortInt: integer; + /// compute the root resource Address, without any URI-encoded parameter + // - e.g. '/category/name/10' + function Root: SockString; + /// reset all stored information + procedure Clear; + end; + + /// the supported authentication schemes which may be used by HTTP clients + // - supported only by TWinHTTP class yet + THttpRequestAuthentication = (wraNone,wraBasic,wraDigest,wraNegotiate); + + /// a record to set some extended options for HTTP clients + // - allow easy propagation e.g. from a TSQLHttpClient* wrapper class to + // the actual SynCrtSock's THttpRequest implementation class + THttpRequestExtendedOptions = record + /// let HTTPS be less paranoid about SSL certificates + // - IgnoreSSLCertificateErrors is handled by TWinHttp and TCurlHTTP + IgnoreSSLCertificateErrors: boolean; + /// allow HTTP authentication to take place at connection + // - Auth.Scheme and UserName/Password properties are handled + // by the TWinHttp class only by now + Auth: record + UserName: SockUnicode; + Password: SockUnicode; + Scheme: THttpRequestAuthentication; + end; + /// allow to customize the User-Agent header + UserAgent: SockString; + end; + + {$M+} // to have existing RTTI for published properties + /// abstract class to handle HTTP/1.1 request + // - never instantiate this class, but inherited TWinHTTP, TWinINet or TCurlHTTP + THttpRequest = class + protected + fServer: SockString; + fProxyName: SockString; + fProxyByPass: SockString; + fPort: cardinal; + fHttps: boolean; + fLayer: TCrtSocketLayer; + fKeepAlive: cardinal; + fExtendedOptions: THttpRequestExtendedOptions; + /// used by RegisterCompress method + fCompress: THttpSocketCompressRecDynArray; + /// set by RegisterCompress method + fCompressAcceptEncoding: SockString; + /// set index of protocol in fCompress[], from ACCEPT-ENCODING: header + fCompressAcceptHeader: THttpSocketCompressSet; + fTag: PtrInt; + class function InternalREST(const url,method,data,header: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString=nil; + outStatus: PInteger=nil): SockString; + // inherited class should override those abstract methods + procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); virtual; abstract; + procedure InternalCreateRequest(const aMethod,aURL: SockString); virtual; abstract; + procedure InternalSendRequest(const aMethod,aData: SockString); virtual; abstract; + function InternalRetrieveAnswer(var Header,Encoding,AcceptEncoding, + Data: SockString): integer; virtual; abstract; + procedure InternalCloseRequest; virtual; abstract; + procedure InternalAddHeader(const hdr: SockString); virtual; abstract; + public + /// returns TRUE if the class is actually supported on this system + class function IsAvailable: boolean; virtual; abstract; + /// connect to http://aServer:aPort or https://aServer:aPort + // - optional aProxyName may contain the name of the proxy server to use, + // and aProxyByPass an optional semicolon delimited list of host names or + // IP addresses, or both, that should not be routed through the proxy: + // aProxyName/aProxyByPass will be recognized by TWinHTTP and TWinINet, + // and aProxyName will set the CURLOPT_PROXY option to TCurlHttp + // (see https://curl.haxx.se/libcurl/c/CURLOPT_PROXY.html as reference) + // - you can customize the default client timeouts by setting appropriate + // SendTimeout and ReceiveTimeout parameters (in ms) - note that after + // creation of this instance, the connection is tied to the initial + // parameters, so we won't publish any properties to change those + // initial values once created - if you left the 0 default parameters, it + // would use global HTTP_DEFAULT_CONNECTTIMEOUT, HTTP_DEFAULT_SENDTIMEOUT + // and HTTP_DEFAULT_RECEIVETIMEOUT variable values + // - *TimeOut parameters are currently ignored by TCurlHttp + constructor Create(const aServer, aPort: SockString; aHttps: boolean; + const aProxyName: SockString=''; const aProxyByPass: SockString=''; + ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0; + aLayer: TCrtSocketLayer=cslTCP); overload; virtual; + /// connect to the supplied URI + // - is just a wrapper around TURI and the overloaded Create() constructor + constructor Create(const aURI: SockString; + const aProxyName: SockString=''; const aProxyByPass: SockString=''; + ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0; + aIgnoreSSLCertificateErrors: boolean=false); overload; + + /// low-level HTTP/1.1 request + // - after an Create(server,port), return 200,202,204 if OK, + // http status error otherwise + // - KeepAlive is in milliseconds, 0 for "Connection: Close" HTTP/1.0 requests + function Request(const url, method: SockString; KeepAlive: cardinal; + const InHeader, InData, InDataType: SockString; + out OutHeader, OutData: SockString): integer; virtual; + + /// wrapper method to retrieve a resource via an HTTP GET + // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), + // server name and port, and resource name + // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates + // - it will internally create a THttpRequest inherited instance: do not use + // THttpRequest.Get() but either TWinHTTP.Get(), TWinINet.Get() or + // TCurlHTTP.Get() methods + class function Get(const aURI: SockString; const aHeader: SockString=''; + aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; + outStatus: PInteger=nil): SockString; + /// wrapper method to create a resource via an HTTP POST + // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), + // server name and port, and resource name + // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates + // - the supplied aData content is POSTed to the server, with an optional + // aHeader content + // - it will internally create a THttpRequest inherited instance: do not use + // THttpRequest.Post() but either TWinHTTP.Post(), TWinINet.Post() or + // TCurlHTTP.Post() methods + class function Post(const aURI, aData: SockString; const aHeader: SockString=''; + aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; + outStatus: PInteger=nil): SockString; + /// wrapper method to update a resource via an HTTP PUT + // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), + // server name and port, and resource name + // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates + // - the supplied aData content is PUT to the server, with an optional + // aHeader content + // - it will internally create a THttpRequest inherited instance: do not use + // THttpRequest.Put() but either TWinHTTP.Put(), TWinINet.Put() or + // TCurlHTTP.Put() methods + class function Put(const aURI, aData: SockString; const aHeader: SockString=''; + aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; + outStatus: PInteger=nil): SockString; + /// wrapper method to delete a resource via an HTTP DELETE + // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), + // server name and port, and resource name + // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates + // - it will internally create a THttpRequest inherited instance: do not use + // THttpRequest.Delete() but either TWinHTTP.Delete(), TWinINet.Delete() or + // TCurlHTTP.Delete() methods + class function Delete(const aURI: SockString; const aHeader: SockString=''; + aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; + outStatus: PInteger=nil): SockString; + + /// will register a compression algorithm + // - used e.g. to compress on the fly the data, with standard gzip/deflate + // or custom (synlzo/synlz) protocols + // - returns true on success, false if this function or this + // ACCEPT-ENCODING: header was already registered + // - you can specify a minimal size (in bytes) before which the content won't + // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) + // - the first registered algorithm will be the prefered one for compression + function RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024): boolean; + + /// allows to ignore untrusted SSL certificates + // - similar to adding a security exception for a domain in the browser + property IgnoreSSLCertificateErrors: boolean + read fExtendedOptions.IgnoreSSLCertificateErrors + write fExtendedOptions.IgnoreSSLCertificateErrors; + /// optional Authentication Scheme + property AuthScheme: THttpRequestAuthentication + read fExtendedOptions.Auth.Scheme write fExtendedOptions.Auth.Scheme; + /// optional User Name for Authentication + property AuthUserName: SockUnicode + read fExtendedOptions.Auth.UserName write fExtendedOptions.Auth.UserName; + /// optional Password for Authentication + property AuthPassword: SockUnicode + read fExtendedOptions.Auth.Password write fExtendedOptions.Auth.Password; + /// custom HTTP "User Agent:" header value + property UserAgent: SockString + read fExtendedOptions.UserAgent write fExtendedOptions.UserAgent; + /// internal structure used to store extended options + // - will be replicated by IgnoreSSLCertificateErrors and Auth* properties + property ExtendedOptions: THttpRequestExtendedOptions + read fExtendedOptions write fExtendedOptions; + /// some internal field, which may be used by end-user code + property Tag: PtrInt read fTag write fTag; + published + /// the remote server host name, as stated specified to the class constructor + property Server: SockString read fServer; + /// the remote server port number, as specified to the class constructor + property Port: cardinal read fPort; + /// if the remote server uses HTTPS, as specified to the class constructor + property Https: boolean read fHttps; + /// the remote server optional proxy, as specified to the class constructor + property ProxyName: SockString read fProxyName; + /// the remote server optional proxy by-pass list, as specified to the class + // constructor + property ProxyByPass: SockString read fProxyByPass; + end; + {$M-} + + /// store the actual class of a HTTP/1.1 client instance + // - may be used to define at runtime which API to be used (e.g. WinHTTP, + // WinINet or LibCurl), following the Liskov substitution principle + THttpRequestClass = class of THttpRequest; + +{$ifdef USEWININET} + TWinHttpAPI = class; + + /// event callback to track download progress, e.g. in the UI + // - used in TWinHttpAPI.OnProgress property + // - CurrentSize is the current total number of downloaded bytes + // - ContentLength is retrieved from HTTP headers, but may be 0 if not set + TWinHttpProgress = procedure(Sender: TWinHttpAPI; + CurrentSize, ContentLength: DWORD) of object; + /// event callback to process the download by chunks, not in memory + // - used in TWinHttpAPI.OnDownload property + // - CurrentSize is the current total number of downloaded bytes + // - ContentLength is retrieved from HTTP headers, but may be 0 if not set + // - ChunkSize is the size of the latest downloaded chunk, available in + // the untyped ChunkData memory buffer + // - implementation should return TRUE to continue the download, or FALSE + // to abort the download process + TWinHttpDownload = function(Sender: TWinHttpAPI; + CurrentSize, ContentLength, ChunkSize: DWORD; const ChunkData): boolean of object; + /// event callback to track upload progress, e.g. in the UI + // - used in TWinHttpAPI.OnUpload property + // - CurrentSize is the current total number of uploaded bytes + // - ContentLength is the size of content + // - implementation should return TRUE to continue the upload, or FALSE + // to abort the upload process + TWinHttpUpload = function(Sender: TWinHttpAPI; + CurrentSize, ContentLength: DWORD): boolean of object; + + /// a class to handle HTTP/1.1 request using either WinINet or WinHTTP API + // - both APIs have a common logic, which is encapsulated by this parent class + // - this abstract class defined some abstract methods which will be + // implemented by TWinINet or TWinHttp with the proper API calls + TWinHttpAPI = class(THttpRequest) + protected + fOnProgress: TWinHttpProgress; + fOnDownload: TWinHttpDownload; + fOnUpload : TWinHttpUpload; + fOnDownloadChunkSize: cardinal; + /// used for internal connection + fSession, fConnection, fRequest: HINTERNET; + /// do not add "Accept: */*" HTTP header by default + fNoAllAccept: boolean; + function InternalGetInfo(Info: DWORD): SockString; virtual; abstract; + function InternalGetInfo32(Info: DWORD): DWORD; virtual; abstract; + function InternalQueryDataAvailable: DWORD; virtual; abstract; + function InternalReadData(var Data: SockString; Read: integer; + Size: cardinal): cardinal; virtual; abstract; + function InternalRetrieveAnswer( + var Header, Encoding, AcceptEncoding, Data: SockString): integer; override; + public + /// returns TRUE if the class is actually supported on this system + class function IsAvailable: boolean; override; + /// do not add "Accept: */*" HTTP header by default + property NoAllAccept: boolean read fNoAllAccept write fNoAllAccept; + /// download would call this method to notify progress of incoming data + property OnProgress: TWinHttpProgress read fOnProgress write fOnProgress; + /// download would call this method instead of filling Data: SockString value + // - may be used e.g. when downloading huge content, and saving directly + // the incoming data on disk or database + // - if this property is set, raw TCP/IP incoming data would be supplied: + // compression and encoding won't be handled by the class + property OnDownload: TWinHttpDownload read fOnDownload write fOnDownload; + /// upload would call this method to notify progress of outgoing data + // - and optionally abort sending the data by returning FALSE + property OnUpload : TWinHttpUpload read fOnUpload write fOnUpload; + /// how many bytes should be retrieved for each OnDownload event chunk + // - if default 0 value is left, would use 65536, i.e. 64KB + property OnDownloadChunkSize: cardinal + read fOnDownloadChunkSize write fOnDownloadChunkSize; + end; + + /// a class to handle HTTP/1.1 request using the WinINet API + // - The Microsoft Windows Internet (WinINet) application programming interface + // (API) enables applications to access standard Internet protocols, such as + // FTP and HTTP/HTTPS, similar to what IE offers + // - by design, the WinINet API should not be used from a service, since this + // API may require end-user GUI interaction + // - note: WinINet is MUCH slower than THttpClientSocket or TWinHttp: do not + // use this, only if you find some configuration benefit on some old networks + // (e.g. to diaplay the dialup popup window for a GUI client application) + TWinINet = class(TWinHttpAPI) + protected + // those internal methods will raise an EWinINet exception on error + procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; + procedure InternalCreateRequest(const aMethod,aURL: SockString); override; + procedure InternalCloseRequest; override; + procedure InternalAddHeader(const hdr: SockString); override; + procedure InternalSendRequest(const aMethod,aData: SockString); override; + function InternalGetInfo(Info: DWORD): SockString; override; + function InternalGetInfo32(Info: DWORD): DWORD; override; + function InternalQueryDataAvailable: DWORD; override; + function InternalReadData(var Data: SockString; Read: integer; + Size: cardinal): cardinal; override; + public + /// relase the connection + destructor Destroy; override; + end; + + /// WinINet exception type + EWinINet = class(ECrtSocket) + public + /// create a WinINet exception, with the error message as text + constructor Create; + end; + + /// a class to handle HTTP/1.1 request using the WinHTTP API + // - has a common behavior as THttpClientSocket() but seems to be faster + // over a network and is able to retrieve the current proxy settings + // (if available) and handle secure https connection - so it seems to be the + // class to use in your client programs + // - WinHTTP does not share any proxy settings with Internet Explorer. + // The WinHTTP proxy configuration is set by either + // $ proxycfg.exe + // on Windows XP and Windows Server 2003 or earlier, either + // $ netsh.exe + // on Windows Vista and Windows Server 2008 or later; for instance, + // you can run either: + // $ proxycfg -u + // $ netsh winhttp import proxy source=ie + // to use the current user's proxy settings for Internet Explorer (under 64-bit + // Vista/Seven, to configure applications using the 32 bit WinHttp settings, + // call netsh or proxycfg bits from %SystemRoot%\SysWOW64 folder explicitely) + // - Microsoft Windows HTTP Services (WinHTTP) is targeted at middle-tier and + // back-end server applications that require access to an HTTP client stack + TWinHTTP = class(TWinHttpAPI) + protected + // you can override this method e.g. to disable/enable some protocols + function InternalGetProtocols: cardinal; virtual; + // those internal methods will raise an EOSError exception on error + procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; + procedure InternalCreateRequest(const aMethod,aURL: SockString); override; + procedure InternalCloseRequest; override; + procedure InternalAddHeader(const hdr: SockString); override; + procedure InternalSendRequest(const aMethod,aData: SockString); override; + function InternalGetInfo(Info: DWORD): SockString; override; + function InternalGetInfo32(Info: DWORD): DWORD; override; + function InternalQueryDataAvailable: DWORD; override; + function InternalReadData(var Data: SockString; Read: integer; + Size: cardinal): cardinal; override; + public + /// relase the connection + destructor Destroy; override; + end; + + /// WinHTTP exception type + EWinHTTP = class(Exception); + + /// types of WebSocket buffers for winhttp.dll + // it is the different thing than WEB_SOCKET_BUFFER_TYPE for httpapi.dll + WINHTTP_WEB_SOCKET_BUFFER_TYPE = ULONG; + + /// A class to establish a client connection to a WebSocket server using Windows API + // - used by TWinWebSocketClient class + TWinHTTPUpgradeable = class(TWinHTTP) + private + fSocket: HINTERNET; + protected + function InternalRetrieveAnswer(var Header, Encoding, AcceptEncoding, + Data: SockString): integer; override; + procedure InternalSendRequest(const aMethod,aData: SockString); override; + public + /// initialize the instance + constructor Create(const aServer, aPort: SockString; aHttps: boolean; + const aProxyName: SockString=''; const aProxyByPass: SockString=''; + ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; + ReceiveTimeout: DWORD=0; aLayer: TCrtSocketLayer=cslTCP); override; + end; + + /// WebSocket client implementation + TWinHTTPWebSocketClient = class + protected + fSocket: HINTERNET; + function CheckSocket: Boolean; + public + /// initialize the instance + // - all parameters do match TWinHTTP.Create except url: address of WebSocketServer + // for sending upgrade request + constructor Create(const aServer, aPort: SockString; aHttps: boolean; + const url: SockString; const aSubProtocol: SockString = ''; + const aProxyName: SockString=''; const aProxyByPass: SockString=''; + ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0); + /// Send buffer + function Send(aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; aBuffer: pointer; + aBufferLength: DWORD): DWORD; + /// Receive buffer + function Receive(aBuffer: pointer; aBufferLength: DWORD; + out aBytesRead: DWORD; out aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; + /// Close current connection + function CloseConnection(const aCloseReason: SockString): DWORD; + destructor Destroy; override; + end; + +{$endif USEWININET} + +{$ifdef USELIBCURL} +type + /// libcurl exception type + ECurlHTTP = class(Exception); + + /// a class to handle HTTP/1.1 request using the libcurl library + // - libcurl is a free and easy-to-use cross-platform URL transfer library, + // able to directly connect via HTTP or HTTPS on most Linux systems + // - under a 32 bit Linux system, the libcurl library (and its dependencies, + // like OpenSSL) may not be installed - you can add it via your package + // manager, e.g. on Ubuntu: + // $ sudo apt-get install libcurl3 + // - under a 64-bit Linux system, if compiled with Kylix, you should install + // the 32-bit flavor of libcurl, e.g. on Ubuntu: + // $ sudo apt-get install libcurl3:i386 + // - will use in fact libcurl.so, so either libcurl.so.3 or libcurl.so.4, + // depending on the default version available on the system + TCurlHTTP = class(THttpRequest) + protected + fHandle: pointer; + fRootURL: SockString; + fIn: record + Headers: pointer; + DataOffset: integer; + URL, Method, Data: SockString; + end; + fOut: record + Header, Encoding, AcceptEncoding, Data: SockString; + end; + fSSL: record + CertFile, CACertFile, KeyName, PassPhrase: SockString; + end; + procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; + procedure InternalCreateRequest(const aMethod,aURL: SockString); override; + procedure InternalSendRequest(const aMethod,aData: SockString); override; + function InternalRetrieveAnswer(var Header,Encoding,AcceptEncoding, Data: SockString): integer; override; + procedure InternalCloseRequest; override; + procedure InternalAddHeader(const hdr: SockString); override; + function GetCACertFile: SockString; + procedure SetCACertFile(const aCertFile: SockString); + public + /// returns TRUE if the class is actually supported on this system + class function IsAvailable: boolean; override; + /// release the connection + destructor Destroy; override; + /// allow to set a CA certification file without touching the client certification + property CACertFile: SockString read GetCACertFile write SetCACertFile; + /// set the client SSL certification details + // - see CACertFile if you don't want to change the whole client cert info + // - used e.g. as + // ! UseClientCertificate('testcert.pem','cacert.pem','testkey.pem','pass'); + procedure UseClientCertificate( + const aCertFile, aCACertFile, aKeyName, aPassPhrase: SockString); + end; + +{$endif USELIBCURL} + + /// simple wrapper around THttpClientSocket/THttpRequest instances + // - this class will reuse the previous connection if possible, and select the + // best connection class available on this platform for a given URI + TSimpleHttpClient = class + protected + fHttp: THttpClientSocket; + fHttps: THttpRequest; + fProxy, fBody, fHeaders, fUserAgent: SockString; + fOnlyUseClientSocket, fIgnoreSSLCertificateErrors: boolean; + public + /// initialize the instance + constructor Create(aOnlyUseClientSocket: boolean=false); reintroduce; + /// finalize the connection + destructor Destroy; override; + /// low-level entry point of this instance + function RawRequest(const Uri: TURI; const Method, Header, Data, DataType: SockString; + KeepAlive: cardinal): integer; overload; + /// simple-to-use entry point of this instance + // - use Body and Headers properties to retrieve the HTTP body and headers + function Request(const uri: SockString; const method: SockString='GET'; + const header: SockString = ''; const data: SockString = ''; + const datatype: SockString = ''; keepalive: cardinal=10000): integer; overload; + /// returns the HTTP body as returned by a previous call to Request() + property Body: SockString read fBody; + /// returns the HTTP headers as returned by a previous call to Request() + property Headers: SockString read fHeaders; + /// allows to customize the user-agent header + property UserAgent: SockString read fUserAgent write fUserAgent; + /// allows to customize HTTPS connection and allow weak certificates + property IgnoreSSLCertificateErrors: boolean read fIgnoreSSLCertificateErrors + write fIgnoreSSLCertificateErrors; + /// alows to customize the connection using a proxy + property Proxy: SockString read fProxy write fProxy; + end; + + + +/// returns the best THttpRequest class, depending on the system it runs on +// - e.g. TWinHTTP or TCurlHTTP +// - consider using TSimpleHttpClient if you just need a simple connection +function MainHttpClass: THttpRequestClass; + +/// low-level forcing of another THttpRequest class +// - could be used if we found out that the current MainHttpClass failed (which +// could easily happen with TCurlHTTP if the library is missing or deprecated) +procedure ReplaceMainHttpClass(aClass: THttpRequestClass); + +/// create a TCrtSocket, returning nil on error +// (useful to easily catch socket error exception ECrtSocket) +function Open(const aServer, aPort: SockString; aTLS: boolean=false): TCrtSocket; + +/// create a THttpClientSocket, returning nil on error +// - useful to easily catch socket error exception ECrtSocket +function OpenHttp(const aServer, aPort: SockString; aTLS: boolean=false; + aLayer: TCrtSocketLayer = cslTCP): THttpClientSocket; overload; + +/// create a THttpClientSocket, returning nil on error +// - useful to easily catch socket error exception ECrtSocket +function OpenHttp(const aURI: SockString; aAddress: PSockString=nil): THttpClientSocket; overload; + +/// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method +// - this method will use a low-level THttpClientSock socket: if you want +// something able to use your computer proxy, take a look at TWinINet.Get() or +// the overloaded HttpGet() methods +function HttpGet(const server, port: SockString; const url: SockString; + const inHeaders: SockString; outHeaders: PSockString=nil; + aLayer: TCrtSocketLayer = cslTCP; outStatus: PInteger = nil): SockString; overload; + +/// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method +// - this method will use a low-level THttpClientSock socket for plain http URI, +// or TWinHTTP/TCurlHTTP for any https URI, or if forceNotSocket is set to true +function HttpGet(const aURI: SockString; outHeaders: PSockString=nil; + forceNotSocket: boolean=false; outStatus: PInteger=nil): SockString; overload; + +/// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method +// - this method will use a low-level THttpClientSock socket for plain http URI, +// or TWinHTTP/TCurlHTTP for any https URI +function HttpGet(const aURI: SockString; const inHeaders: SockString; + outHeaders: PSockString=nil; forceNotSocket: boolean=false; + outStatus: PInteger=nil): SockString; overload; + +/// retrieve the content of a web page, using HTTP/1.1 GET method and a token +// - this method will use a low-level THttpClientSock socket and its GetAuth method +// - if AuthToken<>'', will add an header with 'Authorization: Bearer '+AuthToken +function HttpGetAuth(const aURI, aAuthToken: SockString; + outHeaders: PSockString=nil; forceNotSocket: boolean=false; + outStatus: PInteger=nil): SockString; + +/// send some data to a remote web server, using the HTTP/1.1 protocol and POST method +function HttpPost(const server, port: SockString; const url, Data, DataType: SockString; + outData: PSockString=nil; const auth: SockString=''): boolean; + +/// send some data to a remote web server, using the HTTP/1.1 protocol and PUT method +function HttpPut(const server, port: SockString; const url, Data, DataType: SockString; + outData: PSockString=nil; const auth: SockString=''): boolean; + +/// compute the 'Authorization: Bearer ####' HTTP header of a given token value +function AuthorizationBearer(const AuthToken: SockString): SockString; + +/// compute the '1.2.3.4' text representation of a raw IP4 binary +procedure IP4Text(const ip4addr; var result: SockString); overload; + +/// compute the text representation of a IP4/IP6 low-level connection +procedure IPText(const sin: TVarSin; var result: SockString; + localasvoid: boolean=false); + +var + /// defines if a connection from the loopback should be reported as '' + // (no Remote-IP - which is the default) or as '127.0.0.1' (force to false) + // - used by both TCrtSock.AcceptRequest and THttpApiServer.Execute servers + RemoteIPLocalHostAsVoidInServers: boolean = true; + + +const + /// the layout of TSMTPConnection.FromText method + SMTP_DEFAULT = 'user:password@smtpserver:port'; + +type + /// may be used to store a connection to a SMTP server + // - see SendEmail() overloaded function + {$ifdef USERECORDWITHMETHODS}TSMTPConnection = record + {$else}TSMTPConnection = object{$endif} + public + /// the SMTP server IP or host name + Host: SockString; + /// the SMTP server port (25 by default) + Port: SockString; + /// the SMTP user login (if any) + User: SockString; + /// the SMTP user password (if any) + Pass: SockString; + /// fill the STMP server information from a single text field + // - expects 'user:password@smtpserver:port' format + // - if aText equals SMTP_DEFAULT ('user:password@smtpserver:port'), + // does nothing + function FromText(const aText: SockString): boolean; + end; + +/// send an email using the SMTP protocol +// - retry true on success +// - the Subject is expected to be in plain 7 bit ASCII, so you could use +// SendEmailSubject() to encode it as Unicode, if needed +// - you can optionally set the encoding charset to be used for the Text body +function SendEmail(const Server, From, CSVDest, Subject, Text: SockString; + const Headers: SockString=''; const User: SockString=''; const Pass: SockString=''; + const Port: SockString='25'; const TextCharSet: SockString = 'ISO-8859-1'; + aTLS: boolean=false): boolean; overload; + +/// send an email using the SMTP protocol +// - retry true on success +// - the Subject is expected to be in plain 7 bit ASCII, so you could use +// SendEmailSubject() to encode it as Unicode, if needed +// - you can optionally set the encoding charset to be used for the Text body, +// or even TextCharSet='JSON' to force application/json +function SendEmail(const Server: TSMTPConnection; + const From, CSVDest, Subject, Text: SockString; const Headers: SockString=''; + const TextCharSet: SockString = 'ISO-8859-1'; aTLS: boolean=false): boolean; overload; + +/// convert a supplied subject text into an Unicode encoding +// - will convert the text into UTF-8 and append '=?UTF-8?B?' +// - for pre-Unicode versions of Delphi, Text is expected to be already UTF-8 +// encoded - since Delphi 2010, it will be converted from UnicodeString +function SendEmailSubject(const Text: string): SockString; + +const + /// HTTP Status Code for "Success" + STATUS_SUCCESS = 200; + /// HTTP Status Code for "Created" + STATUS_CREATED = 201; + /// HTTP Status Code for "Accepted" + STATUS_ACCEPTED = 202; + /// HTTP Status Code for "No Content" + STATUS_NOCONTENT = 204; + /// HTTP Status Code for "Partial Content" + STATUS_PARTIALCONTENT = 206; + /// HTTP Status Code for "Not Modified" + STATUS_NOTMODIFIED = 304; + /// HTTP Status Code for "Bad Request" + STATUS_BADREQUEST = 400; + /// HTTP Status Code for "Unauthorized" + STATUS_UNAUTHORIZED = 401; + /// HTTP Status Code for "Forbidden" + STATUS_FORBIDDEN = 403; + /// HTTP Status Code for "Not Found" + STATUS_NOTFOUND = 404; + /// HTTP Status Code for "Not Acceptable" + STATUS_NOTACCEPTABLE = 406; + /// HTTP Status Code for "Payload Too Large" + STATUS_PAYLOADTOOLARGE = 413; + /// HTTP Status Code for "Internal Server Error" + STATUS_SERVERERROR = 500; + /// HTTP Status Code for "Not Implemented" + STATUS_NOTIMPLEMENTED = 501; + /// HTTP Status Code for "HTTP Version Not Supported" + STATUS_HTTPVERSIONNONSUPPORTED = 505; + +{$ifdef MSWINDOWS} + + /// can be used with THttpApiServer.AuthenticationSchemes to enable all schemes + HTTPAPI_AUTH_ENABLE_ALL = [hraBasic..hraKerberos]; + + /// the buffer contains the last, and possibly only, part of a UTF8 message + WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000000; + /// the buffer contains part of a UTF8 message + WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000001; + /// the buffer contains the last, and possibly only, part of a binary message + WEB_SOCKET_BINARY_MESSAGE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000002; + /// the buffer contains part of a binary message + WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000003; + /// the buffer contains a close message + WEB_SOCKET_CLOSE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000004; + /// the buffer contains a ping or pong message + // - when sending, this value means 'ping' + // - when processing received data, this value means 'pong' + WEB_SOCKET_PING_PONG_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000005; + /// the buffer contains an unsolicited pong message + WEB_SOCKET_UNSOLICITED_PONG_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000006; + + // https://msdn.microsoft.com/en-us/library/windows/desktop/hh449347 + WEB_SOCKET_MAX_CLOSE_REASON_LENGTH = 123; + /// Close completed successfully + WEB_SOCKET_SUCCESS_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1000; + /// The endpoint is going away and thus closing the connection + WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1001; + /// Peer detected protocol error and it is closing the connection + WEB_SOCKET_PROTOCOL_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1002; + /// The endpoint cannot receive this type of data + WEB_SOCKET_INVALID_DATA_TYPE_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1003; + /// No close status code was provided + WEB_SOCKET_EMPTY_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1005; + /// The connection was closed without sending or receiving a close frame + WEB_SOCKET_ABORTED_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1006; + /// Data within a message is not consistent with the type of the message + WEB_SOCKET_INVALID_PAYLOAD_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1007; + /// The message violates an endpoint's policy + WEB_SOCKET_POLICY_VIOLATION_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1008; + /// The message sent was too large to process + WEB_SOCKET_MESSAGE_TOO_BIG_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1009; + /// A client endpoint expected the server to negotiate one or more extensions, + // but the server didn't return them in the response message of the WebSocket handshake + WEB_SOCKET_UNSUPPORTED_EXTENSIONS_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1010; + /// An unexpected condition prevented the server from fulfilling the request + WEB_SOCKET_SERVER_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1011; + /// The TLS handshake could not be completed + WEB_SOCKET_SECURE_HANDSHAKE_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1015; + +{$endif MSWINDOWS} + +/// retrieve the HTTP reason text from a code +// - e.g. StatusCodeToReason(200)='OK' +// - see http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html +// - mORMot.StatusCodeToErrorMsg() will call this function +function StatusCodeToReason(Code: cardinal): SockString; + +/// retrieve the IP address from a computer name +function ResolveName(const Name: SockString; + Family: Integer=AF_INET; SockProtocol: Integer=IPPROTO_TCP; + SockType: integer=SOCK_STREAM): SockString; + +/// Base64 encoding of a string +// - used internally for STMP email sending +// - consider using more efficient BinToBase64() from SynCommons.pas instead +function SockBase64Encode(const s: SockString): SockString; + +/// Base64 decoding of a string +// - consider using more efficient Base64ToBin() from SynCommons.pas instead +function SockBase64Decode(const s: SockString): SockString; + +/// escaping of HTML codes like < > & " +function HtmlEncode(const s: SockString): SockString; + +/// decode a HTTP chunk length +function HttpChunkToHex32(p: PAnsiChar): integer; + +{$ifdef MSWINDOWS} + +/// remotly get the MAC address of a computer, from its IP Address +// - only works under Win2K and later +// - return the MAC address as a 12 hexa chars ('0050C204C80A' e.g.) +function GetRemoteMacAddress(const IP: SockString): SockString; + +{$else} + +/// returns how many files could be opened at once on this POSIX system +// - hard=true is for the maximum allowed limit, false for the current process +// - returns -1 if the getrlimit() API call failed +function GetFileOpenLimit(hard: boolean=false): integer; + +/// changes how many files could be opened at once on this POSIX system +// - hard=true is for the maximum allowed limit (requires root priviledges), +// false for the current process +// - returns the new value set (may not match the expected max value on error) +// - returns -1 if the getrlimit().setrlimit() API calls failed +// - for instance, to set the limit of the current process to its highest value: +// ! SetFileOpenLimit(GetFileOpenLimit(true)); +function SetFileOpenLimit(max: integer; hard: boolean=false): integer; + +{$endif MSWINDOWS} + +type + TIPAddress = (tiaAny, tiaPublic, tiaPrivate); + +/// enumerate all IP addresses of the current computer +// - may be used to enumerate all adapters +function GetIPAddresses(Kind: TIPAddress = tiaAny): TSockStringDynArray; + +/// returns all IP addresses of the current computer as a single CSV text +// - may be used to enumerate all adapters +function GetIPAddressesText(const Sep: SockString = ' '; + PublicOnly: boolean = false): SockString; + +type + /// interface name/address pairs as returned by GetMacAddresses + TMacAddress = record + /// contains e.g. 'eth0' on Linux + name: SockString; + /// contains e.g. '12:50:b6:1e:c6:aa' from /sys/class/net/eth0/adddress + address: SockString; + end; + TMacAddressDynArray = array of TMacAddress; + +/// enumerate all Mac addresses of the current computer +function GetMacAddresses: TMacAddressDynArray; + +/// enumerate all Mac addresses of the current computer as 'name1=addr1 name2=addr2' +function GetMacAddressesText: SockString; + +/// low-level text description of Socket error code +// - if Error is -1, will call WSAGetLastError to retrieve the last error code +function SocketErrorMessage(Error: integer=-1): string; + +/// low-level direct creation of a TSocket handle for TCP, UDP or UNIX layers +// - doBind=true will call Bind() to create a server socket instance +// - doBind=false will call Connect() to create a client socket instance +function CallServer(const Server, Port: SockString; doBind: boolean; + aLayer: TCrtSocketLayer; ConnectTimeout: DWORD): TSocket; + +/// retrieve the text-converted remote IP address of a client socket +function GetRemoteIP(aClientSock: TSocket): SockString; + +/// low-level direct shutdown of a given socket +procedure DirectShutdown(sock: TSocket; rdwr: boolean=false); + +/// low-level change of a socket to be in non-blocking mode +// - used e.g. by TPollAsynchSockets.Start +function AsynchSocket(sock: TSocket): boolean; + +/// low-level direct call of the socket recv() function +// - by-pass overriden blocking recv() e.g. in SynFPCSock, so will work if +// the socket is in non-blocking mode, as with AsynchSocket/TPollAsynchSockets +function AsynchRecv(sock: TSocket; buf: pointer; buflen: integer): integer; + +/// low-level direct call of the socket send() function +// - by-pass overriden blocking send() e.g. in SynFPCSock, so will work if +// the socket is in non-blocking mode, as with AsynchSocket/TPollAsynchSockets +function AsynchSend(sock: TSocket; buf: pointer; buflen: integer): integer; + + +{ ************ socket polling optimized for multiple connections } + +type + /// the events monitored by TPollSocketAbstract classes + // - we don't make any difference between urgent or normal read/write events + TPollSocketEvent = (pseRead, pseWrite, pseError, pseClosed); + + /// set of events monitored by TPollSocketAbstract classes + TPollSocketEvents = set of TPollSocketEvent; + + /// some opaque value (which may be a pointer) associated with a polling event + TPollSocketTag = type PtrInt; + + /// modifications notified by TPollSocketAbstract.WaitForModified + TPollSocketResult = record + /// the events which are notified + events: TPollSocketEvents; + /// opaque value as defined by TPollSocketAbstract.Subscribe + tag: TPollSocketTag; + end; + /// all modifications returned by TPollSocketAbstract.WaitForModified + TPollSocketResults = array of TPollSocketResult; + + {$M+} + /// abstract parent class for efficient socket polling + // - works like Linux epoll API in level-triggered (LT) mode + // - implements libevent-like cross-platform features + // - use PollSockClass global function to retrieve the best class depending + // on the running Operating System + TPollSocketAbstract = class + protected + fCount: integer; + fMaxSockets: integer; + public + /// class function factory, returning a socket polling instance matching + // at best the current operating system + // - returns a TPollSocketSelect/TPollSocketPoll instance under Windows, + // a TPollSocketEpoll instance under Linux, or a TPollSocketPoll on BSD + // - just a wrapper around PollSockClass.Create + class function New: TPollSocketAbstract; + /// initialize the polling + constructor Create; virtual; + /// track status modifications on one specified TSocket + // - you can specify which events are monitored - pseError and pseClosed + // will always be notified + // - tag parameter will be returned as TPollSocketResult - you may set + // here the socket file descriptor value, or a transtyped class instance + // - similar to epoll's EPOLL_CTL_ADD control interface + function Subscribe(socket: TSocket; events: TPollSocketEvents; + tag: TPollSocketTag): boolean; virtual; abstract; + /// stop status modifications tracking on one specified TSocket + // - the socket should have been monitored by a previous call to Subscribe() + // - on success, returns true and fill tag with the associated opaque value + // - similar to epoll's EPOLL_CTL_DEL control interface + function Unsubscribe(socket: TSocket): boolean; virtual; abstract; + /// waits for status modifications of all tracked TSocket + // - will wait up to timeoutMS milliseconds, 0 meaning immediate return + // and -1 for infinite blocking + // - returns -1 on error (e.g. no TSocket currently registered), or + // the number of modifications stored in results[] (may be 0 if none) + function WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; virtual; abstract; + published + /// how many TSocket instances could be tracked, at most + // - depends on the API used + property MaxSockets: integer read fMaxSockets; + /// how many TSocket instances are currently tracked + property Count: integer read fCount; + end; + {$M-} + + /// meta-class of TPollSocketAbstract socket polling classes + // - since TPollSocketAbstract.Create is declared as virtual, could be used + // to specify the proper polling class to add + // - see PollSockClass function and TPollSocketAbstract.New method + TPollSocketClass = class of TPollSocketAbstract; + +/// returns the TPollSocketAbstract class best fitting with the current +// Operating System +// - as used by TPollSocketAbstract.New method +function PollSocketClass: TPollSocketClass; + +type + {$ifdef MSWINDOWS} + /// socket polling via Windows' Select() API + // - under Windows, Select() handles up to 64 TSocket, and is available + // in Windows XP, whereas WSAPoll() is available only since Vista + // - under Linux, select() is very limited, so poll/epoll APIs are to be used + // - in practice, TPollSocketSelect is slighlty FASTER than TPollSocketPoll + // when tracking a lot of connections (at least under Windows): WSAPoll() + // seems to be just an emulation API - very disapointing :( + TPollSocketSelect = class(TPollSocketAbstract) + protected + fHighestSocket: integer; + fRead: TFDSet; + fWrite: TFDSet; + fTag: array[0..FD_SETSIZE-1] of record + socket: TSocket; + tag: TPollSocketTag; + end; + public + /// initialize the polling via creating an epoll file descriptor + constructor Create; override; + /// track status modifications on one specified TSocket + // - you can specify which events are monitored - pseError and pseClosed + // will always be notified + function Subscribe(socket: TSocket; events: TPollSocketEvents; + tag: TPollSocketTag): boolean; override; + /// stop status modifications tracking on one specified TSocket + // - the socket should have been monitored by a previous call to Subscribe() + function Unsubscribe(socket: TSocket): boolean; override; + /// waits for status modifications of all tracked TSocket + // - will wait up to timeoutMS milliseconds, 0 meaning immediate return + // and -1 for infinite blocking + // - returns -1 on error (e.g. no TSocket currently registered), or + // the number of modifications stored in results[] (may be 0 if none) + function WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; override; + end; + {$endif MSWINDOWS} + + /// socket polling via poll/WSAPoll API + // - direct call of the Linux/POSIX poll() API, or Windows WSAPoll() API + TPollSocketPoll = class(TPollSocketAbstract) + protected + fFD: TPollFDDynArray; // fd=-1 for ignored fields + fTags: array of TPollSocketTag; + fFDCount: integer; + procedure FDVacuum; + public + /// initialize the polling using poll/WSAPoll API + constructor Create; override; + /// track status modifications on one specified TSocket + // - you can specify which events are monitored - pseError and pseClosed + // will always be notified + function Subscribe(socket: TSocket; events: TPollSocketEvents; + tag: TPollSocketTag): boolean; override; + /// stop status modifications tracking on one specified TSocket + // - the socket should have been monitored by a previous call to Subscribe() + function Unsubscribe(socket: TSocket): boolean; override; + /// waits for status modifications of all tracked TSocket + // - will wait up to timeoutMS milliseconds, 0 meaning immediate return + // and -1 for infinite blocking + // - returns -1 on error (e.g. no TSocket currently registered), or + // the number of modifications stored in results[] (may be 0 if none) + function WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; override; + end; + + {$ifdef LINUXNOTBSD} + /// socket polling via Linux epoll optimized API + // - not available under Windows or BSD/Darwin + // - direct call of the epoll API in level-triggered (LT) mode + // - only available on Linux - use TPollSocketPoll for using cross-plaform + // poll/WSAPoll API + TPollSocketEpoll = class(TPollSocketAbstract) + protected + fEPFD: integer; + fResults: TEPollEventDynArray; + public + /// initialize the polling via creating an epoll file descriptor + constructor Create; override; + /// finalize the polling by closing the epoll file descriptor + destructor Destroy; override; + /// track status modifications on one specified TSocket + // - you can specify which events are monitored - pseError and pseClosed + // will always be notified + // - directly calls epoll's EPOLL_CTL_ADD control interface + function Subscribe(socket: TSocket; events: TPollSocketEvents; + tag: TPollSocketTag): boolean; override; + /// stop status modifications tracking on one specified TSocket + // - the socket should have been monitored by a previous call to Subscribe() + // - directly calls epoll's EPOLL_CTL_DEL control interface + function Unsubscribe(socket: TSocket): boolean; override; + /// waits for status modifications of all tracked TSocket + // - will wait up to timeoutMS milliseconds, 0 meaning immediate return + // and -1 for infinite blocking + // - returns -1 on error (e.g. no TSocket currently registered), or + // the number of modifications stored in results[] (may be 0 if none) + // - directly calls epool_wait() function + function WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; override; + /// read-only access to the low-level epoll_create file descriptor + property EPFD: integer read fEPFD; + end; + {$endif LINUXNOTBSD} + +type + {$M+} + /// implements efficient polling of multiple sockets + // - will maintain a pool of TPollSocketAbstract instances, to monitor + // incoming data or outgoing availability for a set of active connections + // - call Subscribe/Unsubscribe to setup the monitored sockets + // - call GetOne from any consumming threads to process new events + TPollSockets = class + protected + fPollClass: TPollSocketClass; + fPoll: array of TPollSocketAbstract; + fPollIndex: integer; + fPending: TPollSocketResults; + fPendingIndex: integer; + fTerminated: boolean; + fCount: integer; + fPollLock: TRTLCriticalSection; + fPendingLock: TRTLCriticalSection; + public + /// initialize the sockets polling + // - you can specify the TPollSocketAbsract class to be used, if the + // default is not the one expected + // - under Linux/POSIX, will set the open files maximum number for the + // current process to match the system hard limit: if your system has a + // low "ulimit -H -n" value, you may add the following line in your + // /etc/limits.conf or /etc/security/limits.conf file: + // $ * hard nofile 65535 + constructor Create(aPollClass: TPollSocketClass=nil); + /// finalize the sockets polling, and release all used memory + destructor Destroy; override; + /// track modifications on one specified TSocket and tag + // - the supplied tag value - maybe a PtrInt(aObject) - will be part of + // GetOne method results + // - will create as many TPollSocketAbstract instances as needed, depending + // on the MaxSockets capability of the actual implementation class + // - this method is thread-safe + function Subscribe(socket: TSocket; tag: TPollSocketTag; + events: TPollSocketEvents): boolean; virtual; + /// stop status modifications tracking on one specified TSocket and tag + // - the socket should have been monitored by a previous call to Subscribe() + // - this method is thread-safe + function Unsubscribe(socket: TSocket; tag: TPollSocketTag): boolean; virtual; + /// retrieve the next pending notification, or let the poll wait for new + // - if there is no pending notification, will poll and wait up to + // timeoutMS milliseconds for pending data + // - returns true and set notif.events/tag with the corresponding notification + // - returns false if no pending event was handled within the timeoutMS period + // - this method is thread-safe, and could be called from several threads + function GetOne(timeoutMS: integer; out notif: TPollSocketResult): boolean; virtual; + /// retrieve the next pending notification + // - returns true and set notif.events/tag with the corresponding notification + // - returns false if no pending event is available + // - this method is thread-safe, and could be called from several threads + function GetOneWithinPending(out notif: TPollSocketResult): boolean; + /// notify any GetOne waiting method to stop its polling loop + procedure Terminate; + /// the actual polling class used to track socket state changes + property PollClass: TPollSocketClass read fPollClass; + /// set to true by the Terminate method + property Terminated: boolean read fTerminated; + published + /// how many sockets are currently tracked + property Count: integer read fCount; + end; + {$M-} + + /// store information of one TPollAsynchSockets connection + {$ifdef USERECORDWITHMETHODS}TPollSocketsSlot = record + {$else}TPollSocketsSlot = object{$endif} + /// the associated TCP connection + // - equals 0 after TPollAsynchSockets.Stop + socket: TSocket; + /// Lock/Unlock R/W thread acquisition (lighter than a TRTLCriticalSection) + lockcounter: array[boolean] of integer; + /// the last error reported by WSAGetLastError before the connection ends + lastWSAError: integer; + /// the current read data buffer of this slot + readbuf: SockString; + /// the current write data buffer of this slot + writebuf: SockString; + /// acquire an exclusive R/W access to this connection + // - returns true if slot has been acquired + // - returns false if it is used by another thread + // - warning: this method is not re-entrant + function Lock(writer: boolean): boolean; + /// try to acquire an exclusive R/W access to this connection + // - returns true if slot has been acquired + // - returns false if it is used by another thread, after the timeoutMS period + // - warning: this method is not re-entrant + function TryLock(writer: boolean; timeoutMS: cardinal): boolean; + /// release exclusive R/W access to this connection + procedure UnLock(writer: boolean); + end; + /// points to thread-safe information of one TPollAsynchSockets connection + PPollSocketsSlot = ^TPollSocketsSlot; + + /// possible options for TPollAsynchSockets process + // - by default, TPollAsynchSockets.Write will first try to send the data + // using Send() in non-blocking mode, unless paoWritePollOnly is defined, + // and fWrite will be used to poll output state and send it asynchronously + TPollAsynchSocketsOptions = set of (paoWritePollOnly); + + /// let TPollAsynchSockets.OnRead shutdown the socket if needed + TPollAsynchSocketOnRead = (sorContinue, sorClose); + + {$M+} + /// read/write buffer-oriented process of multiple non-blocking connections + // - to be used e.g. for stream protocols (e.g. WebSockets or IoT communication) + // - assigned sockets will be set in non-blocking mode, so that polling will + // work as expected: you should then never use direclty the socket (e.g. via + // blocking TCrtSocket), but rely on this class for asynchronous process: + // OnRead() overriden method will receive all incoming data from input buffer, + // and Write() should be called to add some data to asynchronous output buffer + // - connections are identified as TObject instances, which should hold a + // TPollSocketsSlot record as private values for the polling process + // - ProcessRead/ProcessWrite methods are to be run for actual communication: + // either you call those methods from multiple threads, or you run them in + // loop from a single thread, then define a TSynThreadPool for running any + // blocking process (e.g. computing requests answers) from OnRead callbacks + // - inherited classes should override abstract OnRead, OnClose, OnError and + // SlotFromConnection methods according to the actual connection class + TPollAsynchSockets = class + protected + fRead: TPollSockets; + fWrite: TPollSockets; + fReadCount: integer; + fWriteCount: integer; + fReadBytes: Int64; + fWriteBytes: Int64; + fProcessing: integer; + fOptions: TPollAsynchSocketsOptions; + function GetCount: integer; + // warning: abstract methods below should be properly overriden + // return low-level socket information from connection instance + function SlotFromConnection(connection: TObject): PPollSocketsSlot; virtual; abstract; + // extract frames from slot.readbuf, and handle them + function OnRead(connection: TObject): TPollAsynchSocketOnRead; virtual; abstract; + // called when slot.writebuf has been sent through the socket + procedure AfterWrite(connection: TObject); virtual; abstract; + // pseClosed: should do connection.free - Stop() has been called (socket=0) + procedure OnClose(connection: TObject); virtual; abstract; + // pseError: return false to close socket and connection (calling OnClose) + function OnError(connection: TObject; events: TPollSocketEvents): boolean; virtual; abstract; + public + /// initialize the read/write sockets polling + // - fRead and fWrite TPollSocketsBuffer instances will track pseRead or + // pseWrite events, and maintain input and output data buffers + constructor Create; virtual; + /// finalize buffer-oriented sockets polling, and release all used memory + destructor Destroy; override; + /// assign a new connection to the internal poll + // - the TSocket handle will be retrieved via SlotFromConnection, and + // set in non-blocking mode from now on - it is not recommended to access + // it directly any more, but use Write() and handle OnRead() callback + // - fRead will poll incoming packets, then call OnRead to handle them, + // or Unsubscribe and delete the socket when pseClosed is notified + // - fWrite will poll for outgoing packets as specified by Write(), then + // send any pending data once the socket is ready + function Start(connection: TObject): boolean; virtual; + /// remove a connection from the internal poll, and shutdown its socket + // - most of the time, the connection is released by OnClose when the other + // end shutdown the socket; but you can explicitely call this method when + // the connection (and its socket) is to be shutdown + // - this method won't call OnClose, since it is initiated by the class + function Stop(connection: TObject): boolean; virtual; + /// add some data to the asynchronous output buffer of a given connection + // - this method may block if the connection is currently writing from + // another thread (which is not possible from TPollAsynchSockets.Write), + // up to timeout milliseconds + function Write(connection: TObject; const data; datalen: integer; + timeout: integer=5000): boolean; virtual; + /// add some data to the asynchronous output buffer of a given connection + function WriteString(connection: TObject; const data: SockString): boolean; + /// one or several threads should execute this method + // - thread-safe handle of any incoming packets + // - if this method is called from a single thread, you should use + // a TSynThreadPool for any blocking process of OnRead events + // - otherwise, this method is thread-safe, and incoming packets may be + // consumed from a set of threads, and call OnRead with newly received data + procedure ProcessRead(timeoutMS: integer); + /// one or several threads should execute this method + // - thread-safe handle of any outgoing packets + procedure ProcessWrite(timeoutMS: integer); + /// notify internal socket polls to stop their polling loop ASAP + procedure Terminate(waitforMS: integer); + /// low-level access to the polling class used for incoming data + property PollRead: TPollSockets read fRead; + /// low-level access to the polling class used for outgoind data + property PollWrite: TPollSockets write fWrite; + /// some processing options + property Options: TPollAsynchSocketsOptions read fOptions write fOptions; + published + /// how many connections are currently managed by this instance + property Count: integer read GetCount; + /// how many times data has been received by this instance + property ReadCount: integer read fReadCount; + /// how many times data has been sent by this instance + property WriteCount: integer read fWriteCount; + /// how many data bytes have been received by this instance + property ReadBytes: Int64 read fReadBytes; + /// how many data bytes have been sent by this instance + property WriteBytes: Int64 read fWriteBytes; + end; + {$M-} + + +function SysErrorMessagePerModule(Code: DWORD; ModuleName: PChar): string; + +{$ifdef MSWINDOWS} +/// is HTTP.SYS web socket API available on the target system Windows 8 and UP +function WinHTTP_WebSocketEnabled: boolean; +{$endif} + +var + /// Queue length for completely established sockets waiting to be accepted, + // a backlog parameter for listen() function. If queue overflows client + // got ECONNREFUSED error for connect() call + // - for windows default is taken from SynWinSock ($7fffffff) and should + // not be modified. Actual limit is 200; + // - for Unix default is taken from SynFPCSock (128 as in linux kernel >2.2), + // but actual value is min(DefaultListenBacklog, /proc/sys/net/core/somaxconn) + DefaultListenBacklog: integer = SOMAXCONN; + + +implementation + +{ ************ some shared helper functions and classes } + +var + ReasonCache: array[1..5,0..13] of SockString; // avoid memory allocation + +function StatusCodeToReasonInternal(Code: cardinal): SockString; +begin + case Code of + 100: result := 'Continue'; + 101: result := 'Switching Protocols'; + 200: result := 'OK'; + 201: result := 'Created'; + 202: result := 'Accepted'; + 203: result := 'Non-Authoritative Information'; + 204: result := 'No Content'; + 205: result := 'Reset Content'; + 206: result := 'Partial Content'; + 207: result := 'Multi-Status'; + 300: result := 'Multiple Choices'; + 301: result := 'Moved Permanently'; + 302: result := 'Found'; + 303: result := 'See Other'; + 304: result := 'Not Modified'; + 305: result := 'Use Proxy'; + 307: result := 'Temporary Redirect'; + 308: result := 'Permanent Redirect'; + 400: result := 'Bad Request'; + 401: result := 'Unauthorized'; + 403: result := 'Forbidden'; + 404: result := 'Not Found'; + 405: result := 'Method Not Allowed'; + 406: result := 'Not Acceptable'; + 407: result := 'Proxy Authentication Required'; + 408: result := 'Request Timeout'; + 409: result := 'Conflict'; + 410: result := 'Gone'; + 411: result := 'Length Required'; + 412: result := 'Precondition Failed'; + 413: result := 'Payload Too Large'; + 414: result := 'URI Too Long'; + 415: result := 'Unsupported Media Type'; + 416: result := 'Requested Range Not Satisfiable'; + 426: result := 'Upgrade Required'; + 500: result := 'Internal Server Error'; + 501: result := 'Not Implemented'; + 502: result := 'Bad Gateway'; + 503: result := 'Service Unavailable'; + 504: result := 'Gateway Timeout'; + 505: result := 'HTTP Version Not Supported'; + 511: result := 'Network Authentication Required'; + else result := 'Invalid Request'; + end; +end; + +function StatusCodeToReason(Code: cardinal): SockString; +var Hi,Lo: cardinal; +begin + if Code=200 then begin // optimistic approach :) + Hi := 2; + Lo := 0; + end else begin + Hi := Code div 100; + Lo := Code-Hi*100; + if not ((Hi in [1..5]) and (Lo in [0..13])) then begin + result := StatusCodeToReasonInternal(Code); + exit; + end; + end; + result := ReasonCache[Hi,Lo]; + if result<>'' then + exit; + result := StatusCodeToReasonInternal(Code); + ReasonCache[Hi,Lo] := result; +end; + +function Hex2Dec(c: integer): integer; {$ifdef HASINLINE}inline;{$endif} +begin + result := c; + case c of + ord('A')..ord('Z'): dec(result,(ord('A') - 10)); + ord('a')..ord('z'): dec(result,(ord('a') - 10)); + ord('0')..ord('9'): dec(result,ord('0')); + else result := -1; + end; +end; + +function SockBase64Encode(const s: SockString): SockString; + procedure Encode(rp, sp: PAnsiChar; len: integer); + const + b64: array[0..63] of AnsiChar = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + var i: integer; + c: cardinal; + begin + for i := 1 to len div 3 do begin + c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]); + rp[0] := b64[(c shr 18) and $3f]; + rp[1] := b64[(c shr 12) and $3f]; + rp[2] := b64[(c shr 6) and $3f]; + rp[3] := b64[c and $3f]; + inc(rp,4); + inc(sp,3); + end; + case len mod 3 of + 1: begin + c := ord(sp[0]) shl 16; + rp[0] := b64[(c shr 18) and $3f]; + rp[1] := b64[(c shr 12) and $3f]; + rp[2] := '='; + rp[3] := '='; + end; + 2: begin + c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8; + rp[0] := b64[(c shr 18) and $3f]; + rp[1] := b64[(c shr 12) and $3f]; + rp[2] := b64[(c shr 6) and $3f]; + rp[3] := '='; + end; + end; + end; +var len: integer; +begin + result:=''; + len := length(s); + if len = 0 then exit; + SetLength(result, ((len + 2) div 3) * 4); + Encode(pointer(result),pointer(s),len); +end; + +function SockBase64Decode(const s: SockString): SockString; +var i, j, len: integer; + sp, rp: PAnsiChar; + c, ch: integer; +begin + result:= ''; + len := length(s); + if (len <= 0) or (len and 3 <> 0) then + exit; + len := len shr 2; + SetLength(result, len * 3); + sp := pointer(s); + rp := pointer(result); + for i := 1 to len do begin + c := 0; + j := 0; + while true do begin + ch := ord(sp[j]); + case chr(ch) of + 'A'..'Z': c := c or (ch - ord('A')); + 'a'..'z': c := c or (ch - (ord('a')-26)); + '0'..'9': c := c or (ch - (ord('0')-52)); + '+': c := c or 62; + '/': c := c or 63; + else + if j=3 then begin + rp[0] := AnsiChar(c shr 16); + rp[1] := AnsiChar(c shr 8); + SetLength(result, len*3-1); + exit; + end else begin + rp[0] := AnsiChar(c shr 10); + SetLength(result, len*3-2); + exit; + end; + end; + if j=3 then break; + inc(j); + c := c shl 6; + end; + rp[2] := AnsiChar(c); + c := c shr 8; + rp[1] := AnsiChar(c); + c := c shr 8; + rp[0] := AnsiChar(c); + inc(rp,3); + inc(sp,4); + end; +end; + +function HtmlEncode(const s: SockString): SockString; +var i: integer; +begin // not very fast, but working + result := ''; + for i := 1 to length(s) do + case s[i] of + '<': result := result+'<'; + '>': result := result+'>'; + '&': result := result+'&'; + '"': result := result+'"'; + else result := result+s[i]; + end; +end; + +function HtmlEncodeString(const s: string): string; +var i: integer; +begin // not very fast, but working + result := ''; + for i := 1 to length(s) do + case s[i] of + '<': result := result+'<'; + '>': result := result+'>'; + '&': result := result+'&'; + '"': result := result+'"'; + else result := result+s[i]; + end; +end; + +const + CRLF: array[0..1] of AnsiChar = (#13,#10); + +function StrLen(S: PAnsiChar): PtrInt; +{$ifdef CPUX64} +{$ifdef FPC}nostackframe; assembler; asm {$else} +asm .noframe // rcx=S (Linux: rdi) +{$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize + {$ifdef win64} + mov rax, rcx // get pointer to string from rcx + mov r8, rcx // copy pointer + test rcx, rcx + {$else} + mov rax, rdi + mov ecx, edi + test rdi, rdi + {$endif} + jz @null // returns 0 if S=nil + // rax=s,ecx=32-bit of s + pxor xmm0, xmm0 // set to zero + and ecx, 15 // lower 4 bits indicate misalignment + and rax, -16 // align pointer by 16 + // will never read outside a memory page boundary, so won't trigger GPF + movaps xmm1, [rax] // read from nearest preceding boundary + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + shr edx, cl // shift out false bits + shl edx, cl // shift back again + bsf edx, edx // find first 1-bit + jnz @L2 // found + // Main loop, search 16 bytes at a time +{$ifdef FPC} align 16 {$else} .align 16 {$endif} +@L1: add rax, 10H // increment pointer by 16 + movaps xmm1, [rax] // read 16 bytes aligned + pcmpeqb xmm1, xmm0 // compare 16 bytes with zero + pmovmskb edx, xmm1 // get one bit for each byte result + bsf edx, edx // find first 1-bit + // (moving the bsf out of the loop and using test here would be faster + // for long strings on old processors, but we are assuming that most + // strings are short, and newer processors have higher priority) + jz @L1 // loop if not found +@L2: // Zero-byte found. Compute string length + {$ifdef win64} + sub rax, r8 // subtract start address + {$else} + sub rax, rdi + {$endif} + add rax, rdx // add byte index +@null: +end; +{$else} +begin + result := 0; + if S<>nil then + while true do + if S[0]<>#0 then + if S[1]<>#0 then + if S[2]<>#0 then + if S[3]<>#0 then begin + inc(S,4); + inc(result,4); + end else begin + inc(result,3); + exit; + end else begin + inc(result,2); + exit; + end else begin + inc(result); + exit; + end else + exit; +end; +{$endif CPUX64} + +type + TNormToUpper = array[byte] of byte; + PPByteArray = ^PByteArray; +var + NormToUpper: TNormToUpper; + +function IdemPCharUp(p: PByteArray; up: PByte; toup: PByteArray): boolean; + {$ifdef HASINLINE}inline;{$endif} +var u: byte; +begin + result := false; + dec(PtrUInt(p),PtrUInt(up)); + repeat + u := up^; + if u=0 then + break; + if toup[p[PtrUInt(up)]]<>u then + exit; + inc(up); + until false; + result := true; +end; + +function IdemPChar(p, up: pAnsiChar): boolean; +// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) +begin + if p=nil then + result := false else + if up=nil then + result := true else + result := IdemPCharUp(pointer(p),pointer(up),@NormToUpper); +end; + +function IdemPCharArray(p: PAnsiChar; const upArray: array of PAnsiChar): integer; +var w: word; + toup: PByteArray; + up: ^PAnsiChar; +begin + if p<>nil then begin + toup := @NormToUpper; + w := toup[ord(p[0])]+toup[ord(p[1])]shl 8; + up := @upArray[0]; + for result := 0 to high(upArray) do + if (PWord(up^)^=w) and IdemPCharUp(pointer(p+2),pointer(up^+2),toup) then + exit else + inc(up); + end; + result := -1; +end; + +procedure GetNextItem(var P: PAnsiChar; Sep: AnsiChar; var result: SockString); +// return next CSV string in P, nil if no more +var S: PAnsiChar; +begin + if P=nil then + result := '' else begin + S := P; + while (S^<>#0) and (S^<>Sep) do + inc(S); + SetString(result,P,S-P); + if S^<>#0 then + P := S+1 else + P := nil; + end; +end; + +function SameText(const a,b: SockString): boolean; +var n,i: integer; +begin + result := false; + n := length(a); + if length(b)<>n then + exit; + for i := 1 to n do + if NormToUpper[ord(a[i])]<>NormToUpper[ord(b[i])] then + exit; + result := true; +end; + +function GetNextItemUInt64(var P: PAnsiChar): ULONGLONG; +var c: PtrUInt; +begin + result := 0; + if P<>nil then + repeat + c := byte(P^)-48; + if c>9 then + break else + result := result*10+ULONGLONG(c); + inc(P); + until false; +end; // P^ will point to the first non digit char + +procedure GetNextLine(var P: PAnsiChar; var result: SockString); +var S: PAnsiChar; +begin + if P=nil then + result := '' else begin + S := P; + while S^>=' ' do // break on any control char + inc(S); + SetString(result,P,S-P); + while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 + if S^<>#0 then + P := S else + P := nil; + end; +end; + +// rewrite some functions to avoid unattempted ansi<->unicode conversion + +function PosCh(ch: AnsiChar; const s: SockString): PtrInt; + {$ifdef HASINLINE}inline;{$endif} +begin // Pos() overloads are quite cumbersome on Delphi/FPC + for result := 1 to length(s) do + if s[result]=ch then + exit; + result := 0; +end; + +procedure TrimCopy(const S: SockString; start,count: PtrInt; + out result: SockString); // faster alternative to Trim(copy()) +var L: PtrInt; +begin + if count<=0 then + exit; + if start<=0 then + start := 1; + L := Length(S); + while (start<=L) and (S[start]<=' ') do begin + inc(start); dec(count); end; + dec(start); + dec(L,start); + if count0 do + if S[start+L]<=' ' then + dec(L) else + break; + if L>0 then + SetString(result,PAnsiChar(@PByteArray(S)[start]),L); +end; + +{$ifdef FPC_OR_PUREPASCAL} +function Trim(const S: SockString): SockString; +var i, L: PtrInt; +begin + L := Length(S); + i := 1; + while (i<=L) and (S[i]<=' ') do + inc(i); + if i>L then + result := '' else + if (i=1) and (S[L]>' ') then + result := S else begin + while S[L]<=' ' do + dec(L); + result := copy(S,i,L-i+1); + end; +end; +{$else} +function Trim(const S: SockString): SockString; +asm // fast implementation by John O'Harrow + test eax,eax {S = nil?} + xchg eax,edx + jz System.@LStrClr {Yes, Return Empty String} + mov ecx,[edx-4] {Length(S)} + cmp byte ptr [edx],' ' {S[1] <= ' '?} + jbe @@TrimLeft {Yes, Trim Leading Spaces} + cmp byte ptr [edx+ecx-1],' ' {S[Length(S)] <= ' '?} + jbe @@TrimRight {Yes, Trim Trailing Spaces} + jmp System.@LStrLAsg {No, Result := S (which occurs most time)} +@@TrimLeft: {Strip Leading Whitespace} + dec ecx + jle System.@LStrClr {All Whitespace} + inc edx + cmp byte ptr [edx],' ' + jbe @@TrimLeft +@@CheckDone: + cmp byte ptr [edx+ecx-1],' ' +{$ifdef UNICODE} + jbe @@TrimRight + push 65535 // SockString code page for Delphi 2009 and up + call System.@LStrFromPCharLen // we need a call, not a direct jmp + ret +{$else} + ja System.@LStrFromPCharLen +{$endif} +@@TrimRight: {Strip Trailing Whitespace} + dec ecx + jmp @@CheckDone +end; +{$endif} + +function ExistNameValue(p,up: PAnsiChar): PAnsiChar; +var tab: PByteArray; +begin + result := p; + if p=nil then + exit; + tab := @NormToUpper; + repeat + if IdemPCharUp(pointer(result),pointer(up),tab) then + exit; + while result^>#13 do + inc(result); + while result^<=#13 do + if result^=#0 then begin + result := nil; + exit; + end else + inc(result); + until false; +end; + +function FindHeaderValue(p: PAnsiChar; const up: SockString): PAnsiChar; +begin + result := ExistNameValue(p,pointer(up)); + if result=nil then + exit; + inc(result,length(up)); + if result^<>':' then + result := nil else + repeat + inc(result); + until (result^>' ') or (result^=#0); +end; + +procedure GetHeaderValue(const s, up: SockString; var res: SockString); +var p: PAnsiChar; + L: PtrInt; +begin + p := FindHeaderValue(pointer(s),up); + if (p=nil) or (p^=#0) then + exit; + L := 0; + while p[L]>#13 do + inc(L); + while p[L-1]=' ' do + dec(L); + SetString(res,p,L); +end; + +procedure ExtractNameValue(var headers: SockString; const upname: SockString; + out res: SockString); +var i,j,k: PtrInt; +begin + if (headers='') or (upname='') then + exit; + i := 1; + repeat + k := length(headers)+1; + for j := i to k-1 do + if headers[j]<' ' then begin + k := j; + break; + end; + if IdemPCharUp(@PByteArray(headers)[i-1],pointer(upname),@NormToUpper) then begin + j := i; + inc(i,length(upname)); + TrimCopy(headers,i,k-i,res); + while true do // delete also ending #13#10 + if (headers[k]=#0) or (headers[k]>=' ') then + break else + inc(k); + delete(headers,j,k-j); + exit; + end; + i := k; + while headers[i]<' ' do + if headers[i]=#0 then + exit else + inc(i); + until false; +end; + +procedure UpperMove(Source, Dest: PByte; ToUp: PByteArray; L: cardinal); +begin + repeat + Dest^ := ToUp[Source^]; + dec(L); + inc(Source); + inc(Dest); + until L=0; +end; + +function UpperCase(const S: SockString): SockString; +var L: cardinal; +begin + result := ''; + L := Length(S); + if L=0 then + exit; + SetLength(result,L); + UpperMove(pointer(S),pointer(result),@NormToUpper,L); +end; + +function GetCardinal(P: PAnsiChar): cardinal; overload; +var c: cardinal; +begin + if P=nil then begin + result := 0; + exit; + end; + if P^=' ' then repeat inc(P) until P^<>' '; + c := byte(P^)-48; + if c>9 then + result := 0 else begin + result := c; + inc(P); + repeat + c := byte(P^)-48; + if c>9 then + break else + result := result*10+c; + inc(P); + until false; + end; +end; + +function GetCardinal(P,PEnd: PAnsiChar): cardinal; overload; +var c: cardinal; +begin + result := 0; + if (P=nil) or (P>=PEnd) then + exit; + if P^=' ' then repeat + inc(P); + if P=PEnd then exit; + until P^<>' '; + c := byte(P^)-48; + if c>9 then + exit; + result := c; + inc(P); + while P9 then + break else + result := result*10+c; + inc(P); + end; +end; + +function HttpChunkToHex32(p: PAnsiChar): integer; +var v0,v1: integer; +begin + result := 0; + if p<>nil then begin + while p^=' ' do inc(p); + repeat + v0 := Hex2Dec(ord(p[0])); + if v0<0 then break; // not in '0'..'9','a'..'f' + v1 := Hex2Dec(ord(p[1])); + inc(p); + if v1<0 then begin + result := (result shl 4) or v0; // only one char left + break; + end; + result := (result shl 8) or (v0 shl 4) or v1; + inc(p); + until false; + end; +end; + +{$ifdef DELPHI5OROLDER} +function Utf8ToAnsi(const UTF8: SockString): SockString; +begin + result := UTF8; // fallback to no conversion +end; +{$endif} + +const + ENGLISH_LANGID = $0409; + // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa383770 + ERROR_WINHTTP_CANNOT_CONNECT = 12029; + ERROR_WINHTTP_TIMEOUT = 12002; + ERROR_WINHTTP_INVALID_SERVER_RESPONSE = 12152; + +function SysErrorMessagePerModule(Code: DWORD; ModuleName: PChar): string; +{$ifdef MSWINDOWS} +var tmpLen: DWORD; + err: PChar; +{$endif} +begin + result := ''; + if Code=NO_ERROR then + exit; + {$ifdef MSWINDOWS} + tmpLen := FormatMessage( + FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_ALLOCATE_BUFFER, + pointer(GetModuleHandle(ModuleName)),Code,ENGLISH_LANGID,@err,0,nil); + // if string is empty, it may be because english is not found + if (tmpLen = 0) then + tmpLen := FormatMessage( + FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS, + pointer(GetModuleHandle(ModuleName)),Code,0,@err,0,nil); + try + while (tmpLen>0) and (ord(err[tmpLen-1]) in [0..32,ord('.')]) do + dec(tmpLen); + SetString(result,err,tmpLen); + finally + LocalFree(HLOCAL(err)); + end; + {$endif} + if result='' then begin + result := SysErrorMessage(Code); + if result='' then + if Code=ERROR_WINHTTP_CANNOT_CONNECT then + result := 'cannot connect' else + if Code=ERROR_WINHTTP_TIMEOUT then + result := 'timeout' else + if Code=ERROR_WINHTTP_INVALID_SERVER_RESPONSE then + result := 'invalid server response' else + result := IntToHex(Code,8); + end; +end; + +procedure RaiseLastModuleError(ModuleName: PChar; ModuleException: ExceptClass); +var LastError: Integer; + Error: Exception; +begin + LastError := GetLastError; + if LastError<>NO_ERROR then + Error := ModuleException.CreateFmt('%s error %d (%s)', + [ModuleName,LastError,SysErrorMessagePerModule(LastError,ModuleName)]) else + Error := ModuleException.CreateFmt('Undefined %s error',[ModuleName]); + raise Error; +end; + +function Ansi7ToUnicode(const Ansi: SockString): SockString; +var n, i: PtrInt; +begin // fast ANSI 7 bit conversion + result := ''; + if Ansi='' then + exit; + n := length(Ansi); + SetLength(result,n*2+1); + for i := 0 to n do // to n = including last #0 + PWordArray(pointer(result))^[i] := PByteArray(pointer(Ansi))^[i]; +end; + +function DefaultUserAgent(Instance: TObject): SockString; +begin + // note: some part of mORMot.pas would identify 'mORMot' pattern in the + // agent header to enable advanced behavior e.g. about JSON transmission + result := 'Mozilla/5.0 ('+XPOWEREDOS+'; '+XPOWEREDPROGRAM+' '+ + SockString(Instance.ClassName)+')'; +end; + +/// decode 'CONTENT-ENCODING: ' parameter from registered compression list +function ComputeContentEncoding(const Compress: THttpSocketCompressRecDynArray; + P: PAnsiChar): THttpSocketCompressSet; +var i: PtrInt; + aName: SockString; + Beg: PAnsiChar; +begin + integer(result) := 0; + if P<>nil then + repeat + while P^ in [' ',','] do inc(P); + Beg := P; // 'gzip;q=1.0, deflate' -> aName='gzip' then 'deflate' + while not (P^ in [';',',',#0]) do inc(P); + SetString(aName,Beg,P-Beg); + for i := 0 to high(Compress) do + if aName=Compress[i].Name then + include(result,i); + while not (P^ in [',',#0]) do inc(P); + until P^=#0; +end; + +function RegisterCompressFunc(var Compress: THttpSocketCompressRecDynArray; + aFunction: THttpSocketCompress; var aAcceptEncoding: SockString; + aCompressMinSize: integer): SockString; +var i, n: PtrInt; + dummy, aName: SockString; +begin + result := ''; + if @aFunction=nil then + exit; + n := length(Compress); + aName := aFunction(dummy,true); + for i := 0 to n-1 do + with Compress[i] do + if Name=aName then begin // already set + if @Func=@aFunction then // update min. compress size value + CompressMinSize := aCompressMinSize; + exit; + end; + if n=sizeof(integer)*8 then + exit; // fCompressAcceptHeader is 0..31 (casted as integer) + SetLength(Compress,n+1); + with Compress[n] do begin + Name := aName; + @Func := @aFunction; + CompressMinSize := aCompressMinSize; + end; + if aAcceptEncoding='' then + aAcceptEncoding := 'Accept-Encoding: '+aName else + aAcceptEncoding := aAcceptEncoding+','+aName; + result := aName; +end; + +function CompressDataAndGetHeaders(Accepted: THttpSocketCompressSet; + const Handled: THttpSocketCompressRecDynArray; const OutContentType: SockString; + var OutContent: SockString): SockString; +var i, OutContentLen: integer; + compressible: boolean; + OutContentTypeP: PAnsiChar absolute OutContentType; +begin + if (integer(Accepted)<>0) and (OutContentType<>'') and (Handled<>nil) then begin + OutContentLen := length(OutContent); + case IdemPCharArray(OutContentTypeP,['TEXT/','IMAGE/','APPLICATION/']) of + 0: compressible := true; + 1: compressible := IdemPCharArray(OutContentTypeP+6,['SVG','X-ICO'])>=0; + 2: compressible := IdemPCharArray(OutContentTypeP+12,['JSON','XML','JAVASCRIPT'])>=0; + else compressible := false; + end; + for i := 0 to high(Handled) do + if i in Accepted then + with Handled[i] do + if (CompressMinSize=0) or // 0 here means "always" (e.g. for encryption) + (compressible and (OutContentLen>=CompressMinSize)) then begin + // compression of the OutContent + update header + result := Func(OutContent,true); + exit; // first in fCompress[] is prefered + end; + end; + result := ''; +end; + +procedure AppendI32(value: integer; var dest: shortstring); {$ifdef FPC}inline;{$endif} +var temp: shortstring; +begin + str(value,temp); + move(temp[1],dest[ord(dest[0])+1],ord(temp[0])); + inc(dest[0],ord(temp[0])); +end; + +procedure AppendI64(value: Int64; var dest: shortstring); +var temp: shortstring; +begin + str(value,temp); + move(temp[1],dest[ord(dest[0])+1],ord(temp[0])); + inc(dest[0],ord(temp[0])); +end; + +procedure AppendChar(chr: AnsiChar; var dest: shortstring); {$ifdef FPC}inline;{$endif} +begin + inc(dest[0]); + dest[ord(dest[0])] := chr; +end; + +var + IP4local: SockString; // contains '127.0.0.1' + +procedure IP4Text(const ip4addr; var result: SockString); +var b: array[0..3] of byte absolute ip4addr; + s: shortstring; + i: PtrInt; +begin + if cardinal(ip4addr)=0 then + result := '' else + if cardinal(ip4addr)=$0100007f then + result := IP4local else begin + s := ''; + i := 0; + repeat + AppendI32(b[i],s); + if i=3 then + break; + AppendChar('.',s); + inc(i); + until false; + SetString(result,PAnsiChar(@s[1]),ord(s[0])); + end; +end; + +procedure IPText(const sin: TVarSin; var result: SockString; localasvoid: boolean); +begin + if sin.sin_family=AF_INET then + if localasvoid and (cardinal(sin.sin_addr)=$0100007f) then + result := '' else + IP4Text(sin.sin_addr,result) else begin + result := GetSinIP(sin); // AF_INET6 may be optimized in a future revision + if result='::1' then + if localasvoid then + result := '' else + result := IP4local; // IP6 localhost loopback benefits of matching IP4 + end; +end; + +function IsPublicIP(ip4: cardinal): boolean; +begin + result := false; + case ip4 and 255 of // ignore IANA private IP4 address spaces + 10: exit; + 172: if ((ip4 shr 8) and 255) in [16..31] then exit; + 192: if (ip4 shr 8) and 255=168 then exit; + end; + result := true; +end; + +{$ifdef MSWINDOWS} + +{$ifdef FPC} // oddly not defined in fpc\rtl\win +function SwitchToThread: BOOL; stdcall; external kernel32 name 'SwitchToThread'; +{$endif} + +procedure SleepHiRes(ms: cardinal); // see SynKylix/SynFPCLinux for POSIX +begin + if (ms<>0) or not SwitchToThread then + Windows.Sleep(ms); +end; + +const + HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; + +procedure BinToHexDisplayW(Bin: PByte; BinBytes: integer; var result: SockUnicode); +var j: PtrInt; + P: PWideChar; +begin + SetString(Result,nil,BinBytes*2); + P := pointer(Result); + for j := BinBytes-1 downto 0 do begin + P[j*2] := WideChar(HexCharsLower[Bin^ shr 4]); + P[j*2+1] := WideChar(HexCharsLower[Bin^ and $F]); + inc(Bin); + end; +end; + +function MacToText(pMacAddr: PByteArray): SockString; +var P: PAnsiChar; + i: PtrInt; +begin + SetLength(result,17); + P := pointer(result); + i := 0; + repeat + P[0] := HexCharsLower[pMacAddr[i] shr 4]; + P[1] := HexCharsLower[pMacAddr[i] and $F]; + if i = 5 then + break; + P[2] := ':'; // as in Linux + inc(P,3); + inc(i); + until false; +end; + +function SendARP(DestIp: DWORD; srcIP: DWORD; pMacAddr: pointer; + PhyAddrLen: Pointer): DWORD; stdcall; external 'iphlpapi.dll'; + +function GetRemoteMacAddress(const IP: SockString): SockString; +// implements http://msdn.microsoft.com/en-us/library/aa366358 +var dwRemoteIP: DWORD; + PhyAddrLen: Longword; + pMacAddr: array [0..7] of byte; +begin + result := ''; + dwremoteIP := inet_addr(pointer(IP)); + if dwremoteIP<>0 then begin + PhyAddrLen := 8; + if SendARP(dwremoteIP,0,@pMacAddr,@PhyAddrLen)=NO_ERROR then begin + if PhyAddrLen=6 then + result := MacToText(@pMacAddr); + end; + end; +end; + +type + PMIB_IPADDRTABLE = ^MIB_IPADDRTABLE; + MIB_IPADDRTABLE = record + dwNumEntries: DWORD; + ip: array[0..200] of record + dwAddr: DWORD; + dwIndex: DWORD; + dwMask: DWORD; + dwBCastAddr: DWORD; + dwReasmSize: DWORD; + unused1: Word; + wType: Word; + end; + end; + +function GetIpAddrTable(pIpAddrTable: PMIB_IPADDRTABLE; + var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; external 'iphlpapi.dll'; + +const + MAX_ADAPTER_ADDRESS_LENGTH = 8; + GAA_FLAG_SKIP_UNICAST = $1; + GAA_FLAG_SKIP_ANYCAST = $2; + GAA_FLAG_SKIP_MULTICAST = $4; + GAA_FLAG_SKIP_DNS_SERVER = $8; + GAA_FLAG_SKIP_FRIENDLY_NAME = $20; + GAA_FLAG_INCLUDE_ALL_INTERFACES = $100; // Vista+ + GAA_FLAGS = GAA_FLAG_SKIP_UNICAST or GAA_FLAG_SKIP_ANYCAST or + GAA_FLAG_SKIP_MULTICAST or GAA_FLAG_SKIP_DNS_SERVER or + GAA_FLAG_SKIP_FRIENDLY_NAME; // or GAA_FLAG_INCLUDE_ALL_INTERFACES; + IfOperStatusUp = 1; +type + SOCKET_ADDRESS = record + lpSockaddr: PSOCKADDR; + iSockaddrLength: Integer; + end; + PIP_ADAPTER_UNICAST_ADDRESS = pointer; + PIP_ADAPTER_ANYCAST_ADDRESS = pointer; + PIP_ADAPTER_DNS_SERVER_ADDRESS = pointer; + PIP_ADAPTER_MULTICAST_ADDRESS = pointer; + PIP_ADAPTER_ADDRESSES = ^_IP_ADAPTER_ADDRESSES; + _IP_ADAPTER_ADDRESSES = record + Union: record + case Integer of + 0: ( + Alignment: ULONGLONG); + 1: ( + Length: ULONG; + IfIndex: DWORD); + end; + Next: PIP_ADAPTER_ADDRESSES; + AdapterName: PAnsiChar; + FirstUnicastAddress: PIP_ADAPTER_UNICAST_ADDRESS; + FirstAnycastAddress: PIP_ADAPTER_ANYCAST_ADDRESS; + FirstMulticastAddress: PIP_ADAPTER_MULTICAST_ADDRESS; + FirstDnsServerAddress: PIP_ADAPTER_DNS_SERVER_ADDRESS; + DnsSuffix: PWCHAR; + Description: PWCHAR; + FriendlyName: PWCHAR; + PhysicalAddress: array [0..MAX_ADAPTER_ADDRESS_LENGTH - 1] of BYTE; + PhysicalAddressLength: DWORD; + Flags: DWORD; + Mtu: DWORD; + IfType: ULONG; + OperStatus: DWORD; + // below fields are only available on Windows XP with SP1 and later + Ipv6IfIndex: ULONG; + ZoneIndices: array [0..15] of DWORD; + FirstPrefix: pointer; + // below fields are only available on Windows Vista and later + TransmitLinkSpeed: Int64; + ReceiveLinkSpeed: Int64; + FirstWinsServerAddress: pointer; + FirstGatewayAddress: pointer; + Ipv4Metric: ULONG; + Ipv6Metric: ULONG; + Luid: Int64; + Dhcpv4Server: SOCKET_ADDRESS; + CompartmentId: DWORD; + NetworkGuid: TGUID; + ConnectionType: DWORD; + TunnelType: DWORD; + // DHCP v6 Info following + end; + +function GetAdaptersAddresses(Family: ULONG; Flags: DWORD; Reserved: pointer; + pAdapterAddresses: PIP_ADAPTER_ADDRESSES; pOutBufLen: PULONG): DWORD; stdcall; + external 'iphlpapi.dll'; + + +function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; +var Table: MIB_IPADDRTABLE; + Size: DWORD; + i: integer; + n: cardinal; +begin + result := nil; + Size := SizeOf(Table); + if GetIpAddrTable(@Table,Size,false)<>NO_ERROR then + exit; + SetLength(result,Table.dwNumEntries); + n := 0; + for i := 0 to Table.dwNumEntries-1 do + with Table.ip[i] do + if (dwAddr<>$0100007f) and (dwAddr<>0) then begin + case Kind of + tiaPublic: if not IsPublicIP(dwAddr) then continue; + tiaPrivate: if IsPublicIP(dwAddr) then continue; + end; + IP4Text(dwAddr,result[n]); + inc(n); + end; + if n<>Table.dwNumEntries then + SetLength(result,n); +end; + +{$else MSWINDOWS} + +function GetFileOpenLimit(hard: boolean=false): integer; +var limit: TRLIMIT; +begin + {$ifdef FPC} + if fpgetrlimit(RLIMIT_NOFILE,@limit)=0 then + {$else} + if getrlimit(RLIMIT_NOFILE,limit)=0 then + {$endif} + if hard then + result := limit.rlim_max else + result := limit.rlim_cur else + result := -1; +end; + +function SetFileOpenLimit(max: integer; hard: boolean=false): integer; +var limit: TRLIMIT; +begin + result := -1; + {$ifdef FPC} + if fpgetrlimit(RLIMIT_NOFILE,@limit)<>0 then + {$else} + if getrlimit(RLIMIT_NOFILE,limit)<>0 then + {$endif} + exit; + if (hard and (integer(limit.rlim_max)=max)) or + (not hard and (integer(limit.rlim_cur)=max)) then begin + result := max; // already to the expected value + exit; + end; + if hard then + limit.rlim_max := max else + limit.rlim_cur := max; + {$ifdef FPC} + if fpsetrlimit(RLIMIT_NOFILE,@limit)=0 then + {$else} + if setrlimit(RLIMIT_NOFILE,limit)=0 then + {$endif} + result := GetFileOpenLimit(hard); +end; + +{$define USE_IFADDRS} + +{$ifdef USE_IFADDRS} +type + Pifaddrs = ^ifaddrs; + ifaddrs = record + ifa_next: Pifaddrs; + ifa_name: PAnsiChar; + ifa_flags: cardinal; + ifa_addr: Psockaddr; + ifa_netmask: Psockaddr; + ifa_dstaddr: Psockaddr; + ifa_data: Pointer; + end; + +const + IFF_UP = $1; + IFF_LOOPBACK = $8; + {$ifndef KYLIX3} + libcmodulename = 'c'; + {$endif} + +function getifaddrs(var ifap: Pifaddrs): Integer; cdecl; + external libcmodulename name 'getifaddrs'; +procedure freeifaddrs(ifap: Pifaddrs); cdecl; + external libcmodulename name 'freeifaddrs'; + +function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; +var list, info: Pifaddrs; + n, dwAddr: integer; + s: SockString; +begin + result := nil; + n := 0; + if getifaddrs(list)=0 then + try + info := list; + repeat + if (info^.ifa_addr<>nil) and (info^.ifa_flags and IFF_LOOPBACK=0) and + (info^.ifa_flags and IFF_UP<>0) then begin + s := ''; + case info^.ifa_addr^.sa_family of + AF_INET: begin + dwAddr := integer(info^.ifa_addr^.sin_addr); + if (dwAddr<>$0100007f) and (dwAddr<>0) then + case Kind of + tiaPublic: if IsPublicIP(dwAddr) then IP4Text(dwAddr,s); + tiaPrivate: if not IsPublicIP(dwAddr) then IP4Text(dwAddr,s); + tiaAny: IP4Text(dwAddr,s); + end; + //s := s+'@'+info^.ifa_name; + end; + //AF_INET6: IPText(PVarSin(info^.ifa_addr)^,s); + end; + if s<>'' then begin + if n=length(result) then + SetLength(result,n+8); + result[n] := s; + inc(n); + end; + end; + info := info^.ifa_next; + until info=nil; + finally + freeifaddrs(list); + end; + if n<>length(result) then + SetLength(result,n); +end; +{$else} +function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; +begin + result := nil; +end; +{$endif USE_IFADDRS} + +{$endif MSWINDOWS} + +{$ifdef MSWINDOWS} +var // not available before Vista -> Lazy loading + GetTick64: function: Int64; stdcall; + GetTickXP: Int64Rec; + +function GetTick64ForXP: Int64; stdcall; +var t32: cardinal; + t64: Int64Rec absolute result; +begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! + t32 := Windows.GetTickCount; + t64 := GetTickXP; // (almost) atomic read + if t32IPAddressesTix[PublicOnly] then + IPAddressesTix[PublicOnly] := tix else begin + result := IPAddressesText[PublicOnly]; + if result<>'' then + exit; + end; + end; + if PublicOnly then + ip := GetIPAddresses(tiaPublic) else + ip := GetIPAddresses(tiaAny); + if ip=nil then + exit; + result := ip[0]; + for i := 1 to high(ip) do + result := result+Sep+ip[i]; + if Sep=' ' then + IPAddressesText[PublicOnly] := result; +end; + +var + MacAddressesSearched: boolean; // will not change during process lifetime + MacAddresses: TMacAddressDynArray; + MacAddressesText: SockString; + +{$ifdef LINUX} +procedure GetSmallFile(const fn: TFileName; out result: SockString); +var tmp: array[byte] of AnsiChar; + F: THandle; + t: PtrInt; +begin + F := FileOpen(fn, fmOpenRead or fmShareDenyNone); + if PtrInt(F) < 0 then + exit; + t := FileRead(F, tmp, SizeOf(tmp)); + FileClose(F); + while (t > 0) and (tmp[t - 1] <= ' ') do dec(t); // trim right + if t > 0 then + SetString(result, PAnsiChar(@tmp), t); +end; +{$endif LINUX} + +procedure RetrieveMacAddresses; +var n: integer; +{$ifdef LINUX} + SR: TSearchRec; + fn: TFileName; + f: SockString; +{$endif LINUX} +{$ifdef MSWINDOWS} + tmp: array[word] of byte; + siz: ULONG; + p: PIP_ADAPTER_ADDRESSES; +{$endif MSWINDOWS} +begin + EnterCriticalSection(SynSockCS); + try + if MacAddressesSearched then + exit; + n := 0; + {$ifdef LINUX} + if FindFirst('/sys/class/net/*', faDirectory, SR) = 0 then begin + repeat + if (SR.Name <> 'lo') and (SR.Name[1] <> '.') then begin + fn := '/sys/class/net/' + SR.Name; + GetSmallFile(fn + '/flags', f); + if (length(f) > 2) and // e.g. '0x40' or '0x1043' + (HttpChunkToHex32(@f[3]) and (IFF_UP or IFF_LOOPBACK) = IFF_UP) then begin + GetSmallFile(fn + '/address', f); + if f <> '' then begin + SetLength(MacAddresses, n + 1); + MacAddresses[n].name := SR.Name; + MacAddresses[n].address := f; + inc(n); + end; + end; + end; + until FindNext(SR) <> 0; + FindClose(SR); + end; + {$endif LINUX} + {$ifdef MSWINDOWS} + siz := SizeOf(tmp); + p := @tmp; + if GetAdaptersAddresses(AF_UNSPEC, GAA_FLAGS, nil, p, @siz) = ERROR_SUCCESS then begin + repeat + if (p^.Flags <> 0) and (p^.OperStatus = IfOperStatusUp) and + (p^.PhysicalAddressLength = 6) then begin + SetLength(MacAddresses, n + 1); + MacAddresses[n].name := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(WideString(p^.Description)); + MacAddresses[n].address := MacToText(@p^.PhysicalAddress); + inc(n); + end; + p := p^.Next; + until p = nil; + end; + {$endif MSWINDOWS} + { TODO : RetrieveMacAddresses() for BSD + see e.g. https://gist.github.com/OrangeTide/909204 } + finally + LeaveCriticalSection(SynSockCS); + end; + MacAddressesSearched := true; +end; + +function GetMacAddresses: TMacAddressDynArray; +begin + if not MacAddressesSearched then + RetrieveMacAddresses; + result := MacAddresses; +end; + +function GetMacAddressesText: SockString; +var i: integer; +begin + result := MacAddressesText; + if (result <> '') or MacAddressesSearched then + exit; + RetrieveMacAddresses; + result := ''; + if MacAddresses = nil then + exit; + for i := 0 to high(MacAddresses) do + with MacAddresses[i] do + result := result + name + '=' + address + ' '; + SetLength(result, length(result) - 1); + MacAddressesText := result; +end; + +{$ifndef NOXPOWEREDNAME} +const + XPOWEREDNAME = 'X-Powered-By'; + XPOWEREDVALUE = XPOWEREDPROGRAM + ' synopse.info'; +{$endif} + + +{ TURI } + +const + DEFAULT_PORT: array[boolean] of SockString = ('80','443'); + UNIX_LOW = ord('u')+ord('n')shl 8+ord('i')shl 16+ord('x')shl 24; + +procedure TURI.Clear; +begin + Https := false; + Layer := cslTCP; + Finalize(self); +end; + +function TURI.From(aURI: SockString; const DefaultPort: SockString): boolean; +var P,S: PAnsiChar; +begin + Clear; + result := false; + aURI := Trim(aURI); + if aURI='' then + exit; + P := pointer(aURI); + S := P; + while S^ in ['a'..'z','A'..'Z','+','-','.','0'..'9'] do inc(S); + if PInteger(S)^ and $ffffff=ord(':')+ord('/')shl 8+ord('/')shl 16 then begin + SetString(Scheme,P,S-P); + if IdemPChar(P,'HTTPS') then + Https := true; + P := S+3; + end; + S := P; + if (PInteger(S)^=UNIX_LOW) and (S[4]=':') then begin + inc(S,5); // 'http://unix:/path/to/socket.sock:/url/path' + inc(P,5); + Layer := cslUNIX; + while not(S^ in [#0,':']) do inc(S); // Server='path/to/socket.sock' + end else + while not(S^ in [#0,':','/']) do inc(S); + SetString(Server,P,S-P); + if S^=':' then begin + inc(S); + P := S; + while not(S^ in [#0,'/']) do inc(S); + SetString(Port,P,S-P); // Port='' for cslUnix + end else + if DefaultPort<>'' then + Port := DefaultPort else + Port := DEFAULT_PORT[Https]; + if S^<>#0 then // ':' or '/' + inc(S); + Address := S; + if Server<>'' then + result := true; +end; + +function TURI.URI: SockString; +const Prefix: array[boolean] of SockString = ('http://','https://'); +begin + if Layer=cslUNIX then + result := 'http://unix:'+Server+':/'+Address else + if (Port='') or (Port='0') or (Port=DEFAULT_PORT[Https]) then + result := Prefix[Https]+Server+'/'+Address else + result := Prefix[Https]+Server+':'+Port+'/'+Address; +end; + +function TURI.PortInt: integer; +begin + result := GetCardinal(pointer(port)); +end; + +function TURI.Root: SockString; +var i: PtrInt; +begin + i := PosCh('?',Address); + if i=0 then + Root := Address else + Root := copy(Address,1,i-1); +end; + + +{ ************ Socket API access - TCrtSocket and THttp*Socket } + +var + WsaDataOnce: TWSADATA; + SO_TRUE: integer = ord(true); + +function ResolveName(const Name: SockString; + Family, SockProtocol, SockType: integer): SockString; +var l: TStringList; +begin + l := TStringList.Create; + try + ResolveNameToIP(Name, Family, SockProtocol, SockType, l); + if l.Count=0 then + result := Name else + result := SockString(l[0]); + finally + l.Free; + end; +end; + +procedure SetInt32Option(Sock: TSocket; OptName, OptVal: integer); +var li: TLinger; + {$ifndef MSWINDOWS} + timeval: TTimeval; + {$endif} +begin + if Sock<=0 then + raise ECrtSocket.CreateFmt('Unexpected SetOption(%d,%d)',[OptName,OptVal]); + case OptName of + SO_SNDTIMEO, SO_RCVTIMEO: begin + {$ifndef MSWINDOWS} // POSIX expects a timeval parameter for time out values + timeval.tv_sec := OptVal div 1000; + timeval.tv_usec := (OptVal mod 1000)*1000; + if SetSockOpt(Sock,SOL_SOCKET,OptName,@timeval,sizeof(timeval))=0 then + {$else} + // WinAPI expects the time out directly as ms integer + if SetSockOpt(Sock,SOL_SOCKET,OptName,pointer(@OptVal),sizeof(OptVal))=0 then + {$endif} + exit; + end; + SO_KEEPALIVE: // boolean (0/1) value + if SetSockOpt(Sock,SOL_SOCKET,OptName,pointer(@OptVal),sizeof(OptVal))=0 then + exit; + SO_LINGER: begin // not available on UDP + if OptVal<0 then + li.l_onoff := Ord(false) else begin + li.l_onoff := Ord(true); + li.l_linger := OptVal; + end; + SetSockOpt(Sock,SOL_SOCKET, SO_LINGER, @li, SizeOf(li)); + if OptVal>0 then begin + {$ifdef LINUX} + {$ifdef BSD} + SetSockOpt(Sock,SOL_SOCKET,SO_REUSEPORT,@SO_TRUE,SizeOf(SO_TRUE)); + {$ifndef OpenBSD} + SetSockOpt(Sock,SOL_SOCKET,SO_NOSIGPIPE,@SO_TRUE,SizeOf(SO_TRUE)); + {$endif OpenBSD} + {$else} + SetSockOpt(Sock,SOL_SOCKET, SO_REUSEADDR,@SO_TRUE,SizeOf(SO_TRUE)); + {$endif BSD} + {$endif LINUX} + end; + exit; + end; + TCP_NODELAY: // boolean (0/1) value + if SetSockOpt(Sock,IPPROTO_TCP,OptName,@OptVal,sizeof(OptVal))=0 then + exit; + end; + raise ECrtSocket.CreateFmt('SetOption(%d,%d)',[OptName,OptVal],-1); +end; + +function CallServer(const Server, Port: SockString; doBind: boolean; + aLayer: TCrtSocketLayer; ConnectTimeout: DWORD): TSocket; +var sin: TVarSin; + IP: SockString; + socktype, ipproto, family: integer; + {$ifndef MSWINDOWS} + //serveraddr: sockaddr_un; + {$endif} +begin + result := -1; + case aLayer of + cslTCP: begin + socktype := SOCK_STREAM; + ipproto := IPPROTO_TCP; + end; + cslUDP: begin + socktype := SOCK_DGRAM; + ipproto := IPPROTO_UDP; + end; + cslUNIX: begin + {$ifdef MSWINDOWS} + exit; // not handled under Win32 + {$else} + socktype := SOCK_STREAM; + ipproto := 0; + {$endif} + end; + else exit; + end; + if SameText(Server,'localhost') + {$ifndef MSWINDOWS}or ((Server='') and not doBind){$endif} then + IP := cLocalHost else + if aLayer=cslUNIX then + IP := Server else + IP := ResolveName(Server,AF_INET,ipproto,socktype); + {$ifndef MSWINDOWS} + if aLayer=cslUNIX then + family := AF_UNIX else + {$endif} + // use AF_INET instead of AF_UNSPEC: IP6 is buggy! + family := AF_INET; + if SetVarSin(sin,IP,Port,family,ipproto,socktype,false)<>0 then + exit; + result := Socket(integer(sin.AddressFamily),socktype,ipproto); + if result=-1 then + exit; + if doBind then begin + // Socket should remain open for 5 seconds after a closesocket() call + SetInt32Option(result,SO_LINGER,5); + // bind and listen to this port as server + if (Bind(result,sin)<>0) or + ((aLayer<>cslUDP) and (Listen(result,DefaultListenBacklog)<>0)) then begin + CloseSocket(result); + result := -1; + end; + end else begin + // open client connection + if ConnectTimeout>0 then begin + SetInt32Option(result,SO_RCVTIMEO,ConnectTimeout); + SetInt32Option(result,SO_SNDTIMEO,ConnectTimeout); + end; + if Connect(result,sin)<>0 then begin + CloseSocket(result); + result := -1; + end; + end; +end; + +type + PCrtSocket = ^TCrtSocket; + +function OutputSock(var F: TTextRec): integer; +begin + if F.BufPos=0 then + result := 0 else + if PCrtSocket(@F.UserData)^.TrySndLow(F.BufPtr,F.BufPos) then begin + F.BufPos := 0; + result := 0; + end else + result := -1; // on socket error -> raise ioresult error +end; + +function WSAIsFatalError(anothernonfatal: integer=NO_ERROR): boolean; +var err: integer; +begin + err := WSAGetLastError; + result := (err<>NO_ERROR) and (err<>WSATRY_AGAIN) and + {$ifdef MSWINDOWS}(err<>WSAETIMEDOUT) and (err<>WSAEWOULDBLOCK) and{$endif} + (err<>anothernonfatal); // allow WSAEADDRNOTAVAIL from OpenBind() +end; + +function WSAErrorAtShutdown(sock: TSocket): integer; +var dummy: byte; +begin + if AsynchRecv(sock,@dummy,SizeOf(dummy))<0 then + result := WSAGetLastError else + result := 0; // read access allowed = socket was closed gracefully +end; + +function InputSock(var F: TTextRec): Integer; +// SockIn pseudo text file fill its internal buffer only with available data +// -> no unwanted wait time is added +// -> very optimized use for readln() in HTTP stream +var Size: integer; + Sock: TCRTSocket; + {$ifdef MSWINDOWS} + iSize: integer; + {$else} + sin: TVarSin; + {$endif} +begin + F.BufEnd := 0; + F.BufPos := 0; + Sock := PCrtSocket(@F.UserData)^; + if (Sock=nil) or (Sock.Sock<=0) then begin + result := WSAECONNABORTED; // on socket error -> raise ioresult error + exit; // file closed = no socket -> error + end; + result := Sock.fSockInEofError; + if result<>0 then + exit; // already reached error below + Size := F.BufSize; + if Sock.SocketLayer=cslUDP then begin + {$ifdef MSWINDOWS} + iSize := SizeOf(TSockAddr); + Size := RecvFrom(Sock.Sock, F.BufPtr, Size, 0, @Sock.fPeerAddr, @iSize); + {$else} + Size := RecvFrom(Sock.Sock, F.BufPtr, Size, 0, sin); + Sock.fPeerAddr.sin_port := sin.sin_port; + Sock.fPeerAddr.sin_addr := sin.sin_addr; + {$endif} + end else // cslTCP/cslUNIX + if not Sock.TrySockRecv(F.BufPtr,Size,{StopBeforeLength=}true) then + Size := -1; // fatal socket error + // TrySockRecv() may return Size=0 if no data is pending, but no TCP/IP error + if Size>=0 then begin + F.BufEnd := Size; + inc(Sock.fBytesIn,Size); + result := 0; // no error + end else begin + if Sock.Sock<=0 then // socket broken or closed + result := WSAECONNABORTED else begin + result := -integer(WSAGetLastError); // integer() for FPC+Win target + if result=0 then + result := WSAETIMEDOUT; + end; + Sock.fSockInEofError := result; // error -> mark end of SockIn + // result <0 will update ioresult and raise an exception if {$I+} + end; +end; + +function CloseSock(var F: TTextRec): integer; +begin + if PCrtSocket(@F.UserData)^<>nil then + PCrtSocket(@F.UserData)^.Close; + PCrtSocket(@F.UserData)^ := nil; + Result := 0; +end; + +function OpenSock(var F: TTextRec): integer; +begin + F.BufPos := 0; + F.BufEnd := 0; + if F.Mode=fmInput then begin // ReadLn + F.InOutFunc := @InputSock; + F.FlushFunc := nil; + end else begin // WriteLn + F.Mode := fmOutput; + F.InOutFunc := @OutputSock; + F.FlushFunc := @OutputSock; + end; + F.CloseFunc := @CloseSock; + Result := 0; +end; + + +{ TCrtSocket } + +function Split(const Text: SockString; Sep: AnsiChar; var Before,After: SockString): boolean; +var i: integer; +begin + for i := length(Text)-1 downto 2 do + if Text[i]=Sep then begin + trimcopy(Text,1,i-1,Before); + trimcopy(Text,i+1,maxInt,After); + result := true; + exit; + end; + result := false; +end; + +constructor TCrtSocket.Bind(const aAddr: SockString; aLayer: TCrtSocketLayer; + aTimeOut: integer); +var s,p: SockString; + aSock: integer; + {$ifdef LINUXNOTBSD} + n: integer; + {$endif} +begin + Create(aTimeOut); + if aAddr='' then begin + {$ifdef LINUXNOTBSD} // try systemd + if not SystemdIsAvailable then + raise ECrtSocket.Create('Bind('''') but Systemd is not available'); + n := ExternalLibraries.sd_listen_fds(0); + if n > 1 then + raise ECrtSocket.Create('Bind(''''): Systemd activation failed - too ' + + 'many file descriptors received'); + aSock := SD_LISTEN_FDS_START + 0; + {$else} + raise ECrtSocket.Create('Bind('''') is not allowed on this platform'); + {$endif} + end else begin + aSock := -1; // force OpenBind to create listening socket + if not Split(aAddr,':',s,p) then begin + s := '0.0.0.0'; + p := aAddr; + end; + {$ifndef MSWINDOWS} + if s='unix' then begin + aLayer := cslUNIX; + s := p; + p := ''; + end; + {$endif MSWINDOWS} + end; + OpenBind(s,p,{dobind=}true,aSock,aLayer); // raise a ECrtSocket on error +end; + +constructor TCrtSocket.Open(const aServer, aPort: SockString; aLayer: TCrtSocketLayer; + aTimeOut: cardinal; aTLS: boolean); +begin + Create(aTimeOut); // default read timeout is 10 seconds + OpenBind(aServer,aPort,{dobind=}false,-1,aLayer,aTLS); // raise an ECrtSocket on error +end; + +type + PTextRec = ^TTextRec; + +procedure TCrtSocket.Close; +begin + if self=nil then + exit; + fSndBufLen := 0; // always reset (e.g. in case of further Open) + fSockInEofError := 0; + ioresult; // reset ioresult value if SockIn/SockOut were used + if SockIn<>nil then begin + PTextRec(SockIn)^.BufPos := 0; // reset input buffer + PTextRec(SockIn)^.BufEnd := 0; + end; + if SockOut<>nil then begin + PTextRec(SockOut)^.BufPos := 0; // reset output buffer + PTextRec(SockOut)^.BufEnd := 0; + end; + if fSock<=0 then + exit; // no opened connection, or Close already executed + {$ifdef LINUXNOTBSD} + if (fWasBind and (fPort='')) then begin // binded on external socket + fSock := -1; + exit; + end; + {$endif} + {$ifdef MSWINDOWS} + if fSecure.Initialized then + fSecure.BeforeDisconnection(fSock); + {$endif MSWINDOWS} + DirectShutdown(fSock,{rdwr=}fWasBind); + fSock := -1; // don't change Server or Port, since may try to reconnect +end; + +constructor TCrtSocket.Create(aTimeOut: PtrInt); +begin + fTimeOut := aTimeOut; +end; + +procedure TCrtSocket.SetInt32OptionByIndex(OptName, OptVal: integer); +begin + SetInt32Option(Sock,OptName,OptVal); +end; + +procedure TCrtSocket.OpenBind(const aServer, aPort: SockString; + doBind: boolean; aSock: integer; aLayer: TCrtSocketLayer; aTLS: boolean); +const BINDTXT: array[boolean] of string[4] = ('open','bind'); + BINDMSG: array[boolean] of string = ('Is a server running on this address:port?', + 'Another process may be currently listening to this port!'); +var retry: integer; +begin + fSocketLayer := aLayer; + fWasBind := doBind; + if aSock<=0 then begin + if (aPort='') and (aLayer<>cslUNIX) then + fPort := DEFAULT_PORT[aTLS] else // default port is 80/443 (HTTP/S) + fPort := aPort; + fServer := aServer; + if doBind then // allow small number of retries (e.g. XP or BSD during aggressive tests) + retry := 10 else + retry := {$ifdef BSD}10{$else}2{$endif}; + repeat + fSock := CallServer(aServer,Port,doBind,aLayer,Timeout); // OPEN or BIND + if (fSock>0) then + break; + dec(retry); + if WSAIsFatalError(WSAEADDRNOTAVAIL) or (retry<=0) then + raise ECrtSocket.CreateFmt('OpenBind(%s:%s,%s) failed: %s', + [aServer,fPort,BINDTXT[doBind],BINDMSG[doBind]],-1); + sleep(10); + until false; + end else + fSock := aSock; // ACCEPT mode -> socket is already created by caller + if TimeOut>0 then begin // set timout values for both directions + ReceiveTimeout := TimeOut; + SendTimeout := TimeOut; + end; + if aLayer=cslTCP then begin + if (aSock<0) or ((aSock>0) and not doBind) then begin // do not touch externally created socket + TCPNoDelay := 1; // disable Nagle algorithm since we use our own buffers + KeepAlive := 1; // enable TCP keepalive (even if we rely on transport layer) + end; + if aTLS and (aSock<=0) and not doBind then + try + {$ifdef MSWINDOWS} + fSecure.AfterConnection(fSock,pointer(aServer)); + {$else} + raise ECrtSocket.Create('TLS is unsupported on this system'); + {$endif MSWINDOWS} + fTLS := true; + except + on E: Exception do + raise ECrtSocket.CreateFmt('OpenBind(%s:%s,%s): TLS failed [%s %s]', + [aServer,Port,BINDTXT[doBind],E.ClassName,E.Message],-1); + end; + end; + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'OpenBind(%:%) % sock=% (accept=%) ', + [fServer,fPort,BINDTXT[doBind], fSock, aSock], self); + {$endif} +end; + +procedure TCrtSocket.AcceptRequest(aClientSock: TSocket; aClientSin: PVarSin); +begin + {$ifdef LINUXNOTBSD} + // on Linux fd returned from accept() inherits all parent fd options + // except O_NONBLOCK and O_ASYNC + fSock := aClientSock; + {$else} + // on other OS inheritance is undefined, so call OpenBind to set all fd options + OpenBind('','',false,aClientSock,fSocketLayer); // set the ACCEPTed aClientSock + Linger := 5; // should remain open for 5 seconds after a closesocket() call + {$endif LINUXNOTBSD} + if aClientSin<>nil then + IPText(aClientSin^,fRemoteIP,RemoteIPLocalHostAsVoidInServers); +end; + +procedure TCrtSocket.SockSend(const Values: array of const); +var i: integer; + tmp: shortstring; +begin + for i := 0 to high(Values) do + with Values[i] do + case VType of + vtString: + SockSend(@VString^[1],pByte(VString)^); + vtAnsiString: + SockSend(VAnsiString,length(SockString(VAnsiString))); + {$ifdef HASVARUSTRING} + vtUnicodeString: begin + tmp := ShortString(UnicodeString(VUnicodeString)); // convert into ansi + SockSend(@tmp[1],length(tmp)); + end; + {$endif} + vtPChar: + SockSend(VPChar,StrLen(VPChar)); + vtChar: + SockSend(@VChar,1); + vtWideChar: + SockSend(@VWideChar,1); // only ansi part of the character + vtInteger: begin + Str(VInteger,tmp); + SockSend(@tmp[1],length(tmp)); + end; + vtInt64{$ifdef FPC},vtQWord{$endif}: begin + Str(VInt64^,tmp); + SockSend(@tmp[1],length(tmp)); + end; + end; + SockSend(@CRLF,2); +end; + +procedure TCrtSocket.SockSend(const Line: SockString); +begin + if Line<>'' then + SockSend(pointer(Line),length(Line)); + SockSend(@CRLF,2); +end; + +procedure TCrtSocket.SockSendFlush(const aBody: SockString); +var body,avail: integer; +begin + body := Length(aBody); + if body>0 then begin + avail := SockSendRemainingSize; // around 1800 bytes + if avail>=body then begin + SockSend(pointer(aBody),body); // append to buffer as single TCP packet + body := 0; + end; + end; + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'SockSend sock=% flush len=% body=% %', + [fSock,fSndBufLen,length(aBody),LogEscapeFull(pointer(fSndBuf),fSndBufLen)],self); + if body>0 then + TSynLog.Add.Log(sllCustom2, 'SockSend sock=% body len=% %', + [fSock,body,LogEscapeFull(pointer(aBody),body)],self); + {$endif} + if not TrySockSendFlush then + raise ECrtSocket.CreateFmt('SockSendFlush(%s) len=%d',[fServer,fSndBufLen],-1); + if body>0 then + SndLow(pointer(aBody),body); // direct sending of biggest packets +end; + +function TCrtSocket.TrySockSendFlush: boolean; +begin + if fSndBufLen=0 then + result := true else begin + result := TrySndLow(pointer(fSndBuf),fSndBufLen); + if result then + fSndBufLen := 0; + end; +end; + +function TCrtSocket.SockSendRemainingSize: integer; +begin + result := length(fSndBuf)-fSndBufLen; +end; + +procedure TCrtSocket.SndLow(P: pointer; Len: integer); +begin + if not TrySndLow(P,Len) then + raise ECrtSocket.CreateFmt('SndLow(%s) len=%d',[fServer,Len],-1); +end; + +function TCrtSocket.TrySndLow(P: pointer; Len: integer): boolean; +var sent: integer; + now, start: Int64; +begin + result := Len=0; + if (self=nil) or (fSock<=0) or (Len<=0) or (P=nil) then + exit; + start := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; + repeat + {$ifdef MSWINDOWS} + if fSecure.Initialized then + sent := fSecure.Send(fSock, P, Len) else + {$endif MSWINDOWS} + sent := AsynchSend(fSock, P, Len); + if sent>0 then begin + inc(fBytesOut,sent); + dec(Len,sent); + if Len<=0 then + break; + inc(PByte(P),sent); + end else if WSAIsFatalError then + exit; // fatal socket error + now := GetTick64; + if (start=0) or (sent>0) then + start := now else // measure timeout since nothing written + if now-start>TimeOut then + exit; // identify timeout as error + SleepHiRes(1); + until false; + result := true; +end; + +procedure TCrtSocket.Write(const Data: SockString); +begin + SndLow(pointer(Data),length(Data)); +end; + +function TCrtSocket.AcceptIncoming(ResultClass: TCrtSocketClass): TCrtSocket; +var client: TSocket; + sin: TVarSin; +begin + result := nil; + if (self=nil) or (fSock<=0) then + exit; + client := Accept(fSock,sin); + if client<=0 then + exit; + if ResultClass=nil then + ResultClass := TCrtSocket; + result := ResultClass.Create(Timeout); + result.AcceptRequest(client,@sin); + result.CreateSockIn; // use SockIn with 1KB input buffer: 2x faster +end; + +function TCrtSocket.SockInRead(Content: PAnsiChar; Length: integer; + UseOnlySockIn: boolean): integer; +var len,res: integer; +// read Length bytes from SockIn^ buffer + Sock if necessary +begin + // get data from SockIn buffer, if any (faster than ReadChar) + result := 0; + if Length<=0 then + exit; + if SockIn<>nil then + with PTextRec(SockIn)^ do + repeat + len := BufEnd-BufPos; + if len>0 then begin + if len>Length then + len := Length; + move(BufPtr[BufPos],Content^,len); + inc(BufPos,len); + inc(Content,len); + dec(Length,len); + inc(result,len); + end; + if Length=0 then + exit; // we got everything we wanted + if not UseOnlySockIn then + break; + res := InputSock(PTextRec(SockIn)^); + if res<0 then + raise ECrtSocket.CreateFmt('SockInRead InputSock=%d',[res],-1); + until Timeout=0; + // direct receiving of the remaining bytes from socket + if Length>0 then begin + SockRecv(Content,Length); // raise ECrtSocket if failed to read Length + inc(result,Length); + end; +end; + +function TCrtSocket.SockInPending(aTimeOutMS: integer; aPendingAlsoInSocket: boolean): integer; +var backup: PtrInt; + insocket: integer; +begin + if SockIn=nil then + raise ECrtSocket.Create('SockInPending without SockIn'); + if aTimeOutMS<0 then + raise ECrtSocket.Create('SockInPending(aTimeOutMS<0)'); + with PTextRec(SockIn)^ do + result := BufEnd-BufPos; + if result=0 then + // no data in SockIn^.Buffer, so try if some pending at socket level + case SockReceivePending(aTimeOutMS) of + cspDataAvailable: begin + backup := fTimeOut; + fTimeOut := 0; // not blocking call to fill SockIn buffer + try + // call InputSock() to actually retrieve any pending data + if InputSock(PTextRec(SockIn)^)=NO_ERROR then + with PTextRec(SockIn)^ do + result := BufEnd-BufPos else + result := -1; // indicates broken socket + finally + fTimeOut := backup; + end; + end; + cspSocketError: + result := -1; // indicates broken/closed socket + end; // cspNoData will leave result=0 + {$ifdef MSWINDOWS} + // under Unix SockReceivePending use poll(fSocket) and if data available + // ioctl syscall is redundant + if aPendingAlsoInSocket then + // also includes data in socket bigger than TTextRec's buffer + if (IOCtlSocket(Sock,FIONREAD,insocket)=0) and (insocket>0) then + inc(result,insocket); + {$endif MSWINDOWS} +end; + +destructor TCrtSocket.Destroy; +begin + Close; + CloseSockIn; + CloseSockOut; + inherited; +end; + +procedure TCrtSocket.SockSend(P: pointer; Len: integer); +var cap: integer; +begin + if Len<=0 then + exit; + cap := Length(fSndBuf); + if Len+fSndBufLen>cap then + SetLength(fSndBuf,len+cap+cap shr 3+2048); + move(P^,PByteArray(fSndBuf)[fSndBufLen],Len); + inc(fSndBufLen,Len); +end; + +const + SOCKMINBUFSIZE = 1024; // big enough for headers (content will be read directly) + +{$ifdef FPC} +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + case Style Of + tlbsCR: TextRec(T).LineEnd := #13; + tlbsLF: TextRec(T).LineEnd := #10; + tlbsCRLF: TextRec(T).LineEnd := #13#10; + end; +end; +{$endif FPC} + +procedure TCrtSocket.CreateSockIn(LineBreak: TTextLineBreakStyle; + InputBufferSize: Integer); +begin + if (Self=nil) or (SockIn<>nil) then + exit; // initialization already occured + if InputBufferSizenil then + exit; // initialization already occured + if OutputBufferSizenil) and (fSockIn<>nil) then begin + Freemem(fSockIn); + fSockIn := nil; + end; +end; + +procedure TCrtSocket.CloseSockOut; +begin + if (self<>nil) and (fSockOut<>nil) then begin + Freemem(fSockOut); + fSockOut := nil; + end; +end; + +procedure TCrtSocket.SockRecv(Buffer: pointer; Length: integer); +var read: integer; +begin + read := Length; + if not TrySockRecv(Buffer,read,{StopBeforeLength=}false) or (Length<>read) then + raise ECrtSocket.CreateFmt('SockRecv(%d) failure (read=%d)',[Length,read]); +end; + +const + _CSP: array[TCrtSocketPending] of string[7] = ('ERROR','nodata','data'); + +function TCrtSocket.TrySockRecv(Buffer: pointer; var Length: integer; + StopBeforeLength: boolean): boolean; +var expected,read: PtrInt; + now, last, diff: Int64; +begin + result := false; + if (self<>nil) and (fSock>0) and (Buffer<>nil) and (Length>0) then begin + expected := Length; + Length := 0; + last := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; + repeat + read := expected-Length; + {$ifdef MSWINDOWS} + if fSecure.Initialized then + read := fSecure.Receive(fSock,Buffer,read) else + {$endif MSWINDOWS} + read := AsynchRecv(fSock,Buffer,read); + if read<=0 then begin // no more to read, or socket issue? + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'TrySockRecv: sock=% AsynchRecv=% %', + [Sock,read,SocketErrorMessage],self); + {$endif} + if (read=0) or WSAIsFatalError then begin + Close; // connection broken or socket closed gracefully (read=0) + exit; + end; + if StopBeforeLength then + break; + end else begin + inc(fBytesIn,read); + inc(Length,read); + if StopBeforeLength or (Length=expected) then + break; // good enough for now + inc(PByte(Buffer),read); + end; + now := GetTick64; + if (last=0) or (read>0) then // check timeout from unfinished read + last := now else begin + diff := now-last; + if diff>=TimeOut then begin + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'TrySockRecv: timeout (diff=%>%)',[diff,TimeOut],self); + {$endif} + exit; // identify read timeout as error + end; + if diff<100 then + SleepHiRes(0) else + SleepHiRes(1); + end; + until false; + result := true; + end; +end; + +function TCrtSocket.SockReceivePending(TimeOutMS: integer): TCrtSocketPending; +var res: integer; + {$ifdef MSWINDOWS} + tv: TTimeVal; + fdset: TFDSet; + pending: integer; + {$ifdef SYNCRTDEBUGLOW} + time: TPrecisionTimer; + {$endif} + {$else} + p: TPollFD; // TFDSet limited to 1024 total sockets in POSIX -> use poll() + {$endif} +begin + if (self=nil) or (fSock<=0) then begin + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'SockReceivePending: no Sock',self); + {$endif} + result := cspSocketError; + exit; + end; + {$ifdef MSWINDOWS} + {$ifdef SYNCRTDEBUGLOW} time.Start; {$endif} + fdset.fd_array[0] := fSock; + fdset.fd_count := 1; + tv.tv_sec := TimeOutMS div 1000; + tv.tv_usec := (TimeOutMS mod 1000)*1000; + pending := -1; + res := Select(fSock+1,@fdset,nil,nil,@tv); + if res<0 then + result := cspSocketError else + if (res=0) or (fdset.fd_count<>1) or (fdset.fd_array[0]<>fSock) then + result := cspNoData else + if IoctlSocket(fSock,FIONREAD,pending)=0 then + if pending>0 then + result := cspDataAvailable else + if TimeOutMS=0 then + result := cspNoData else begin + // https://docs.microsoft.com/en-us/windows/win32/api/winsock2/nf-winsock2-select#remarks + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom3, 'SockReceivePending: sock=% closed gracefully?',[fSock],self); + {$endif} + result := cspSocketError; + end else + result := cspSocketError; + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'SockReceivePending sock=% timeout=% fd_count=% fd_array[0]=% select=% result=% pending=% time=%', + [fSock, TimeOutMS, fdset.fd_count, fdset.fd_array[0], res, _CSP[result], pending, time.Stop], self); + {$endif} + {$else} + // https://moythreads.com/wordpress/2009/12/22/select-system-call-limitation + p.fd := fSock; + p.events := POLLIN; + p.revents := 0; + res := poll(@p,1,TimeOutMS); + if res<0 then + if WSAIsFatalError then + result := cspSocketError else + result := cspNoData else + if p.revents=POLLIN then + result := cspDataAvailable else + result := cspNoData; + {$endif} +end; + +function TCrtSocket.LastLowSocketError: Integer; +begin + result := WSAGetLastError; // retrieved directly from Sockets API +end; + +procedure TCrtSocket.SockRecvLn(out Line: SockString; CROnly: boolean); + procedure RecvLn(var Line: SockString); + var P: PAnsiChar; + LP, L: PtrInt; + tmp: array[0..1023] of AnsiChar; // avoid ReallocMem() every char + begin + P := @tmp; + Line := ''; + repeat + SockRecv(P,1); // this is very slow under Windows -> use SockIn^ instead + if P^<>#13 then // at least NCSA 1.3 does send a #10 only -> ignore #13 + if P^=#10 then begin + if Line='' then // get line + SetString(Line,tmp,P-tmp) else begin + LP := P-tmp; // append to already read chars + L := length(Line); + Setlength(Line,L+LP); + move(tmp,PByteArray(Line)[L],LP); + end; + exit; + end else + if P=@tmp[1023] then begin // tmp[] buffer full? + L := length(Line); // -> append to already read chars + Setlength(Line,L+1024); + move(tmp,PByteArray(Line)[L],1024); + P := tmp; + end else + inc(P); + until false; + end; +var c: byte; + L, Error: PtrInt; +begin + if CROnly then begin // slower but accurate version expecting #13 as line end + // SockIn^ expect either #10, either #13#10 -> a dedicated version is needed + repeat + SockRecv(@c,1); // this is slow but works + if c in [0,13] then + exit; // end of line + L := length(Line); + SetLength(Line,L+1); + PByteArray(Line)[L] := c; + until false; + end else + if SockIn<>nil then begin + {$I-} + readln(SockIn^,Line); // example: HTTP/1.0 200 OK + Error := ioresult; + if Error<>0 then + raise ECrtSocket.CreateFmt('SockRecvLn after %d chars',[length(Line)],Error); + {$I+} + end else + RecvLn(Line); // slow under Windows -> use SockIn^ instead +end; + +procedure TCrtSocket.SockRecvLn; +var c: AnsiChar; + Error: integer; +begin + if SockIn<>nil then begin + {$I-} + readln(SockIn^); + Error := ioresult; + if Error<>0 then + raise ECrtSocket.Create('SockRecvLn',Error); + {$I+} + end else + repeat + SockRecv(@c,1); + until c=#10; +end; + +function TCrtSocket.SockConnected: boolean; +var sin: TVarSin; +begin + result := (self<>nil) and (fSock>0) and (GetPeerName(fSock,sin)=0); +end; + +function TCrtSocket.PeerAddress: SockString; +begin + IPText(PVarSin(@fPeerAddr)^,result); +end; + +function TCrtSocket.PeerPort: integer; +begin + result := fPeerAddr.sin_port; +end; + +function TCrtSocket.SockReceiveString: SockString; +var available, resultlen, read: integer; +begin + result := ''; + if (self=nil) or (fSock<=0) then + exit; + resultlen := 0; + repeat + if (fSock<=0) or ((IOCtlSocket(fSock,FIONREAD,available)<>0) and WSAIsFatalError) then + exit; // raw socket error + if available=0 then // no data in the allowed timeout + if result='' then begin // wait till something + SleepHiRes(1);// some delay in infinite loop + continue; + end else + break; // return what we have + SetLength(result,resultlen+available); // append to result + read := available; + if not TrySockRecv(@PByteArray(result)[resultlen],read,{StopBeforeLength=}true) then begin + Close; + SetLength(result,resultlen); + exit; + end; + inc(resultlen,read); + if read'' then + SockSend(TCPPrefix); + if (url='') or (url[1]<>'/') then + SockSend([method,' /',url,' HTTP/1.1']) else + SockSend([method,' ',url,' HTTP/1.1']); + if Port=DEFAULT_PORT[fTLS] then + SockSend(['Host: ',Server]) else + SockSend(['Host: ',Server,':',Port]); + SockSend(['Accept: */*'#13#10'User-Agent: ',UserAgent]); +end; + +function THttpClientSocket.Request(const url, method: SockString; + KeepAlive: cardinal; const header, Data, DataType: SockString; retry: boolean): integer; + procedure DoRetry(Error: integer; const msg: SockString); + begin + {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, + 'Request: % socket=% DoRetry(%) retry=%',[msg,Sock,Error,BOOL_STR[retry]],self); + {$endif} + if retry then // retry once -> return error only if failed after retrial + result := Error else begin + Close; // close this connection + try + HeaderFlags := []; + OpenBind(Server,Port,false,-1,cslTcp,fTLS); // retry with a new socket + result := Request(url,method,KeepAlive,Header,Data,DataType,true); + except + on Exception do + result := Error; + end; + end; + end; +var P: PAnsiChar; + aData: SockString; +begin + if SockIn=nil then // done once + CreateSockIn; // use SockIn by default if not already initialized: 2x faster + Content := ''; + if (connectionClose in HeaderFlags) or + (SockReceivePending(0)=cspSocketError) then begin + DoRetry(STATUS_NOTFOUND,'connection broken (kepepalive timeout or too many requests)'); + exit; + end; + try + try + // send request - we use SockSend because writeln() is calling flush() + // -> all headers will be sent at once + RequestSendHeader(url,method); + if KeepAlive>0 then + SockSend(['Keep-Alive: ',KeepAlive,#13#10'Connection: Keep-Alive']) else + SockSend('Connection: Close'); + aData := Data; // local var copy for Data to be compressed in-place + CompressDataAndWriteHeaders(DataType,aData); + if header<>'' then + SockSend(header); + if fCompressAcceptEncoding<>'' then + SockSend(fCompressAcceptEncoding); + SockSend; // send CRLF + SockSendFlush(aData); // flush all pending data to network + // get headers + if SockReceivePending(1000)=cspSocketError then begin + DoRetry(STATUS_NOTFOUND,'cspSocketError waiting for headers'); + exit; + end; + SockRecvLn(Command); // will raise ECrtSocket on any error + if TCPPrefix<>'' then + if Command<>TCPPrefix then begin + result := STATUS_HTTPVERSIONNONSUPPORTED; // 505 + exit; + end else + SockRecvLn(Command); + P := pointer(Command); + if IdemPChar(P,'HTTP/1.') then begin + result := GetCardinal(P+9); // get http numeric status code (200,404...) + if result=0 then begin + result := STATUS_HTTPVERSIONNONSUPPORTED; + exit; + end; + while result=100 do begin + repeat // 100 CONTINUE is just to be ignored client side + SockRecvLn(Command); + P := pointer(Command); + until IdemPChar(P,'HTTP/1.'); // ignore up to next command + result := GetCardinal(P+9); + end; + if P[7]='0' then + KeepAlive := 0; // HTTP/1.0 -> force connection close + end else begin // error on reading answer + DoRetry(STATUS_HTTPVERSIONNONSUPPORTED,Command); // 505=wrong format + exit; + end; + GetHeader(false); // read all other headers + if (result>=STATUS_SUCCESS) and (result<>STATUS_NOCONTENT) and + (result<>STATUS_NOTMODIFIED) and + (IdemPCharArray(pointer(method),['HEAD','OPTIONS'])<0) then + GetBody; // get content if necessary (HEAD or OPTIONS have no body) + except + on Exception do + DoRetry(STATUS_NOTFOUND,'Exception'); + end; + finally + if KeepAlive=0 then + Close; + end; +end; + +function Open(const aServer, aPort: SockString; aTLS: boolean): TCrtSocket; +begin + try + result := TCrtSocket.Open(aServer,aPort,cslTCP,10000,aTLS); + except + on ECrtSocket do + result := nil; + end; +end; + +function OpenHttp(const aServer, aPort: SockString; aTLS: boolean; + aLayer: TCrtSocketLayer): THttpClientSocket; +begin + try + result := THttpClientSocket.Open(aServer,aPort,aLayer,0,aTLS); // HTTP_DEFAULT_RECEIVETIMEOUT + except + on ECrtSocket do + result := nil; + end; +end; + +function OpenHttp(const aURI: SockString; aAddress: PSockString): THttpClientSocket; +var URI: TURI; +begin + result := nil; + if URI.From(aURI) then begin + result := OpenHttp(URI.Server,URI.Port,URI.Https,URI.Layer); + if aAddress <> nil then + aAddress^ := URI.Address; + end; +end; + +function HttpGet(const server, port: SockString; const url: SockString; + const inHeaders: SockString; outHeaders: PSockString; + aLayer: TCrtSocketLayer; outStatus: PInteger): SockString; +var Http: THttpClientSocket; + status: integer; +begin + result := ''; + Http := OpenHttp(server,port,false,aLayer); + if Http<>nil then + try + status := Http.Get(url,0,inHeaders); + if outStatus <> nil then + outStatus^ := status; + if status in [STATUS_SUCCESS..STATUS_PARTIALCONTENT] then begin + result := Http.Content; + if outHeaders<>nil then + outHeaders^ := Http.HeaderGetText; + end; + finally + Http.Free; + end; +end; + +function HttpGet(const aURI: SockString; outHeaders: PSockString; forceNotSocket: boolean; + outStatus: PInteger): SockString; +begin + result := HttpGet(aURI,'',outHeaders,forceNotSocket,outStatus); +end; + +function HttpGet(const aURI: SockString; const inHeaders: SockString; + outHeaders: PSockString; forceNotSocket: boolean; outStatus: PInteger): SockString; +var URI: TURI; +begin + if URI.From(aURI) then + if URI.Https or forceNotSocket then + {$ifdef USEWININET} + result := TWinHTTP.Get(aURI,inHeaders,{weakCA=}true,outHeaders,outStatus) else + {$else} + {$ifdef USELIBCURL} + result := TCurlHTTP.Get(aURI,inHeaders,{weakCA=}true,outHeaders,outStatus) else + {$else} + raise ECrtSocket.CreateFmt('https is not supported by HttpGet(%s)',[aURI]) else + {$endif} + {$endif USEWININET} + result := HttpGet(URI.Server,URI.Port,URI.Address,inHeaders,outHeaders,URI.Layer,outStatus) else + result := ''; + {$ifdef LINUX_RAWDEBUGVOIDHTTPGET} + if result='' then + writeln('HttpGet returned VOID for ',URI.server,':',URI.Port,' ',URI.Address); + {$endif} +end; + +function HttpGetAuth(const aURI, aAuthToken: SockString; outHeaders: PSockString; + forceNotSocket: boolean; outStatus: PInteger): SockString; +var status: integer; +begin + result := HttpGet(aURI,AuthorizationBearer(aAuthToken),outHeaders,forceNotSocket,@status); + if outStatus<>nil then + outStatus^ := status; + if not(status in [STATUS_SUCCESS..STATUS_PARTIALCONTENT]) then + result := ''; +end; + +function HttpPost(const server, port: SockString; const url, Data, DataType: SockString; + outData: PSockString; const auth: SockString): boolean; +var Http: THttpClientSocket; +begin + result := false; + Http := OpenHttp(server,port); + if Http<>nil then + try + result := Http.Post(url,Data,DataType,0,AuthorizationBearer(auth)) in + [STATUS_SUCCESS,STATUS_CREATED,STATUS_NOCONTENT]; + if outdata<>nil then + outdata^ := Http.Content; + finally + Http.Free; + end; +end; + +function HttpPut(const server, port: SockString; const url, Data, DataType: SockString; + outData: PSockString; const auth: SockString): boolean; +var Http: THttpClientSocket; +begin + result := false; + Http := OpenHttp(server,port); + if Http<>nil then + try + result := Http.Put(url,Data,DataType,0,AuthorizationBearer(auth)) in + [STATUS_SUCCESS,STATUS_CREATED,STATUS_NOCONTENT]; + if outdata<>nil then + outdata^ := Http.Content; + finally + Http.Free; + end; +end; + +function TSMTPConnection.FromText(const aText: SockString): boolean; +var u,h: SockString; +begin + if aText=SMTP_DEFAULT then begin + result := false; + exit; + end; + if Split(aText,'@',u,h) then begin + if not Split(u,':',User,Pass) then + User := u; + end else + h := aText; + if not Split(h,':',Host,Port) then begin + Host := h; + Port := '25'; + end; + if (Host<>'') and (Host[1]='?') then + Host := ''; + result := Host<>''; +end; + +function SendEmail(const Server: TSMTPConnection; const From, CSVDest, Subject, + Text, Headers, TextCharSet: SockString; aTLS: boolean): boolean; +begin + result := SendEmail(Server.Host, From, CSVDest, Subject, Text, Headers, + Server.User, Server.Pass, Server.Port, TextCharSet, + (Server.Port = '465') or (Server.Port = '587')); +end; + +function SendEmail(const Server, From, CSVDest, Subject, Text, Headers, + User, Pass, Port, TextCharSet: SockString; aTLS: boolean): boolean; +var TCP: TCrtSocket; + procedure Expect(const Answer: SockString); + var Res: SockString; + begin + repeat + readln(TCP.SockIn^,Res); + until (Length(Res)<4)or(Res[4]<>'-'); + if not IdemPChar(pointer(Res),pointer(Answer)) then + raise ECrtSocket.Create(string(Res)); + end; + procedure Exec(const Command, Answer: SockString); + begin + writeln(TCP.SockOut^,Command); + Expect(Answer) + end; +var P: PAnsiChar; + rec, ToList, head: SockString; +begin + result := false; + P := pointer(CSVDest); + if P=nil then exit; + TCP := Open(Server,Port,aTLS); + if TCP<>nil then + try + TCP.CreateSockIn; // we use SockIn and SockOut here + TCP.CreateSockOut; + Expect('220'); + if (User<>'') and (Pass<>'') then begin + Exec('EHLO '+Server,'25'); + Exec('AUTH LOGIN','334'); + Exec(SockBase64Encode(User),'334'); + Exec(SockBase64Encode(Pass),'235'); + end else + Exec('HELO '+Server,'25'); + writeln(TCP.SockOut^,'MAIL FROM:<',From,'>'); Expect('250'); + repeat + GetNextItem(P,',',rec); + rec := Trim(rec); + if rec='' then continue; + if PosCh('<',rec)=0 then + rec := '<'+rec+'>'; + Exec('RCPT TO:'+rec,'25'); + if ToList='' then + ToList := #13#10'To: '+rec else + ToList := ToList+', '+rec; + until P=nil; + Exec('DATA','354'); + head := trim(Headers); + if head<>'' then + head := head+#13#10; + writeln(TCP.SockOut^,'Subject: ',Subject,#13#10'From: ',From,ToList); + if TextCharSet='JSON' then + writeln(TCP.SockOut^,'Content-Type: application/json; charset=UTF-8') + else + writeln(TCP.SockOut^,'Content-Type: text/plain; charset=',TextCharSet); + writeln(TCP.SockOut^,'Content-Transfer-Encoding: 8bit'#13#10,head,#13#10,Text); + Exec('.','25'); + writeln(TCP.SockOut^,'QUIT'); + result := true; + finally + TCP.Free; + end; +end; + +function IsAnsi7(const s: string): boolean; +var i: integer; +begin + result := false; + for i := 1 to length(s) do + if ord(s[i])>126 then + exit; + result := true; +end; + +function SendEmailSubject(const Text: string): SockString; +var utf8: UTF8String; +begin + if IsAnsi7(Text) then + result := SockString(Text) else begin + utf8 := UTF8String(Text); + result := '=?UTF-8?B?'+SockBase64Encode(utf8); + end; +end; + + +{ THttpServerRequest } + +constructor THttpServerRequest.Create(aServer: THttpServerGeneric; + aConnectionID: THttpServerConnectionID; aConnectionThread: TSynThread); +begin + inherited Create; + fServer := aServer; + fConnectionID := aConnectionID; + fConnectionThread := aConnectionThread; +end; + +var + GlobalRequestID: integer; + +procedure THttpServerRequest.Prepare(const aURL, aMethod, aInHeaders, + aInContent, aInContentType, aRemoteIP: SockString; aUseSSL: boolean); +var id: PInteger; +begin + if fServer=nil then + id := @GlobalRequestID else + id := @fServer.fCurrentRequestID; + fRequestID := InterLockedIncrement(id^); + if fRequestID=maxInt-2048 then // ensure no overflow (31-bit range) + id^ := 0; + fUseSSL := aUseSSL; + fURL := aURL; + fMethod := aMethod; + fRemoteIP := aRemoteIP; + if aRemoteIP<>'' then + if aInHeaders='' then + fInHeaders := 'RemoteIP: '+aRemoteIP else + fInHeaders := aInHeaders+#13#10'RemoteIP: '+aRemoteIP else + fInHeaders := aInHeaders; + fInContent := aInContent; + fInContentType := aInContentType; + fOutContent := ''; + fOutContentType := ''; + fOutCustomHeaders := ''; +end; + +procedure THttpServerRequest.AddInHeader(additionalHeader: SockString); +begin + additionalHeader := Trim(additionalHeader); + if additionalHeader<>'' then + if fInHeaders='' then + fInHeaders := additionalHeader else + fInHeaders := fInHeaders+#13#10+additionalHeader; +end; + + +{ TServerGeneric } + +constructor TServerGeneric.Create(CreateSuspended: boolean; + OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); +begin + fProcessName := ProcessName; + fOnHttpThreadStart := OnStart; + SetOnTerminate(OnStop); + inherited Create(CreateSuspended); +end; + +procedure TServerGeneric.NotifyThreadStart(Sender: TSynThread); +begin + if Sender=nil then + raise ECrtSocket.Create('NotifyThreadStart(nil)'); + if Assigned(fOnHttpThreadStart) and not Assigned(Sender.fStartNotified) then begin + fOnHttpThreadStart(Sender); + Sender.fStartNotified := self; + end; +end; + +procedure TServerGeneric.SetOnTerminate(const Event: TNotifyThreadEvent); +begin + fOnThreadTerminate := Event; +end; + + +{ THttpServerGeneric } + +constructor THttpServerGeneric.Create(CreateSuspended: boolean; + OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); +begin + SetServerName('mORMot ('+XPOWEREDOS+')'); + inherited Create(CreateSuspended,OnStart,OnStop,ProcessName); +end; + +procedure THttpServerGeneric.RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024); +begin + RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize); +end; + +procedure THttpServerGeneric.Shutdown; +begin + if self<>nil then + fShutdownInProgress := true; +end; + +function THttpServerGeneric.Request(Ctxt: THttpServerRequest): cardinal; +begin + if (self=nil) or fShutdownInProgress then + result := STATUS_NOTFOUND else begin + NotifyThreadStart(Ctxt.ConnectionThread); + if Assigned(OnRequest) then + result := OnRequest(Ctxt) else + result := STATUS_NOTFOUND; + end; +end; + +function THttpServerGeneric.Callback(Ctxt: THttpServerRequest; aNonBlocking: boolean): cardinal; +begin + raise ECrtSocket.CreateFmt('%s.Callback is not implemented: try to use '+ + 'another communication protocol, e.g. WebSockets',[ClassName]); +end; + +procedure THttpServerGeneric.SetServerName(const aName: SockString); +begin + fServerName := aName; +end; + +procedure THttpServerGeneric.SetOnRequest(const aRequest: TOnHttpServerRequest); +begin + fOnRequest := aRequest; +end; + +procedure THttpServerGeneric.SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); +begin + fOnBeforeBody := aEvent; +end; + +procedure THttpServerGeneric.SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); +begin + fOnBeforeRequest := aEvent; +end; + +procedure THttpServerGeneric.SetOnAfterRequest(const aEvent: TOnHttpServerRequest); +begin + fOnAfterRequest := aEvent; +end; + +procedure THttpServerGeneric.SetOnAfterResponse( + const aEvent: TOnHttpServerAfterResponse); +begin + fOnAfterResponse := aEvent; +end; + +function THttpServerGeneric.DoBeforeRequest(Ctxt: THttpServerRequest): cardinal; +begin + if Assigned(fOnBeforeRequest) then + result := fOnBeforeRequest(Ctxt) else + result := 0; +end; + +function THttpServerGeneric.DoAfterRequest(Ctxt: THttpServerRequest): cardinal; +begin + if Assigned(fOnAfterRequest) then + result := fOnAfterRequest(Ctxt) else + result := 0; +end; + +procedure THttpServerGeneric.DoAfterResponse(Ctxt: THttpServerRequest; + const Code: cardinal); +begin + if Assigned(fOnAfterResponse) then + fOnAfterResponse(Ctxt, Code); +end; + +procedure THttpServerGeneric.SetMaximumAllowedContentLength(aMax: cardinal); +begin + fMaximumAllowedContentLength := aMax; +end; + +procedure THttpServerGeneric.SetRemoteIPHeader(const aHeader: SockString); +begin + fRemoteIPHeader := aHeader; + fRemoteIPHeaderUpper := UpperCase(aHeader); +end; + +procedure THttpServerGeneric.SetRemoteConnIDHeader(const aHeader: SockString); +begin + fRemoteConnIDHeader := aHeader; + fRemoteConnIDHeaderUpper := UpperCase(aHeader); +end; + +function THttpServerGeneric.NextConnectionID: integer; +begin + result := InterlockedIncrement(fCurrentConnectionID); + if result=maxInt-2048 then // paranoid 31-bit counter reset to ensure >0 + fCurrentConnectionID := 0; +end; + + +{ THttpServer } + +constructor THttpServer.Create(const aPort: SockString; OnStart, + OnStop: TNotifyThreadEvent; const ProcessName: SockString; + ServerThreadPoolCount: integer; KeepAliveTimeOut: integer; + HeadersUnFiltered: boolean; CreateSuspended: boolean); +begin + fSockPort := aPort; + fInternalHttpServerRespList := {$ifdef FPC}TFPList{$else}TList{$endif}.Create; + InitializeCriticalSection(fProcessCS); + fServerKeepAliveTimeOut := KeepAliveTimeOut; // 30 seconds by default + if fThreadPool<>nil then + fThreadPool.ContentionAbortDelay := 5000; // 5 seconds default + // event handlers set before inherited Create to be visible in childs + fOnHttpThreadStart := OnStart; + SetOnTerminate(OnStop); + if fThreadRespClass=nil then + fThreadRespClass := THttpServerResp; + if fSocketClass=nil then + fSocketClass := THttpServerSocket; + if ServerThreadPoolCount>0 then begin + fThreadPool := TSynThreadPoolTHttpServer.Create(self,ServerThreadPoolCount); + fHTTPQueueLength := 1000; + end; + fHeadersNotFiltered := HeadersUnFiltered; + inherited Create(CreateSuspended,OnStart,OnStop,ProcessName); +end; + +function THttpServer.GetAPIVersion: string; +begin + result := Format('%s.%d',[WsaDataOnce.szDescription,WsaDataOnce.wVersion]); +end; + +destructor THttpServer.Destroy; +var endtix: Int64; + i: integer; + resp: THttpServerResp; +begin + Terminate; // set Terminated := true for THttpServerResp.Execute + if fThreadPool<>nil then + fThreadPool.fTerminated := true; // notify background process + if (fExecuteState=esRunning) and (Sock<>nil) then begin + Sock.Close; // shutdown the socket to unlock Accept() in Execute + DirectShutdown(CallServer('127.0.0.1',Sock.Port,false,cslTCP,1)); + end; + endtix := GetTick64+20000; + EnterCriticalSection(fProcessCS); + try + if fInternalHttpServerRespList<>nil then begin + for i := 0 to fInternalHttpServerRespList.Count-1 do begin + resp := fInternalHttpServerRespList.List[i]; + resp.Terminate; + DirectShutdown(resp.fServerSock.Sock,{rdwr=}true); + end; + repeat // wait for all THttpServerResp.Execute to be finished + if (fInternalHttpServerRespList.Count=0) and (fExecuteState<>esRunning) then + break; + LeaveCriticalSection(fProcessCS); + SleepHiRes(100); + EnterCriticalSection(fProcessCS); + until GetTick64>endtix; + FreeAndNil(fInternalHttpServerRespList); + end; + finally + LeaveCriticalSection(fProcessCS); + FreeAndNil(fThreadPool); // release all associated threads and I/O completion + FreeAndNil(fSock); + inherited Destroy; // direct Thread abort, no wait till ended + DeleteCriticalSection(fProcessCS); + end; +end; + +function THttpServer.GetStat(one: THttpServerSocketGetRequestResult): integer; +begin + result := fStats[one]; +end; + +function THttpServer.GetHTTPQueueLength: Cardinal; +begin + result := fHTTPQueueLength; +end; + +procedure THttpServer.SetHTTPQueueLength(aValue: Cardinal); +begin + fHTTPQueueLength := aValue; +end; + +procedure THttpServer.InternalHttpServerRespListAdd(resp: THttpServerResp); +begin + if (self=nil) or (fInternalHttpServerRespList=nil) or (resp=nil) then + exit; + EnterCriticalSection(fProcessCS); + try + fInternalHttpServerRespList.Add(resp); + finally + LeaveCriticalSection(fProcessCS); + end; +end; + +procedure THttpServer.InternalHttpServerRespListRemove(resp: THttpServerResp); +var i: integer; +begin + if (self=nil) or (fInternalHttpServerRespList=nil) then + exit; + EnterCriticalSection(fProcessCS); + try + i := fInternalHttpServerRespList.IndexOf(resp); + if i>=0 then + fInternalHttpServerRespList.Delete(i); + finally + LeaveCriticalSection(fProcessCS); + end; +end; + +function THttpServer.OnNginxAllowSend(Context: THttpServerRequest; + const LocalFileName: TFileName): boolean; +var match,i,f: PtrInt; + folder: ^TFileName; +begin + match := 0; + folder := pointer(fNginxSendFileFrom); + if LocalFileName<>'' then + for f := 1 to length(fNginxSendFileFrom) do begin + match := length(folder^); + for i := 1 to match do // case sensitive left search + if LocalFileName[i]<>folder^[i] then begin + match := 0; + break; + end; + if match<>0 then + break; // found matching folder + inc(folder); + end; + result := match<>0; + if not result then + exit; // no match -> manual send + delete(Context.fOutContent,1,match); // remove e.g. '/var/www' + Context.OutCustomHeaders := Trim(Context.OutCustomHeaders+#13#10+ + 'X-Accel-Redirect: '+Context.OutContent); + Context.OutContent := ''; +end; + +procedure THttpServer.NginxSendFileFrom(const FileNameLeftTrim: TFileName); +var n: PtrInt; +begin + n := length(fNginxSendFileFrom); + SetLength(fNginxSendFileFrom,n+1); + fNginxSendFileFrom[n] := FileNameLeftTrim; + fOnSendFile := OnNginxAllowSend; +end; + +procedure THttpServer.WaitStarted(Seconds: integer); +var tix: Int64; + ok: boolean; +begin + tix := GetTick64 + Seconds * 1000; // never wait forever + repeat + EnterCriticalSection(fProcessCS); + ok := Terminated or (fExecuteState in [esRunning, esFinished]); + LeaveCriticalSection(fProcessCS); + if ok then + exit; + Sleep(1); + if GetTick64 > tix then + raise ECrtSocket.CreateFmt('%s.WaitStarted failed after %d seconds [%s]', + [ClassName,Seconds,fExecuteMessage]); + until false; +end; + +{.$define MONOTHREAD} +// define this not to create a thread at every connection (not recommended) + +procedure THttpServer.Execute; +var ClientSock: TSocket; + ClientSin: TVarSin; + ClientCrtSock: THttpServerSocket; + {$ifdef MONOTHREAD} + endtix: Int64; + {$endif} +begin + // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event + fExecuteState := esBinding; + NotifyThreadStart(self); + // main server process loop + try + fSock := TCrtSocket.Bind(fSockPort); // BIND + LISTEN + {$ifdef LINUXNOTBSD} + // in case we started by systemd, listening socket is created by another process + // and do not interrupt while process got a signal. So we need to set a timeout to + // unblock accept() periodically and check we need terminations + if fSockPort = '' then // external socket + fSock.ReceiveTimeout := 1000; // unblock accept every second + {$endif} + fExecuteState := esRunning; + if fSock.Sock<=0 then // paranoid (Bind would have raise an exception) + raise ECrtSocket.Create('THttpServer.Execute: TCrtSocket.Bind failed'); + while not Terminated do begin + ClientSock := Accept(Sock.Sock,ClientSin); + if ClientSock<=0 then + if Terminated then + break else begin + SleepHiRes(1); // failure (too many clients?) -> wait and retry + continue; + end; + if Terminated or (Sock=nil) then begin + DirectShutdown(ClientSock); + break; // don't accept input if server is down + end; + OnConnect; + {$ifdef MONOTHREAD} + ClientCrtSock := fSocketClass.Create(self); + try + ClientCrtSock.InitRequest(ClientSock); + endtix := fHeaderRetrieveAbortDelay; + if endtix>0 then + inc(endtix,GetTick64); + if ClientCrtSock.GetRequest({withbody=}true,endtix) in [grBodyReceived,grHeaderReceived] then + Process(ClientCrtSock,0,self); + OnDisconnect; + DirectShutdown(ClientSock); + finally + ClientCrtSock.Free; + end; + {$else} + if Assigned(fThreadPool) then begin + // use thread pool to process the request header, and probably its body + ClientCrtSock := fSocketClass.Create(self); + ClientCrtSock.AcceptRequest(ClientSock,@ClientSin); + if not fThreadPool.Push(pointer(PtrUInt(ClientCrtSock)),{waitoncontention=}true) then begin + // returned false if there is no idle thread in the pool, and queue is full + ClientCrtSock.Free; // will call DirectShutdown(ClientSock) + end; + end else + // default implementation creates one thread for each incoming socket + fThreadRespClass.Create(ClientSock,ClientSin,self); + {$endif MONOTHREAD} + end; + except + on E: Exception do // any exception would break and release the thread + fExecuteMessage := E.ClassName+' ['+E.Message+']'; + end; + EnterCriticalSection(fProcessCS); + fExecuteState := esFinished; + LeaveCriticalSection(fProcessCS); +end; + +procedure THttpServer.OnConnect; +begin + InterLockedIncrement(fServerConnectionCount); + InterLockedIncrement(fServerConnectionActive); +end; + +procedure THttpServer.OnDisconnect; +begin + InterLockedDecrement(fServerConnectionActive); +end; + +procedure THttpServer.Process(ClientSock: THttpServerSocket; + ConnectionID: THttpServerConnectionID; ConnectionThread: TSynThread); +var ctxt: THttpServerRequest; + P: PAnsiChar; + respsent: boolean; + Code, afterCode: cardinal; + s, reason: SockString; + ErrorMsg: string; + + function SendResponse: boolean; + var + fs: TFileStream; + fn: TFileName; + len: PtrInt; + begin + result := not Terminated; // true=success + if not result then + exit; + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'SendResponse respsent=% code=%', [respsent,code], self); + {$endif} + respsent := true; + len := -1; // use length(ctxt.OutContent) by default + // handle case of direct sending of static file (as with http.sys) + if (ctxt.OutContent<>'') and (ctxt.OutContentType=HTTP_RESP_STATICFILE) then + try + ExtractNameValue(ctxt.fOutCustomHeaders,'CONTENT-TYPE:',ctxt.fOutContentType); + fn := {$ifdef UNICODE}UTF8ToUnicodeString{$else}Utf8ToAnsi{$endif}(ctxt.OutContent); + if (ctxt.Method='HEAD') or not Assigned(fOnSendFile) or not fOnSendFile(ctxt,fn) then begin + fs := TFileStream.Create(fn,fmOpenRead or fmShareDenyNone); + try + if ctxt.Method='HEAD' then + len := fs.Size else + begin // regular GET or POST response + SetString(ctxt.fOutContent,nil,fs.Size); + fs.Read(Pointer(ctxt.fOutContent)^,length(ctxt.fOutContent)); + end; + finally + fs.Free; + end; + end; + except + on E: Exception do begin // error reading or sending file + ErrorMsg := E.ClassName+': '+E.Message; + Code := STATUS_NOTFOUND; + result := false; // fatal error + end; + end; + if ctxt.OutContentType=HTTP_RESP_NORESPONSE then + ctxt.OutContentType := ''; // true HTTP always expects a response + // send response (multi-thread OK) at once + if (Code'' then begin + ctxt.OutCustomHeaders := ''; + ctxt.OutContentType := 'text/html; charset=utf-8'; // create message to display + ctxt.OutContent := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}( + format(''#10+ + '

%s Server Error %d

HTTP %d %s

%s

%s', + [ClassName,Code,Code,reason,HtmlEncodeString(ErrorMsg),fServerName])); + end; + // 1. send HTTP status command + if ClientSock.TCPPrefix<>'' then + ClientSock.SockSend(ClientSock.TCPPrefix); + if ClientSock.KeepAliveClient then + ClientSock.SockSend(['HTTP/1.1 ',Code,' ',reason]) else + ClientSock.SockSend(['HTTP/1.0 ',Code,' ',reason]); + // 2. send headers + // 2.1. custom headers from Request() method + P := pointer(ctxt.fOutCustomHeaders); + while P<>nil do begin + GetNextLine(P,s); + if s<>'' then begin // no void line (means headers ending) + ClientSock.SockSend(s); + if IdemPChar(pointer(s),'CONTENT-ENCODING:') then + integer(ClientSock.fCompressAcceptHeader) := 0; // custom encoding: don't compress + end; + end; + // 2.2. generic headers + ClientSock.SockSend([ + {$ifndef NOXPOWEREDNAME}XPOWEREDNAME+': '+XPOWEREDVALUE+#13#10+{$endif} + 'Server: ',fServerName]); + ClientSock.CompressDataAndWriteHeaders(ctxt.OutContentType,ctxt.fOutContent,len); + if ClientSock.KeepAliveClient then begin + if ClientSock.fCompressAcceptEncoding<>'' then + ClientSock.SockSend(ClientSock.fCompressAcceptEncoding); + ClientSock.SockSend('Connection: Keep-Alive'#13#10); // #13#10 -> end headers + end else + ClientSock.SockSend; // headers must end with a void line + // 3. sent HTTP body content (if any) + ClientSock.SockSendFlush(ctxt.OutContent); // flush all data to network + end; + +begin + if (ClientSock=nil) or (ClientSock.Headers='') then + // we didn't get the request = socket read error + exit; // -> send will probably fail -> nothing to send back + if Terminated then + exit; + ctxt := THttpServerRequest.Create(self,ConnectionID,ConnectionThread); + try + respsent := false; + with ClientSock do + ctxt.Prepare(URL,Method,HeaderGetText(fRemoteIP),Content,ContentType,fRemoteIP,ClientSock.fTLS); + try + Code := DoBeforeRequest(ctxt); + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'DoBeforeRequest=%', [code], self); + {$endif} + if Code>0 then + if not SendResponse or (Code<>STATUS_ACCEPTED) then + exit; + Code := Request(ctxt); + afterCode := DoAfterRequest(ctxt); + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'Request=% DoAfterRequest=%', [code,afterCode], self); + {$endif} + if afterCode>0 then + Code := afterCode; + if respsent or SendResponse then + DoAfterResponse(ctxt, Code); + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'DoAfterResponse respsent=% ErrorMsg=%', [respsent,ErrorMsg], self); + {$endif} + except + on E: Exception do + if not respsent then begin + ErrorMsg := E.ClassName+': '+E.Message; + Code := STATUS_SERVERERROR; + SendResponse; + end; + end; + finally + if Sock<>nil then begin // add transfert stats to main socket + EnterCriticalSection(fProcessCS); + inc(Sock.fBytesIn,ClientSock.BytesIn); + inc(Sock.fBytesOut,ClientSock.BytesOut); + LeaveCriticalSection(fProcessCS); + ClientSock.fBytesIn := 0; + ClientSock.fBytesOut := 0; + end; + ctxt.Free; + end; +end; + + +{ TSynThread } + +constructor TSynThread.Create(CreateSuspended: boolean); +begin + {$ifdef FPC} + inherited Create(CreateSuspended,512*1024); // DefaultSizeStack=512KB + {$else} + inherited Create(CreateSuspended); + {$endif} +end; + +function TSynThread.SleepOrTerminated(MS: cardinal): boolean; +var endtix: Int64; +begin + result := true; // notify Terminated + if Terminated then + exit; + if MS<32 then begin // smaller than GetTickCount resolution (under Windows) + SleepHiRes(MS); + if Terminated then + exit; + end else begin + endtix := GetTick64+MS; + repeat + SleepHiRes(10); + if Terminated then + exit; + until GetTick64>endtix; + end; + result := false; // abnormal delay expiration +end; + +{$ifndef LVCL} +procedure TSynThread.DoTerminate; +begin + try + if Assigned(fStartNotified) and Assigned(fOnThreadTerminate) then begin + fOnThreadTerminate(self); + fStartNotified := nil; + end; + inherited DoTerminate; // call OnTerminate via Synchronize() + except // hardened: a closing thread should not jeopardize the whole project! + end; +end; +{$endif} + +{$ifndef HASTTHREADSTART} +procedure TSynThread.Start; +begin + Resume; +end; +{$endif} + + +{ THttpServerResp } + +constructor THttpServerResp.Create(aSock: TSocket; const aSin: TVarSin; aServer: THttpServer); +var c: THttpServerSocketClass; +begin + fClientSock := aSock; + fClientSin := aSin; + if aServer=nil then + c := THttpServerSocket else + c := aServer.fSocketClass; + Create(c.Create(aServer),aServer); // on Linux, Execute raises during Create +end; + +constructor THttpServerResp.Create(aServerSock: THttpServerSocket; aServer: THttpServer); +begin + fServer := aServer; + fServerSock := aServerSock; + fOnThreadTerminate := fServer.fOnThreadTerminate; + fServer.InternalHttpServerRespListAdd(self); + fConnectionID := aServerSock.RemoteConnectionID; + if fConnectionID=0 then + fConnectionID := fServer.NextConnectionID; // fallback to 31-bit sequence + FreeOnTerminate := true; + inherited Create(false); +end; + +procedure THttpServerResp.Execute; + + procedure HandleRequestsProcess; + var keepaliveendtix,beforetix,headertix,tix: Int64; + pending: TCrtSocketPending; + res: THttpServerSocketGetRequestResult; + begin + {$ifdef SYNCRTDEBUGLOW} try {$endif} + try + repeat + beforetix := GetTick64; + keepaliveendtix := beforetix+fServer.ServerKeepAliveTimeOut; + repeat // within this loop, break=wait for next command, exit=quit + if (fServer=nil) or fServer.Terminated or (fServerSock=nil) then + exit; // server is down -> close connection + pending := fServerSock.SockReceivePending(50); // 50 ms timeout + if (fServer=nil) or fServer.Terminated then + exit; // server is down -> disconnect the client + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: sock=% pending=%', + [fServerSock.fSock, _CSP[pending]], self); + {$endif} + case pending of + cspSocketError: + exit; // socket error -> disconnect the client + cspNoData: begin + tix := GetTick64; + if tix>=keepaliveendtix then + exit; // reached keep alive time out -> close connection + if tix-beforetix<40 then begin + {$ifdef SYNCRTDEBUGLOW} + // getsockopt(fServerSock.fSock,SOL_SOCKET,SO_ERROR,@error,errorlen) returns 0 :( + TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: sock=% LOWDELAY=%', + [fServerSock.fSock, tix-beforetix], self); + {$endif} + SleepHiRes(1); // seen only on Windows in practice + if (fServer=nil) or fServer.Terminated then + exit; // server is down -> disconnect the client + end; + beforetix := tix; + end; + cspDataAvailable: begin + // get request and headers + headertix := fServer.HeaderRetrieveAbortDelay; + if headertix>0 then + inc(headertix,beforetix); + res := fServerSock.GetRequest({withbody=}true,headertix); + if (fServer=nil) or fServer.Terminated then + exit; // server is down -> disconnect the client + InterLockedIncrement(fServer.fStats[res]); + case res of + grBodyReceived, grHeaderReceived: begin + if res=grBodyReceived then + InterlockedIncrement(fServer.fStats[grHeaderReceived]); + // calc answer and send response + fServer.Process(fServerSock,ConnectionID,self); + // keep connection only if necessary + if fServerSock.KeepAliveClient then + break else + exit; + end; + grOwned: begin + fServerSock := nil; // will be freed by new owner + exit; + end; + else // fServerSock connection was down or headers are not correct + exit; + end; + end; + end; + until false; + until false; + except + on E: Exception do + ; // any exception will silently disconnect the client + end; + {$ifdef SYNCRTDEBUGLOW} + finally + TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: close sock=%', [fServerSock.fSock], self); + end; + {$endif} + end; + +var aSock: TSocket; +begin + fServer.NotifyThreadStart(self); + try + try + if fClientSock<>0 then begin + // direct call from incoming socket + aSock := fClientSock; + fClientSock := 0; // fServerSock owns fClientSock + fServerSock.AcceptRequest(aSock,@fClientSin); + if fServer<>nil then + HandleRequestsProcess; + end else begin + // call from TSynThreadPoolTHttpServer -> handle first request + if not fServerSock.fBodyRetrieved and + (IdemPCharArray(pointer(fServerSock.fMethod),['HEAD','OPTIONS'])<0) then + fServerSock.GetBody; + fServer.Process(fServerSock,ConnectionID,self); + if (fServer<>nil) and fServerSock.KeepAliveClient then + HandleRequestsProcess; // process further kept alive requests + end; + finally + try + if fServer<>nil then + try + fServer.OnDisconnect; + finally + fServer.InternalHttpServerRespListRemove(self); + fServer := nil; + end; + finally + FreeAndNil(fServerSock); + // if Destroy happens before fServerSock.GetRequest() in Execute below + DirectShutdown(fClientSock); + end; + end; + except + on Exception do + ; // just ignore unexpected exceptions here, especially during clean-up + end; +end; + + +{ THttpSocket } + +procedure THttpSocket.GetBody; +var Line: SockString; // 32 bits chunk length in hexa + LinePChar: array[0..31] of AnsiChar; + Len, LContent, Error: integer; +begin + fBodyRetrieved := true; + Content := ''; + {$I-} + // direct read bytes, as indicated by Content-Length or Chunked + if transferChuked in HeaderFlags then begin // we ignore the Length + LContent := 0; // current read position in Content + repeat + if SockIn<>nil then begin + readln(SockIn^,LinePChar); // use of a static PChar is faster + Error := ioresult; + if Error<>0 then + raise ECrtSocket.Create('GetBody1',Error); + Len := HttpChunkToHex32(LinePChar); // get chunk length in hexa + end else begin + SockRecvLn(Line); + Len := HttpChunkToHex32(pointer(Line)); // get chunk length in hexa + end; + if Len=0 then begin // ignore next line (normally void) + SockRecvLn; + break; + end; + SetLength(Content,LContent+Len); // reserve memory space for this chunk + SockInRead(@PByteArray(Content)[LContent],Len) ; // append chunk data + inc(LContent,Len); + SockRecvLn; // ignore next #13#10 + until false; + end else + if ContentLength>0 then begin + SetLength(Content,ContentLength); // not chuncked: direct read + SockInRead(pointer(Content),ContentLength); // works with SockIn=nil or not + end else + if (ContentLength<0) and IdemPChar(pointer(Command),'HTTP/1.0 200') then begin + // body = either Content-Length or Transfer-Encoding (HTTP/1.1 RFC 4.3) + if SockIn<>nil then // client loop for compatibility with old servers + while not eof(SockIn^) do begin + readln(SockIn^,Line); + if Content='' then + Content := Line else + Content := Content+#13#10+Line; + end; + ContentLength := length(Content); // update Content-Length + exit; + end; + // optionaly uncompress content + if cardinal(fContentCompress)nil then begin + Error := ioresult; + if Error<>0 then + raise ECrtSocket.Create('GetBody2',Error); + end; + {$I+} +end; + +procedure GetTrimmed(P: PAnsiChar; out result: SockString); +var B: PAnsiChar; +begin + while (P^>#0) and (P^<=' ') do inc(P); + B := P; + while P^<>#0 do inc(P); + while (P>B) and (P[-1]<=' ') do dec(P); + SetString(result,B,P-B); +end; + +var + JSON_CONTENT_TYPE_VAR: SockString; + +procedure THttpSocket.GetHeader(HeadersUnFiltered: boolean); +var s,c: SockString; + i, len: PtrInt; + err: integer; + P: PAnsiChar; + line: array[0..4095] of AnsiChar; // avoid most memory allocation +begin + HeaderFlags := []; + fBodyRetrieved := false; + fContentCompress := -1; + integer(fCompressAcceptHeader) := 0; + ContentType := ''; + Upgrade := ''; + ContentLength := -1; + ServerInternalState := 0; + fSndBufLen := 0; // SockSend() internal buffer is used when adding headers + repeat + P := @line; + if (SockIn<>nil) and not HeadersUnFiltered then begin + {$I-} + readln(SockIn^,line); + err := ioresult; + if err<>0 then + raise ECrtSocket.CreateFmt('%s.GetHeader',[ClassName],err); + {$I+} + if line[0]=#0 then + break; // HTTP headers end with a void line + end else begin + SockRecvLn(s); + if s = '' then + break; + P := pointer(s); // set P=nil below to store in Headers[] + end; + case IdemPCharArray(P,['CONTENT-', 'TRANSFER-ENCODING: CHUNKED', 'CONNECTION: ', + 'ACCEPT-ENCODING:', 'UPGRADE:', 'SERVER-INTERNALSTATE:', 'X-POWERED-BY:']) of + 0: case IdemPCharArray(P+8,['LENGTH:', 'TYPE:', 'ENCODING:']) of + 0: ContentLength := GetCardinal(P+16); + 1: begin + inc(P,13); + while P^=' ' do inc(P); + if IdemPChar(P,'APPLICATION/JSON') then + ContentType := JSON_CONTENT_TYPE_VAR else begin + GetTrimmed(P,ContentType); + if ContentType<>'' then + P := nil; // is searched by HEADER_CONTENT_TYPE_UPPER later on + end; + end; + 2: if fCompress<>nil then begin + GetTrimmed(P+17,c); + for i := 0 to high(fCompress) do + if fCompress[i].Name=c then begin + fContentCompress := i; + break; + end; + end; + else P := nil; + end; + 1: include(HeaderFlags,transferChuked); + 2: case IdemPCharArray(P+12,['CLOSE','UPGRADE','KEEP-ALIVE']) of + 0: include(HeaderFlags,connectionClose); + 1: include(HeaderFlags,connectionUpgrade); + 2: begin + include(HeaderFlags,connectionKeepAlive); + if P[22]=',' then begin + inc(P,23); + if P^=' ' then inc(P); + if IdemPChar(P,'UPGRADE') then + include(HeaderFlags,connectionUpgrade); + end; + end; + else P := nil; + end; + 3: if fCompress<>nil then + fCompressAcceptHeader := ComputeContentEncoding(fCompress,P+16) else + P := nil; + 4: GetTrimmed(P+8,Upgrade); + 5: ServerInternalState := GetCardinal(P+21); + 6: GetTrimmed(P+13,XPoweredBy); + else P := nil; + end; + if (P=nil) or HeadersUnFiltered then // only store meaningful headers + if s='' then begin + len := StrLen(line); + if len>SizeOf(line)-2 then + break; // avoid buffer overflow + PWord(@line[len])^ := 13+10 shl 8; // CR + LF + SockSend(@line,len+2); + end else + SockSend(s); // SockSend() internal buffer is used as temporary buffer + until false; + Headers := copy(fSndBuf, 1, fSndBufLen); + fSndBufLen := 0; +end; + +procedure THttpSocket.HeaderAdd(const aValue: SockString); +begin + if aValue<>'' then + Headers := Headers+aValue+#13#10; +end; + +procedure THttpSocket.HeaderSetText(const aText, aForcedContentType: SockString); +begin + if aText='' then + Headers := '' else + if aText[length(aText)-1]<>#10 then + Headers := aText+#13#10 else + Headers := aText; + if (aForcedContentType<>'') and + (ExistNameValue(pointer(aText),'CONTENT-TYPE:')=nil) then + Headers := Headers+'Content-Type: '+aForcedContentType+#13#10; +end; + +function THttpSocket.HeaderGetText(const aRemoteIP: SockString): SockString; +begin + if (aRemoteIP<>'') and not(hasRemoteIP in HeaderFlags) then begin + Headers := Headers+'RemoteIP: '+aRemoteIP+#13#10; + include(HeaderFlags,hasRemoteIP); + end; + result := Headers; +end; + +function THttpSocket.HeaderGetValue(const aUpperName: SockString): SockString; +begin + result := ''; + GetHeaderValue(Headers,aUpperName,result); +end; + +function THttpSocket.RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer): boolean; +begin + result := RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize)<>''; +end; + +procedure THttpSocket.CompressDataAndWriteHeaders(const OutContentType: SockString; + var OutContent: SockString; OutContentLength: PtrInt); +var OutContentEncoding: SockString; +begin + if integer(fCompressAcceptHeader)<>0 then begin + OutContentEncoding := CompressDataAndGetHeaders(fCompressAcceptHeader,fCompress, + OutContentType,OutContent); + if OutContentEncoding<>'' then + SockSend(['Content-Encoding: ',OutContentEncoding]); + end; + if OutContentLength<0 then + OutContentLength := length(OutContent); + SockSend(['Content-Length: ',OutContentLength]); // needed even 0 + if (OutContentType<>'') and (OutContentType<>HTTP_RESP_STATICFILE) then + SockSend(['Content-Type: ',OutContentType]); +end; + + +{ THttpServerSocket } + +constructor THttpServerSocket.Create(aServer: THttpServer); +begin + inherited Create(5000); + if aServer<>nil then begin // nil e.g. from TRTSPOverHTTPServer + fServer := aServer; + fCompress := aServer.fCompress; + fCompressAcceptEncoding := aServer.fCompressAcceptEncoding; + fSocketLayer:=aServer.Sock.SocketLayer; + TCPPrefix := aServer.TCPPrefix; + end; +end; + +function THttpServerSocket.GetRequest(withBody: boolean; headerMaxTix: Int64): THttpServerSocketGetRequestResult; +var P: PAnsiChar; + status: cardinal; + pending: integer; + reason, allheaders: SockString; + noheaderfilter: boolean; +begin + result := grError; + try + // use SockIn with 1KB buffer if not already initialized: 2x faster + CreateSockIn; + // abort now with no exception if socket is obviously broken + if fServer<>nil then begin + pending := SockInPending(100,{alsosocket=}true); + if (pending<0) or (fServer=nil) or fServer.Terminated then + exit; + noheaderfilter := fServer.HeadersNotFiltered; + end else + noheaderfilter := false; + // 1st line is command: 'GET /path HTTP/1.1' e.g. + SockRecvLn(Command); + if TCPPrefix<>'' then + if TCPPrefix<>Command then + exit else + SockRecvLn(Command); + P := pointer(Command); + if P=nil then + exit; // broken + GetNextItem(P,' ',fMethod); // 'GET' + GetNextItem(P,' ',fURL); // '/path' + fKeepAliveClient := ((fServer=nil) or (fServer.ServerKeepAliveTimeOut>0)) and + IdemPChar(P,'HTTP/1.1'); + Content := ''; + // get headers and content + GetHeader(noheaderfilter); + if fServer<>nil then begin // nil from TRTSPOverHTTPServer + if fServer.fRemoteIPHeaderUpper<>'' then + // real Internet IP (replace 127.0.0.1 from a proxy) + GetHeaderValue(Headers,fServer.fRemoteIPHeaderUpper,fRemoteIP); + if fServer.fRemoteConnIDHeaderUpper<>'' then begin + P := FindHeaderValue(pointer(Headers),fServer.fRemoteConnIDHeaderUpper); + if P<>nil then + fRemoteConnectionID := GetNextItemUInt64(P); + end; + end; + if connectionClose in HeaderFlags then + fKeepAliveClient := false; + if (ContentLength<0) and (KeepAliveClient or (fMethod = 'GET')) then + ContentLength := 0; // HTTP/1.1 and no content length -> no eof + if (headerMaxTix>0) and (GetTick64>headerMaxTix) then begin + result := grTimeout; + exit; // allow 10 sec for header -> DOS/TCPSYN Flood + end; + if fServer<>nil then begin + if (ContentLength>0) and (fServer.MaximumAllowedContentLength>0) and + (cardinal(ContentLength)>fServer.MaximumAllowedContentLength) then begin + SockSend('HTTP/1.0 413 Payload Too Large'#13#10#13#10'Rejected'); + SockSendFlush(''); + result := grOversizedPayload; + exit; + end; + if Assigned(fServer.OnBeforeBody) then begin + allheaders := HeaderGetText(fRemoteIP); + status := fServer.OnBeforeBody(fURL,fMethod,allheaders,ContentType,RemoteIP,ContentLength,false); + {$ifdef SYNCRTDEBUGLOW} + TSynLog.Add.Log(sllCustom2,'GetRequest sock=% OnBeforeBody=% Command=% Headers=%', + [fSock, status, LogEscapeFull(Command), LogEscapeFull(allheaders)], self); + TSynLog.Add.Log(sllCustom2,'GetRequest OnBeforeBody headers', TypeInfo(TSockStringDynArray), Headers, self); + {$endif} + if status<>STATUS_SUCCESS then begin + reason := StatusCodeToReason(status); + SockSend(['HTTP/1.0 ',status,' ',reason,#13#10#13#10,reason,' ', status]); + SockSendFlush(''); + result := grRejected; + exit; + end; + end; + end; + if withBody and not (connectionUpgrade in HeaderFlags) then begin + if IdemPCharArray(pointer(fMethod),['HEAD','OPTIONS'])<0 then + GetBody; + result := grBodyReceived; + end else + result := grHeaderReceived; + except + on E: Exception do + result := grException; + end; +end; + +procedure DirectShutdown(sock: TSocket; rdwr: boolean); +const SHUT_: array[boolean] of integer = (SHUT_RD, SHUT_RDWR); +begin + if sock<=0 then + exit; + {$ifdef LINUXNOTBSD} + // at last under Linux close() is enough. For example nginx don't call shutdown + if rdwr then + {$endif LINUXNOTBSD} + Shutdown(sock,SHUT_[rdwr]); // SHUT_RD doesn't unlock accept() on Linux + CloseSocket(sock); // SO_LINGER usually set to 5 or 10 seconds +end; + +function AsynchSocket(sock: TSocket): boolean; +var nonblocking: integer; +begin + nonblocking := 1; // for both Windows and POSIX + if sock<=0 then + result := false else + result := IoctlSocket(sock, FIONBIO, nonblocking)=0; +end; + +function AsynchRecv(sock: TSocket; buf: pointer; buflen: integer): integer; +begin + {$ifdef MSWINDOWS} + result := Recv(sock,buf,buflen,0); + {$else} + {$ifdef KYLIX3} + result := LibC.Recv(sock,buf^,buflen,0); + {$else} + result := fpRecv(sock,buf,buflen,0); + {$endif KYLIX3} + {$endif MSWINDOWS} +end; + +function AsynchSend(sock: TSocket; buf: pointer; buflen: integer): integer; +begin + {$ifdef MSWINDOWS} + result := Send(sock,buf,buflen,MSG_NOSIGNAL); + {$else} + {$ifdef KYLIX3} + result := LibC.Send(sock,buf^,buflen,MSG_NOSIGNAL); + {$else} + result := fpSend(sock,buf,buflen,MSG_NOSIGNAL); + {$endif} + {$endif} +end; + + +{ ECrtSocket } + +function GetRemoteIP(aClientSock: TSocket): SockString; +var Name: TVarSin; +begin + if GetPeerName(aClientSock,Name)=0 then + IPText(Name,result) else + result := ''; +end; + +function SocketErrorMessage(Error: integer): string; +begin + if Error=-1 then + Error := WSAGetLastError; + case Error of + WSAETIMEDOUT: result := 'WSAETIMEDOUT'; + WSAENETDOWN: result := 'WSAENETDOWN'; + WSATRY_AGAIN: result := 'WSATRY_AGAIN'; + {$ifdef MSWINDOWS} // WSATRY_AGAIN=WSAEWOULDBLOCK on POSIX + WSAEWOULDBLOCK: result := 'WSAEWOULDBLOCK'; + {$endif} + WSAECONNABORTED: result := 'WSAECONNABORTED'; + WSAECONNRESET: result := 'WSAECONNRESET'; + WSAEMFILE: result := 'WSAEMFILE'; + else result := ''; + end; + result := Format('%d %s %s',[Error,result,SysErrorMessage(Error)]); +end; + +constructor ECrtSocket.Create(const Msg: string); +begin + Create(Msg,WSAGetLastError); +end; + +constructor ECrtSocket.Create(const Msg: string; Error: integer); +begin + if Error=0 then + fLastError := WSAEWOULDBLOCK else // if unknown, probably a timeout + fLastError := abs(Error); + inherited CreateFmt('%s [%s]', [Msg,SocketErrorMessage(fLastError)]); +end; + +constructor ECrtSocket.CreateFmt(const Msg: string; const Args: array of const; Error: integer); +begin + if Error<0 then + Error := WSAGetLastError; + Create(Format(Msg,Args),Error); +end; + + +{ TSynThreadPool } + +const + // up to 256 * 2MB = 512MB of RAM for the TSynThreadPoolWorkThread stack + THREADPOOL_MAXTHREADS = 256; + + // kept-alive or big HTTP requests will create a dedicated THttpServerResp + // - each thread reserves 2 MB of memory so it may break the server + // - keep the value to a decent number, to let resources be constrained up to 1GB + THREADPOOL_MAXWORKTHREADS = 512; + + // if HTTP body length is bigger than 16 MB, creates a dedicated THttpServerResp + THREADPOOL_BIGBODYSIZE = 16*1024*1024; + +constructor TSynThreadPool.Create(NumberOfThreads: Integer; + {$ifdef USE_WINIOCP}aOverlapHandle: THandle{$else}aQueuePendingContext: boolean{$endif}); +var i: integer; +begin + if NumberOfThreads=0 then + NumberOfThreads := 1 else + if cardinal(NumberOfThreads)>THREADPOOL_MAXTHREADS then + NumberOfThreads := THREADPOOL_MAXTHREADS; + // create IO completion port to queue the HTTP requests + {$ifdef USE_WINIOCP} + fRequestQueue := CreateIoCompletionPort(aOverlapHandle, 0, 0, NumberOfThreads); + if fRequestQueue=INVALID_HANDLE_VALUE then begin + fRequestQueue := 0; + exit; + end; + {$else} + InitializeCriticalSection(fSafe); + fQueuePendingContext := aQueuePendingContext; + {$endif} + // now create the worker threads + fWorkThreadCount := NumberOfThreads; + SetLength(fWorkThread,fWorkThreadCount); + for i := 0 to fWorkThreadCount-1 do + fWorkThread[i] := TSynThreadPoolWorkThread.Create(Self); +end; + +destructor TSynThreadPool.Destroy; +var i: integer; + endtix: Int64; +begin + fTerminated := true; // fWorkThread[].Execute will check this flag + try + // notify the threads we are shutting down + for i := 0 to fWorkThreadCount-1 do + {$ifdef USE_WINIOCP} + PostQueuedCompletionStatus(fRequestQueue,0,0,nil); + {$else} + fWorkThread[i].fEvent.SetEvent; + {$endif} + {$ifndef USE_WINIOCP} + // cleanup now any pending task (e.g. THttpServerSocket instance) + for i := 0 to fPendingContextCount-1 do + TaskAbort(fPendingContext[i]); + {$endif} + // wait for threads to finish, with 30 seconds TimeOut + endtix := GetTick64+30000; + while (fRunningThreads>0) and (GetTick64QueueLength then + exit; // too many connection limit reached (see QueueIsFull) + if n=length(fPendingContext) then + SetLength(fPendingContext,n+n shr 3+64); + fPendingContext[n] := aContext; + inc(fPendingContextCount); + result := true; // added in pending queue + finally + LeaveCriticalsection(fSafe); + if found<>nil then + found.fEvent.SetEvent; // rather notify outside of the fSafe lock + end; + end; + {$endif} +var tix, starttix, endtix: Int64; +begin + result := false; + if (self=nil) or fTerminated then + exit; + result := Enqueue; + if result then + exit; + inc(fContentionCount); + if (fContentionAbortDelay>0) and aWaitOnContention then begin + tix := GetTick64; + starttix := tix; + endtix := tix+fContentionAbortDelay; // default 5 sec + repeat // during this delay, no new connection is ACCEPTed + if tix-starttix<50 then // wait for an available slot in the queue + SleepHiRes(1) else + SleepHiRes(10); + tix := GetTick64; + if fTerminated then + exit; + if Enqueue then begin + result := true; // thread pool acquired or queued the client sock + break; + end; + until fTerminated or (tix>endtix); + inc(fContentionTime,tix-starttix); + end; + if not result then + inc(fContentionAbortCount); +end; + +{$ifndef USE_WINIOCP} +function TSynThreadPool.GetPendingContextCount: integer; +begin + result := 0; + if (self=nil) or fTerminated or (fPendingContext=nil) then + exit; + EnterCriticalsection(fSafe); + try + result := fPendingContextCount; + finally + LeaveCriticalsection(fSafe); + end; +end; + +function TSynThreadPool.QueueIsFull: boolean; +begin + result := fQueuePendingContext and + (GetPendingContextCount+fWorkThreadCount>QueueLength); +end; + +function TSynThreadPool.PopPendingContext: pointer; +begin + result := nil; + if (self=nil) or fTerminated or (fPendingContext=nil) then + exit; + EnterCriticalsection(fSafe); + try + if fPendingContextCount>0 then begin + result := fPendingContext[0]; + dec(fPendingContextCount); + Move(fPendingContext[1],fPendingContext[0],fPendingContextCount*SizeOf(pointer)); + if fPendingContextCount=128 then + SetLength(fPendingContext,128); // small queue when congestion is resolved + end; + finally + LeaveCriticalsection(fSafe); + end; +end; + +function TSynThreadPool.QueueLength: integer; +begin + result := 10000; // lazy high value +end; +{$endif USE_WINIOCP} + +function TSynThreadPool.NeedStopOnIOError: boolean; +begin + result := True; +end; + +procedure TSynThreadPool.TaskAbort(aContext: Pointer); +begin +end; + + +{ TSynThreadPoolWorkThread } + +constructor TSynThreadPoolWorkThread.Create(Owner: TSynThreadPool); +begin + fOwner := Owner; // ensure it is set ASAP: on Linux, Execute raises immediately + fOnThreadTerminate := Owner.fOnThreadTerminate; + {$ifndef USE_WINIOCP} + fEvent := TEvent.Create(nil,false,false,''); + {$endif} + inherited Create(false); +end; + +destructor TSynThreadPoolWorkThread.Destroy; +begin + inherited Destroy; + {$ifndef USE_WINIOCP} + fEvent.Free; + {$endif} +end; + +{$ifdef USE_WINIOCP} +function GetQueuedCompletionStatus(CompletionPort: THandle; + var lpNumberOfBytesTransferred: DWORD; var lpCompletionKey: PtrUInt; + var lpOverlapped: pointer; dwMilliseconds: DWORD): BOOL; stdcall; + external kernel32; // redefine with an unique signature for all Delphi/FPC +{$endif} + +procedure TSynThreadPoolWorkThread.DoTask(Context: pointer); +begin + try + fOwner.Task(Self,Context); + except + on Exception do // intercept any exception and let the thread continue + inc(fOwner.fExceptionsCount); + end; +end; + +procedure TSynThreadPoolWorkThread.Execute; +var ctxt: pointer; + {$ifdef USE_WINIOCP} + dum1: DWORD; + dum2: PtrUInt; + {$endif} +begin + if fOwner<>nil then + try + fThreadNumber := InterlockedIncrement(fOwner.fRunningThreads); + NotifyThreadStart(self); + repeat + {$ifdef USE_WINIOCP} + if (not GetQueuedCompletionStatus(fOwner.fRequestQueue,dum1,dum2,ctxt,INFINITE) and + fOwner.NeedStopOnIOError) or fOwner.fTerminated then + break; + if ctxt<>nil then + DoTask(ctxt); + {$else} + fEvent.WaitFor(INFINITE); + if fOwner.fTerminated then + break; + EnterCriticalSection(fOwner.fSafe); + ctxt := fProcessingContext; + LeaveCriticalSection(fOwner.fSafe); + if ctxt<>nil then begin + repeat + DoTask(ctxt); + ctxt := fOwner.PopPendingContext; // unqueue any pending context + until ctxt=nil; + EnterCriticalSection(fOwner.fSafe); + fProcessingContext := nil; // indicates this thread is now available + LeaveCriticalSection(fOwner.fSafe); + end; + {$endif USE_WINIOCP} + until fOwner.fTerminated or Terminated; + finally + InterlockedDecrement(fOwner.fRunningThreads); + end; +end; + +procedure TSynThreadPoolWorkThread.NotifyThreadStart(Sender: TSynThread); +begin + if Sender=nil then + raise ECrtSocket.Create('NotifyThreadStart(nil)'); + {$ifdef FPC} + {$ifdef LINUX} + if fNotifyThreadStartName='' then begin + fNotifyThreadStartName := format('Pool%d-%4x',[fThreadNumber,PtrInt(fOwner)]); + SetUnixThreadName(fThreadID,fNotifyThreadStartName); + end; + {$endif} + {$endif} + if Assigned(fOwner.fOnThreadStart) and not Assigned(Sender.fStartNotified) then begin + fOwner.fOnThreadStart(Sender); + Sender.fStartNotified := self; + end; +end; + + +{ TSynThreadPoolTHttpServer } + +constructor TSynThreadPoolTHttpServer.Create(Server: THttpServer; NumberOfThreads: Integer=32); +begin + fServer := Server; + fOnThreadTerminate := fServer.fOnThreadTerminate; + inherited Create(NumberOfThreads{$ifndef USE_WINIOCP},{queuepending=}true{$endif}); +end; + +{$ifndef USE_WINIOCP} +function TSynThreadPoolTHttpServer.QueueLength: integer; +begin + if fServer=nil then + result := 10000 else + result := fServer.fHTTPQueueLength; +end; +{$endif USE_WINIOCP} + +procedure TSynThreadPoolTHttpServer.Task(aCaller: TSynThread; aContext: Pointer); +var ServerSock: THttpServerSocket; + headertix: Int64; + res: THttpServerSocketGetRequestResult; +begin + ServerSock := aContext; + try + if fServer.Terminated then + exit; + // get Header of incoming request in the thread pool + headertix := fServer.HeaderRetrieveAbortDelay; + if headertix>0 then + headertix := headertix+GetTick64; + res := ServerSock.GetRequest({withbody=}false,headertix); + if (fServer=nil) or fServer.Terminated then + exit; + InterlockedIncrement(fServer.fStats[res]); + case res of + grHeaderReceived: begin + // connection and header seem valid -> process request further + if (fServer.ServerKeepAliveTimeOut>0) and + (fServer.fInternalHttpServerRespList.CountTHREADPOOL_BIGBODYSIZE)) then begin + // HTTP/1.1 Keep Alive (including WebSockets) or posted data > 16 MB + // -> process in dedicated background thread + fServer.fThreadRespClass.Create(ServerSock,fServer); + ServerSock := nil; // THttpServerResp will own and free ServerSock + end else begin + // no Keep Alive = multi-connection -> process in the Thread Pool + if not (connectionUpgrade in ServerSock.HeaderFlags) and + (IdemPCharArray(pointer(ServerSock.Method),['HEAD','OPTIONS'])<0) then begin + ServerSock.GetBody; // we need to get it now + InterlockedIncrement(fServer.fStats[grBodyReceived]); + end; + // multi-connection -> process now + fServer.Process(ServerSock,ServerSock.RemoteConnectionID,aCaller); + fServer.OnDisconnect; + // no Shutdown here: will be done client-side + end; + end; + grOwned: // e.g. for asynchrounous WebSockets + ServerSock := nil; // to ignore FreeAndNil(ServerSock) below + end; // errors will close the connection + finally + FreeAndNil(ServerSock); + end; +end; + +procedure TSynThreadPoolTHttpServer.TaskAbort(aContext: Pointer); +begin + THttpServerSocket(aContext).Free; +end; + + +{$ifdef MSWINDOWS} + +{ ************ http.sys / HTTP API low-level direct access } + +{$MINENUMSIZE 4} +{$A+} + +{$ifdef FPC} +{$PACKRECORDS C} +{$endif} + +type + // HTTP version used + HTTP_VERSION = packed record + MajorVersion: word; + MinorVersion: word; + end; + + // the req* values identify Request Headers, and resp* Response Headers + THttpHeader = ( + reqCacheControl, + reqConnection, + reqDate, + reqKeepAlive, + reqPragma, + reqTrailer, + reqTransferEncoding, + reqUpgrade, + reqVia, + reqWarning, + reqAllow, + reqContentLength, + reqContentType, + reqContentEncoding, + reqContentLanguage, + reqContentLocation, + reqContentMd5, + reqContentRange, + reqExpires, + reqLastModified, + reqAccept, + reqAcceptCharset, + reqAcceptEncoding, + reqAcceptLanguage, + reqAuthorization, + reqCookie, + reqExpect, + reqFrom, + reqHost, + reqIfMatch, + reqIfModifiedSince, + reqIfNoneMatch, + reqIfRange, + reqIfUnmodifiedSince, + reqMaxForwards, + reqProxyAuthorization, + reqReferrer, + reqRange, + reqTe, + reqTranslate, + reqUserAgent +{$ifdef DELPHI5OROLDER} + ); +const // Delphi 5 does not support values overlapping for enums + respAcceptRanges = THttpHeader(20); + respAge = THttpHeader(21); + respEtag = THttpHeader(22); + respLocation = THttpHeader(23); + respProxyAuthenticate = THttpHeader(24); + respRetryAfter = THttpHeader(25); + respServer = THttpHeader(26); + respSetCookie = THttpHeader(27); + respVary = THttpHeader(28); + respWwwAuthenticate = THttpHeader(29); +type +{$else} , + respAcceptRanges = 20, + respAge, + respEtag, + respLocation, + respProxyAuthenticate, + respRetryAfter, + respServer, + respSetCookie, + respVary, + respWwwAuthenticate); +{$endif} + + THttpVerb = ( + hvUnparsed, + hvUnknown, + hvInvalid, + hvOPTIONS, + hvGET, + hvHEAD, + hvPOST, + hvPUT, + hvDELETE, + hvTRACE, + hvCONNECT, + hvTRACK, // used by Microsoft Cluster Server for a non-logged trace + hvMOVE, + hvCOPY, + hvPROPFIND, + hvPROPPATCH, + hvMKCOL, + hvLOCK, + hvUNLOCK, + hvSEARCH, + hvMaximum ); + + THttpChunkType = ( + hctFromMemory, + hctFromFileHandle, + hctFromFragmentCache); + + THttpServiceConfigID = ( + hscIPListenList, + hscSSLCertInfo, + hscUrlAclInfo, + hscMax); + THttpServiceConfigQueryType = ( + hscQueryExact, + hscQueryNext, + hscQueryMax); + + HTTP_URL_CONTEXT = HTTP_OPAQUE_ID; + HTTP_CONNECTION_ID = HTTP_OPAQUE_ID; + HTTP_RAW_CONNECTION_ID = HTTP_OPAQUE_ID; + + // Pointers overlap and point into pFullUrl. nil if not present. + HTTP_COOKED_URL = record + FullUrlLength: word; // in bytes not including the #0 + HostLength: word; // in bytes not including the #0 + AbsPathLength: word; // in bytes not including the #0 + QueryStringLength: word; // in bytes not including the #0 + pFullUrl: PWideChar; // points to "http://hostname:port/abs/.../path?query" + pHost: PWideChar; // points to the first char in the hostname + pAbsPath: PWideChar; // Points to the 3rd '/' char + pQueryString: PWideChar; // Points to the 1st '?' char or #0 + end; + + HTTP_TRANSPORT_ADDRESS = record + pRemoteAddress: PSOCKADDR; + pLocalAddress: PSOCKADDR; + end; + + HTTP_UNKNOWN_HEADER = record + NameLength: word; // in bytes not including the #0 + RawValueLength: word; // in bytes not including the n#0 + pName: PAnsiChar; // The header name (minus the ':' character) + pRawValue: PAnsiChar; // The header value + end; + PHTTP_UNKNOWN_HEADER = ^HTTP_UNKNOWN_HEADER; + HTTP_UNKNOWN_HEADERs = array of HTTP_UNKNOWN_HEADER; + + HTTP_KNOWN_HEADER = record + RawValueLength: word; // in bytes not including the #0 + pRawValue: PAnsiChar; + end; + PHTTP_KNOWN_HEADER = ^HTTP_KNOWN_HEADER; + + HTTP_RESPONSE_HEADERS = record + // number of entries in the unknown HTTP headers array + UnknownHeaderCount: word; + // array of unknown HTTP headers + pUnknownHeaders: pointer; + // Reserved, must be 0 + TrailerCount: word; + // Reserved, must be nil + pTrailers: pointer; + // Known headers + KnownHeaders: array[low(THttpHeader)..respWwwAuthenticate] of HTTP_KNOWN_HEADER; + end; + + HTTP_REQUEST_HEADERS = record + // number of entries in the unknown HTTP headers array + UnknownHeaderCount: word; + // array of unknown HTTP headers + pUnknownHeaders: PHTTP_UNKNOWN_HEADER; + // Reserved, must be 0 + TrailerCount: word; + // Reserved, must be nil + pTrailers: pointer; + // Known headers + KnownHeaders: array[low(THttpHeader)..reqUserAgent] of HTTP_KNOWN_HEADER; + end; + + HTTP_BYTE_RANGE = record + StartingOffset: ULARGE_INTEGER; + Length: ULARGE_INTEGER; + end; + + // we use 3 distinct HTTP_DATA_CHUNK_* records since variable records + // alignment is buggy/non compatible under Delphi XE3 + HTTP_DATA_CHUNK_INMEMORY = record + DataChunkType: THttpChunkType; // always hctFromMemory + Reserved1: ULONG; + pBuffer: pointer; + BufferLength: ULONG; + Reserved2: ULONG; + Reserved3: ULONG; + end; + PHTTP_DATA_CHUNK_INMEMORY = ^HTTP_DATA_CHUNK_INMEMORY; + HTTP_DATA_CHUNK_FILEHANDLE = record + DataChunkType: THttpChunkType; // always hctFromFileHandle + ByteRange: HTTP_BYTE_RANGE; + FileHandle: THandle; + end; + HTTP_DATA_CHUNK_FRAGMENTCACHE = record + DataChunkType: THttpChunkType; // always hctFromFragmentCache + FragmentNameLength: word; // in bytes not including the #0 + pFragmentName: PWideChar; + end; + + HTTP_SSL_CLIENT_CERT_INFO = record + CertFlags: ULONG; + CertEncodedSize: ULONG; + pCertEncoded: PUCHAR; + Token: THandle; + CertDeniedByMapper: boolean; + end; + PHTTP_SSL_CLIENT_CERT_INFO = ^HTTP_SSL_CLIENT_CERT_INFO; + + HTTP_SSL_INFO = record + ServerCertKeySize: word; + ConnectionKeySize: word; + ServerCertIssuerSize: ULONG; + ServerCertSubjectSize: ULONG; + pServerCertIssuer: PAnsiChar; + pServerCertSubject: PAnsiChar; + pClientCertInfo: PHTTP_SSL_CLIENT_CERT_INFO; + SslClientCertNegotiated: ULONG; + end; + PHTTP_SSL_INFO = ^HTTP_SSL_INFO; + + HTTP_SERVICE_CONFIG_URLACL_KEY = record + pUrlPrefix: PWideChar; + end; + HTTP_SERVICE_CONFIG_URLACL_PARAM = record + pStringSecurityDescriptor: PWideChar; + end; + HTTP_SERVICE_CONFIG_URLACL_SET = record + KeyDesc: HTTP_SERVICE_CONFIG_URLACL_KEY; + ParamDesc: HTTP_SERVICE_CONFIG_URLACL_PARAM; + end; + HTTP_SERVICE_CONFIG_URLACL_QUERY = record + QueryDesc: THttpServiceConfigQueryType; + KeyDesc: HTTP_SERVICE_CONFIG_URLACL_KEY; + dwToken: DWORD; + end; + + HTTP_REQUEST_INFO_TYPE = ( + HttpRequestInfoTypeAuth, + HttpRequestInfoTypeChannelBind, + HttpRequestInfoTypeSslProtocol, + HttpRequestInfoTypeSslTokenBindingDraft, + HttpRequestInfoTypeSslTokenBinding, + HttpRequestInfoTypeRequestTiming, + HttpRequestInfoTypeTcpInfoV0, + HttpRequestInfoTypeRequestSizing, + HttpRequestInfoTypeQuicStats, + HttpRequestInfoTypeTcpInfoV1 + ); + + // about Authentication in HTTP Version 2.0 + // see https://msdn.microsoft.com/en-us/library/windows/desktop/aa364452 + + HTTP_AUTH_STATUS = ( + HttpAuthStatusSuccess, + HttpAuthStatusNotAuthenticated, + HttpAuthStatusFailure + ); + + HTTP_REQUEST_AUTH_TYPE = ( + HttpRequestAuthTypeNone, + HttpRequestAuthTypeBasic, + HttpRequestAuthTypeDigest, + HttpRequestAuthTypeNTLM, + HttpRequestAuthTypeNegotiate, + HttpRequestAuthTypeKerberos + ); + + SECURITY_STATUS = ULONG; + + HTTP_REQUEST_AUTH_INFO = record + AuthStatus: HTTP_AUTH_STATUS; + SecStatus: SECURITY_STATUS; + Flags: ULONG; + AuthType: HTTP_REQUEST_AUTH_TYPE; + AccessToken: THandle; + ContextAttributes: ULONG; + PackedContextLength: ULONG; + PackedContextType: ULONG; + PackedContext: pointer; + MutualAuthDataLength: ULONG; + pMutualAuthData: PAnsiChar; + PackageNameLength: word; + pPackageName: LPWSTR; + end; + PHTTP_REQUEST_AUTH_INFO = ^HTTP_REQUEST_AUTH_INFO; + + HTTP_REQUEST_INFO = record + InfoType: HTTP_REQUEST_INFO_TYPE; + InfoLength: ULONG; + pInfo: pointer; + end; + HTTP_REQUEST_INFOS = array[0..1000] of HTTP_REQUEST_INFO; + PHTTP_REQUEST_INFOS = ^HTTP_REQUEST_INFOS; + + /// structure used to handle data associated with a specific request + HTTP_REQUEST = record + // either 0 (Only Header), either HTTP_RECEIVE_REQUEST_FLAG_COPY_BODY + Flags: cardinal; + // An identifier for the connection on which the request was received + ConnectionId: HTTP_CONNECTION_ID; + // A value used to identify the request when calling + // HttpReceiveRequestEntityBody, HttpSendHttpResponse, and/or + // HttpSendResponseEntityBody + RequestId: HTTP_REQUEST_ID; + // The context associated with the URL prefix + UrlContext: HTTP_URL_CONTEXT; + // The HTTP version number + Version: HTTP_VERSION; + // An HTTP verb associated with this request + Verb: THttpVerb; + // The length of the verb string if the Verb field is hvUnknown + // (in bytes not including the last #0) + UnknownVerbLength: word; + // The length of the raw (uncooked) URL (in bytes not including the last #0) + RawUrlLength: word; + // Pointer to the verb string if the Verb field is hvUnknown + pUnknownVerb: PAnsiChar; + // Pointer to the raw (uncooked) URL + pRawUrl: PAnsiChar; + // The canonicalized Unicode URL + CookedUrl: HTTP_COOKED_URL; + // Local and remote transport addresses for the connection + Address: HTTP_TRANSPORT_ADDRESS; + // The request headers. + Headers: HTTP_REQUEST_HEADERS; + // The total number of bytes received from network for this request + BytesReceived: ULONGLONG; + EntityChunkCount: word; + pEntityChunks: pointer; + RawConnectionId: HTTP_RAW_CONNECTION_ID; + // SSL connection information + pSslInfo: PHTTP_SSL_INFO; + { beginning of HTTP_REQUEST_V2 structure - manual padding is needed :( } + {$ifdef CPU32} + padding: dword; + {$endif CPU32} + /// how many extended info about a specific request is available in v2 + RequestInfoCount: word; + /// v2 trailing structure used to handle extended info about a specific request + pRequestInfo: PHTTP_REQUEST_INFOS; + end; + PHTTP_REQUEST = ^HTTP_REQUEST; + + HTTP_RESPONSE_INFO_TYPE = ( + HttpResponseInfoTypeMultipleKnownHeaders, + HttpResponseInfoTypeAuthenticationProperty, + HttpResponseInfoTypeQosProperty, + HttpResponseInfoTypeChannelBind + ); + + HTTP_RESPONSE_INFO = record + Typ: HTTP_RESPONSE_INFO_TYPE; + Length: ULONG; + pInfo: Pointer; + end; + PHTTP_RESPONSE_INFO = ^HTTP_RESPONSE_INFO; + + /// structure as expected by HttpSendHttpResponse() API + HTTP_RESPONSE = object + public + Flags: cardinal; + // The raw HTTP protocol version number + Version: HTTP_VERSION; + // The HTTP status code (e.g., 200) + StatusCode: word; + // in bytes not including the '\0' + ReasonLength: word; + // The HTTP reason (e.g., "OK"). This MUST not contain non-ASCII characters + // (i.e., all chars must be in range 0x20-0x7E). + pReason: PAnsiChar; + // The response headers + Headers: HTTP_RESPONSE_HEADERS; + // number of elements in pEntityChunks[] array + EntityChunkCount: word; + // pEntityChunks points to an array of EntityChunkCount HTTP_DATA_CHUNK_* + pEntityChunks: pointer; + // contains the number of HTTP API 2.0 extended information + ResponseInfoCount: word; + // map the HTTP API 2.0 extended information + pResponseInfo: PHTTP_RESPONSE_INFO; + // will set both StatusCode and Reason + // - OutStatus is a temporary variable which will be field with the + // corresponding text + procedure SetStatus(code: integer; var OutStatus: SockString); + // will set the content of the reponse, and ContentType header + procedure SetContent(var DataChunk: HTTP_DATA_CHUNK_INMEMORY; + const Content: SockString; const ContentType: SockString='text/html'); + /// will set all header values from lines + // - Content-Type/Content-Encoding/Location will be set in KnownHeaders[] + // - all other headers will be set in temp UnknownHeaders[] + procedure SetHeaders(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs); + /// add one header value to the internal headers + // - SetHeaders() method should have been called before to initialize the + // internal UnknownHeaders[] array + function AddCustomHeader(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs; + ForceCustomHeader: boolean): PAnsiChar; + end; + PHTTP_RESPONSE = ^HTTP_RESPONSE; + + HTTP_PROPERTY_FLAGS = ULONG; + + HTTP_ENABLED_STATE = ( + HttpEnabledStateActive, + HttpEnabledStateInactive + ); + PHTTP_ENABLED_STATE = ^HTTP_ENABLED_STATE; + + HTTP_STATE_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + State: HTTP_ENABLED_STATE; + end; + PHTTP_STATE_INFO = ^HTTP_STATE_INFO; + + THTTP_503_RESPONSE_VERBOSITY = ( + Http503ResponseVerbosityBasic, + Http503ResponseVerbosityLimited, + Http503ResponseVerbosityFull + ); + PHTTP_503_RESPONSE_VERBOSITY = ^ THTTP_503_RESPONSE_VERBOSITY; + + HTTP_QOS_SETTING_TYPE = ( + HttpQosSettingTypeBandwidth, + HttpQosSettingTypeConnectionLimit, + HttpQosSettingTypeFlowRate // Windows Server 2008 R2 and Windows 7 only. + ); + PHTTP_QOS_SETTING_TYPE = ^HTTP_QOS_SETTING_TYPE; + + HTTP_QOS_SETTING_INFO = record + QosType: HTTP_QOS_SETTING_TYPE; + QosSetting: Pointer; + end; + PHTTP_QOS_SETTING_INFO = ^HTTP_QOS_SETTING_INFO; + + HTTP_CONNECTION_LIMIT_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + MaxConnections: ULONG; + end; + PHTTP_CONNECTION_LIMIT_INFO = ^HTTP_CONNECTION_LIMIT_INFO; + + HTTP_BANDWIDTH_LIMIT_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + MaxBandwidth: ULONG; + end; + PHTTP_BANDWIDTH_LIMIT_INFO = ^HTTP_BANDWIDTH_LIMIT_INFO; + + HTTP_FLOWRATE_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + MaxBandwidth: ULONG; + MaxPeakBandwidth: ULONG; + BurstSize: ULONG; + end; + PHTTP_FLOWRATE_INFO = ^HTTP_FLOWRATE_INFO; + +const + HTTP_MIN_ALLOWED_BANDWIDTH_THROTTLING_RATE {:ULONG} = 1024; + HTTP_LIMIT_INFINITE {:ULONG} = ULONG(-1); + +type + HTTP_SERVICE_CONFIG_TIMEOUT_KEY = ( + IdleConnectionTimeout, + HeaderWaitTimeout + ); + PHTTP_SERVICE_CONFIG_TIMEOUT_KEY = ^HTTP_SERVICE_CONFIG_TIMEOUT_KEY; + + HTTP_SERVICE_CONFIG_TIMEOUT_PARAM = word; + PHTTP_SERVICE_CONFIG_TIMEOUT_PARAM = ^HTTP_SERVICE_CONFIG_TIMEOUT_PARAM; + + HTTP_SERVICE_CONFIG_TIMEOUT_SET = record + KeyDesc: HTTP_SERVICE_CONFIG_TIMEOUT_KEY; + ParamDesc: HTTP_SERVICE_CONFIG_TIMEOUT_PARAM; + end; + PHTTP_SERVICE_CONFIG_TIMEOUT_SET = ^HTTP_SERVICE_CONFIG_TIMEOUT_SET; + + HTTP_TIMEOUT_LIMIT_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + EntityBody: word; + DrainEntityBody: word; + RequestQueue: word; + IdleConnection: word; + HeaderWait: word; + MinSendRate: cardinal; + end; + PHTTP_TIMEOUT_LIMIT_INFO = ^HTTP_TIMEOUT_LIMIT_INFO; + + HTTP_LISTEN_ENDPOINT_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + EnableSharing: boolean; + end; + PHTTP_LISTEN_ENDPOINT_INFO = ^HTTP_LISTEN_ENDPOINT_INFO; + + HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS = record + DomainNameLength: word; + DomainName: PWideChar; + RealmLength: word; + Realm: PWideChar; + end; + PHTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS = ^HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS; + + HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS = record + RealmLength: word; + Realm: PWideChar; + end; + PHTTP_SERVER_AUTHENTICATION_BASIC_PARAMS = ^HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS; + +const + HTTP_AUTH_ENABLE_BASIC = $00000001; + HTTP_AUTH_ENABLE_DIGEST = $00000002; + HTTP_AUTH_ENABLE_NTLM = $00000004; + HTTP_AUTH_ENABLE_NEGOTIATE = $00000008; + HTTP_AUTH_ENABLE_KERBEROS = $00000010; + HTTP_AUTH_ENABLE_ALL = $0000001F; + + HTTP_AUTH_EX_FLAG_ENABLE_KERBEROS_CREDENTIAL_CACHING = $01; + HTTP_AUTH_EX_FLAG_CAPTURE_CREDENTIAL = $02; + +type + HTTP_SERVER_AUTHENTICATION_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + AuthSchemes: ULONG; + ReceiveMutualAuth: BYTEBOOL; + ReceiveContextHandle: BYTEBOOL; + DisableNTLMCredentialCaching: BYTEBOOL; + ExFlags: BYTE; + DigestParams: HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS; + BasicParams: HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS; + end; + PHTTP_SERVER_AUTHENTICATION_INFO = ^HTTP_SERVER_AUTHENTICATION_INFO; + + + HTTP_SERVICE_BINDING_TYPE=( + HttpServiceBindingTypeNone, + HttpServiceBindingTypeW, + HttpServiceBindingTypeA + ); + + HTTP_SERVICE_BINDING_BASE = record + BindingType: HTTP_SERVICE_BINDING_TYPE; + end; + PHTTP_SERVICE_BINDING_BASE = ^HTTP_SERVICE_BINDING_BASE; + + HTTP_SERVICE_BINDING_A = record + Base: HTTP_SERVICE_BINDING_BASE; + Buffer: PAnsiChar; + BufferSize: ULONG; + end; + PHTTP_SERVICE_BINDING_A = HTTP_SERVICE_BINDING_A; + + HTTP_SERVICE_BINDING_W = record + Base: HTTP_SERVICE_BINDING_BASE; + Buffer: PWCHAR; + BufferSize: ULONG; + end; + PHTTP_SERVICE_BINDING_W = ^HTTP_SERVICE_BINDING_W; + + HTTP_AUTHENTICATION_HARDENING_LEVELS = ( + HttpAuthenticationHardeningLegacy, + HttpAuthenticationHardeningMedium, + HttpAuthenticationHardeningStrict + ); + +const + HTTP_CHANNEL_BIND_PROXY = $1; + HTTP_CHANNEL_BIND_PROXY_COHOSTING = $20; + + HTTP_CHANNEL_BIND_NO_SERVICE_NAME_CHECK = $2; + HTTP_CHANNEL_BIND_DOTLESS_SERVICE = $4; + HTTP_CHANNEL_BIND_SECURE_CHANNEL_TOKEN = $8; + HTTP_CHANNEL_BIND_CLIENT_SERVICE = $10; + +type + HTTP_CHANNEL_BIND_INFO = record + Hardening: HTTP_AUTHENTICATION_HARDENING_LEVELS; + Flags: ULONG; + ServiceNames: PHTTP_SERVICE_BINDING_BASE; + NumberOfServiceNames: ULONG; + end; + PHTTP_CHANNEL_BIND_INFO = ^HTTP_CHANNEL_BIND_INFO; + + HTTP_REQUEST_CHANNEL_BIND_STATUS = record + ServiceName: PHTTP_SERVICE_BINDING_BASE; + ChannelToken: PUCHAR; + ChannelTokenSize: ULONG; + Flags: ULONG; + end; + PHTTP_REQUEST_CHANNEL_BIND_STATUS = ^HTTP_REQUEST_CHANNEL_BIND_STATUS; + +const + // Logging option flags. When used in the logging configuration alters + // some default logging behaviour. + + // HTTP_LOGGING_FLAG_LOCAL_TIME_ROLLOVER - This flag is used to change + // the log file rollover to happen by local time based. By default + // log file rollovers happen by GMT time. + HTTP_LOGGING_FLAG_LOCAL_TIME_ROLLOVER = 1; + + // HTTP_LOGGING_FLAG_USE_UTF8_CONVERSION - When set the unicode fields + // will be converted to UTF8 multibytes when writting to the log + // files. When this flag is not present, the local code page + // conversion happens. + HTTP_LOGGING_FLAG_USE_UTF8_CONVERSION = 2; + + // HTTP_LOGGING_FLAG_LOG_ERRORS_ONLY - + // HTTP_LOGGING_FLAG_LOG_SUCCESS_ONLY - These two flags are used to + // to do selective logging. If neither of them are present both + // types of requests will be logged. Only one these flags can be + // set at a time. They are mutually exclusive. + HTTP_LOGGING_FLAG_LOG_ERRORS_ONLY = 4; + HTTP_LOGGING_FLAG_LOG_SUCCESS_ONLY = 8; + + // The known log fields recognized/supported by HTTPAPI. Following fields + // are used for W3C logging. Subset of them are also used for error logging + HTTP_LOG_FIELD_DATE = $00000001; + HTTP_LOG_FIELD_TIME = $00000002; + HTTP_LOG_FIELD_CLIENT_IP = $00000004; + HTTP_LOG_FIELD_USER_NAME = $00000008; + HTTP_LOG_FIELD_SITE_NAME = $00000010; + HTTP_LOG_FIELD_COMPUTER_NAME = $00000020; + HTTP_LOG_FIELD_SERVER_IP = $00000040; + HTTP_LOG_FIELD_METHOD = $00000080; + HTTP_LOG_FIELD_URI_STEM = $00000100; + HTTP_LOG_FIELD_URI_QUERY = $00000200; + HTTP_LOG_FIELD_STATUS = $00000400; + HTTP_LOG_FIELD_WIN32_STATUS = $00000800; + HTTP_LOG_FIELD_BYTES_SENT = $00001000; + HTTP_LOG_FIELD_BYTES_RECV = $00002000; + HTTP_LOG_FIELD_TIME_TAKEN = $00004000; + HTTP_LOG_FIELD_SERVER_PORT = $00008000; + HTTP_LOG_FIELD_USER_AGENT = $00010000; + HTTP_LOG_FIELD_COOKIE = $00020000; + HTTP_LOG_FIELD_REFERER = $00040000; + HTTP_LOG_FIELD_VERSION = $00080000; + HTTP_LOG_FIELD_HOST = $00100000; + HTTP_LOG_FIELD_SUB_STATUS = $00200000; + + HTTP_ALL_NON_ERROR_LOG_FIELDS = HTTP_LOG_FIELD_SUB_STATUS*2-1; + + // Fields that are used only for error logging + HTTP_LOG_FIELD_CLIENT_PORT = $00400000; + HTTP_LOG_FIELD_URI = $00800000; + HTTP_LOG_FIELD_SITE_ID = $01000000; + HTTP_LOG_FIELD_REASON = $02000000; + HTTP_LOG_FIELD_QUEUE_NAME = $04000000; + +type + HTTP_LOGGING_TYPE = ( + HttpLoggingTypeW3C, + HttpLoggingTypeIIS, + HttpLoggingTypeNCSA, + HttpLoggingTypeRaw + ); + + HTTP_LOGGING_ROLLOVER_TYPE = ( + HttpLoggingRolloverSize, + HttpLoggingRolloverDaily, + HttpLoggingRolloverWeekly, + HttpLoggingRolloverMonthly, + HttpLoggingRolloverHourly + ); + + HTTP_LOGGING_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + LoggingFlags: ULONG; + SoftwareName: PWideChar; + SoftwareNameLength: word; + DirectoryNameLength: word; + DirectoryName: PWideChar; + Format: HTTP_LOGGING_TYPE; + Fields: ULONG; + pExtFields: pointer; + NumOfExtFields: word; + MaxRecordSize: word; + RolloverType: HTTP_LOGGING_ROLLOVER_TYPE; + RolloverSize: ULONG; + pSecurityDescriptor: PSECURITY_DESCRIPTOR; + end; + PHTTP_LOGGING_INFO = ^HTTP_LOGGING_INFO; + + HTTP_LOG_DATA_TYPE = ( + HttpLogDataTypeFields + ); + + HTTP_LOG_DATA = record + Typ: HTTP_LOG_DATA_TYPE + end; + PHTTP_LOG_DATA = ^HTTP_LOG_DATA; + + HTTP_LOG_FIELDS_DATA = record + Base: HTTP_LOG_DATA; + UserNameLength: word; + UriStemLength: word; + ClientIpLength: word; + ServerNameLength: word; + ServiceNameLength: word; + ServerIpLength: word; + MethodLength: word; + UriQueryLength: word; + HostLength: word; + UserAgentLength: word; + CookieLength: word; + ReferrerLength: word; + UserName: PWideChar; + UriStem: PWideChar; + ClientIp: PAnsiChar; + ServerName: PAnsiChar; + ServiceName: PAnsiChar; + ServerIp: PAnsiChar; + Method: PAnsiChar; + UriQuery: PAnsiChar; + Host: PAnsiChar; + UserAgent: PAnsiChar; + Cookie: PAnsiChar; + Referrer: PAnsiChar; + ServerPort: word; + ProtocolStatus: word; + Win32Status: ULONG; + MethodNum: THttpVerb; + SubStatus: word; + end; + PHTTP_LOG_FIELDS_DATA = ^HTTP_LOG_FIELDS_DATA; + + HTTP_BINDING_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + RequestQueueHandle: THandle; + end; + + HTTP_PROTECTION_LEVEL_TYPE=( + HttpProtectionLevelUnrestricted, + HttpProtectionLevelEdgeRestricted, + HttpProtectionLevelRestricted + ); + + HTTP_PROTECTION_LEVEL_INFO = record + Flags: HTTP_PROPERTY_FLAGS; + Level: HTTP_PROTECTION_LEVEL_TYPE; + end; + PHTTP_PROTECTION_LEVEL_INFO = ^HTTP_PROTECTION_LEVEL_INFO; + +const + HTTP_VERSION_UNKNOWN: HTTP_VERSION = (MajorVersion: 0; MinorVersion: 0); + HTTP_VERSION_0_9: HTTP_VERSION = (MajorVersion: 0; MinorVersion: 9); + HTTP_VERSION_1_0: HTTP_VERSION = (MajorVersion: 1; MinorVersion: 0); + HTTP_VERSION_1_1: HTTP_VERSION = (MajorVersion: 1; MinorVersion: 1); + /// error raised by HTTP API when the client disconnected (e.g. after timeout) + HTTPAPI_ERROR_NONEXISTENTCONNECTION = 1229; + // if set, available entity body is copied along with the request headers + // into pEntityChunks + HTTP_RECEIVE_REQUEST_FLAG_COPY_BODY = 1; + // there is more entity body to be read for this request + HTTP_REQUEST_FLAG_MORE_ENTITY_BODY_EXISTS = 1; + // initialization for applications that use the HTTP Server API + HTTP_INITIALIZE_SERVER = 1; + // initialization for applications that use the HTTP configuration functions + HTTP_INITIALIZE_CONFIG = 2; + // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa364496 + HTTP_RECEIVE_REQUEST_ENTITY_BODY_FLAG_FILL_BUFFER = 1; + // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa364499 + HTTP_SEND_RESPONSE_FLAG_DISCONNECT = $00000001; + HTTP_SEND_RESPONSE_FLAG_MORE_DATA = $00000002; + HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA = $00000004; + HTTP_SEND_RESPONSE_FLAG_PROCESS_RANGES = $00000020; + HTTP_SEND_RESPONSE_FLAG_OPAQUE = $00000040; + // flag which can be used by HttpRemoveUrlFromUrlGroup() + HTTP_URL_FLAG_REMOVE_ALL = 1; + + HTTP_KNOWNHEADERS: array[low(THttpHeader)..reqUserAgent] of string[19] = ( + 'Cache-Control','Connection','Date','Keep-Alive','Pragma','Trailer', + 'Transfer-Encoding','Upgrade','Via','Warning','Allow','Content-Length', + 'Content-Type','Content-Encoding','Content-Language','Content-Location', + 'Content-MD5','Content-Range','Expires','Last-Modified','Accept', + 'Accept-Charset','Accept-Encoding','Accept-Language','Authorization', + 'Cookie','Expect','From','Host','If-Match','If-Modified-Since', + 'If-None-Match','If-Range','If-Unmodified-Since','Max-Forwards', + 'Proxy-Authorization','Referer','Range','TE','Translate','User-Agent'); + + REMOTEIP_HEADERLEN = 10; + REMOTEIP_HEADER: string[REMOTEIP_HEADERLEN] = 'RemoteIP: '; + +function RetrieveHeaders(const Request: HTTP_REQUEST; + const RemoteIPHeadUp: SockString; out RemoteIP: SockString): SockString; +var i, L, Lip: integer; + H: THttpHeader; + P: PHTTP_UNKNOWN_HEADER; + D: PAnsiChar; +begin + assert(low(HTTP_KNOWNHEADERS)=low(Request.Headers.KnownHeaders)); + assert(high(HTTP_KNOWNHEADERS)=high(Request.Headers.KnownHeaders)); + // compute remote IP + L := length(RemoteIPHeadUp); + if L<>0 then begin + P := Request.Headers.pUnknownHeaders; + if P<>nil then + for i := 1 to Request.Headers.UnknownHeaderCount do + if (P^.NameLength=L) and IdemPChar(P^.pName,Pointer(RemoteIPHeadUp)) then begin + SetString(RemoteIP,p^.pRawValue,p^.RawValueLength); + break; + end else + inc(P); + end; + if (RemoteIP='') and (Request.Address.pRemoteAddress<>nil) then + IPText(PVarSin(Request.Address.pRemoteAddress)^,RemoteIP,RemoteIPLocalHostAsVoidInServers); + // compute headers length + Lip := length(RemoteIP); + if Lip<>0 then + L := (REMOTEIP_HEADERLEN+2)+Lip else + L := 0; + for H := low(HTTP_KNOWNHEADERS) to high(HTTP_KNOWNHEADERS) do + if Request.Headers.KnownHeaders[h].RawValueLength<>0 then + inc(L,Request.Headers.KnownHeaders[h].RawValueLength+ord(HTTP_KNOWNHEADERS[h][0])+4); + P := Request.Headers.pUnknownHeaders; + if P<>nil then + for i := 1 to Request.Headers.UnknownHeaderCount do begin + inc(L,P^.NameLength+P^.RawValueLength+4); // +4 for each ': '+#13#10 + inc(P); + end; + // set headers content + SetString(result,nil,L); + D := pointer(result); + for H := low(HTTP_KNOWNHEADERS) to high(HTTP_KNOWNHEADERS) do + if Request.Headers.KnownHeaders[h].RawValueLength<>0 then begin + move(HTTP_KNOWNHEADERS[h][1],D^,ord(HTTP_KNOWNHEADERS[h][0])); + inc(D,ord(HTTP_KNOWNHEADERS[h][0])); + PWord(D)^ := ord(':')+ord(' ')shl 8; + inc(D,2); + move(Request.Headers.KnownHeaders[h].pRawValue^,D^, + Request.Headers.KnownHeaders[h].RawValueLength); + inc(D,Request.Headers.KnownHeaders[h].RawValueLength); + PWord(D)^ := 13+10 shl 8; + inc(D,2); + end; + P := Request.Headers.pUnknownHeaders; + if P<>nil then + for i := 1 to Request.Headers.UnknownHeaderCount do begin + move(P^.pName^,D^,P^.NameLength); + inc(D,P^.NameLength); + PWord(D)^ := ord(':')+ord(' ')shl 8; + inc(D,2); + move(P^.pRawValue^,D^,P^.RawValueLength); + inc(D,P^.RawValueLength); + inc(P); + PWord(D)^ := 13+10 shl 8; + inc(D,2); + end; + if Lip<>0 then begin + move(REMOTEIP_HEADER[1],D^,REMOTEIP_HEADERLEN); + inc(D,REMOTEIP_HEADERLEN); + move(pointer(RemoteIP)^,D^,Lip); + inc(D,Lip); + PWord(D)^ := 13+10 shl 8; + {$ifopt C+} + inc(D,2); + end; + assert(D-pointer(result)=L); + {$else} + end; + {$endif} +end; + +type + HTTP_SERVER_PROPERTY = ( + HttpServerAuthenticationProperty, + HttpServerLoggingProperty, + HttpServerQosProperty, + HttpServerTimeoutsProperty, + HttpServerQueueLengthProperty, + HttpServerStateProperty, + HttpServer503VerbosityProperty, + HttpServerBindingProperty, + HttpServerExtendedAuthenticationProperty, + HttpServerListenEndpointProperty, + HttpServerChannelBindProperty, + HttpServerProtectionLevelProperty + ); + + /// direct late-binding access to the HTTP API server 1.0 or 2.0 + THttpAPI = packed record + /// access to the httpapi.dll loaded library + Module: THandle; + /// will be either 1.0 or 2.0, depending on the published .dll functions + Version: HTTP_VERSION; + /// The HttpInitialize function initializes the HTTP Server API driver, starts it, + // if it has not already been started, and allocates data structures for the + // calling application to support response-queue creation and other operations. + // Call this function before calling any other functions in the HTTP Server API. + Initialize: function(Version: HTTP_VERSION; Flags: cardinal; + pReserved: pointer=nil): HRESULT; stdcall; + /// The HttpTerminate function cleans up resources used by the HTTP Server API + // to process calls by an application. An application should call HttpTerminate + // once for every time it called HttpInitialize, with matching flag settings. + Terminate: function(Flags: cardinal; + Reserved: integer=0): HRESULT; stdcall; + /// The HttpCreateHttpHandle function creates an HTTP request queue for the + // calling application and returns a handle to it. + CreateHttpHandle: function(var ReqQueueHandle: THandle; + Reserved: integer=0): HRESULT; stdcall; + /// The HttpAddUrl function registers a given URL so that requests that match + // it are routed to a specified HTTP Server API request queue. An application + // can register multiple URLs to a single request queue using repeated calls to + // HttpAddUrl + // - a typical url prefix is 'http://+:80/vroot/', 'https://+:80/vroot/' or + // 'https://adatum.com:443/secure/database/' - here the '+' is called a + // Strong wildcard, i.e. will match every IP or server name + AddUrl: function(ReqQueueHandle: THandle; UrlPrefix: PWideChar; + Reserved: integer=0): HRESULT; stdcall; + /// Unregisters a specified URL, so that requests for it are no longer + // routed to a specified queue. + RemoveUrl: function(ReqQueueHandle: THandle; UrlPrefix: PWideChar): HRESULT; stdcall; + /// retrieves the next available HTTP request from the specified request queue + ReceiveHttpRequest: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; + Flags: cardinal; var pRequestBuffer: HTTP_REQUEST; RequestBufferLength: ULONG; + var pBytesReceived: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; + /// sent the response to a specified HTTP request + // - pLogData optional parameter is handled since HTTP API 2.0 + SendHttpResponse: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; + Flags: integer; var pHttpResponse: HTTP_RESPONSE; pReserved1: pointer; + var pBytesSent: cardinal; pReserved2: pointer=nil; Reserved3: ULONG=0; + pOverlapped: pointer=nil; pLogData: PHTTP_LOG_DATA=nil): HRESULT; stdcall; + /// receives additional entity body data for a specified HTTP request + ReceiveRequestEntityBody: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; + Flags: ULONG; pBuffer: pointer; BufferLength: cardinal; var pBytesReceived: cardinal; + pOverlapped: pointer=nil): HRESULT; stdcall; + /// sends entity-body data associated with an HTTP response. + SendResponseEntityBody: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; + Flags: integer; EntityChunkCount: word; pEntityChunks: pointer; var pBytesSent: Cardinal; + pReserved1: Pointer=nil; pReserved2: Pointer=nil; pOverlapped: POverlapped=nil; + pLogData: PHTTP_LOG_DATA=nil): HRESULT; stdcall; + /// set specified data, such as IP addresses or SSL Certificates, from the + // HTTP Server API configuration store + SetServiceConfiguration: function(ServiceHandle: THandle; + ConfigId: THttpServiceConfigID; pConfigInformation: pointer; + ConfigInformationLength: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; + /// deletes specified data, such as IP addresses or SSL Certificates, from the + // HTTP Server API configuration store + DeleteServiceConfiguration: function(ServiceHandle: THandle; + ConfigId: THttpServiceConfigID; pConfigInformation: pointer; + ConfigInformationLength: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; + /// removes from the HTTP Server API cache associated with a given request + // queue all response fragments that have a name whose site portion matches + // a specified UrlPrefix + FlushResponseCache: function(ReqQueueHandle: THandle; pUrlPrefix: PWideChar; Flags: ULONG; + pOverlapped: POverlapped): ULONG; stdcall; + /// cancels a specified request + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + CancelHttpRequest: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; + pOverlapped: pointer = nil): HRESULT; stdcall; + /// creates a server session for the specified HTTP API version + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + CreateServerSession: function(Version: HTTP_VERSION; + var ServerSessionId: HTTP_SERVER_SESSION_ID; Reserved: ULONG = 0): HRESULT; stdcall; + /// deletes the server session identified by the server session ID + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + CloseServerSession: function(ServerSessionId: HTTP_SERVER_SESSION_ID): HRESULT; stdcall; + /// creates a new request queue or opens an existing request queue + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + // - replaces the HTTP version 1.0 CreateHttpHandle() function + CreateRequestQueue: function(Version: HTTP_VERSION; + pName: PWideChar; pSecurityAttributes: Pointer; + Flags: ULONG; var ReqQueueHandle: THandle): HRESULT; stdcall; + /// sets a new server session property or modifies an existing property + // on the specified server session + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + SetServerSessionProperty: function(ServerSessionId: HTTP_SERVER_SESSION_ID; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG): HRESULT; stdcall; + /// queries a server property on the specified server session + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + QueryServerSessionProperty: function(ServerSessionId: HTTP_SERVER_SESSION_ID; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG; pReturnLength: PULONG = nil): HRESULT; stdcall; + /// creates a URL Group under the specified server session + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + CreateUrlGroup: function(ServerSessionId: HTTP_SERVER_SESSION_ID; + var UrlGroupId: HTTP_URL_GROUP_ID; Reserved: ULONG = 0): HRESULT; stdcall; + /// closes the URL Group identified by the URL Group ID + // - this call also removes all of the URLs that are associated with + // the URL Group + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + CloseUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID): HRESULT; stdcall; + /// adds the specified URL to the URL Group identified by the URL Group ID + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + // - this function replaces the HTTP version 1.0 AddUrl() function + AddUrlToUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID; + pFullyQualifiedUrl: PWideChar; UrlContext: HTTP_URL_CONTEXT = 0; + Reserved: ULONG = 0): HRESULT; stdcall; + /// removes the specified URL from the group identified by the URL Group ID + // - this function removes one, or all, of the URLs from the group + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + // - it replaces the HTTP version 1.0 RemoveUrl() function + RemoveUrlFromUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID; + pFullyQualifiedUrl: PWideChar; Flags: ULONG): HRESULT; stdcall; + /// sets a new property or modifies an existing property on the specified + // URL Group + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + SetUrlGroupProperty: function(UrlGroupId: HTTP_URL_GROUP_ID; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG): HRESULT; stdcall; + /// queries a property on the specified URL Group + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + QueryUrlGroupProperty: function(UrlGroupId: HTTP_URL_GROUP_ID; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG; pReturnLength: PULONG = nil): HRESULT; stdcall; + /// sets a new property or modifies an existing property on the request + // queue identified by the specified handle + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + SetRequestQueueProperty: function(ReqQueueHandle: THandle; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG; Reserved: ULONG; pReserved: Pointer): HRESULT; stdcall; + /// queries a property of the request queue identified by the + // specified handle + // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) + QueryRequestQueueProperty: function(ReqQueueHandle: THandle; + aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; + PropertyInformationLength: ULONG; Reserved: ULONG; pReturnLength: PULONG; pReserved: Pointer): HRESULT; stdcall; + end; + +var + Http: THttpAPI; + +type + THttpAPIs = (hInitialize,hTerminate,hCreateHttpHandle, + hAddUrl, hRemoveUrl, hReceiveHttpRequest, + hSendHttpResponse, hReceiveRequestEntityBody, + hResponseEntityBody, + hSetServiceConfiguration, hDeleteServiceConfiguration, hFlushResponseCache, + hCancelHttpRequest, + hCreateServerSession, hCloseServerSession, + hCreateRequestQueue, + hSetServerSessionProperty, hQueryServerSessionProperty, + hCreateUrlGroup, hCloseUrlGroup, + hAddUrlToUrlGroup, hRemoveUrlFromUrlGroup, + hSetUrlGroupProperty, hQueryUrlGroupProperty, + hSetRequestQueueProperty, hQueryRequestQueueProperty + ); +const + hHttpApi2First = hCancelHttpRequest; + + HttpNames: array[THttpAPIs] of PChar = ( + 'HttpInitialize','HttpTerminate','HttpCreateHttpHandle', + 'HttpAddUrl', 'HttpRemoveUrl', 'HttpReceiveHttpRequest', + 'HttpSendHttpResponse', 'HttpReceiveRequestEntityBody', + 'HttpSendResponseEntityBody', + 'HttpSetServiceConfiguration', 'HttpDeleteServiceConfiguration', + 'HttpFlushResponseCache', + 'HttpCancelHttpRequest', + 'HttpCreateServerSession', 'HttpCloseServerSession', + 'HttpCreateRequestQueue', + 'HttpSetServerSessionProperty', 'HttpQueryServerSessionProperty', + 'HttpCreateUrlGroup', 'HttpCloseUrlGroup', + 'HttpAddUrlToUrlGroup', 'HttpRemoveUrlFromUrlGroup', + 'HttpSetUrlGroupProperty', 'HttpQueryUrlGroupProperty', + 'HttpSetRequestQueueProperty', 'HttpQueryRequestQueueProperty' + ); + +function RegURL(aRoot, aPort: SockString; Https: boolean; + aDomainName: SockString): SockUnicode; +const Prefix: array[boolean] of SockString = ('http://','https://'); +begin + if aPort='' then + aPort := DEFAULT_PORT[Https]; + aRoot := trim(aRoot); + aDomainName := trim(aDomainName); + if aDomainName='' then begin + result := ''; + exit; + end; + if aRoot<>'' then begin + if aRoot[1]<>'/' then + insert('/',aRoot,1); + if aRoot[length(aRoot)]<>'/' then + aRoot := aRoot+'/'; + end else + aRoot := '/'; // allow for instance 'http://*:2869/' + aRoot := Prefix[Https]+aDomainName+':'+aPort+aRoot; + result := SockUnicode(aRoot); +end; + +const + HTTPAPI_DLL = 'httpapi.dll'; + +procedure HttpApiInitialize; +var api: THttpAPIs; + P: PPointer; +begin + if Http.Module<>0 then + exit; // already loaded + try + Http.Module := LoadLibrary(HTTPAPI_DLL); + Http.Version.MajorVersion := 2; // API 2.0 if all functions are available + if Http.Module<=255 then + raise ECrtSocket.CreateFmt('Unable to find %s',[HTTPAPI_DLL]); + P := @@Http.Initialize; + for api := low(api) to high(api) do begin + P^ := GetProcAddress(Http.Module,HttpNames[api]); + if P^=nil then + if api255 then begin + FreeLibrary(Http.Module); + Http.Module := 0; + end; + raise; + end; + end; +end; + + +{ EHttpApiServer } + +type + EHttpApiServer = class(ECrtSocket) + protected + fLastApi: THttpAPIs; + public + class procedure RaiseOnError(api: THttpAPIs; Error: integer); + constructor Create(api: THttpAPIs; Error: integer); reintroduce; + published + property LastApi: THttpAPIs read fLastApi; + end; + +class procedure EHttpApiServer.RaiseOnError(api: THttpAPIs; Error: integer); +begin + if Error<>NO_ERROR then + raise self.Create(api,Error); +end; + +constructor EHttpApiServer.Create(api: THttpAPIs; Error: integer); +begin + fLastError := Error; + fLastApi := api; + inherited CreateFmt('%s failed: %s (%d)', + [HttpNames[api],SysErrorMessagePerModule(Error,HTTPAPI_DLL),Error]) +end; + + +{ THttpApiServer } + +function THttpApiServer.AddUrl(const aRoot, aPort: SockString; Https: boolean; + const aDomainName: SockString; aRegisterURI: boolean; aContext: Int64): integer; +var uri: SockUnicode; + n: integer; +begin + result := -1; + if (Self=nil) or (fReqQueue=0) or (Http.Module=0) then + exit; + uri := RegURL(aRoot, aPort, Https, aDomainName); + if uri='' then + exit; // invalid parameters + if aRegisterURI then + AddUrlAuthorize(aRoot,aPort,Https,aDomainName); + if Http.Version.MajorVersion>1 then + result := Http.AddUrlToUrlGroup(fUrlGroupID,pointer(uri),aContext) else + result := Http.AddUrl(fReqQueue,pointer(uri)); + if result=NO_ERROR then begin + n := length(fRegisteredUnicodeUrl); + SetLength(fRegisteredUnicodeUrl,n+1); + fRegisteredUnicodeUrl[n] := uri; + end; +end; + +function THttpApiServer.RemoveUrl(const aRoot, aPort: SockString; Https: boolean; + const aDomainName: SockString): integer; +var uri: SockUnicode; + i,j,n: integer; +begin + result := -1; + if (Self=nil) or (fReqQueue=0) or (Http.Module=0) then + exit; + uri := RegURL(aRoot, aPort, Https, aDomainName); + if uri='' then + exit; // invalid parameters + n := High(fRegisteredUnicodeUrl); + for i := 0 to n do + if fRegisteredUnicodeUrl[i]=uri then begin + if Http.Version.MajorVersion>1 then + result := Http.RemoveUrlFromUrlGroup(fUrlGroupID,pointer(uri),0) else + result := Http.RemoveUrl(fReqQueue,pointer(uri)); + if result<>0 then + exit; // shall be handled by caller + for j := i to n-1 do + fRegisteredUnicodeUrl[j] := fRegisteredUnicodeUrl[j+1]; + SetLength(fRegisteredUnicodeUrl,n); + exit; + end; +end; + +class function THttpApiServer.AddUrlAuthorize(const aRoot, aPort: SockString; + Https: boolean; const aDomainName: SockString; OnlyDelete: boolean): string; +const + /// will allow AddUrl() registration to everyone + // - 'GA' (GENERIC_ALL) to grant all access + // - 'S-1-1-0' defines a group that includes all users + HTTPADDURLSECDESC: PWideChar = 'D:(A;;GA;;;S-1-1-0)'; +var prefix: SockUnicode; + Error: HRESULT; + Config: HTTP_SERVICE_CONFIG_URLACL_SET; +begin + try + HttpApiInitialize; + prefix := RegURL(aRoot, aPort, Https, aDomainName); + if prefix='' then + result := 'Invalid parameters' else begin + EHttpApiServer.RaiseOnError(hInitialize,Http.Initialize( + Http.Version,HTTP_INITIALIZE_CONFIG)); + try + fillchar(Config,sizeof(Config),0); + Config.KeyDesc.pUrlPrefix := pointer(prefix); + // first delete any existing information + Error := Http.DeleteServiceConfiguration(0,hscUrlAclInfo,@Config,Sizeof(Config)); + // then add authorization rule + if not OnlyDelete then begin + Config.KeyDesc.pUrlPrefix := pointer(prefix); + Config.ParamDesc.pStringSecurityDescriptor := HTTPADDURLSECDESC; + Error := Http.SetServiceConfiguration(0,hscUrlAclInfo,@Config,Sizeof(Config)); + end; + if (Error<>NO_ERROR) and (Error<>ERROR_ALREADY_EXISTS) then + raise EHttpApiServer.Create(hSetServiceConfiguration,Error); + result := ''; // success + finally + Http.Terminate(HTTP_INITIALIZE_CONFIG); + end; + end; + except + on E: Exception do + result := E.Message; + end; +end; + +type + THttpApiServerClass = class of THttpApiServer; + +procedure THttpApiServer.Clone(ChildThreadCount: integer); +var i: integer; +begin + if (fReqQueue=0) or not Assigned(OnRequest) or (ChildThreadCount<=0) or (fClones<>nil) then + exit; // nothing to clone (need a queue and a process event) + if ChildThreadCount>256 then + ChildThreadCount := 256; // not worth adding + SetLength(fClones,ChildThreadCount); + for i := 0 to ChildThreadCount-1 do + fClones[i] := THttpApiServerClass(Self.ClassType).CreateClone(self); +end; + +function THttpApiServer.GetAPIVersion: string; +begin + result := Format('HTTP API %d.%d',[Http.Version.MajorVersion,Http.Version.MinorVersion]); +end; + +constructor THttpApiServer.Create(CreateSuspended: boolean; QueueName: SockUnicode; + OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); +var bindInfo: HTTP_BINDING_INFO; +begin + SetLength(fLogDataStorage,sizeof(HTTP_LOG_FIELDS_DATA)); // should be done 1st + inherited Create({suspended=}true,OnStart,OnStop,ProcessName); + HttpApiInitialize; // will raise an exception in case of failure + EHttpApiServer.RaiseOnError(hInitialize, + Http.Initialize(Http.Version,HTTP_INITIALIZE_SERVER)); + if Http.Version.MajorVersion>1 then begin + EHttpApiServer.RaiseOnError(hCreateServerSession,Http.CreateServerSession( + Http.Version,fServerSessionID)); + EHttpApiServer.RaiseOnError(hCreateUrlGroup,Http.CreateUrlGroup( + fServerSessionID,fUrlGroupID)); + if QueueName='' then + BinToHexDisplayW(@fServerSessionID,SizeOf(fServerSessionID),QueueName); + EHttpApiServer.RaiseOnError(hCreateRequestQueue,Http.CreateRequestQueue( + Http.Version,pointer(QueueName),nil,0,fReqQueue)); + bindInfo.Flags := 1; + bindInfo.RequestQueueHandle := FReqQueue; + EHttpApiServer.RaiseOnError(hSetUrlGroupProperty,Http.SetUrlGroupProperty( + fUrlGroupID,HttpServerBindingProperty,@bindInfo,SizeOf(bindInfo))); + end else + EHttpApiServer.RaiseOnError(hCreateHttpHandle,Http.CreateHttpHandle(fReqQueue)); + fReceiveBufferSize := 1048576; // i.e. 1 MB + if not CreateSuspended then + Suspended := False; +end; + +constructor THttpApiServer.CreateClone(From: THttpApiServer); +begin + SetLength(fLogDataStorage,sizeof(HTTP_LOG_FIELDS_DATA)); + fOwner := From; + fReqQueue := From.fReqQueue; + fOnRequest := From.fOnRequest; + fOnBeforeBody := From.fOnBeforeBody; + fOnBeforeRequest := From.fOnBeforeRequest; + fOnAfterRequest := From.fOnAfterRequest; + fCanNotifyCallback := From.fCanNotifyCallback; + fCompress := From.fCompress; + fCompressAcceptEncoding := From.fCompressAcceptEncoding; + fReceiveBufferSize := From.fReceiveBufferSize; + if From.fLogData<>nil then + fLogData := pointer(fLogDataStorage); + SetServerName(From.fServerName); + SetRemoteIPHeader(From.RemoteIPHeader); + SetRemoteConnIDHeader(From.RemoteConnIDHeader); + fLoggingServiceName := From.fLoggingServiceName; + inherited Create(false,From.fOnHttpThreadStart,From.fOnThreadTerminate,From.ProcessName); +end; + +procedure THttpApiServer.DestroyMainThread; +var i: PtrInt; +begin + if fReqQueue<>0 then begin + for i := 0 to length(fClones)-1 do + fClones[i].Terminate; // for CloseHandle() below to finish Execute + if Http.Version.MajorVersion>1 then begin + if fUrlGroupID<>0 then begin + Http.RemoveUrlFromUrlGroup(fUrlGroupID,nil,HTTP_URL_FLAG_REMOVE_ALL); + Http.CloseUrlGroup(fUrlGroupID); + fUrlGroupID := 0; + end; + CloseHandle(fReqQueue); + if fServerSessionID<>0 then begin + Http.CloseServerSession(fServerSessionID); + fServerSessionID := 0; + end; + end else begin + for i := 0 to high(fRegisteredUnicodeUrl) do + Http.RemoveUrl(fReqQueue,pointer(fRegisteredUnicodeUrl[i])); + CloseHandle(fReqQueue); // will break all THttpApiServer.Execute + end; + fReqQueue := 0; + {$ifdef FPC} + for i := 0 to length(fClones)-1 do + WaitForSingleObject(fClones[i].Handle,30000); // sometimes needed on FPC + {$endif FPC} + for i := 0 to length(fClones)-1 do + fClones[i].Free; + fClones := nil; + Http.Terminate(HTTP_INITIALIZE_SERVER); + end; +end; + +destructor THttpApiServer.Destroy; +begin + Terminate; // for Execute to be notified about end of process + try + if (fOwner=nil) and (Http.Module<>0) then // fOwner<>nil for cloned threads + DestroyMainThread; + {$ifdef FPC} + WaitForSingleObject(Handle,30000); // wait the main Execute method on FPC + {$endif FPC} + finally + inherited Destroy; + end; +end; + +procedure GetDomainUserNameFromToken(UserToken: THandle; var result: SockString); +var Buffer: array[0..511] of byte; + BufferSize, UserSize, DomainSize: DWORD; + UserInfo: PSIDAndAttributes; + NameUse: {$ifdef FPC}SID_NAME_USE{$else}Cardinal{$endif}; + tmp: SockUnicode; + P: PWideChar; +begin + if not GetTokenInformation(UserToken,TokenUser,@Buffer,SizeOf(Buffer),{%H-}BufferSize) then + exit; + UserInfo := @Buffer; + UserSize := 0; + DomainSize := 0; + LookupAccountSidW(nil,UserInfo^.Sid,nil,UserSize,nil,DomainSize,{%H-}NameUse); + if (UserSize=0) or (DomainSize=0) then + exit; + SetLength({%H-}tmp,UserSize+DomainSize-1); + P := pointer(tmp); + if not LookupAccountSidW(nil,UserInfo^.Sid,P+DomainSize,UserSize,P,DomainSize,NameUse) then + exit; + P[DomainSize] := '\'; + result := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(tmp); +end; + +function THttpApiServer.GetSendResponseFlags(Ctxt: THttpServerRequest): Integer; +begin + result := 0; +end; + +procedure THttpApiServer.Execute; +type + TVerbText = array[hvOPTIONS..pred(hvMaximum)] of SockString; +const + VERB_TEXT: TVerbText = ( + 'OPTIONS','GET','HEAD','POST','PUT','DELETE','TRACE','CONNECT','TRACK', + 'MOVE','COPY','PROPFIND','PROPPATCH','MKCOL','LOCK','UNLOCK','SEARCH'); +var Req: PHTTP_REQUEST; + ReqID: HTTP_REQUEST_ID; + ReqBuf, RespBuf, RemoteIP, RemoteConn: SockString; + ContentRange: shortstring; + i, L: integer; + P: PHTTP_UNKNOWN_HEADER; + flags, bytesRead, bytesSent: cardinal; + Err: HRESULT; + InCompressAccept: THttpSocketCompressSet; + InContentLength, InContentLengthChunk, InContentLengthRead: cardinal; + InContentEncoding, InAcceptEncoding, Range: SockString; + OutContentEncoding, OutStatus: SockString; + OutStatusCode, AfterStatusCode: Cardinal; + RespSent: boolean; + Context: THttpServerRequest; + FileHandle: THandle; + Resp: PHTTP_RESPONSE; + BufRead, R: PAnsiChar; + Heads: HTTP_UNKNOWN_HEADERs; + RangeStart, RangeLength: ULONGLONG; + OutContentLength: ULARGE_INTEGER; + DataChunkInMemory: HTTP_DATA_CHUNK_INMEMORY; + DataChunkFile: HTTP_DATA_CHUNK_FILEHANDLE; + CurrentLog: PHTTP_LOG_FIELDS_DATA; + Verbs: TVerbText; // to avoid memory allocation + + procedure SendError(StatusCode: cardinal; const ErrorMsg: string; E: Exception=nil); + var Msg: string; + begin + try + Resp^.SetStatus(StatusCode,OutStatus); + CurrentLog^.ProtocolStatus := StatusCode; + Msg := format( + '

Server Error %d: %s

', + [StatusCode,OutStatus]); + if E<>nil then + Msg := Msg+string(E.ClassName)+' Exception raised:
'; + Resp^.SetContent(DataChunkInMemory,UTF8String(Msg)+HtmlEncode( + {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(ErrorMsg)) + {$ifndef NOXPOWEREDNAME}+'

'+XPOWEREDVALUE{$endif}, + 'text/html; charset=utf-8'); + Http.SendHttpResponse(fReqQueue, + Req^.RequestId,0,Resp^,nil,bytesSent,nil,0,nil,fLogData); + except + on Exception do + ; // ignore any HttpApi level errors here (client may crashed) + end; + end; + + function SendResponse: boolean; + begin + result := not Terminated; // true=success + if not result then + exit; + RespSent := true; + Resp^.SetStatus(OutStatusCode,OutStatus); + if Terminated then + exit; + // update log information + if Http.Version.MajorVersion>=2 then + with Req^,CurrentLog^ do begin + MethodNum := Verb; + UriStemLength := CookedUrl.AbsPathLength; + UriStem := CookedUrl.pAbsPath; + with Headers.KnownHeaders[reqUserAgent] do begin + UserAgentLength := RawValueLength; + UserAgent := pRawValue; + end; + with Headers.KnownHeaders[reqHost] do begin + HostLength := RawValueLength; + Host := pRawValue; + end; + with Headers.KnownHeaders[reqReferrer] do begin + ReferrerLength := RawValueLength; + Referrer := pRawValue; + end; + ProtocolStatus := Resp^.StatusCode; + ClientIp := pointer(RemoteIP); + ClientIpLength := length(RemoteIP); + Method := pointer(Context.fMethod); + MethodLength := length(Context.fMethod); + UserName := pointer(Context.fAuthenticatedUser); + UserNameLength := Length(Context.fAuthenticatedUser); + end; + // send response + Resp^.Version := Req^.Version; + Resp^.SetHeaders(pointer(Context.OutCustomHeaders),Heads); + if fCompressAcceptEncoding<>'' then + Resp^.AddCustomHeader(pointer(fCompressAcceptEncoding),Heads,false); + with Resp^.Headers.KnownHeaders[respServer] do begin + pRawValue := pointer(fServerName); + RawValueLength := length(fServerName); + end; + if Context.OutContentType=HTTP_RESP_STATICFILE then begin + // response is file -> OutContent is UTF-8 file name to be served + FileHandle := FileOpen( + {$ifdef UNICODE}UTF8ToUnicodeString{$else}Utf8ToAnsi{$endif}(Context.OutContent), + fmOpenRead or fmShareDenyNone); + if PtrInt(FileHandle)<0 then begin + SendError(STATUS_NOTFOUND,SysErrorMessage(GetLastError)); + result := false; // notify fatal error + end; + try // http.sys will serve then close the file from kernel + DataChunkFile.DataChunkType := hctFromFileHandle; + DataChunkFile.FileHandle := FileHandle; + flags := 0; + DataChunkFile.ByteRange.StartingOffset.QuadPart := 0; + Int64(DataChunkFile.ByteRange.Length.QuadPart) := -1; // to eof + with Req^.Headers.KnownHeaders[reqRange] do begin + if (RawValueLength>6) and IdemPChar(pRawValue,'BYTES=') and + (pRawValue[6] in ['0'..'9']) then begin + SetString(Range,pRawValue+6,RawValueLength-6); // need #0 end + R := pointer(Range); + RangeStart := GetNextItemUInt64(R); + if R^='-' then begin + OutContentLength.LowPart := GetFileSize(FileHandle,@OutContentLength.HighPart); + DataChunkFile.ByteRange.Length.QuadPart := OutContentLength.QuadPart-RangeStart; + inc(R); + flags := HTTP_SEND_RESPONSE_FLAG_PROCESS_RANGES; + DataChunkFile.ByteRange.StartingOffset.QuadPart := RangeStart; + if R^ in ['0'..'9'] then begin + RangeLength := GetNextItemUInt64(R)-RangeStart+1; + if RangeLength start=0, len=500 + DataChunkFile.ByteRange.Length.QuadPart := RangeLength; + end; // "bytes=1000-" -> start=1000, to eof) + ContentRange := 'Content-Range: bytes '; + AppendI64(RangeStart,ContentRange); + AppendChar('-',ContentRange); + AppendI64(RangeStart+DataChunkFile.ByteRange.Length.QuadPart-1,ContentRange); + AppendChar('/',ContentRange); + AppendI64(OutContentLength.QuadPart,ContentRange); + AppendChar(#0,ContentRange); + Resp^.AddCustomHeader(@ContentRange[1],Heads,false); + Resp^.SetStatus(STATUS_PARTIALCONTENT,OutStatus); + end; + end; + with Resp^.Headers.KnownHeaders[respAcceptRanges] do begin + pRawValue := 'bytes'; + RawValueLength := 5; + end; + end; + Resp^.EntityChunkCount := 1; + Resp^.pEntityChunks := @DataChunkFile; + Http.SendHttpResponse(fReqQueue, + Req^.RequestId,flags,Resp^,nil,bytesSent,nil,0,nil,fLogData); + finally + FileClose(FileHandle); + end; + end else begin + // response is in OutContent -> send it from memory + if Context.OutContentType=HTTP_RESP_NORESPONSE then + Context.OutContentType := ''; // true HTTP always expects a response + if fCompress<>nil then begin + with Resp^.Headers.KnownHeaders[reqContentEncoding] do + if RawValueLength=0 then begin + // no previous encoding -> try if any compression + OutContentEncoding := CompressDataAndGetHeaders(InCompressAccept, + fCompress,Context.OutContentType,Context.fOutContent); + pRawValue := pointer(OutContentEncoding); + RawValueLength := length(OutContentEncoding); + end; + end; + Resp^.SetContent(DataChunkInMemory,Context.OutContent,Context.OutContentType); + EHttpApiServer.RaiseOnError(hSendHttpResponse,Http.SendHttpResponse( + fReqQueue,Req^.RequestId,getSendResponseFlags(Context), + Resp^,nil,bytesSent,nil,0,nil,fLogData)); + end; + end; + +begin + if Terminated then + exit; + Context := nil; + try + // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event + NotifyThreadStart(self); + // reserve working buffers + SetLength(Heads,64); + SetLength(RespBuf,sizeof(Resp^)); + Resp := pointer(RespBuf); + SetLength(ReqBuf,16384+sizeof(HTTP_REQUEST)); // space for Req^ + 16 KB of headers + Req := pointer(ReqBuf); + CurrentLog := pointer(fLogDataStorage); + Verbs := VERB_TEXT; + Context := THttpServerRequest.Create(self,0,self); + // main loop reusing a single Context instance for this thread + ReqID := 0; + Context.fServer := self; + repeat + Context.fInContent := ''; // release input/output body buffers ASAP + Context.fOutContent := ''; + // Reset AuthenticationStatus & user between requests + Context.fAuthenticationStatus := hraNone; + Context.fAuthenticatedUser := ''; + // retrieve next pending request, and read its headers + fillchar(Req^,sizeof(HTTP_REQUEST),0); + BytesRead := 0; + Err := Http.ReceiveHttpRequest(fReqQueue,ReqID,0,Req^,length(ReqBuf),BytesRead); + if Terminated then + break; + case Err of + NO_ERROR: + try + // parse method and headers + Context.fConnectionID := Req^.ConnectionId; + Context.fHttpApiRequest := Req; + Context.fFullURL := Req^.CookedUrl.pFullUrl; // FullUrlLength is in bytes + SetString(Context.fURL,Req^.pRawUrl,Req^.RawUrlLength); + if Req^.Verb in [low(Verbs)..high(Verbs)] then + Context.fMethod := Verbs[Req^.Verb] else + SetString(Context.fMethod,Req^.pUnknownVerb,Req^.UnknownVerbLength); + with Req^.Headers.KnownHeaders[reqContentType] do + SetString(Context.fInContentType,pRawValue,RawValueLength); + with Req^.Headers.KnownHeaders[reqAcceptEncoding] do + SetString(InAcceptEncoding,pRawValue,RawValueLength); + InCompressAccept := ComputeContentEncoding(fCompress,pointer(InAcceptEncoding)); + Context.fUseSSL := Req^.pSslInfo<>nil; + Context.fInHeaders := RetrieveHeaders(Req^,fRemoteIPHeaderUpper,RemoteIP); + Context.RemoteIP := RemoteIP; + // compute remote connection ID + L := length(fRemoteConnIDHeaderUpper); + if L<>0 then begin + P := Req^.Headers.pUnknownHeaders; + if P<>nil then + for i := 1 to Req^.Headers.UnknownHeaderCount do + if (P^.NameLength=L) and + IdemPChar(P^.pName,Pointer(fRemoteConnIDHeaderUpper)) then begin + SetString(RemoteConn,p^.pRawValue,p^.RawValueLength); // need #0 end + R := pointer(RemoteConn); + Context.fConnectionID := GetNextItemUInt64(R); + break; + end else + inc(P); + end; + // retrieve any SetAuthenticationSchemes() information + if byte(fAuthenticationSchemes)<>0 then // set only with HTTP API 2.0 + for i := 0 to Req^.RequestInfoCount-1 do + if Req^.pRequestInfo^[i].InfoType=HttpRequestInfoTypeAuth then + with PHTTP_REQUEST_AUTH_INFO(Req^.pRequestInfo^[i].pInfo)^ do + case AuthStatus of + HttpAuthStatusSuccess: + if AuthType>HttpRequestAuthTypeNone then begin + byte(Context.fAuthenticationStatus) := ord(AuthType)+1; + if AccessToken<>0 then begin + GetDomainUserNameFromToken(AccessToken,Context.fAuthenticatedUser); + // Per spec https://docs.microsoft.com/en-us/windows/win32/http/authentication-in-http-version-2-0 + // AccessToken lifecycle is application responsability and should be closed after use + CloseHandle(AccessToken); + end; + end; + HttpAuthStatusFailure: + Context.fAuthenticationStatus := hraFailed; + end; + with Req^.Headers.KnownHeaders[reqContentLength] do + InContentLength := GetCardinal(pRawValue,pRawValue+RawValueLength); + if (InContentLength>0) and (MaximumAllowedContentLength>0) and + (InContentLength>MaximumAllowedContentLength) then begin + SendError(STATUS_PAYLOADTOOLARGE,'Rejected'); + continue; + end; + if Assigned(OnBeforeBody) then begin + Err := OnBeforeBody(Context.URL,Context.Method,Context.InHeaders, + Context.InContentType,RemoteIP,InContentLength,Context.fUseSSL); + if Err<>STATUS_SUCCESS then begin + SendError(Err,'Rejected'); + continue; + end; + end; + // retrieve body + if HTTP_REQUEST_FLAG_MORE_ENTITY_BODY_EXISTS and Req^.Flags<>0 then begin + with Req^.Headers.KnownHeaders[reqContentEncoding] do + SetString(InContentEncoding,pRawValue,RawValueLength); + if InContentLength<>0 then begin + SetLength(Context.fInContent,InContentLength); + BufRead := pointer(Context.InContent); + InContentLengthRead := 0; + repeat + BytesRead := 0; + if Http.Version.MajorVersion>1 then // speed optimization for Vista+ + flags := HTTP_RECEIVE_REQUEST_ENTITY_BODY_FLAG_FILL_BUFFER else + flags := 0; + InContentLengthChunk := InContentLength-InContentLengthRead; + if (fReceiveBufferSize>=1024) and (InContentLengthChunk>fReceiveBufferSize) then + InContentLengthChunk := fReceiveBufferSize; + Err := Http.ReceiveRequestEntityBody(fReqQueue,Req^.RequestId,flags, + BufRead,InContentLengthChunk,BytesRead); + if Terminated then + exit; + inc(InContentLengthRead,BytesRead); + if Err=ERROR_HANDLE_EOF then begin + if InContentLengthReadNO_ERROR then + break; + inc(BufRead,BytesRead); + until InContentLengthRead=InContentLength; + if Err<>NO_ERROR then begin + SendError(STATUS_NOTACCEPTABLE,SysErrorMessagePerModule(Err,HTTPAPI_DLL)); + continue; + end; + if InContentEncoding<>'' then + for i := 0 to high(fCompress) do + if fCompress[i].Name=InContentEncoding then begin + fCompress[i].Func(Context.fInContent,false); // uncompress + break; + end; + end; + end; + try + // compute response + Context.OutContent := ''; + Context.OutContentType := ''; + Context.OutCustomHeaders := ''; + fillchar(Resp^,sizeof(Resp^),0); + RespSent := false; + OutStatusCode := DoBeforeRequest(Context); + if OutStatusCode>0 then + if not SendResponse or (OutStatusCode<>STATUS_ACCEPTED) then + continue; + OutStatusCode := Request(Context); + AfterStatusCode := DoAfterRequest(Context); + if AfterStatusCode>0 then + OutStatusCode := AfterStatusCode; + // send response + if not RespSent then + if not SendResponse then + continue; + DoAfterResponse(Context, OutStatusCode); + except + on E: Exception do + // handle any exception raised during process: show must go on! + if not RespSent then + if not E.InheritsFrom(EHttpApiServer) or // ensure still connected + (EHttpApiServer(E).LastError<>HTTPAPI_ERROR_NONEXISTENTCONNECTION) then + SendError(STATUS_SERVERERROR,E.Message,E); + end; + finally + ReqId := 0; // reset Request ID to handle the next pending request + end; + ERROR_MORE_DATA: begin + // input buffer was too small to hold the request headers + // -> increase buffer size and call the API again + ReqID := Req^.RequestId; + SetLength(ReqBuf,bytesRead); + Req := pointer(ReqBuf); + end; + ERROR_CONNECTION_INVALID: + if ReqID=0 then + break else + // TCP connection was corrupted by the peer -> ignore + next request + ReqID := 0; + else break; // unhandled Err value + end; + until Terminated; + finally + Context.Free; + end; +end; + +function THttpApiServer.GetHTTPQueueLength: Cardinal; +var returnLength: ULONG; +begin + if (Http.Version.MajorVersion<2) or (self=nil) then + result := 0 else begin + if fOwner<>nil then + self := fOwner; + if fReqQueue=0 then + result := 0 else + EHttpApiServer.RaiseOnError(hQueryRequestQueueProperty, + Http.QueryRequestQueueProperty(fReqQueue,HttpServerQueueLengthProperty, + @Result, sizeof(Result), 0, @returnLength, nil)); + end; +end; + +procedure THttpApiServer.SetHTTPQueueLength(aValue: Cardinal); +begin + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetRequestQueueProperty, ERROR_OLD_WIN_VERSION); + if (self<>nil) and (fReqQueue<>0) then + EHttpApiServer.RaiseOnError(hSetRequestQueueProperty, + Http.SetRequestQueueProperty(fReqQueue,HttpServerQueueLengthProperty, + @aValue, sizeof(aValue), 0, nil)); +end; + +function THttpApiServer.GetRegisteredUrl: SockUnicode; +var i: integer; +begin + if fRegisteredUnicodeUrl=nil then + result := '' else + result := fRegisteredUnicodeUrl[0]; + for i := 1 to high(fRegisteredUnicodeUrl) do + result := result+','+fRegisteredUnicodeUrl[i]; +end; + +function THttpApiServer.GetCloned: boolean; +begin + result := (fOwner<>nil); +end; + +procedure THttpApiServer.SetMaxBandwidth(aValue: Cardinal); +var qosInfo: HTTP_QOS_SETTING_INFO; + limitInfo: HTTP_BANDWIDTH_LIMIT_INFO; +begin + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); + if (self<>nil) and (fUrlGroupID<>0) then begin + if AValue=0 then + limitInfo.MaxBandwidth := HTTP_LIMIT_INFINITE else + if AValuenil then + self := fOwner; + if fUrlGroupID=0 then begin + result := 0; + exit; + end; + qosInfoGet.qosInfo.QosType := HttpQosSettingTypeBandwidth; + qosInfoGet.qosInfo.QosSetting := @qosInfoGet.limitInfo; + EHttpApiServer.RaiseOnError(hQueryUrlGroupProperty, + Http.QueryUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, + @qosInfoGet, SizeOf(qosInfoGet))); + Result := qosInfoGet.limitInfo.MaxBandwidth; +end; + +function THttpApiServer.GetMaxConnections: Cardinal; +var qosInfoGet: record + qosInfo: HTTP_QOS_SETTING_INFO; + limitInfo: HTTP_CONNECTION_LIMIT_INFO; + end; + returnLength: ULONG; +begin + if (Http.Version.MajorVersion<2) or (self=nil) then begin + result := 0; + exit; + end; + if fOwner<>nil then + self := fOwner; + if fUrlGroupID=0 then begin + result := 0; + exit; + end; + qosInfoGet.qosInfo.QosType := HttpQosSettingTypeConnectionLimit; + qosInfoGet.qosInfo.QosSetting := @qosInfoGet.limitInfo; + EHttpApiServer.RaiseOnError(hQueryUrlGroupProperty, + Http.QueryUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, + @qosInfoGet, SizeOf(qosInfoGet), @returnLength)); + Result := qosInfoGet.limitInfo.MaxConnections; +end; + +procedure THttpApiServer.SetMaxConnections(aValue: Cardinal); +var qosInfo: HTTP_QOS_SETTING_INFO; + limitInfo: HTTP_CONNECTION_LIMIT_INFO; +begin + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetUrlGroupProperty, ERROR_OLD_WIN_VERSION); + if (self<>nil) and (fUrlGroupID<>0) then begin + if AValue = 0 then + limitInfo.MaxConnections := HTTP_LIMIT_INFINITE else + limitInfo.MaxConnections := aValue; + limitInfo.Flags := 1; + qosInfo.QosType := HttpQosSettingTypeConnectionLimit; + qosInfo.QosSetting := @limitInfo; + EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, + Http.SetUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, + @qosInfo, SizeOf(qosInfo))); + end; +end; + +function THttpApiServer.HasAPI2: boolean; +begin + result := Http.Version.MajorVersion>=2; +end; + +function THttpApiServer.GetLogging: boolean; +begin + result := (fLogData<>nil); +end; + +procedure THttpApiServer.LogStart(const aLogFolder: TFileName; + aType: THttpApiLoggingType; const aSoftwareName: TFileName; + aRolloverType: THttpApiLoggingRollOver; aRolloverSize: cardinal; + aLogFields: THttpApiLogFields; aFlags: THttpApiLoggingFlags); +var logInfo : HTTP_LOGGING_INFO; + folder,software: SockUnicode; +begin + if (self=nil) or (fOwner<>nil) then + exit; + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); + fLogData := nil; // disable any previous logging + fillchar(logInfo,SizeOf(logInfo),0); + logInfo.Flags := 1; + logInfo.LoggingFlags := byte(aFlags); + if aLogFolder='' then + raise EHttpApiServer.CreateFmt('LogStart(aLogFolder="")',[]); + if length(aLogFolder)>212 then + // http://msdn.microsoft.com/en-us/library/windows/desktop/aa364532 + raise EHttpApiServer.CreateFmt('aLogFolder is too long for LogStart(%s)',[aLogFolder]); + folder := SockUnicode(aLogFolder); + software := SockUnicode(aSoftwareName); + logInfo.SoftwareNameLength := length(software)*2; + logInfo.SoftwareName := pointer(software); + logInfo.DirectoryNameLength := length(folder)*2; + logInfo.DirectoryName := pointer(folder); + logInfo.Format := HTTP_LOGGING_TYPE(aType); + if aType=hltNCSA then + aLogFields := [hlfDate..hlfSubStatus]; + logInfo.Fields := integer(aLogFields); + logInfo.RolloverType := HTTP_LOGGING_ROLLOVER_TYPE(aRolloverType); + if aRolloverType=hlrSize then + logInfo.RolloverSize := aRolloverSize; + EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, + Http.SetUrlGroupProperty(fUrlGroupID, HttpServerLoggingProperty, + @logInfo, SizeOf(logInfo))); + // on success, update the actual log memory structure + fLogData := pointer(fLogDataStorage); +end; + +procedure THttpApiServer.RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer=1024); +var i: integer; +begin + inherited; + for i := 0 to length(fClones)-1 do + fClones[i].RegisterCompress(aFunction,aCompressMinSize); +end; + +procedure THttpApiServer.SetOnTerminate(const Event: TNotifyThreadEvent); +var i: integer; +begin + inherited SetOnTerminate(Event); + if fOwner=nil then + for i := 0 to length(fClones)-1 do + fClones[i].OnHttpThreadTerminate := Event; +end; + +procedure THttpApiServer.LogStop; +var i: integer; +begin + if (self=nil) or (fClones=nil) or (fLogData=nil) then + exit; + fLogData := nil; + for i := 0 to length(fClones)-1 do + fClones[i].fLogData := nil; +end; + +procedure THttpApiServer.SetReceiveBufferSize(Value: cardinal); +var i: integer; +begin + fReceiveBufferSize := Value; + for i := 0 to length(fClones)-1 do + fClones[i].fReceiveBufferSize := Value; +end; + +procedure THttpApiServer.SetServerName(const aName: SockString); +var i: integer; +begin + inherited SetServerName(aName); + with PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^ do begin + ServerName := pointer(aName); + ServerNameLength := Length(aName); + end; + for i := 0 to length(fClones)-1 do + fClones[i].SetServerName(aName); +end; + +procedure THttpApiServer.SetOnRequest(const aRequest: TOnHttpServerRequest); +var i: integer; +begin + inherited SetOnRequest(aRequest); + for i := 0 to length(fClones)-1 do + fClones[i].SetOnRequest(aRequest); +end; + +procedure THttpApiServer.SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); +var i: integer; +begin + inherited SetOnBeforeBody(aEvent); + for i := 0 to length(fClones)-1 do + fClones[i].SetOnBeforeBody(aEvent); +end; + +procedure THttpApiServer.SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); +var i: integer; +begin + inherited SetOnBeforeRequest(aEvent); + for i := 0 to length(fClones)-1 do + fClones[i].SetOnBeforeRequest(aEvent); +end; + +procedure THttpApiServer.SetOnAfterRequest(const aEvent: TOnHttpServerRequest); +var i: integer; +begin + inherited SetOnAfterRequest(aEvent); + for i := 0 to length(fClones)-1 do + fClones[i].SetOnAfterRequest(aEvent); +end; + +procedure THttpApiServer.SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); +var i: integer; +begin + inherited SetOnAfterResponse(aEvent); + for i := 0 to length(fClones)-1 do + fClones[i].SetOnAfterResponse(aEvent); +end; + +procedure THttpApiServer.SetMaximumAllowedContentLength(aMax: cardinal); +var i: integer; +begin + inherited SetMaximumAllowedContentLength(aMax); + for i := 0 to length(fClones)-1 do + fClones[i].SetMaximumAllowedContentLength(aMax); +end; + +procedure THttpApiServer.SetRemoteIPHeader(const aHeader: SockString); +var i: integer; +begin + inherited SetRemoteIPHeader(aHeader); + for i := 0 to length(fClones)-1 do + fClones[i].SetRemoteIPHeader(aHeader); +end; + +procedure THttpApiServer.SetRemoteConnIDHeader(const aHeader: SockString); +var i: integer; +begin + inherited SetRemoteConnIDHeader(aHeader); + for i := 0 to length(fClones)-1 do + fClones[i].SetRemoteConnIDHeader(aHeader); +end; + +procedure THttpApiServer.SetLoggingServiceName(const aName: SockString); +begin + if self=nil then + exit; + fLoggingServiceName := aName; + PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^.ServiceNameLength := Length(fLoggingServiceName); + PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^.ServiceName := pointer(fLoggingServiceName); +end; + +procedure THttpApiServer.SetAuthenticationSchemes(schemes: THttpApiRequestAuthentications; + const DomainName, Realm: SockUnicode); +var authInfo: HTTP_SERVER_AUTHENTICATION_INFO; +begin + if (self=nil) or (fOwner<>nil) then + exit; + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); + fAuthenticationSchemes := schemes; + FillChar(authInfo,SizeOf(authInfo),0); + authInfo.Flags := 1; + authInfo.AuthSchemes := byte(schemes); + authInfo.ReceiveMutualAuth := true; + if haBasic in schemes then + with authInfo.BasicParams do begin + RealmLength := Length(Realm); + Realm := pointer(Realm); + end; + if haDigest in schemes then + with authInfo.DigestParams do begin + DomainNameLength := Length(DomainName); + DomainName := pointer(DomainName); + RealmLength := Length(Realm); + Realm := pointer(Realm); + end; + EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, + Http.SetUrlGroupProperty(fUrlGroupID, HttpServerAuthenticationProperty, + @authInfo, SizeOf(authInfo))); +end; + +procedure THttpApiServer.SetTimeOutLimits(aEntityBody, aDrainEntityBody, + aRequestQueue, aIdleConnection, aHeaderWait, aMinSendRate: cardinal); +var timeoutInfo: HTTP_TIMEOUT_LIMIT_INFO; +begin + if (self=nil) or (fOwner<>nil) then + exit; + if Http.Version.MajorVersion<2 then + raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); + FillChar(timeOutInfo,SizeOf(timeOutInfo),0); + timeoutInfo.Flags := 1; + timeoutInfo.EntityBody := aEntityBody; + timeoutInfo.DrainEntityBody := aDrainEntityBody; + timeoutInfo.RequestQueue := aRequestQueue; + timeoutInfo.IdleConnection := aIdleConnection; + timeoutInfo.HeaderWait := aHeaderWait; + timeoutInfo.MinSendRate := aMinSendRate; + EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, + Http.SetUrlGroupProperty(fUrlGroupID, HttpServerTimeoutsProperty, + @timeoutInfo, SizeOf(timeoutInfo))); +end; + + +type + WEB_SOCKET_PROPERTY_TYPE = ( + WEB_SOCKET_RECEIVE_BUFFER_SIZE_PROPERTY_TYPE, //0 + WEB_SOCKET_SEND_BUFFER_SIZE_PROPERTY_TYPE, + WEB_SOCKET_DISABLE_MASKING_PROPERTY_TYPE, + WEB_SOCKET_ALLOCATED_BUFFER_PROPERTY_TYPE, + WEB_SOCKET_DISABLE_UTF8_VERIFICATION_PROPERTY_TYPE, + WEB_SOCKET_KEEPALIVE_INTERVAL_PROPERTY_TYPE, + WEB_SOCKET_SUPPORTED_VERSIONS_PROPERTY_TYPE + ); + WEB_SOCKET_ACTION_QUEUE = Cardinal; + + WEB_SOCKET_ACTION = ( + WEB_SOCKET_NO_ACTION, //0 + WEB_SOCKET_SEND_TO_NETWORK_ACTION, + WEB_SOCKET_INDICATE_SEND_COMPLETE_ACTION, + WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION, + WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION + ); + PWEB_SOCKET_ACTION = ^WEB_SOCKET_ACTION; + + WEB_SOCKET_PROPERTY = record + PropType: WEB_SOCKET_PROPERTY_TYPE; + pvValue: Pointer; + ulValueSize: ULONG; + end; + PWEB_SOCKET_PROPERTY = ^WEB_SOCKET_PROPERTY; + + WEB_SOCKET_HTTP_HEADER = record + pcName: PAnsiChar; + ulNameLength: ULONG; + pcValue: PAnsiChar; + ulValueLength: ULONG; + end; + PWEB_SOCKET_HTTP_HEADER = ^WEB_SOCKET_HTTP_HEADER; + WEB_SOCKET_HTTP_HEADER_ARR = array of WEB_SOCKET_HTTP_HEADER; + + PWEB_SOCKET_BUFFER_DATA = ^WEB_SOCKET_BUFFER_DATA; + WEB_SOCKET_BUFFER_DATA = record + pbBuffer: PBYTE; + ulBufferLength: ULONG; + Reserved1: Word; + end; + WEB_SOCKET_BUFFER_CLOSE_STATUS = record + pbReason: PBYTE; + ulReasonLength: ULONG; + usStatus: WEB_SOCKET_CLOSE_STATUS; + end; + + /// direct late-binding access to the WebSocket Protocol Component API functions + TWebSocketAPI = packed record + /// acces to the loaded library handle + LibraryHandle: THandle; + /// depends on Windows version + WebSocketEnabled: Boolean; + /// aborts a WebSocket session handle created by WebSocketCreateClientHandle + // or WebSocketCreateServerHandle + AbortHandle: procedure (hWebSocket: WEB_SOCKET_HANDLE); stdcall; + /// begins the client-side handshake + BeginClientHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; pszSubprotocols: PAnsiChar; + ulSubprotocolCount: ULONG; pszExtensions: PAnsiChar; ulExtensionCount: ULONG; + const pInitialHeaders: PWEB_SOCKET_HTTP_HEADER; ulInitialHeaderCount: ULONG; + out pAdditionalHeaders: PWEB_SOCKET_HTTP_HEADER; out pulAdditionalHeaderCount: ULONG): HRESULT; stdcall; + /// begins the server-side handshake + BeginServerHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; pszSubprotocolSelected: PAnsiChar; + pszExtensionSelected: PAnsiChar; ulExtensionSelectedCount: ULONG; + const pRequestHeaders: PWEB_SOCKET_HTTP_HEADER; + ulRequestHeaderCount: ULONG; out pResponseHeaders: PWEB_SOCKET_HTTP_HEADER; + out pulResponseHeaderCount: ULONG): HRESULT; stdcall; + /// completes an action started by WebSocketGetAction + CompleteAction: function (hWebSocket: WEB_SOCKET_HANDLE; + pvActionContext: Pointer; ulBytesTransferred: ULONG): HRESULT; stdcall; + /// creates a client-side WebSocket session handle + CreateClientHandle: function (const pProperties: PWEB_SOCKET_PROPERTY; ulPropertyCount: ULONG; + out phWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; + /// creates a server-side WebSocket session handle + CreateServerHandle: function (const pProperties: PWEB_SOCKET_PROPERTY; ulPropertyCount: ULONG; + out phWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; + /// deletes a WebSocket session handle created by WebSocketCreateClientHandle + // or WebSocketCreateServerHandle + DeleteHandle: procedure (hWebSocket: WEB_SOCKET_HANDLE); stdcall; + /// completes the client-side handshake + EndClientHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; + const pResponseHeaders: PWEB_SOCKET_HTTP_HEADER; + ulReponseHeaderCount: ULONG; var pulSelectedExtensions: ULONG; + var pulSelectedExtensionCount: ULONG; + var pulSelectedSubprotocol: ULONG): HRESULT; stdcall; + /// completes the server-side handshake + EndServerHandshake: function (hWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; + /// returns an action from a call to WebSocketSend, WebSocketReceive or WebSocketCompleteAction + GetAction: function (hWebSocket: WEB_SOCKET_HANDLE; eActionQueue: WEB_SOCKET_ACTION_QUEUE; + pDataBuffers: Pointer {WEB_SOCKET_BUFFER_DATA}; var pulDataBufferCount: ULONG; + var pAction: WEB_SOCKET_ACTION; + var pBufferType: WEB_SOCKET_BUFFER_TYPE; var pvApplicationContext: Pointer; + var pvActionContext: Pointer): HRESULT; stdcall; + /// gets a single WebSocket property + GetGlobalProperty: function (eType: WEB_SOCKET_PROPERTY_TYPE; + pvValue: Pointer; var ulSize: ULONG): HRESULT ; stdcall; + /// adds a receive operation to the protocol component operation queue + Receive: function (hWebSocket: WEB_SOCKET_HANDLE; pBuffer: Pointer {PWEB_SOCKET_BUFFER_*}; + pvContext: Pointer): HRESULT; stdcall; + /// adds a send operation to the protocol component operation queue + Send: function (hWebSocket: WEB_SOCKET_HANDLE; BufferType: WEB_SOCKET_BUFFER_TYPE; + pBuffer: Pointer {PWEB_SOCKET_BUFFER_*}; Context: Pointer): HRESULT; stdcall; + end; + + /// identify each TWebSocketAPI late-binding API function + TWebSocketAPIs = (hAbortHandle, hBeginClientHandshake, hBeginServerHandshake, + hCompleteAction, hCreateClientHandle, hCreateServerHandle, hDeleteHandle, + hEndClientHandshake, hEndServerHandshake, hGetAction, hGetGlobalProperty, + hReceive, hSend + ); + +const + sProtocolHeader: SockString = 'SEC-WEBSOCKET-PROTOCOL'; + +function HttpSys2ToWebSocketHeaders(const aHttpHeaders: HTTP_REQUEST_HEADERS): WEB_SOCKET_HTTP_HEADER_ARR; +var headerCnt: Integer; + i, idx: PtrInt; + h: THttpHeader; + p: PHTTP_UNKNOWN_HEADER; +begin + headerCnt := 0; + for h := Low(HTTP_KNOWNHEADERS) to High(HTTP_KNOWNHEADERS) do + if aHttpHeaders.KnownHeaders[h].RawValueLength <> 0 then + inc(headerCnt); + p := aHttpHeaders.pUnknownHeaders; + if p<>nil then + inc(headerCnt, aHttpHeaders.UnknownHeaderCount); + SetLength(Result, headerCnt); + idx := 0; + for h := Low(HTTP_KNOWNHEADERS) to High(HTTP_KNOWNHEADERS) do + if aHttpHeaders.KnownHeaders[h].RawValueLength<>0 then begin + Result[idx].pcName := @HTTP_KNOWNHEADERS[h][1]; + Result[idx].ulNameLength := ord(HTTP_KNOWNHEADERS[h][0]); + Result[idx].pcValue := aHttpHeaders.KnownHeaders[h].pRawValue; + Result[idx].ulValueLength := aHttpHeaders.KnownHeaders[h].RawValueLength; + inc(idx); + end; + p := aHttpHeaders.pUnknownHeaders; + if p<>nil then + for i := 1 to aHttpHeaders.UnknownHeaderCount do begin + Result[idx].pcName := p^.pName; + Result[idx].ulNameLength := p^.NameLength; + Result[idx].pcValue := p^.pRawValue; + Result[idx].ulValueLength := p^.RawValueLength; + inc(idx); + inc(p); + end; +end; + +function WebSocketHeadersToSockString(const aHeaders: PWEB_SOCKET_HTTP_HEADER; + const aHeadersCount: Integer): SockString; +var i: Integer; + h: PWEB_SOCKET_HTTP_HEADER; + len: Integer; + d : PAnsiChar; +begin + len := 0; + h := aHeaders; + for i := 1 to aHeadersCount do begin + if h^.ulValueLength<>0 then + inc(len, h^.ulNameLength + h^.ulValueLength + 4); + inc(h); + end; + SetString(Result, nil, len); + d := Pointer(Result); + h := aHeaders; + for i := 1 to aHeadersCount do begin + if h^.ulValueLength<>0 then begin + Move(h^.pcName^, d^, h^.ulNameLength); + inc(d, h^.ulNameLength); + PWord(d)^ := Ord(':') + Ord(' ') shl 8; + inc(d, 2); + Move(h^.pcValue^, d^, h^.ulValueLength); + inc(d, h^.ulValueLength); + PWord(d)^ := 13 + 10 shl 8; + inc(d, 2); + end; + inc(h); + end; + Assert(d - Pointer(Result) = len); +end; + +const + WEBSOCKET_DLL = 'websocket.dll'; + + WebSocketNames: array [TWebSocketAPIs] of PChar = ( + 'WebSocketAbortHandle', + 'WebSocketBeginClientHandshake', + 'WebSocketBeginServerHandshake', + 'WebSocketCompleteAction', + 'WebSocketCreateClientHandle', + 'WebSocketCreateServerHandle', + 'WebSocketDeleteHandle', + 'WebSocketEndClientHandshake', + 'WebSocketEndServerHandshake', + 'WebSocketGetAction', + 'WebSocketGetGlobalProperty', + 'WebSocketReceive', + 'WebSocketSend' + ); + + WEB_SOCKET_SEND_ACTION_QUEUE = $1; + WEB_SOCKET_RECEIVE_ACTION_QUEUE = $2; + WEB_SOCKET_ALL_ACTION_QUEUE = WEB_SOCKET_SEND_ACTION_QUEUE or WEB_SOCKET_RECEIVE_ACTION_QUEUE; + + ///Context ID of WebSocket URI group + WEB_SOCKET_URL_CONTEXT = 1; + +var + WebSocketAPI: TWebSocketAPI; + +procedure WebSocketApiInitialize; +var api: TWebSocketAPIs; + P: PPointer; +begin + if WebSocketAPI.LibraryHandle<>0 then + exit; // already loaded + WebSocketAPI.WebSocketEnabled := false; + WebSocketAPI.LibraryHandle := SafeLoadLibrary(WEBSOCKET_DLL); + if WebSocketAPI.LibraryHandle=0 then + exit; + P := @@WebSocketAPI.AbortHandle; + for api := low(api) to high(api) do begin + P^ := GetProcAddress(WebSocketAPI.LibraryHandle,WebSocketNames[api]); + if P^ = nil then begin + FreeLibrary(WebSocketAPI.LibraryHandle); + WebSocketAPI.LibraryHandle := 0; + exit; + end; + inc(P); + end; + WebSocketAPI.WebSocketEnabled := true; +end; + +function WinHTTP_WebSocketEnabled: boolean; +begin + Result := WebSocketAPI.WebSocketEnabled; +end; + + +{ EWebSocketApi } + +type + EWebSocketApi = class(ECrtSocket) + protected + fLastApi: TWebSocketAPIs; + public + class procedure RaiseOnError(api: TWebSocketAPIs; Error: integer); + constructor Create(api: TWebSocketAPIs; Error: integer); reintroduce; + published + property LastApi: TWebSocketAPIs read fLastApi; + end; + +class procedure EWebSocketApi.RaiseOnError(api: TWebSocketAPIs; Error: integer); +begin + if Error<>NO_ERROR then + raise self.Create(api,Error); +end; + +constructor EWebSocketApi.Create(api: TWebSocketAPIs; Error: integer); +begin + fLastError := Error; + fLastApi := api; + inherited CreateFmt('%s failed: %s (%d)', + [WebSocketNames[api],SysErrorMessagePerModule(Error,WEBSOCKET_DLL),Error]) +end; + + +{ THttpApiWebSocketServerProtocol } + +const WebSocketConnectionCapacity = 1000; + +function THttpApiWebSocketServerProtocol.AddConnection(aConn: PHttpApiWebSocketConnection): Integer; +var i: integer; +begin + if fFirstEmptyConnectionIndex >= fConnectionsCapacity - 1 then begin + inc(fConnectionsCapacity, WebSocketConnectionCapacity); + ReallocMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); + Fillchar(fConnections^[fConnectionsCapacity - WebSocketConnectionCapacity], WebSocketConnectionCapacity * SizeOf(PHttpApiWebSocketConnection), 0); + end; + if fFirstEmptyConnectionIndex >= fConnectionsCount then + fConnectionsCount := fFirstEmptyConnectionIndex + 1; + fConnections[fFirstEmptyConnectionIndex] := aConn; + Result := fFirstEmptyConnectionIndex; + for i := fFirstEmptyConnectionIndex + 1 to fConnectionsCount do begin + if fConnections[i] = nil then begin + fFirstEmptyConnectionIndex := i; + Break; + end; + end; +end; + +function THttpApiWebSocketServerProtocol.Broadcast( + aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; + aBufferSize: ULONG): boolean; +var i: integer; +begin + EnterCriticalSection(fSafe); + try + for i := 0 to fConnectionsCount - 1 do + if Assigned(fConnections[i]) then + fConnections[i].Send(aBufferType, aBuffer, aBufferSize); + finally + LeaveCriticalSection(fSafe); + end; + result := True; +end; + +function THttpApiWebSocketServerProtocol.Close(index: Integer; + aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG): boolean; +var conn: PHttpApiWebSocketConnection; +begin + Result := false; + if (index>=0) and (indexnil) and (conn.fState = wsOpen) then begin + conn.Close(aStatus, aBuffer, aBufferSize); + result := True; + end; + end; +end; + +constructor THttpApiWebSocketServerProtocol.Create(const aName: SockString; + aManualFragmentManagement: Boolean; + aServer: THttpApiWebSocketServer; + aOnAccept: THttpApiWebSocketServerOnAcceptEvent; + aOnMessage: THttpApiWebSocketServerOnMessageEvent; + aOnConnect: THttpApiWebSocketServerOnConnectEvent; + aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; + aOnFragment: THttpApiWebSocketServerOnMessageEvent); +begin + if aManualFragmentManagement and not Assigned(aOnFragment) then + raise EWebSocketApi.CreateFmt('Error register WebSocket protocol. Protocol %s does not use buffer, ' + 'but OnFragment handler is not assigned', [aName]); + {$ifdef FPC} + InitCriticalSection(fSafe); + {$else} + InitializeCriticalSection(fSafe); + {$endif} + fPendingForClose := {$ifdef FPC}TFPList{$else}TList{$endif}.Create; + fName := aName; + fManualFragmentManagement := aManualFragmentManagement; + fServer := aServer; + fOnAccept := aOnAccept; + fOnMessage := aOnMessage; + fOnConnect := aOnConnect; + fOnDisconnect := aOnDisconnect; + fOnFragment := aOnFragment; + fConnectionsCapacity := WebSocketConnectionCapacity; + fConnectionsCount := 0; + fFirstEmptyConnectionIndex := 0; + GetMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); + Fillchar(fConnections^, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection), 0); +end; + +destructor THttpApiWebSocketServerProtocol.Destroy; +var i: integer; + conn: PHttpApiWebSocketConnection; +begin + EnterCriticalSection(fSafe); + try + for i := 0 to fPendingForClose.Count-1 do begin + conn := fPendingForClose[i]; + if Assigned(conn) then begin + conn.DoOnDisconnect(); + conn.Disconnect(); + Dispose(conn); + end; + end; + fPendingForClose.Free; + finally + LeaveCriticalSection(fSafe); + end; + {$IFDEF FPC} + DoneCriticalsection(fSafe); + {$ELSE} + DeleteCriticalSection(fSafe); + {$ENDIF} + FreeMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); + fConnections := nil; + inherited; +end; + +procedure THttpApiWebSocketServerProtocol.doShutdown; +var i: Integer; + conn: PHttpApiWebSocketConnection; +const sReason = 'Server shutdown'; +begin + EnterCriticalSection(fSafe); + try + for i := 0 to fConnectionsCount - 1 do begin + conn := fConnections[i]; + if Assigned(conn) then begin + RemoveConnection(i); + conn.fState := wsClosedByShutdown; + conn.fBuffer := sReason; + conn.fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; + conn.Close(WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS, Pointer(conn.fBuffer), Length(conn.fBuffer)); +// PostQueuedCompletionStatus(fServer.fThreadPoolServer.FRequestQueue, 0, 0, @conn.fOverlapped); + end; + end; + finally + LeaveCriticalSection(fSafe); + end; +end; + +procedure THttpApiWebSocketServerProtocol.RemoveConnection(index: integer); +begin + fPendingForClose.Add(fConnections[index]); + fConnections[index] := nil; + if (fFirstEmptyConnectionIndex > index) then + fFirstEmptyConnectionIndex := index; +end; + +function THttpApiWebSocketServerProtocol.Send(index: Integer; + aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG): boolean; +var conn: PHttpApiWebSocketConnection; +begin + result := false; + if (index>=0) and (indexnil) and (conn.fState=wsOpen) then begin + conn.Send(aBufferType, aBuffer, aBufferSize); + result := True; + end; + end; +end; + + + { THttpApiWebSocketConnection } + +function THttpApiWebSocketConnection.TryAcceptConnection(aProtocol: THttpApiWebSocketServerProtocol; + Ctxt: THttpServerRequest; aNeedHeader: boolean): boolean; +var req: PHTTP_REQUEST; + wsRequestHeaders: WEB_SOCKET_HTTP_HEADER_ARR; + wsServerHeaders: PWEB_SOCKET_HTTP_HEADER; + wsServerHeadersCount: ULONG; +begin + fState := wsConnecting; + fBuffer := ''; + fWSHandle := nil; + fLastActionContext := nil; + Fillchar(fOverlapped, SizeOf(fOverlapped), 0); + fProtocol := aProtocol; + req := PHTTP_REQUEST(Ctxt.HttpApiRequest); + fIndex := fProtocol.fFirstEmptyConnectionIndex; + fOpaqueHTTPRequestId := req^.RequestId; + if (fProtocol=nil) or (Assigned(fProtocol.OnAccept) and not fProtocol.OnAccept(Ctxt, Self)) then begin + result := False; + exit; + end; + EWebSocketApi.RaiseOnError(hCreateServerHandle, WebSocketAPI.CreateServerHandle(nil, 0, fWSHandle)); + wsRequestHeaders := HttpSys2ToWebSocketHeaders(req^.Headers); + if aNeedHeader then + result := WebSocketAPI.BeginServerHandshake(fWSHandle, Pointer(fProtocol.name), nil, 0, + @wsRequestHeaders[0], Length(wsRequestHeaders), wsServerHeaders, wsServerHeadersCount) = S_OK else + result := WebSocketAPI.BeginServerHandshake(fWSHandle, nil, nil, 0, + @wsRequestHeaders[0], Length(wsRequestHeaders), wsServerHeaders, wsServerHeadersCount) = S_OK; + if result then + try + Ctxt.OutCustomHeaders := WebSocketHeadersToSockString(wsServerHeaders, wsServerHeadersCount); + finally + result := WebSocketAPI.EndServerHandshake(fWSHandle) = S_OK; + end; + if not Result then + Disconnect else + fLastReceiveTickCount := 0; +end; + +procedure THttpApiWebSocketConnection.DoOnMessage(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); + procedure PushFragmentIntoBuffer; + var + l: Integer; + begin + l := Length(fBuffer); + SetLength(fBuffer, l + Integer(aBufferSize)); + Move(aBuffer^, fBuffer[l + 1], aBufferSize); + end; +begin + if (fProtocol = nil) then + exit; + if (aBufferType=WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE) or + (aBufferType=WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE) then begin // Fragment + if not fProtocol.ManualFragmentManagement then + PushFragmentIntoBuffer; + if Assigned(fProtocol.OnFragment) then + fProtocol.OnFragment(self,aBufferType,aBuffer,aBufferSize); + end else begin // last Fragment + if Assigned(fProtocol.OnMessage) then begin + if fProtocol.ManualFragmentManagement then + fProtocol.OnMessage(self,aBufferType,aBuffer,aBufferSize) else begin + PushFragmentIntoBuffer; + fProtocol.OnMessage(self,aBufferType,Pointer(fBuffer),Length(fBuffer)); + fBuffer := ''; + end; + end; + end; +end; + +procedure THttpApiWebSocketConnection.DoOnConnect; +begin + if (fProtocol<>nil) and Assigned(fProtocol.OnConnect) then + fProtocol.OnConnect(self); +end; + +procedure THttpApiWebSocketConnection.DoOnDisconnect; +begin + if (fProtocol<>nil) and Assigned(fProtocol.OnDisconnect) then + fProtocol.OnDisconnect(self,fCloseStatus,Pointer(fBuffer),length(fBuffer)); +end; + +function THttpApiWebSocketConnection.ReadData(const WebsocketBufferData): integer; +var Err: HRESULT; + fBytesRead: cardinal; + aBuf: WEB_SOCKET_BUFFER_DATA absolute WebsocketBufferData; +begin + Result := 0; + if fWSHandle = nil then + exit; + Err := Http.ReceiveRequestEntityBody(fProtocol.fServer.FReqQueue, fOpaqueHTTPRequestId, 0, + aBuf.pbBuffer, aBuf.ulBufferLength, fBytesRead, @self.fOverlapped); + case Err of + // On page reload Safari do not send a WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION + // with BufferType = WEB_SOCKET_CLOSE_BUFFER_TYPE, instead it send a dummy packet + // (WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION) and terminate socket + // see forum discussion https://synopse.info/forum/viewtopic.php?pid=27125 + ERROR_HANDLE_EOF: Result := -1; + ERROR_IO_PENDING: ; // + NO_ERROR: ;// + else + // todo: close connection + end; +end; + +procedure THttpApiWebSocketConnection.WriteData(const WebsocketBufferData); +var Err: HRESULT; + httpSendEntity: HTTP_DATA_CHUNK_INMEMORY; + bytesWrite: Cardinal; + aBuf: WEB_SOCKET_BUFFER_DATA absolute WebsocketBufferData; +begin + if fWSHandle = nil then + exit; + bytesWrite := 0; + httpSendEntity.DataChunkType := hctFromMemory; + httpSendEntity.pBuffer := aBuf.pbBuffer; + httpSendEntity.BufferLength := aBuf.ulBufferLength; + Err := Http.SendResponseEntityBody(fProtocol.fServer.FReqQueue,fOpaqueHTTPRequestId, + HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA or HTTP_SEND_RESPONSE_FLAG_MORE_DATA, + 1, @httpSendEntity, bytesWrite, nil, nil, @fProtocol.fServer.fSendOverlaped); + case Err of + ERROR_HANDLE_EOF: Disconnect; + ERROR_IO_PENDING: ; // + NO_ERROR: ;// + else + // todo: close connection + end; +end; + +procedure THttpApiWebSocketConnection.CheckIsActive; +var elapsed: PtrInt; +const sCloseReason = 'Closed after ping timeout'; +begin + if (fLastReceiveTickCount>0) and (fProtocol.fServer.fPingTimeout>0) then begin + elapsed := GetTick64-fLastReceiveTickCount; + if elapsed>2*fProtocol.fServer.PingTimeout*1000 then begin + fProtocol.RemoveConnection(fIndex); + fState := wsClosedByGuard; + fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; + fBuffer := sCloseReason; + PostQueuedCompletionStatus( + fProtocol.fServer.fThreadPoolServer.FRequestQueue, 0, 0, @fOverlapped); + end else + if elapsed>=fProtocol.fServer.PingTimeout * 1000 then + Ping; + end; +end; + +procedure THttpApiWebSocketConnection.Disconnect; +var //Err: HRESULT; //todo: handle error + httpSendEntity: HTTP_DATA_CHUNK_INMEMORY; + bytesWrite: Cardinal; +begin + WebSocketAPI.AbortHandle(fWSHandle); + WebSocketAPI.DeleteHandle(fWSHandle); + fWSHandle := nil; + httpSendEntity.DataChunkType := hctFromMemory; + httpSendEntity.pBuffer := nil; + httpSendEntity.BufferLength := 0; + {Err :=} Http.SendResponseEntityBody(fProtocol.fServer.fReqQueue, fOpaqueHTTPRequestId, + HTTP_SEND_RESPONSE_FLAG_DISCONNECT, 1, @httpSendEntity, bytesWrite, nil, nil, nil); +end; + +procedure THttpApiWebSocketConnection.BeforeRead; +begin + // if reading is in progress then try read messages else try receive new messages + if fState in [wsOpen, wsClosing] then begin + if Assigned(fLastActionContext) then begin + EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( + fWSHandle, fLastActionContext, fOverlapped.InternalHigh)); + fLastActionContext := nil; + end else + EWebSocketApi.RaiseOnError(hReceive, WebSocketAPI.Receive(fWSHandle, nil, nil)); + end else + raise EWebSocketApi.CreateFmt( + 'THttpApiWebSocketConnection.BeforeRead state is not wsOpen', []); +end; + +const + C_WEB_SOCKET_BUFFER_SIZE = 2; + +type + TWebSocketBufferDataArr = + array [0 .. C_WEB_SOCKET_BUFFER_SIZE - 1] of WEB_SOCKET_BUFFER_DATA; + +function THttpApiWebSocketConnection.ProcessActions( + ActionQueue: WEB_SOCKET_ACTION_QUEUE): boolean; +var ulDataBufferCount: ULONG; + Action: WEB_SOCKET_ACTION; + BufferType: WEB_SOCKET_BUFFER_TYPE; + ApplicationContext: Pointer; + ActionContext: Pointer; + i: integer; + Err: HRESULT; + Buffer: TWebSocketBufferDataArr; + procedure closeConnection(); + begin + EnterCriticalSection(fProtocol.fSafe); + try + fProtocol.RemoveConnection(fIndex); + finally + LeaveCriticalSection(fProtocol.fSafe); + end; + EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( + fWSHandle, ActionContext, 0)); + end; +begin + result := true; + repeat + ulDataBufferCount := Length(Buffer); + EWebSocketApi.RaiseOnError(hGetAction, + WebSocketAPI.GetAction(fWSHandle, ActionQueue, @Buffer[0], ulDataBufferCount, + Action, BufferType, ApplicationContext, ActionContext)); + case Action of + WEB_SOCKET_NO_ACTION: ; + WEB_SOCKET_SEND_TO_NETWORK_ACTION: begin + for i := 0 to ulDataBufferCount - 1 do + WriteData(Buffer[i]); + if fWSHandle <> nil then begin + Err := WebSocketAPI.CompleteAction(fWSHandle, ActionContext, 0); + EWebSocketApi.RaiseOnError(hCompleteAction, Err); + end; + result := False; + exit; + end; + WEB_SOCKET_INDICATE_SEND_COMPLETE_ACTION: ; + WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION: begin + for i := 0 to ulDataBufferCount - 1 do + if (ReadData(Buffer[i])=-1) then begin + fState := wsClosedByClient; + fBuffer := ''; + fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; + closeConnection(); + end; + fLastActionContext := ActionContext; + result := False; + exit; + end; + WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION: begin + fLastReceiveTickCount := GetTick64; + if BufferType = WEB_SOCKET_CLOSE_BUFFER_TYPE then begin + if fState = wsOpen then + fState := wsClosedByClient else + fState := wsClosedByServer; + SetString(fBuffer, PChar(Buffer[0].pbBuffer), Buffer[0].ulBufferLength); + fCloseStatus := Buffer[0].Reserved1; + closeConnection(); + result := False; + exit; + end else if BufferType = WEB_SOCKET_PING_PONG_BUFFER_TYPE then begin + // todo: may be answer to client's ping + EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( + fWSHandle, ActionContext, 0)); + exit; + end else if BufferType = WEB_SOCKET_UNSOLICITED_PONG_BUFFER_TYPE then begin + // todo: may be handle this situation + EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( + fWSHandle, ActionContext, 0)); + exit; + end else begin + DoOnMessage(BufferType, Buffer[0].pbBuffer, Buffer[0].ulBufferLength); + EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( + fWSHandle, ActionContext, 0)); + exit; + end; + end else + raise EWebSocketApi.CreateFmt('Invalid WebSocket action %d', [byte(Action)]); + end; + Err := WebSocketAPI.CompleteAction(fWSHandle, ActionContext, 0); + if ActionContext <> nil then + EWebSocketApi.RaiseOnError(hCompleteAction, Err); + until (Action = WEB_SOCKET_NO_ACTION); +end; + +procedure THttpApiWebSocketConnection.InternalSend(aBufferType: WEB_SOCKET_BUFFER_TYPE; + WebsocketBufferData: pointer); +begin + EWebSocketApi.RaiseOnError(hSend, WebSocketAPI.Send( + fWSHandle, aBufferType, WebsocketBufferData, nil)); + ProcessActions(WEB_SOCKET_SEND_ACTION_QUEUE); +end; + +procedure THttpApiWebSocketConnection.Send(aBufferType: WEB_SOCKET_BUFFER_TYPE; + aBuffer: Pointer; aBufferSize: ULONG); +var wsSendBuf: WEB_SOCKET_BUFFER_DATA; +begin + if fState<>wsOpen then + exit; + wsSendBuf.pbBuffer := aBuffer; + wsSendBuf.ulBufferLength := aBufferSize; + InternalSend(aBufferType, @wsSendBuf); +end; + +procedure THttpApiWebSocketConnection.Close(aStatus: WEB_SOCKET_CLOSE_STATUS; + aBuffer: Pointer; aBufferSize: ULONG); +var wsSendBuf: WEB_SOCKET_BUFFER_DATA; +begin + if fState=wsOpen then + fState := wsClosing; + wsSendBuf.pbBuffer := aBuffer; + wsSendBuf.ulBufferLength := aBufferSize; + wsSendBuf.Reserved1 := aStatus; + InternalSend(WEB_SOCKET_CLOSE_BUFFER_TYPE, @wsSendBuf); +end; + +procedure THttpApiWebSocketConnection.Ping; +begin + InternalSend(WEB_SOCKET_PING_PONG_BUFFER_TYPE, nil); +end; + + +{ THttpApiWebSocketServer } + +constructor THttpApiWebSocketServer.Create(CreateSuspended: Boolean; + aSocketThreadsCount, aPingTimeout: integer; QueueName: SockUnicode; + aOnWSThreadStart: TNotifyThreadEvent; aOnWSThreadTerminate: TNotifyThreadEvent); +begin + inherited Create(CreateSuspended, QueueName); + if not (WebSocketAPI.WebSocketEnabled) then + raise ECrtSocket.Create('WebSocket is not supported'); + fPingTimeout := aPingTimeout; + if fPingTimeout>0 then + fGuard := TSynWebSocketGuard.Create(Self); + New(fRegisteredProtocols); + SetLength(fRegisteredProtocols^, 0); + FOnWSThreadStart := aOnWSThreadStart; + FOnWSThreadTerminate := aOnWSThreadTerminate; + fThreadPoolServer := TSynThreadPoolHttpApiWebSocketServer.Create(Self, aSocketThreadsCount); +end; + +constructor THttpApiWebSocketServer.CreateClone(From: THttpApiServer); +var wsServer: THttpApiWebSocketServer absolute From; +begin + inherited CreateClone(From); + fThreadPoolServer := wsServer.fThreadPoolServer; + fPingTimeout := wsServer.fPingTimeout; + fRegisteredProtocols := wsServer.fRegisteredProtocols +end; + +procedure THttpApiWebSocketServer.DestroyMainThread; +var i: PtrInt; +begin + fGuard.Free; + for i := 0 to Length(fRegisteredProtocols^) - 1 do + fRegisteredProtocols^[i].doShutdown; + FreeAndNil(fThreadPoolServer); + for i := 0 to Length(fRegisteredProtocols^) - 1 do + fRegisteredProtocols^[i].Free; + fRegisteredProtocols^ := nil; + Dispose(fRegisteredProtocols); + fRegisteredProtocols := nil; + inherited; +end; + +procedure THttpApiWebSocketServer.DoAfterResponse(Ctxt: THttpServerRequest; + const Code: cardinal); +begin + if Assigned(fLastConnection) then + PostQueuedCompletionStatus(fThreadPoolServer.FRequestQueue, 0, 0, + @fLastConnection.fOverlapped); + inherited DoAfterResponse(Ctxt, Code); +end; + +function THttpApiWebSocketServer.GetProtocol(index: integer): THttpApiWebSocketServerProtocol; +begin + if (index>=0) and (index<=Length(fRegisteredProtocols^)) then + result := fRegisteredProtocols^[index] else + result := nil; +end; + +function THttpApiWebSocketServer.getProtocolsCount: Integer; +begin + if self=nil then + result := 0 else + result := Length(fRegisteredProtocols^); +end; + +function THttpApiWebSocketServer.getSendResponseFlags(Ctxt: THttpServerRequest): Integer; +begin + if (PHTTP_REQUEST(Ctxt.HttpApiRequest)^.UrlContext=WEB_SOCKET_URL_CONTEXT) and + (fLastConnection<>nil) then + result := HTTP_SEND_RESPONSE_FLAG_OPAQUE or HTTP_SEND_RESPONSE_FLAG_MORE_DATA + or HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA else + result := inherited getSendResponseFlags(Ctxt); +end; + +function THttpApiWebSocketServer.UpgradeToWebSocket(Ctxt: THttpServerRequest): cardinal; +var Protocol: THttpApiWebSocketServerProtocol; + i, j: Integer; + p: PHTTP_UNKNOWN_HEADER; + ch, chB: PAnsiChar; + aName: SockString; + ProtocolHeaderFound: Boolean; +label protocolFound; +begin + result := 404; + Protocol := nil; + ProtocolHeaderFound := false; + p := PHTTP_REQUEST(Ctxt.HttpApiRequest)^.Headers.pUnknownHeaders; + for j := 1 to PHTTP_REQUEST(Ctxt.HttpApiRequest)^.Headers.UnknownHeaderCount do begin + if (p.NameLength=Length(sProtocolHeader)) and + IdemPChar(p.pName,Pointer(sProtocolHeader)) then begin + ProtocolHeaderFound := True; + for i := 0 to Length(fRegisteredProtocols^) - 1 do begin + ch := p.pRawValue; + while (ch-p.pRawValue) nil then begin + EnterCriticalSection(Protocol.fSafe); + try + New(fLastConnection); + if fLastConnection.TryAcceptConnection(Protocol,Ctxt,ProtocolHeaderFound) then begin + Protocol.AddConnection(fLastConnection); + result := 101 + end else begin + Dispose(fLastConnection); + fLastConnection := nil; + result := 405; + end; + finally + LeaveCriticalSection(Protocol.fSafe); + end; + end; +end; + +function THttpApiWebSocketServer.AddUrlWebSocket(const aRoot, aPort: SockString; + Https: boolean; const aDomainName: SockString; aRegisterURI: boolean): integer; +begin + result := AddUrl(aRoot, aPort, Https, aDomainName, aRegisterURI, WEB_SOCKET_URL_CONTEXT); +end; + +procedure THttpApiWebSocketServer.RegisterProtocol(const aName: SockString; + aManualFragmentManagement: Boolean; + aOnAccept: THttpApiWebSocketServerOnAcceptEvent; + aOnMessage: THttpApiWebSocketServerOnMessageEvent; + aOnConnect: THttpApiWebSocketServerOnConnectEvent; + aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; + aOnFragment: THttpApiWebSocketServerOnMessageEvent); +var protocol: THttpApiWebSocketServerProtocol; +begin + if self=nil then exit; + protocol := THttpApiWebSocketServerProtocol.Create(aName, aManualFragmentManagement, + Self, aOnAccept, aOnMessage, aOnConnect, aOnDisconnect, aOnFragment); + protocol.fIndex := length(fRegisteredProtocols^); + SetLength(fRegisteredProtocols^, protocol.fIndex + 1); + fRegisteredProtocols^[protocol.fIndex] := protocol; +end; + +function THttpApiWebSocketServer.Request(Ctxt: THttpServerRequest): cardinal; +begin + if PHTTP_REQUEST(Ctxt.HttpApiRequest).UrlContext=WEB_SOCKET_URL_CONTEXT then + result := UpgradeToWebSocket(Ctxt) + else begin + result := inherited Request(Ctxt); + fLastConnection := nil; + end; +end; + +procedure THttpApiWebSocketServer.SendServiceMessage; +begin + PostQueuedCompletionStatus(fThreadPoolServer.FRequestQueue, 0, 0, @fServiceOverlaped); +end; + +procedure THttpApiWebSocketServer.SetOnWSThreadStart( + const Value: TNotifyThreadEvent); +begin + FOnWSThreadStart := Value; +end; + +procedure THttpApiWebSocketServer.SetOnWSThreadTerminate( + const Value: TNotifyThreadEvent); +begin + FOnWSThreadTerminate := Value; +end; + + +{ TSynThreadPoolHttpApiWebSocketServer } + +function TSynThreadPoolHttpApiWebSocketServer.NeedStopOnIOError: Boolean; +begin + // If connection closed by guard than ERROR_HANDLE_EOF or ERROR_OPERATION_ABORTED + // can be returned - Other connections must work normally + result := False; +end; + +procedure TSynThreadPoolHttpApiWebSocketServer.OnThreadStart(Sender: TThread); +begin + if Assigned(fServer.OnWSThreadStart) then + fServer.OnWSThreadStart(Sender); +end; + +procedure TSynThreadPoolHttpApiWebSocketServer.OnThreadTerminate( + Sender: TThread); +begin + if Assigned(fServer.OnWSThreadTerminate) then + fServer.OnWSThreadTerminate(Sender); +end; + +procedure TSynThreadPoolHttpApiWebSocketServer.Task(aCaller: TSynThread; aContext: Pointer); +var conn: PHttpApiWebSocketConnection; +begin + if aContext=@fServer.fSendOverlaped then + exit; + if (aContext=@fServer.fServiceOverlaped) then begin + if Assigned(fServer.onServiceMessage) then + fServer.onServiceMessage; + exit; + end; + conn := PHttpApiWebSocketConnection(aContext); + if conn.fState=wsConnecting then begin + conn.fState := wsOpen; + conn.fLastReceiveTickCount := GetTick64; + conn.DoOnConnect(); + end; + if conn.fState in [wsOpen, wsClosing] then + repeat + conn.BeforeRead; + until not conn.ProcessActions(WEB_SOCKET_RECEIVE_ACTION_QUEUE); + if conn.fState in [wsClosedByGuard] then + EWebSocketApi.RaiseOnError(hCompleteAction, + WebSocketAPI.CompleteAction(conn.fWSHandle, conn.fLastActionContext, 0)); + if conn.fState in [wsClosedByClient,wsClosedByServer,wsClosedByGuard,wsClosedByShutdown] then begin + conn.DoOnDisconnect; + if conn.fState = wsClosedByClient then + conn.Close(conn.fCloseStatus, Pointer(conn.fBuffer), length(conn.fBuffer)); + conn.Disconnect; + EnterCriticalSection(conn.Protocol.fSafe); + try + conn.Protocol.fPendingForClose.Remove(conn); + finally + LeaveCriticalSection(conn.Protocol.fSafe); + end; + Dispose(conn); + end; +end; + +constructor TSynThreadPoolHttpApiWebSocketServer.Create(Server: THttpApiWebSocketServer; + NumberOfThreads: Integer); +begin + fServer := Server; + fOnThreadStart := OnThreadStart; + fOnThreadTerminate := OnThreadTerminate; + inherited Create(NumberOfThreads, Server.fReqQueue); +end; + + +{ TSynWebSocketGuard } + +procedure TSynWebSocketGuard.Execute; +var i, j: Integer; + prot: THttpApiWebSocketServerProtocol; +begin + if fServer.fPingTimeout>0 then + while not Terminated do begin + if fServer<>nil then + for i := 0 to Length(fServer.fRegisteredProtocols^)-1 do begin + prot := fServer.fRegisteredProtocols^[i]; + EnterCriticalSection(prot.fSafe); + try + for j := 0 to prot.fConnectionsCount - 1 do + if Assigned(prot.fConnections[j]) then + prot.fConnections[j].CheckIsActive; + finally + LeaveCriticalSection(prot.fSafe); + end; + end; + i := 0; + while not Terminated and (i'' then begin + Headers.KnownHeaders[reqContentType].RawValueLength := length(ContentType); + Headers.KnownHeaders[reqContentType].pRawValue := pointer(ContentType); + end; + if Content='' then + exit; + DataChunk.DataChunkType := hctFromMemory; + DataChunk.pBuffer := pointer(Content); + DataChunk.BufferLength := length(Content); + EntityChunkCount := 1; + pEntityChunks := @DataChunk; +end; + +function HTTP_RESPONSE.AddCustomHeader(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs; + ForceCustomHeader: boolean): PAnsiChar; +const KNOWNHEADERS: array[reqCacheControl..respWwwAuthenticate] of PAnsiChar = ( + 'CACHE-CONTROL:','CONNECTION:','DATE:','KEEP-ALIVE:','PRAGMA:','TRAILER:', + 'TRANSFER-ENCODING:','UPGRADE:','VIA:','WARNING:','ALLOW:','CONTENT-LENGTH:', + 'CONTENT-TYPE:','CONTENT-ENCODING:','CONTENT-LANGUAGE:','CONTENT-LOCATION:', + 'CONTENT-MD5:','CONTENT-RANGE:','EXPIRES:','LAST-MODIFIED:', + 'ACCEPT-RANGES:','AGE:','ETAG:','LOCATION:','PROXY-AUTHENTICATE:', + 'RETRY-AFTER:','SERVER:','SET-COOKIE:','VARY:','WWW-AUTHENTICATE:'); +var UnknownName: PAnsiChar; + i: integer; +begin + if ForceCustomHeader then + i := -1 else + i := IdemPCharArray(P,KNOWNHEADERS); + // WebSockets need CONNECTION as unknown header + if (i>=0) and (THttpHeader(i)<>reqConnection) then + with Headers.KnownHeaders[THttpHeader(i)] do begin + while P^<>':' do inc(P); + inc(P); // jump ':' + while P^=' ' do inc(P); + pRawValue := P; + while P^>=' ' do inc(P); + RawValueLength := P-pRawValue; + end else begin + UnknownName := P; + while (P^>=' ') and (P^<>':') do inc(P); + if P^=':' then + with UnknownHeaders[Headers.UnknownHeaderCount] do begin + pName := UnknownName; + NameLength := P-pName; + repeat inc(P) until P^<>' '; + pRawValue := P; + while P^>=' ' do inc(P); + RawValueLength := P-pRawValue; + if Headers.UnknownHeaderCount=high(UnknownHeaders) then begin + SetLength(UnknownHeaders,Headers.UnknownHeaderCount+32); + Headers.pUnknownHeaders := pointer(UnknownHeaders); + end; + inc(Headers.UnknownHeaderCount); + end else + while P^>=' ' do inc(P); + end; + result := P; +end; + +procedure HTTP_RESPONSE.SetHeaders(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs); +{$ifndef NOXPOWEREDNAME} +const XPN: PAnsiChar = XPOWEREDNAME; + XPV: PAnsiChar = XPOWEREDVALUE; +{$endif} +begin + Headers.pUnknownHeaders := pointer(UnknownHeaders); + {$ifdef NOXPOWEREDNAME} + Headers.UnknownHeaderCount := 0; + {$else} + with UnknownHeaders[0] do begin + pName := XPN; + NameLength := length(XPOWEREDNAME); + pRawValue := XPV; + RawValueLength := length(XPOWEREDVALUE); + end; + Headers.UnknownHeaderCount := 1; + {$endif} + if P<>nil then + repeat + while ord(P^) in [10,13] do inc(P); + if P^=#0 then + break; + P := AddCustomHeader(P,UnknownHeaders,false); + until false; +end; + +procedure HTTP_RESPONSE.SetStatus(code: integer; var OutStatus: SockString); +begin + StatusCode := code; + OutStatus := StatusCodeToReason(code); + ReasonLength := length(OutStatus); + pReason := pointer(OutStatus); +end; + +const + HTTP_LOG_FIELD_TEST_SUB_STATUS: THttpApiLogFields = [hlfSubStatus]; + +{$endif MSWINDOWS} // encapsulate whole http.sys / HTTP API process + + +{ THttpRequest } + +function THttpRequest.RegisterCompress(aFunction: THttpSocketCompress; + aCompressMinSize: integer): boolean; +begin + result := RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize)<>''; +end; + +constructor THttpRequest.Create(const aServer, aPort: SockString; + aHttps: boolean; const aProxyName,aProxyByPass: SockString; + ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD; + aLayer: TCrtSocketLayer); +begin + fLayer := aLayer; + if fLayer<>cslUNIX then begin + fPort := GetCardinal(pointer(aPort)); + if fPort=0 then + if aHttps then + fPort := 443 else + fPort := 80; + end; + fServer := aServer; + fHttps := aHttps; + fProxyName := aProxyName; + fProxyByPass := aProxyByPass; + fExtendedOptions.UserAgent := DefaultUserAgent(self); + if ConnectionTimeOut=0 then + ConnectionTimeOut := HTTP_DEFAULT_CONNECTTIMEOUT; + if SendTimeout=0 then + SendTimeout := HTTP_DEFAULT_SENDTIMEOUT; + if ReceiveTimeout=0 then + ReceiveTimeout := HTTP_DEFAULT_RECEIVETIMEOUT; + InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout); // raise an exception on error +end; + +constructor THttpRequest.Create(const aURI, aProxyName,aProxyByPass: SockString; + ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD; aIgnoreSSLCertificateErrors: boolean); +var URI: TURI; +begin + if not URI.From(aURI) then + raise ECrtSocket.CreateFmt('%.Create: invalid aURI=%', [ClassName, aURI]); + IgnoreSSLCertificateErrors := aIgnoreSSLCertificateErrors; + Create(URI.Server,URI.Port,URI.Https,aProxyName,aProxyByPass, + ConnectionTimeOut,SendTimeout,ReceiveTimeout,URI.Layer); +end; + +class function THttpRequest.InternalREST(const url,method,data,header: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; + outStatus: PInteger): SockString; +var URI: TURI; + oh: SockString; + status: integer; +begin + result := ''; + with URI do + if From(url) then + try + with self.Create(Server,Port,Https,'','',0,0,0,Layer) do + try + IgnoreSSLCertificateErrors := aIgnoreSSLCertificateErrors; + status := Request(Address,method,0,header,data,'',oh,result); + if outStatus<>nil then + outStatus^ := status; + if outHeaders<>nil then + outHeaders^ := oh; + finally + Free; + end; + except + result := ''; + end; +end; + +class function THttpRequest.Get(const aURI,aHeader: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; + outStatus: PInteger): SockString; +begin + result := InternalREST(aURI,'GET','',aHeader, + aIgnoreSSLCertificateErrors,outHeaders,outStatus); +end; + +class function THttpRequest.Post(const aURI, aData, aHeader: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; + outStatus: PInteger): SockString; +begin + result := InternalREST(aURI,'POST',aData,aHeader, + aIgnoreSSLCertificateErrors,outHeaders,outStatus); +end; + +class function THttpRequest.Put(const aURI, aData, aHeader: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; + outStatus: PInteger): SockString; +begin + result := InternalREST(aURI,'PUT',aData,aHeader, + aIgnoreSSLCertificateErrors,outHeaders,outStatus); +end; + +class function THttpRequest.Delete(const aURI, aHeader: SockString; + aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; + outStatus: PInteger): SockString; +begin + result := InternalREST(aURI,'DELETE','',aHeader, + aIgnoreSSLCertificateErrors,outHeaders,outStatus); +end; + +function THttpRequest.Request(const url, method: SockString; + KeepAlive: cardinal; const InHeader, InData, InDataType: SockString; + out OutHeader, OutData: SockString): integer; +var aData, aDataEncoding, aAcceptEncoding, aURL: SockString; + i: integer; +begin + if (url='') or (url[1]<>'/') then + aURL := '/'+url else // need valid url according to the HTTP/1.1 RFC + aURL := url; + fKeepAlive := KeepAlive; + InternalCreateRequest(method,aURL); // should raise an exception on error + try + // common headers + InternalAddHeader(InHeader); + if InDataType<>'' then + InternalAddHeader(SockString('Content-Type: ')+InDataType); + // handle custom compression + aData := InData; + if integer(fCompressAcceptHeader)<>0 then begin + aDataEncoding := CompressDataAndGetHeaders(fCompressAcceptHeader,fCompress, + InDataType,aData); + if aDataEncoding<>'' then + InternalAddHeader(SockString('Content-Encoding: ')+aDataEncoding); + end; + if fCompressAcceptEncoding<>'' then + InternalAddHeader(fCompressAcceptEncoding); + // send request to remote server + InternalSendRequest(method, aData); + // retrieve status and headers + result := InternalRetrieveAnswer(OutHeader,aDataEncoding,aAcceptEncoding,OutData); + // handle incoming answer compression + if OutData<>'' then begin + if aDataEncoding<>'' then + for i := 0 to high(fCompress) do + with fCompress[i] do + if Name=aDataEncoding then + if Func(OutData,false)='' then + raise ECrtSocket.CreateFmt('%s uncompress',[Name]) else + break; // successfully uncompressed content + if aAcceptEncoding<>'' then + fCompressAcceptHeader := ComputeContentEncoding(fCompress,pointer(aAcceptEncoding)); + end; + finally + InternalCloseRequest; + end; +end; + + +{$ifdef USEWININET} + +{ ************ WinHttp / WinINet HTTP clients } + +{ TWinHttpAPI } + +const + // while reading an HTTP response, read it in blocks of this size. 8K for now + HTTP_RESP_BLOCK_SIZE = 8*1024; + +function TWinHttpAPI.InternalRetrieveAnswer( + var Header, Encoding, AcceptEncoding, Data: SockString): integer; +var Bytes, ContentLength, Read: DWORD; + tmp: SockString; +begin // HTTP_QUERY* and WINHTTP_QUERY* do match -> common to TWinINet + TWinHTTP + result := InternalGetInfo32(HTTP_QUERY_STATUS_CODE); + Header := InternalGetInfo(HTTP_QUERY_RAW_HEADERS_CRLF); + Encoding := InternalGetInfo(HTTP_QUERY_CONTENT_ENCODING); + AcceptEncoding := InternalGetInfo(HTTP_QUERY_ACCEPT_ENCODING); + // retrieve received content (if any) + Read := 0; + ContentLength := InternalGetInfo32(HTTP_QUERY_CONTENT_LENGTH); + if Assigned(fOnDownload) then begin + // download per-chunk using calback event + Bytes := fOnDownloadChunkSize; + if Bytes<=0 then + Bytes := 65536; // 64KB seems fair enough by default + SetLength(tmp,Bytes); + repeat + Bytes := InternalQueryDataAvailable; + if Bytes=0 then + break; + if Integer(Bytes) > Length(tmp) then + SetLength(tmp, Bytes); + Bytes := InternalReadData(tmp,0,Bytes); + if Bytes=0 then + break; + inc(Read,Bytes); + if not fOnDownload(self,Read,ContentLength,Bytes,pointer(tmp)^) then + break; // returned false = aborted + if Assigned(fOnProgress) then + fOnProgress(self,Read,ContentLength); + until false; + end else + if ContentLength<>0 then begin + // optimized version reading "Content-Length: xxx" bytes + SetLength(Data,ContentLength); + repeat + Bytes := InternalQueryDataAvailable; + if Bytes=0 then begin + SetLength(Data,Read); // truncated content + break; + end; + Bytes := InternalReadData(Data,Read,Bytes); + if Bytes=0 then begin + SetLength(Data,Read); // truncated content + break; + end; + inc(Read,Bytes); + if Assigned(fOnProgress) then + fOnProgress(self,Read,ContentLength); + until Read=ContentLength; + end else begin + // Content-Length not set: read response in blocks of HTTP_RESP_BLOCK_SIZE + repeat + Bytes := InternalQueryDataAvailable; + if Bytes=0 then + break; + SetLength(Data,Read+Bytes{HTTP_RESP_BLOCK_SIZE}); + Bytes := InternalReadData(Data,Read,Bytes); + if Bytes=0 then + break; + inc(Read,Bytes); + if Assigned(fOnProgress) then + fOnProgress(self,Read,ContentLength); + until false; + SetLength(Data,Read); + end; +end; + +class function TWinHttpAPI.IsAvailable: boolean; +begin + result := true; // both WinINet and WinHTTP are statically linked +end; + + +{ EWinINet } + +constructor EWinINet.Create; +var dwError, tmpLen: DWORD; + msg, tmp: string; +begin // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa383884 + fLastError := GetLastError; + msg := SysErrorMessagePerModule(fLastError,'wininet.dll'); + if fLastError=ERROR_INTERNET_EXTENDED_ERROR then begin + InternetGetLastResponseInfo({$ifdef FPC}@{$endif}dwError,nil,tmpLen); + if tmpLen > 0 then begin + SetLength(tmp,tmpLen); + InternetGetLastResponseInfo({$ifdef FPC}@{$endif}dwError,PChar(tmp),tmpLen); + msg := msg+' ['+tmp+']'; + end; + end; + inherited CreateFmt('%s (%d)',[msg,fLastError]); +end; + + +{ TWinINet } + +destructor TWinINet.Destroy; +begin + if fConnection<>nil then + InternetCloseHandle(FConnection); + if fSession<>nil then + InternetCloseHandle(FSession); + inherited; +end; + +procedure TWinINet.InternalAddHeader(const hdr: SockString); +begin + if (hdr<>'') and not HttpAddRequestHeadersA(fRequest, + Pointer(hdr), length(hdr), HTTP_ADDREQ_FLAG_COALESCE) then + raise EWinINet.Create; +end; + +procedure TWinINet.InternalCloseRequest; +begin + if fRequest<>nil then begin + InternetCloseHandle(fRequest); + fRequest := nil; + end; +end; + +procedure TWinINet.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); +var OpenType: integer; +begin + if fProxyName='' then + OpenType := INTERNET_OPEN_TYPE_PRECONFIG else + OpenType := INTERNET_OPEN_TYPE_PROXY; + fSession := InternetOpenA(Pointer(fExtendedOptions.UserAgent), OpenType, + pointer(fProxyName), pointer(fProxyByPass), 0); + if fSession=nil then + raise EWinINet.Create; + InternetSetOption(fConnection,INTERNET_OPTION_CONNECT_TIMEOUT, + @ConnectionTimeOut,SizeOf(ConnectionTimeOut)); + InternetSetOption(fConnection,INTERNET_OPTION_SEND_TIMEOUT, + @SendTimeout,SizeOf(SendTimeout)); + InternetSetOption(fConnection,INTERNET_OPTION_RECEIVE_TIMEOUT, + @ReceiveTimeout,SizeOf(ReceiveTimeout)); + fConnection := InternetConnectA(fSession, pointer(fServer), fPort, nil, nil, + INTERNET_SERVICE_HTTP, 0, 0); + if fConnection=nil then + raise EWinINet.Create; +end; + +function TWinINet.InternalGetInfo(Info: DWORD): SockString; +var dwSize, dwIndex: DWORD; +begin + result := ''; + dwSize := 0; + dwIndex := 0; + if not HttpQueryInfoA(fRequest, Info, nil, dwSize, dwIndex) and + (GetLastError=ERROR_INSUFFICIENT_BUFFER) then begin + SetLength(result,dwSize-1); + if not HttpQueryInfoA(fRequest, Info, pointer(result), dwSize, dwIndex) then + result := ''; + end; +end; + +function TWinINet.InternalGetInfo32(Info: DWORD): DWORD; +var dwSize, dwIndex: DWORD; +begin + dwSize := sizeof(result); + dwIndex := 0; + Info := Info or HTTP_QUERY_FLAG_NUMBER; + if not HttpQueryInfoA(fRequest, Info, @result, dwSize, dwIndex) then + result := 0; +end; + +function TWinINet.InternalQueryDataAvailable: DWORD; +begin + if not InternetQueryDataAvailable(fRequest, Result, 0, 0) then + raise EWinINet.Create; +end; + +function TWinINet.InternalReadData(var Data: SockString; Read: integer; + Size: cardinal): cardinal; +begin + if not InternetReadFile(fRequest, @PByteArray(Data)[Read], Size, result) then + raise EWinINet.Create; +end; + +procedure TWinINet.InternalCreateRequest(const aMethod,aURL: SockString); +const ALL_ACCEPT: array[0..1] of PAnsiChar = ('*/*',nil); + ACCEPT_TYPES: array[boolean] of PLPSTR = (@ALL_ACCEPT,nil); +var Flags: DWORD; +begin + Flags := INTERNET_FLAG_HYPERLINK or INTERNET_FLAG_PRAGMA_NOCACHE or + INTERNET_FLAG_RESYNCHRONIZE; // options for a true RESTful request + if fKeepAlive<>0 then + Flags := Flags or INTERNET_FLAG_KEEP_CONNECTION; + if fHttps then + Flags := Flags or INTERNET_FLAG_SECURE; + FRequest := HttpOpenRequestA(FConnection,Pointer(aMethod),Pointer(aURL), + nil,nil,ACCEPT_TYPES[fNoAllAccept],Flags,0); + if FRequest=nil then + raise EWinINet.Create; +end; + +procedure TWinINet.InternalSendRequest(const aMethod,aData: SockString); +var + buff: TInternetBuffersA; + datapos, datalen, max, Bytes, BytesWritten: DWORD; +begin + datalen := length(aData); + if (datalen>0) and Assigned(fOnUpload) then begin + FillChar(buff,SizeOf(buff),0); + buff.dwStructSize := SizeOf(buff); + buff.dwBufferTotal := Length(aData); + if not HttpSendRequestExA(fRequest,@buff,nil,0,0) then + raise EWinINet.Create; + datapos := 0; + while dataposmax then + Bytes := max; + if not InternetWriteFile(fRequest,@PByteArray(aData)[datapos],Bytes,BytesWritten) then + raise EWinINet.Create; + inc(datapos, BytesWritten); + if not fOnUpload(Self,datapos,datalen) then + raise EWinINet.CreateFmt('OnUpload Canceled %s',[aMethod]); + end; + if not HttpEndRequest(fRequest, nil, 0, 0) then + raise EWinINet.Create; + end else // blocking send with no callback + if not HttpSendRequestA(fRequest,nil,0,pointer(aData),length(aData)) then + raise EWinINet.Create; +end; + + +{ TWinHTTP } + +const + winhttpdll = 'winhttp.dll'; + + WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0; + WINHTTP_ACCESS_TYPE_NO_PROXY = 1; + WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3; + WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY = 4; // Windows 8.1 and newer + WINHTTP_FLAG_BYPASS_PROXY_CACHE = $00000100; // add "pragma: no-cache" request header + WINHTTP_FLAG_REFRESH = WINHTTP_FLAG_BYPASS_PROXY_CACHE; + WINHTTP_FLAG_SECURE = $00800000; // use SSL if applicable (HTTPS) + WINHTTP_ADDREQ_FLAG_COALESCE = $40000000; + WINHTTP_QUERY_FLAG_NUMBER = $20000000; + + // taken from http://www.tek-tips.com/faqs.cfm?fid=7493 + // status manifests for WinHttp status callback + WINHTTP_CALLBACK_STATUS_RESOLVING_NAME = $00000001; + WINHTTP_CALLBACK_STATUS_NAME_RESOLVED = $00000002; + WINHTTP_CALLBACK_STATUS_CONNECTING_TO_SERVER = $00000004; + WINHTTP_CALLBACK_STATUS_CONNECTED_TO_SERVER = $00000008; + WINHTTP_CALLBACK_STATUS_SENDING_REQUEST = $00000010; + WINHTTP_CALLBACK_STATUS_REQUEST_SENT = $00000020; + WINHTTP_CALLBACK_STATUS_RECEIVING_RESPONSE = $00000040; + WINHTTP_CALLBACK_STATUS_RESPONSE_RECEIVED = $00000080; + WINHTTP_CALLBACK_STATUS_CLOSING_CONNECTION = $00000100; + WINHTTP_CALLBACK_STATUS_CONNECTION_CLOSED = $00000200; + WINHTTP_CALLBACK_STATUS_HANDLE_CREATED = $00000400; + WINHTTP_CALLBACK_STATUS_HANDLE_CLOSING = $00000800; + WINHTTP_CALLBACK_STATUS_DETECTING_PROXY = $00001000; + WINHTTP_CALLBACK_STATUS_REDIRECT = $00004000; + WINHTTP_CALLBACK_STATUS_INTERMEDIATE_RESPONSE = $00008000; + WINHTTP_CALLBACK_STATUS_SECURE_FAILURE = $00010000; + WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE = $00020000; + WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE = $00040000; + WINHTTP_CALLBACK_STATUS_READ_COMPLETE = $00080000; + WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE = $00100000; + WINHTTP_CALLBACK_STATUS_REQUEST_ERROR = $00200000; + WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE = $00400000; + + WINHTTP_CALLBACK_FLAG_RESOLVE_NAME = + (WINHTTP_CALLBACK_STATUS_RESOLVING_NAME or WINHTTP_CALLBACK_STATUS_NAME_RESOLVED); + WINHTTP_CALLBACK_FLAG_CONNECT_TO_SERVER = + (WINHTTP_CALLBACK_STATUS_CONNECTING_TO_SERVER or + WINHTTP_CALLBACK_STATUS_CONNECTED_TO_SERVER); + WINHTTP_CALLBACK_FLAG_SEND_REQUEST = + (WINHTTP_CALLBACK_STATUS_SENDING_REQUEST or + WINHTTP_CALLBACK_STATUS_REQUEST_SENT); + WINHTTP_CALLBACK_FLAG_RECEIVE_RESPONSE = + (WINHTTP_CALLBACK_STATUS_RECEIVING_RESPONSE or + WINHTTP_CALLBACK_STATUS_RESPONSE_RECEIVED); + WINHTTP_CALLBACK_FLAG_CLOSE_CONNECTION = + (WINHTTP_CALLBACK_STATUS_CLOSING_CONNECTION or + WINHTTP_CALLBACK_STATUS_CONNECTION_CLOSED); + WINHTTP_CALLBACK_FLAG_HANDLES = + (WINHTTP_CALLBACK_STATUS_HANDLE_CREATED or + WINHTTP_CALLBACK_STATUS_HANDLE_CLOSING); + WINHTTP_CALLBACK_FLAG_DETECTING_PROXY = WINHTTP_CALLBACK_STATUS_DETECTING_PROXY; + WINHTTP_CALLBACK_FLAG_REDIRECT = WINHTTP_CALLBACK_STATUS_REDIRECT; + WINHTTP_CALLBACK_FLAG_INTERMEDIATE_RESPONSE = WINHTTP_CALLBACK_STATUS_INTERMEDIATE_RESPONSE; + WINHTTP_CALLBACK_FLAG_SECURE_FAILURE = WINHTTP_CALLBACK_STATUS_SECURE_FAILURE; + WINHTTP_CALLBACK_FLAG_SENDREQUEST_COMPLETE = WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE; + WINHTTP_CALLBACK_FLAG_HEADERS_AVAILABLE = WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE; + WINHTTP_CALLBACK_FLAG_DATA_AVAILABLE = WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE; + WINHTTP_CALLBACK_FLAG_READ_COMPLETE = WINHTTP_CALLBACK_STATUS_READ_COMPLETE; + WINHTTP_CALLBACK_FLAG_WRITE_COMPLETE = WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE; + WINHTTP_CALLBACK_FLAG_REQUEST_ERROR = WINHTTP_CALLBACK_STATUS_REQUEST_ERROR; + + WINHTTP_CALLBACK_FLAG_ALL_COMPLETIONS = + (WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE + or WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE + or WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE + or WINHTTP_CALLBACK_STATUS_READ_COMPLETE + or WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE + or WINHTTP_CALLBACK_STATUS_REQUEST_ERROR); + WINHTTP_CALLBACK_FLAG_ALL_NOTIFICATIONS = $ffffffff; + + WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 = $00000008; + WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 = $00000020; + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1 = $00000080; + // tls 1.1 & 1.2 const from here: + // https://github.com/nihon-tc/Rtest/blob/master/header/Microsoft%20SDKs/Windows/v7.0A/Include/winhttp.h + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 = $00000200; + WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2 = $00000800; + + // Sets an unsigned long integer value that specifies which secure protocols are acceptable. + // By default only SSL3 and TLS1 are enabled in Windows 7 and Windows 8. + // By default only SSL3, TLS1.0, TLS1.1, and TLS1.2 are enabled in Windows 8.1 and Windows 10. + WINHTTP_OPTION_SECURE_PROTOCOLS = 84; + // Instructs the stack to start a WebSocket handshake process with WinHttpSendRequest. + // This option takes no parameters. + WINHTTP_OPTION_UPGRADE_TO_WEB_SOCKET = 114; + + // if the following value is returned by WinHttpSetStatusCallback, then + // probably an invalid (non-code) address was supplied for the callback + WINHTTP_INVALID_STATUS_CALLBACK = -1; + + WINHTTP_OPTION_DISABLE_FEATURE = 63; + // values for WINHTTP_OPTION_DISABLE_FEATURE + WINHTTP_DISABLE_COOKIES = $00000001; + WINHTTP_DISABLE_REDIRECTS = $00000002; + WINHTTP_DISABLE_AUTHENTICATION = $00000004; + WINHTTP_DISABLE_KEEP_ALIVE = $00000008; + + WINHTTP_OPTION_ENABLE_FEATURE = 79; + // values for WINHTTP_OPTION_ENABLE_FEATURE + WINHTTP_ENABLE_SSL_REVOCATION = $00000001; + WINHTTP_ENABLE_SSL_REVERT_IMPERSONATION = $00000002; + +type + WINHTTP_STATUS_CALLBACK = procedure(hInternet: HINTERNET; dwContext: PDWORD; + dwInternetStatus: DWORD; lpvStatusInformation: pointer; dwStatusInformationLength: DWORD); stdcall; + PWINHTTP_STATUS_CALLBACK = ^WINHTTP_STATUS_CALLBACK; + + /// direct late-binding access to the WinHTTP API + // - note: WebSocket* API calls require Windows 8 and later + TWinHTTPBinding = packed record + /// access to the winhttp.dll loaded library + LibraryHandle: THandle; + /// depends on the published .dll functions + WebSocketEnabled: Boolean; + /// Initializes an application's use of the WinHTTP functions. + Open: function(pwszUserAgent: PWideChar; dwAccessType: DWORD; + pwszProxyName, pwszProxyBypass: PWideChar; dwFlags: DWORD): HINTERNET; stdcall; + /// Sets up a callback function that WinHTTP can call as progress is made during an operation. + SetStatusCallback: function(hSession: HINTERNET; + lpfnInternetCallback: WINHTTP_STATUS_CALLBACK; + dwNotificationFlags: DWORD; dwReserved: PDWORD): WINHTTP_STATUS_CALLBACK; stdcall; + /// Specifies the initial target server of an HTTP request. + Connect: function(hSession: HINTERNET; pswzServerName: PWideChar; + nServerPort: INTERNET_PORT; dwReserved: DWORD): HINTERNET; stdcall; + /// Creates an HTTP request handle. + OpenRequest: function(hConnect: HINTERNET; pwszVerb: PWideChar; + pwszObjectName: PWideChar; pwszVersion: PWideChar; pwszReferer: PWideChar; + ppwszAcceptTypes: PLPWSTR; dwFlags: DWORD): HINTERNET; stdcall; + /// Closes a single HINTERNET handle. + CloseHandle: function(hInternet: HINTERNET): BOOL; stdcall; + /// Adds one or more HTTP request headers to the HTTP request handle. + AddRequestHeaders: function(hRequest: HINTERNET; pwszHeaders: PWideChar; + dwHeadersLength: DWORD; dwModifiers: DWORD): BOOL; stdcall; + /// Sends the specified request to the HTTP server. + SendRequest: function(hRequest: HINTERNET; pwszHeaders: PWideChar; + dwHeadersLength: DWORD; lpOptional: Pointer; dwOptionalLength: DWORD; + dwTotalLength: DWORD; dwContext: DWORD): BOOL; stdcall; + /// Ends an HTTP request that is initiated by WinHttpSendRequest. + ReceiveResponse: function(hRequest: HINTERNET; + lpReserved: Pointer): BOOL; stdcall; + /// Retrieves header information associated with an HTTP request. + QueryHeaders: function(hRequest: HINTERNET; dwInfoLevel: DWORD; pwszName: PWideChar; + lpBuffer: Pointer; var lpdwBufferLength, lpdwIndex: DWORD): BOOL; stdcall; + /// Returns the amount of data, in bytes, available to be read with WinHttpReadData. + QueryDataAvailable: function(hRequest: HINTERNET; + var lpdwNumberOfBytesAvailable: DWORD): BOOL; stdcall; + /// Reads data from a handle opened by the WinHttpOpenRequest function. + ReadData: function(hRequest: HINTERNET; lpBuffer: Pointer; + dwNumberOfBytesToRead: DWORD; var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall; + /// Sets the various time-outs that are involved with HTTP transactions. + SetTimeouts: function(hInternet: HINTERNET; dwResolveTimeout: DWORD; + dwConnectTimeout: DWORD; dwSendTimeout: DWORD; dwReceiveTimeout: DWORD): BOOL; stdcall; + /// Sets an Internet option. + SetOption: function(hInternet: HINTERNET; dwOption: DWORD; + lpBuffer: Pointer; dwBufferLength: DWORD): BOOL; stdcall; + /// Passes the required authorization credentials to the server. + SetCredentials: function(hRequest: HINTERNET; AuthTargets: DWORD; AuthScheme: DWORD; + pwszUserName: PWideChar; pwszPassword: PWideChar; pAuthParams: Pointer) : BOOL; stdcall; + /// Completes a WebSocket handshake started by WinHttpSendRequest. + WebSocketCompleteUpgrade: function(hRequest: HINTERNET; + lpReserved: Pointer): HINTERNET; stdcall; + /// Closes a WebSocket connection. + WebSocketClose: function(hWebSocket: HINTERNET; usStatus: Word; + pvReason: Pointer; dwReasonLength: DWORD): DWORD; stdcall; + /// Retrieves the close status sent by a server + WebSocketQueryCloseStatus: function(hWebSocket: HINTERNET; out usStatus: Word; + pvReason: Pointer; dwReasonLength: DWORD; out dwReasonLengthConsumed: DWORD): DWORD; stdcall; + /// Sends data over a WebSocket connection. + WebSocketSend: function(hWebSocket: HINTERNET; eBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; + pvBuffer: Pointer; dwBufferLength: DWORD): DWORD; stdcall; + /// Receives data from a WebSocket connection. + WebSocketReceive: function(hWebSocket: HINTERNET; pvBuffer: Pointer; dwBufferLength: DWORD; + out dwBytesRead: DWORD; out eBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; stdcall; + /// Writes data to a handle opened by the WinHttpOpenRequest function. + WriteData: function(hRequest: HINTERNET; lpBuffer: Pointer; + dwNumberOfBytesToWrite: DWORD; var lpdwNumberOfBytesWritten: DWORD): BOOL; stdcall; + end; + +var + WinHttpAPI: TWinHTTPBinding; + +type + TWinHttpAPIs = (hOpen, hSetStatusCallback, hConnect, + hOpenRequest, hCloseHandle, hAddRequestHeaders, + hSendRequest, hReceiveResponse, hQueryHeaders, + hQueryDataAvailable, hReadData, hSetTimeouts, hSetOption, hSetCredentials, + hWebSocketCompleteUpgrade, hWebSocketClose, hWebSocketQueryCloseStatus, + hWebSocketSend, hWebSocketReceive, hWriteData); +const + hWebSocketApiFirst = hWebSocketCompleteUpgrade; + +const + WinHttpNames: array[TWinHttpAPIs] of PChar = ( + 'WinHttpOpen', 'WinHttpSetStatusCallback', 'WinHttpConnect', + 'WinHttpOpenRequest', 'WinHttpCloseHandle', 'WinHttpAddRequestHeaders', + 'WinHttpSendRequest', 'WinHttpReceiveResponse', 'WinHttpQueryHeaders', + 'WinHttpQueryDataAvailable', 'WinHttpReadData', 'WinHttpSetTimeouts', + 'WinHttpSetOption', 'WinHttpSetCredentials', + 'WinHttpWebSocketCompleteUpgrade', 'WinHttpWebSocketClose', + 'WinHttpWebSocketQueryCloseStatus', 'WinHttpWebSocketSend', + 'WinHttpWebSocketReceive', 'WinHttpWriteData'); + +procedure WinHttpAPIInitialize; +var api: TWinHttpAPIs; + P: PPointer; +begin + if WinHttpAPI.LibraryHandle<>0 then + exit; // already loaded + WinHttpAPI.LibraryHandle := SafeLoadLibrary(winhttpdll); + WinHttpAPI.WebSocketEnabled := true; // WebSocketEnabled if all functions are available + if WinHttpAPI.LibraryHandle=0 then + raise ECrtSocket.CreateFmt('Unable to load library %s',[winhttpdll]); + P := @@WinHttpAPI.Open; + for api := low(api) to high(api) do begin + P^ := GetProcAddress(WinHttpAPI.LibraryHandle,WinHttpNames[api]); + if P^=nil then + if apinil then + WinHttpAPI.CloseHandle(fConnection); + if fSession<>nil then + WinHttpAPI.CloseHandle(fSession); + inherited; +end; + +procedure TWinHTTP.InternalAddHeader(const hdr: SockString); +begin + if (hdr<>'') and not WinHttpAPI.AddRequestHeaders( + FRequest, Pointer(Ansi7ToUnicode(hdr)), length(hdr), WINHTTP_ADDREQ_FLAG_COALESCE) then + RaiseLastModuleError(winhttpdll,EWinHTTP); +end; + +procedure TWinHTTP.InternalCloseRequest; +begin + if fRequest<>nil then begin + WinHttpAPI.CloseHandle(fRequest); + FRequest := nil; + end; +end; + +procedure WinHTTPSecurityErrorCallback(hInternet: HINTERNET; dwContext: PDWORD; + dwInternetStatus: DWORD; lpvStatusInformation: pointer; dwStatusInformationLength: DWORD); stdcall; +var err: string; + code: DWORD; +begin + code := PDWORD(lpvStatusInformation)^; + if code and $00000001<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_REV_FAILED'; + if code and $00000002<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CERT'; + if code and $00000004<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_REVOKED'; + if code and $00000008<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CA'; + if code and $00000010<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_CN_INVALID'; + if code and $00000020<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_DATE_INVALID'; + if code and $00000040<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_WRONG_USAGE'; + if code and $80000000<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_SECURITY_CHANNEL_ERROR'; + // in case lpvStatusInformation^=-2147483648 this is attempt to connect to + // non-https socket wrong port - perhaps must be 443? + raise EWinHTTP.CreateFmt('WinHTTP security error. Status %d, StatusInfo: %d ($%x%s)', + [dwInternetStatus, code, code, err]); +end; + +{$ifndef UNICODE} +type + /// not defined in older Delphi versions + TOSVersionInfoEx = record + dwOSVersionInfoSize: DWORD; + dwMajorVersion: DWORD; + dwMinorVersion: DWORD; + dwBuildNumber: DWORD; + dwPlatformId: DWORD; + szCSDVersion: array[0..127] of char; + wServicePackMajor: WORD; + wServicePackMinor: WORD; + wSuiteMask: WORD; + wProductType: BYTE; + wReserved: BYTE; + end; +function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; + external kernel32 name 'GetVersionExA'; +{$endif} + +var // raw OS call, to avoid dependency to SynCommons.pas unit + OSVersionInfo: TOSVersionInfoEx; + +function TWinHTTP.InternalGetProtocols: cardinal; +begin + // WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 and WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 + // are unsafe, disabled at Windows level, therefore never supplied + result := WINHTTP_FLAG_SECURE_PROTOCOL_TLS1; + // Windows 7 and newer support TLS 1.1 & 1.2 + if (OSVersionInfo.dwMajorVersion>6) or + ((OSVersionInfo.dwMajorVersion=6) and (OSVersionInfo.dwMinorVersion>=1)) then + result := result or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 + or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2; +end; + +procedure TWinHTTP.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); +var OpenType: integer; + Callback: WINHTTP_STATUS_CALLBACK; + CallbackRes: PtrInt absolute Callback; // for FPC compatibility + protocols: DWORD; +begin + if fProxyName='' then + if (OSVersionInfo.dwMajorVersion>6) or + ((OSVersionInfo.dwMajorVersion=6) and (OSVersionInfo.dwMinorVersion>=3)) then + OpenType := WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY else // Windows 8.1 and newer + OpenType := WINHTTP_ACCESS_TYPE_NO_PROXY else + OpenType := WINHTTP_ACCESS_TYPE_NAMED_PROXY; + fSession := WinHttpAPI.Open(pointer(Ansi7ToUnicode(fExtendedOptions.UserAgent)), + OpenType, pointer(Ansi7ToUnicode(fProxyName)), pointer(Ansi7ToUnicode(fProxyByPass)), 0); + if fSession=nil then + RaiseLastModuleError(winhttpdll,EWinHTTP); + // cf. http://msdn.microsoft.com/en-us/library/windows/desktop/aa384116 + if not WinHttpAPI.SetTimeouts(fSession,HTTP_DEFAULT_RESOLVETIMEOUT, + ConnectionTimeOut,SendTimeout,ReceiveTimeout) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + if fHTTPS then begin + protocols := InternalGetProtocols; + if not WinHttpAPI.SetOption(fSession, WINHTTP_OPTION_SECURE_PROTOCOLS, + @protocols, SizeOf(protocols)) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + Callback := WinHttpAPI.SetStatusCallback(fSession, WinHTTPSecurityErrorCallback, + WINHTTP_CALLBACK_FLAG_SECURE_FAILURE, nil); + if CallbackRes=WINHTTP_INVALID_STATUS_CALLBACK then + RaiseLastModuleError(winhttpdll,EWinHTTP); + end; + fConnection := WinHttpAPI.Connect(fSession, pointer(Ansi7ToUnicode(FServer)), fPort, 0); + if fConnection=nil then + RaiseLastModuleError(winhttpdll,EWinHTTP); +end; + +function TWinHTTP.InternalGetInfo(Info: DWORD): SockString; +var dwSize, dwIndex: DWORD; + tmp: SockString; + i: integer; +begin + result := ''; + dwSize := 0; + dwIndex := 0; + if not WinHttpAPI.QueryHeaders(fRequest, Info, nil, nil, dwSize, dwIndex) and + (GetLastError=ERROR_INSUFFICIENT_BUFFER) then begin + SetLength(tmp,dwSize); + if WinHttpAPI.QueryHeaders(fRequest, Info, nil, pointer(tmp), dwSize, dwIndex) then begin + dwSize := dwSize shr 1; + SetLength(result,dwSize); + for i := 0 to dwSize-1 do // fast ANSI 7 bit conversion + PByteArray(result)^[i] := PWordArray(tmp)^[i]; + end; + end; +end; + +function TWinHTTP.InternalGetInfo32(Info: DWORD): DWORD; +var dwSize, dwIndex: DWORD; +begin + dwSize := sizeof(result); + dwIndex := 0; + Info := Info or WINHTTP_QUERY_FLAG_NUMBER; + if not WinHttpAPI.QueryHeaders(fRequest, Info, nil, @result, dwSize, dwIndex) then + result := 0; +end; + +function TWinHTTP.InternalQueryDataAvailable: DWORD; +begin + if not WinHttpAPI.QueryDataAvailable(fRequest, result) then + RaiseLastModuleError(winhttpdll,EWinHTTP); +end; + +function TWinHTTP.InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; +begin + if not WinHttpAPI.ReadData(fRequest, @PByteArray(Data)[Read], Size, result) then + RaiseLastModuleError(winhttpdll,EWinHTTP); +end; + +procedure TWinHTTP.InternalCreateRequest(const aMethod,aURL: SockString); +const ALL_ACCEPT: array[0..1] of PWideChar = ('*/*',nil); + ACCEPT_TYPES: array[boolean] of PLPWSTR = (@ALL_ACCEPT,nil); +var Flags: DWORD; +begin + Flags := WINHTTP_FLAG_REFRESH; // options for a true RESTful request + if fHttps then + Flags := Flags or WINHTTP_FLAG_SECURE; + fRequest := WinHttpAPI.OpenRequest(fConnection,pointer(Ansi7ToUnicode(aMethod)), + pointer(Ansi7ToUnicode(aURL)),nil,nil,ACCEPT_TYPES[fNoAllAccept],Flags); + if fRequest=nil then + RaiseLastModuleError(winhttpdll,EWinHTTP); + if fKeepAlive = 0 then begin + Flags := WINHTTP_DISABLE_KEEP_ALIVE; + if not WinHttpAPI.SetOption(fRequest, WINHTTP_OPTION_DISABLE_FEATURE, @Flags, sizeOf(Flags)) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + end; +end; + +const + // from http://www.tek-tips.com/faqs.cfm?fid=7493 + WINHTTP_OPTION_SECURITY_FLAGS = 31; + WINHTTP_OPTION_CLIENT_CERT_CONTEXT = $0000002F; + WINHTTP_NO_CLIENT_CERT_CONTEXT = $00000000; + ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED = $00002F0C; + SECURITY_FLAG_IGNORE_UNKNOWN_CA = $00000100; + SECURITY_FLAG_IGNORE_CERT_DATE_INVALID = $00002000; // expired X509 Cert. + SECURITY_FLAG_IGNORE_CERT_CN_INVALID = $00001000; // bad common name in X509 Cert. + SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE = $00000200; + SECURITY_FLAT_IGNORE_CERTIFICATES: DWORD = + SECURITY_FLAG_IGNORE_UNKNOWN_CA or + SECURITY_FLAG_IGNORE_CERT_DATE_INVALID or + SECURITY_FLAG_IGNORE_CERT_CN_INVALID or + SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE; + + WINHTTP_AUTH_TARGET_SERVER = 0; + WINHTTP_AUTH_TARGET_PROXY = 1; + WINHTTP_AUTH_SCHEME_BASIC = $00000001; + WINHTTP_AUTH_SCHEME_NTLM = $00000002; + WINHTTP_AUTH_SCHEME_PASSPORT = $00000004; + WINHTTP_AUTH_SCHEME_DIGEST = $00000008; + WINHTTP_AUTH_SCHEME_NEGOTIATE = $00000010; + +procedure TWinHTTP.InternalSendRequest(const aMethod,aData: SockString); + + function _SendRequest(L: DWORD): Boolean; + var Bytes, Current, Max, BytesWritten: DWORD; + begin + if Assigned(fOnUpload) and + (SameText(aMethod,'POST') or SameText(aMethod,'PUT')) then begin + result := WinHttpAPI.SendRequest(fRequest,nil,0,nil,0,L,0); + if result then begin + Current := 0; + while CurrentMax then + Bytes := Max; + if not WinHttpAPI.WriteData(fRequest, @PByteArray(aData)[Current],Bytes,BytesWritten) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + inc(Current,BytesWritten); + if not fOnUpload(Self,Current,L) then + raise EWinHTTP.CreateFmt('OnUpload Canceled %s',[aMethod]); + end; + end; + end else + result := WinHttpAPI.SendRequest(fRequest,nil,0,pointer(aData),L,L,0); + end; + +var L: integer; + winAuth: DWORD; +begin + with fExtendedOptions do + if AuthScheme<>wraNone then begin + case AuthScheme of + wraBasic: winAuth := WINHTTP_AUTH_SCHEME_BASIC; + wraDigest: winAuth := WINHTTP_AUTH_SCHEME_DIGEST; + wraNegotiate: winAuth := WINHTTP_AUTH_SCHEME_NEGOTIATE; + else raise EWinHTTP.CreateFmt('Unsupported AuthScheme=%d',[ord(AuthScheme)]); + end; + if not WinHttpAPI.SetCredentials(fRequest,WINHTTP_AUTH_TARGET_SERVER, + winAuth,pointer(AuthUserName),pointer(AuthPassword),nil) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + end; + if fHTTPS and IgnoreSSLCertificateErrors then + if not WinHttpAPI.SetOption(fRequest, WINHTTP_OPTION_SECURITY_FLAGS, + @SECURITY_FLAT_IGNORE_CERTIFICATES, SizeOf(SECURITY_FLAT_IGNORE_CERTIFICATES)) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + L := length(aData); + if not _SendRequest(L) or + not WinHttpAPI.ReceiveResponse(fRequest,nil) then + if fHTTPS and (GetLastError=ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED) and + IgnoreSSLCertificateErrors then begin + if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_SECURITY_FLAGS, + @SECURITY_FLAT_IGNORE_CERTIFICATES,SizeOf(SECURITY_FLAT_IGNORE_CERTIFICATES)) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_CLIENT_CERT_CONTEXT, + pointer(WINHTTP_NO_CLIENT_CERT_CONTEXT),0) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + if not _SendRequest(L) or + not WinHttpAPI.ReceiveResponse(fRequest,nil) then + RaiseLastModuleError(winhttpdll,EWinHTTP); + end + else RaiseLastModuleError(winhttpdll,EWinHTTP); +end; + + +{ TWinHTTPUpgradeable } + +constructor TWinHTTPUpgradeable.Create(const aServer, aPort: SockString; + aHttps: boolean; const aProxyName, aProxyByPass: SockString; + ConnectionTimeOut, SendTimeout, ReceiveTimeout: DWORD; + aLayer: TCrtSocketLayer); +begin + inherited; + fSocket := nil; +end; + +function TWinHTTPUpgradeable.InternalRetrieveAnswer(var Header, Encoding, + AcceptEncoding, Data: SockString): integer; +begin + result := inherited InternalRetrieveAnswer(Header, Encoding, AcceptEncoding, Data); + fSocket := WinHttpAPI.WebSocketCompleteUpgrade(fRequest, nil); + if fSocket=nil then + raise EWinHTTP.Create('Error upgrading socket'); +end; + +procedure TWinHTTPUpgradeable.InternalSendRequest(const aMethod,aData: SockString); +begin + if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_UPGRADE_TO_WEB_SOCKET,nil,0) then + raise EWinHTTP.Create('Error upgrading socket'); + inherited; +end; + + +{ TWinHTTPWinSocketClient } + +function TWinHTTPWebSocketClient.CheckSocket: Boolean; +begin + result := fSocket <> nil; +end; + +function TWinHTTPWebSocketClient.CloseConnection(const aCloseReason: SockString): DWORD; +begin + if not CheckSocket then + result := ERROR_INVALID_HANDLE else + result := WinHttpAPI.WebSocketClose(fSocket, WEB_SOCKET_SUCCESS_CLOSE_STATUS, Pointer(aCloseReason), Length(aCloseReason)); + if (Result = NO_ERROR) then + fSocket := nil; +end; + +constructor TWinHTTPWebSocketClient.Create(const aServer, aPort: SockString; + aHttps: boolean; const url, aSubProtocol, aProxyName, aProxyByPass: SockString; + ConnectionTimeOut, SendTimeout, ReceiveTimeout: DWORD); +var _http: TWinHTTPUpgradeable; + inH, outH, outD: SockString; +begin + fSocket := nil; + _http := TWinHTTPUpgradeable.Create(aServer, aPort, aHttps, aProxyName, aProxyByPass, + ConnectionTimeOut, SendTimeout, ReceiveTimeout); + try + // WebSocketAPI.BeginClientHandshake() + if aSubProtocol <> '' then + inH := sProtocolHeader + ': '+aSubProtocol else + inH := ''; + if _http.Request(url, 'GET', 0, inH, '', '', outH, outD) = 101 then + fSocket := _http.fSocket else + raise ECrtSocket.Create('WebSocketClient creation fail'); + finally + _http.Free; + end; +end; + +destructor TWinHTTPWebSocketClient.Destroy; +const CloseReason: SockString = 'object is destroyed'; +var status: Word; + reason: SockString; + reasonLength: DWORD; +begin + if CheckSocket then begin // todo: check result + WinHttpAPI.WebSocketClose(fSocket, WEB_SOCKET_ABORTED_CLOSE_STATUS, Pointer(CloseReason), Length(CloseReason)); + SetLength(reason, WEB_SOCKET_MAX_CLOSE_REASON_LENGTH); + WinHttpAPI.WebSocketQueryCloseStatus(fSocket, status, Pointer(reason), + WEB_SOCKET_MAX_CLOSE_REASON_LENGTH, reasonLength); + WinHttpAPI.CloseHandle(fSocket); + end; + inherited; +end; + +function TWinHTTPWebSocketClient.Receive(aBuffer: pointer; aBufferLength: DWORD; out aBytesRead: DWORD; out aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; +begin + if not CheckSocket then + result := ERROR_INVALID_HANDLE else + result := WinHttpAPI.WebSocketReceive(fSocket, aBuffer, aBufferLength, aBytesRead, aBufferType); +end; + +function TWinHTTPWebSocketClient.Send(aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; + aBuffer: pointer; aBufferLength: DWORD): DWORD; +begin + if not CheckSocket then + result := ERROR_INVALID_HANDLE else + result := WinHttpAPI.WebSocketSend(fSocket, aBufferType, aBuffer, aBufferLength); +end; +{$endif USEWININET} + +{$ifdef USELIBCURL} + +{ ************ libcurl implementation } + +{ TCurlHTTP } + +procedure TCurlHTTP.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); +const HTTPS: array[boolean] of string = ('','s'); +begin + if not IsAvailable then + raise ECrtSocket.CreateFmt('No available %s',[LIBCURL_DLL]); + fHandle := curl.easy_init; + if curl.globalShare <> nil then + curl.easy_setopt(fHandle,coShare,curl.globalShare); + curl.easy_setopt(fHandle,coConnectTimeoutMs,ConnectionTimeOut); // default=300 ! + if SendTimeout0 then // prevent send+receive forever + curl.easy_setopt(fHandle,coTimeoutMs,SendTimeout); + if fLayer=cslUNIX then + fRootURL := 'http://localhost' else // see CURLOPT_UNIX_SOCKET_PATH doc + fRootURL := AnsiString(Format('http%s://%s:%d',[HTTPS[fHttps],fServer,fPort])); +end; + +destructor TCurlHTTP.Destroy; +begin + if fHandle<>nil then + curl.easy_cleanup(fHandle); + inherited; +end; + +function TCurlHTTP.GetCACertFile: SockString; +begin + Result := fSSL.CACertFile; +end; + +procedure TCurlHTTP.SetCACertFile(const aCertFile: SockString); +begin + fSSL.CACertFile := aCertFile; +end; + +procedure TCurlHTTP.UseClientCertificate( + const aCertFile, aCACertFile, aKeyName, aPassPhrase: SockString); +begin + fSSL.CertFile := aCertFile; + fSSL.CACertFile := aCACertFile; + fSSL.KeyName := aKeyName; + fSSL.PassPhrase := aPassPhrase; +end; + +procedure TCurlHTTP.InternalCreateRequest(const aMethod,aURL: SockString); +const CERT_PEM: SockString = 'PEM'; +begin + fIn.URL := fRootURL+aURL; + curl.easy_setopt(fHandle,coFollowLocation,1); // url redirection (as TWinHTTP) + //curl.easy_setopt(fHandle,coTCPNoDelay,0); // disable Nagle + if fLayer=cslUNIX then + curl.easy_setopt(fHandle,coUnixSocketPath,pointer(fServer)); + curl.easy_setopt(fHandle,coURL,pointer(fIn.URL)); + if fProxyName<>'' then + curl.easy_setopt(fHandle,coProxy,pointer(fProxyName)); + if fHttps then + if IgnoreSSLCertificateErrors then begin + curl.easy_setopt(fHandle,coSSLVerifyPeer,0); + curl.easy_setopt(fHandle,coSSLVerifyHost,0); + //curl.easy_setopt(fHandle,coProxySSLVerifyPeer,0); + //curl.easy_setopt(fHandle,coProxySSLVerifyHost,0); + end else begin + // see https://curl.haxx.se/libcurl/c/simplessl.html + if fSSL.CertFile<>'' then begin + curl.easy_setopt(fHandle,coSSLCertType,pointer(CERT_PEM)); + curl.easy_setopt(fHandle,coSSLCert,pointer(fSSL.CertFile)); + if fSSL.PassPhrase<>'' then + curl.easy_setopt(fHandle,coSSLCertPasswd,pointer(fSSL.PassPhrase)); + curl.easy_setopt(fHandle,coSSLKeyType,nil); + curl.easy_setopt(fHandle,coSSLKey,pointer(fSSL.KeyName)); + curl.easy_setopt(fHandle,coCAInfo,pointer(fSSL.CACertFile)); + curl.easy_setopt(fHandle,coSSLVerifyPeer,1); + end + else if fSSL.CACertFile<>'' then + curl.easy_setopt(fHandle,coCAInfo,pointer(fSSL.CACertFile)); + end; + curl.easy_setopt(fHandle,coUserAgent,pointer(fExtendedOptions.UserAgent)); + curl.easy_setopt(fHandle,coWriteFunction,@CurlWriteRawByteString); + curl.easy_setopt(fHandle,coHeaderFunction,@CurlWriteRawByteString); + fIn.Method := UpperCase(aMethod); + if fIn.Method = '' then + fIn.Method := 'GET'; + if fIn.Method = 'GET' then + fIn.Headers := nil else // disable Expect 100 continue in libcurl + fIn.Headers := curl.slist_append(nil,'Expect:'); + Finalize(fOut); +end; + +procedure TCurlHTTP.InternalAddHeader(const hdr: SockString); +var P: PAnsiChar; + s: SockString; +begin + P := pointer(hdr); + while P<>nil do begin + GetNextLine(P,s); + if s<>'' then // nil would reset the whole list + fIn.Headers := curl.slist_append(fIn.Headers,pointer(s)); + end; +end; + +class function TCurlHTTP.IsAvailable: boolean; +begin + Result := CurlIsAvailable; +end; + +procedure TCurlHTTP.InternalSendRequest(const aMethod,aData: SockString); +begin // see http://curl.haxx.se/libcurl/c/CURLOPT_CUSTOMREQUEST.html + if fIn.Method='HEAD' then // the only verb what do not expect body in answer is HEAD + curl.easy_setopt(fHandle,coNoBody,1) else + curl.easy_setopt(fHandle,coNoBody,0); + curl.easy_setopt(fHandle,coCustomRequest,pointer(fIn.Method)); + curl.easy_setopt(fHandle,coPostFields,pointer(aData)); + curl.easy_setopt(fHandle,coPostFieldSize,length(aData)); + curl.easy_setopt(fHandle,coHTTPHeader,fIn.Headers); + curl.easy_setopt(fHandle,coFile,@fOut.Data); + curl.easy_setopt(fHandle,coWriteHeader,@fOut.Header); +end; + +function TCurlHTTP.InternalRetrieveAnswer(var Header, Encoding, AcceptEncoding, + Data: SockString): integer; +var res: TCurlResult; + P: PAnsiChar; + s: SockString; + i: integer; + rc: longint; // needed on Linux x86-64 +begin + res := curl.easy_perform(fHandle); + if res<>crOK then + raise ECurlHTTP.CreateFmt('libcurl error %d (%s) on %s %s', + [ord(res), curl.easy_strerror(res), fIn.Method, fIn.URL]); + rc := 0; + curl.easy_getinfo(fHandle,ciResponseCode,rc); + result := rc; + Header := Trim(fOut.Header); + if IdemPChar(pointer(Header),'HTTP/') then begin + i := 6; + while Header[i]>=' ' do inc(i); + while ord(Header[i]) in [10,13] do inc(i); + system.Delete(Header,1,i-1); // trim leading 'HTTP/1.1 200 OK'#$D#$A + end; + P := pointer(Header); + while P<>nil do begin + GetNextLine(P,s); + if IdemPChar(pointer(s),'ACCEPT-ENCODING:') then + trimcopy(s,17,100,AcceptEncoding) else + if IdemPChar(pointer(s),'CONTENT-ENCODING:') then + trimcopy(s,18,100,Encoding); + end; + Data := fOut.Data; +end; + +procedure TCurlHTTP.InternalCloseRequest; +begin + if fIn.Headers<>nil then begin + curl.slist_free_all(fIn.Headers); + fIn.Headers := nil; + end; + Finalize(fIn); + fIn.DataOffset := 0; + Finalize(fOut); +end; + +{$endif USELIBCURL} + + +{ TSimpleHttpClient } + +constructor TSimpleHttpClient.Create(aOnlyUseClientSocket: boolean); +begin + fOnlyUseClientSocket := aOnlyUseClientSocket; + inherited Create; +end; + +destructor TSimpleHttpClient.Destroy; +begin + FreeAndNil(fHttp); + FreeAndNil(fHttps); + inherited Destroy; +end; + +function TSimpleHttpClient.RawRequest(const Uri: TURI; const Method, Header, + Data, DataType: SockString; KeepAlive: cardinal): integer; +begin + result := 0; + if (Uri.Https or (Proxy <> '')) and not fOnlyUseClientSocket then + try + if (fHttps = nil) or (fHttps.Server <> Uri.Server) or + (integer(fHttps.Port) <> Uri.PortInt) then begin + FreeAndNil(fHttp); + FreeAndNil(fHttps); // need a new HTTPS connection + fHttps := MainHttpClass.Create(Uri.Server,Uri.Port,Uri.Https,Proxy,'',5000,5000,5000); + fHttps.IgnoreSSLCertificateErrors := fIgnoreSSLCertificateErrors; + if fUserAgent<>'' then + fHttps.UserAgent := fUserAgent; + end; + result := fHttps.Request(Uri.Address,Method,KeepAlive, + header,data,datatype,fHeaders,fBody); + if KeepAlive = 0 then + FreeAndNil(fHttps); + except + FreeAndNil(fHttps); + end + else + try + if (fHttp = nil) or (fHttp.Server <> Uri.Server) or + (fHttp.Port <> Uri.Port) or (connectionClose in fHttp.HeaderFlags) then begin + FreeAndNil(fHttps); + FreeAndNil(fHttp); // need a new HTTP connection + fHttp := THttpClientSocket.Open(Uri.Server,Uri.Port,cslTCP,5000,Uri.Https); + if fUserAgent<>'' then + fHttp.UserAgent := fUserAgent; + end; + if not fHttp.SockConnected then + exit else + result := fHttp.Request(Uri.Address,Method,KeepAlive,header,data,datatype,true); + fBody := fHttp.Content; + fHeaders := fHttp.HeaderGetText; + if KeepAlive = 0 then + FreeAndNil(fHttp); + except + FreeAndNil(fHttp); + end; +end; + +function TSimpleHttpClient.Request(const uri,method,header,data,datatype: SockString; + keepalive: cardinal): integer; +var u: TURI; +begin + if u.From(uri) then + result := RawRequest(u,method,header,data,datatype,keepalive) else + result := STATUS_NOTFOUND; +end; + + +{ ************ socket polling for optimized multiple connections } + +{ TPollSocketAbstract } + +{.$define USEWSAPOLL} +// you may try it - but seems slightly SLOWER under Windows 7 + +function PollSocketClass: TPollSocketClass; +begin +{$ifdef LINUXNOTBSD} + result := TPollSocketEpoll; // the preferred way for our purpose +{$else} + {$ifdef MSWINDOWS} + {$ifdef USEWSAPOLL} + if Win32MajorVersion>=6 then // WSAPoll() not available before Vista + result := TPollSocketPoll else + {$endif USEWSAPOLL} + result := TPollSocketSelect; // Select() is FASTER than WSAPoll() :( + {$else} + result := TPollSocketPoll; // available on all POSIX systems + {$endif MSWINDOWS} +{$endif LINUXNOTBSD} +end; + +constructor TPollSocketAbstract.Create; +begin + inherited Create; +end; + +class function TPollSocketAbstract.New: TPollSocketAbstract; +begin + result := PollSocketClass.Create; +end; + + +{$ifdef MSWINDOWS} + +{ TPollSocketSelect } + +constructor TPollSocketSelect.Create; +begin + inherited Create; + fMaxSockets := FD_SETSIZE; // 64 +end; + +function TPollSocketSelect.Subscribe(socket: TSocket; + events: TPollSocketEvents; tag: TPollSocketTag): boolean; +begin + result := false; + if (self=nil) or (socket=0) or (byte(events)=0) or (fCount=fMaxSockets) then + exit; + if pseRead in events then + FD_SET(socket, fRead); + if pseWrite in events then + FD_SET(socket, fWrite); + fTag[fCount].socket := socket; + fTag[fCount].tag := tag; + inc(fCount); + if socket>fHighestSocket then + fHighestSocket := socket; + result := true; +end; + +function TPollSocketSelect.Unsubscribe(socket: TSocket): boolean; +var i: integer; +begin + result := false; + if (self<>nil) and (socket<>0) then + for i := 0 to fCount-1 do + if fTag[i].socket=socket then begin + FD_CLR(socket,fRead); + FD_CLR(socket,fWrite); + dec(fCount); + if i0 then begin + rd := fRead; + rdp := @rd; + end else + rdp := nil; + if fWrite.fd_count>0 then begin + wr := fWrite; + wrp := @wr; + end else + wrp := nil; + tv.tv_sec := timeoutMS div 1000; + tv.tv_usec := (timeoutMS mod 1000)*1000; + result := Select(fHighestSocket+1,rdp,wrp,nil,@tv); + if result<=0 then + exit; + result := 0; + for i := 0 to fCount-1 do + with fTag[i] do begin + byte(ev) := 0; + if (rdp<>nil) and FD_ISSET(socket,rd) then begin + if (IoctlSocket(socket,FIONREAD,pending)=0) and (pending=0) then + // socket closed gracefully - see TCrtSocket.SockReceivePending + include(ev,pseClosed) else + include(ev,pseRead); + end; + if (wrp<>nil) and FD_ISSET(socket,wr) then + include(ev,pseWrite); + if byte(ev)<>0 then begin + tmp[result].events := ev; + tmp[result].tag := tag; + inc(result); + end; + end; + SetLength(results,result); + move(tmp,results[0],result*sizeof(tmp[0])); +end; + +{$endif MSWINDOWS} + + +{ TPollSocketPoll } + +constructor TPollSocketPoll.Create; +begin + inherited Create; + {$ifdef MSWINDOWS} // some practical values + fMaxSockets := 1024; + {$else} + fMaxSockets := 20000; + {$endif} +end; + +function TPollSocketPoll.Subscribe(socket: TSocket; + events: TPollSocketEvents; tag: TPollSocketTag): boolean; +var i, n, e, fd: integer; +begin + result := false; + if (self=nil) or (socket=0) or (byte(events)=0) or (fCount=fMaxSockets) then + exit; + if pseRead in events then + e := POLLIN else + e := 0; + if pseWrite in events then + e := e or POLLOUT; + if fFDCount=fCount then begin // no void entry + for i := 0 to fFDCount-1 do + if fFD[i].fd=socket then // already subscribed + exit; + end else + for i := 0 to fFDCount-1 do begin + fd := fFD[i].fd; + if fd=socket then // already subscribed + exit else + if fd<0 then begin // found void entry + fTags[i] := tag; + with fFD[i] do begin + fd := socket; + events := e; + revents := 0; + end; + inc(fCount); + result := true; + exit; + end; + end; + if fFDCount=length(fFD) then begin // add new entry to the array + n := fFDCount+128+fFDCount shr 3; + if n>fMaxSockets then + n := fMaxSockets; + SetLength(fFD,n); + SetLength(fTags,n); + end; + with fFD[fFDCount] do begin + fd := socket; + events := e; + revents := 0; + end; + fTags[fFDCount] := tag; + inc(fFDCount); + inc(fCount); + result := true; +end; + +procedure TPollSocketPoll.FDVacuum; +var n, i: integer; +begin + n := 0; + for i := 0 to fFDCount-1 do + if fFD[i].fd>0 then begin + if i<>n then begin + fFD[n] := fFD[i]; + fTags[n] := fTags[i]; + end; + inc(n); + end; + fFDCount := n; +end; + +function TPollSocketPoll.Unsubscribe(socket: TSocket): boolean; +var i: integer; +begin + for i := 0 to fFDCount-1 do + if fFD[i].fd=socket then begin + fFD[i].fd := -1; // mark entry as void + dec(fCount); + if fCount<=fFDCount shr 1 then + FDVacuum; // avoid too many void entries + result := true; + exit; + end; + result := false; +end; + +function TPollSocketPoll.WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; +var e: TPollSocketEvents; + i, ev, d: integer; +begin + result := -1; // error + if (self=nil) or (fCount=0) then + exit; + result := poll(pointer(fFD),fFDCount,timeoutMS); + if result<=0 then + exit; + SetLength(results,result); + d := 0; + for i := 0 to fFDCount-1 do + if fFD[i].fd>0 then begin + ev := fFD[i].revents; + if ev<>0 then begin + byte(e) := 0; + if ev and POLLIN<>0 then + include(e,pseRead); + if ev and POLLOUT<>0 then + include(e,pseWrite); + if ev and POLLERR<>0 then + include(e,pseError); + if ev and POLLHUP<>0 then + include(e,pseClosed); + results[d].events := e; + results[d].tag := fTags[i]; + inc(d); + fFD[i].revents := 0; // reset result flags for reuse + end; + end; + if d<>result then + raise ECrtSocket.CreateFmt('TPollSocketPoll: result=%d d=%d',[result,d]); +end; + + +{$ifdef LINUXNOTBSD} + +{ TPollSocketEpoll } + +constructor TPollSocketEpoll.Create; +begin + inherited Create; + fEPFD := epoll_create($cafe); + fMaxSockets := 20000; + SetLength(fResults,fMaxSockets); +end; + +destructor TPollSocketEpoll.Destroy; +begin + epoll_close(fEPFD); + inherited; +end; + +function TPollSocketEpoll.Subscribe(socket: TSocket; events: TPollSocketEvents; + tag: TPollSocketTag): boolean; +var e: TEPollEvent; +begin + result := false; + if (self=nil) or (socket=0) or (socket=fEPFD) or + (byte(events)=0) or (fCount=fMaxSockets) then + exit; + e.data.ptr := pointer(tag); + if pseRead in events then + e.events := EPOLLIN else + e.events := 0; + if pseWrite in events then + e.events := e.events or EPOLLOUT; + // EPOLLERR and EPOLLHUP are always implicitly defined + result := epoll_ctl(fEPFD,EPOLL_CTL_ADD,socket,@e)=0; + if result then + inc(fCount); +end; + +function TPollSocketEpoll.Unsubscribe(socket: TSocket): boolean; +var e: TEPollEvent; // should be there even if not used +begin + if (self=nil) or (socket=0) or (socket=fEPFD) then + result := false else begin + result := epoll_ctl(fEPFD,EPOLL_CTL_DEL,socket,@e)=0; + if result then + dec(fCount); + end; +end; + +function TPollSocketEpoll.WaitForModified(out results: TPollSocketResults; + timeoutMS: integer): integer; +var e: TPollSocketEvents; + i, ev: integer; +begin + result := -1; // error + if (self=nil) or (fCount=0) then + exit; + result := epoll_wait(fEPFD,pointer(fResults),fMaxSockets,timeoutMS); + if result<=0 then + exit; + SetLength(results,result); + for i := 0 to result-1 do begin + ev := fResults[i].events; + byte(e) := 0; + if ev and EPOLLIN<>0 then + include(e,pseRead); + if ev and EPOLLOUT<>0 then + include(e,pseWrite); + if ev and EPOLLERR<>0 then + include(e,pseError); + if ev and EPOLLHUP<>0 then + include(e,pseClosed); + results[i].events := e; + results[i].tag := TPollSocketTag(fResults[i].data.ptr); + end; +end; + +{$endif LINUXNOTBSD} + + +{ TPollSockets } + +constructor TPollSockets.Create(aPollClass: TPollSocketClass=nil); +begin + inherited Create; + InitializeCriticalSection(fPendingLock); + InitializeCriticalSection(fPollLock); + if aPollClass=nil then + fPollClass := PollSocketClass else + fPollClass := aPollClass; + {$ifndef MSWINDOWS} + SetFileOpenLimit(GetFileOpenLimit(true)); // set soft limit to hard value + {$endif MSWINDOWS} +end; + +destructor TPollSockets.Destroy; +var p: integer; +begin + for p := 0 to high(fPoll) do + fPoll[p].Free; + DeleteCriticalSection(fPendingLock); + DeleteCriticalSection(fPollLock); + inherited Destroy; +end; + +function TPollSockets.Subscribe(socket: TSocket; tag: TPollSocketTag; + events: TPollSocketEvents): boolean; +var p,n: integer; + poll: TPollSocketAbstract; +begin + result := false; + if (self=nil) or (socket=0) or (events=[]) then + exit; + EnterCriticalSection(fPollLock); + try + poll := nil; + n := length(fPoll); + for p := 0 to n-1 do + if fPoll[p].Count0 then begin // void e.g. after Unsubscribe() + result := true; + exit; + end; + if fPending=nil then + break; // end of list + end; + finally + LeaveCriticalSection(fPendingLock); + end; +end; + +function TPollSockets.GetOne(timeoutMS: integer; out notif: TPollSocketResult): boolean; + function PollAndSearchWithinPending(p: integer): boolean; + begin + if not fTerminated and + (fPoll[p].WaitForModified(fPending,{timeout=}0)>0) then begin + result := GetOneWithinPending(notif); + if result then + fPollIndex := p; // next call to continue from fPoll[fPollIndex+1] + end else + result := false; + end; +var p,n: integer; + elapsed,start: Int64; +begin + result := false; + byte(notif.events) := 0; + if (timeoutMS<0) or fTerminated then + exit; + start := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; + repeat + // non-blocking search within fPoll[] + EnterCriticalSection(fPollLock); + try + // check if some already notified as pending in fPoll[] + if GetOneWithinPending(notif) then + exit; + // calls fPoll[].WaitForModified({timeout=}0) to refresh pending state + n := length(fPoll); + if n>0 then begin + for p := fPollIndex+1 to n-1 do // search from fPollIndex = last found + if PollAndSearchWithinPending(p) then + exit; + for p := 0 to fPollIndex do // search from beginning up to fPollIndex + if PollAndSearchWithinPending(p) then + exit; + end; + finally + LeaveCriticalSection(fPollLock); + result := byte(notif.events)<>0; // exit would comes here and set result + end; + // wait a little for something to happen + if fTerminated or (timeoutMS=0) then + exit; + {$ifndef MSWINDOWS} + if start=0 then // measure time elapsed only if we wait + start := GetTick64 else {$endif} begin + elapsed := GetTick64-start; // allow multi-threaded process + if elapsed>timeoutMS then + exit else + if elapsed>300 then + SleepHiRes(50) else + if elapsed>50 then + SleepHiRes(10) else + SleepHiRes(1); + end; + until fTerminated; +end; + +procedure TPollSockets.Terminate; +begin + if self<>nil then + fTerminated := true; +end; + + +{ TPollSocketsSlot } + +function TPollSocketsSlot.Lock(writer: boolean): boolean; +begin + result := InterlockedIncrement(lockcounter[writer])=1; + if not result then + InterlockedDecrement(lockcounter[writer]); +end; + +procedure TPollSocketsSlot.Unlock(writer: boolean); +begin + if @self<>nil then + InterlockedDecrement(lockcounter[writer]); +end; + +function TPollSocketsSlot.TryLock(writer: boolean; timeoutMS: cardinal): boolean; +var endtix: Int64; + ms: integer; +begin + result := (@self<>nil) and (socket<>0); + if not result then + exit; // socket closed + result := Lock(writer); + if result or (timeoutMS=0) then + exit; // we acquired the slot, or we don't want to wait + endtix := GetTick64+timeoutMS; // never wait forever + ms := 0; + repeat + SleepHiRes(ms); + ms := ms xor 1; // 0,1,0,1,0,1... + if socket=0 then + exit; // no socket to lock for + result := Lock(writer); + if result then begin + result := socket<>0; + if not result then + UnLock(writer); + exit; // acquired or socket closed + end; + until GetTick64>=endtix; +end; + + +{ TPollAsynchSockets } + +constructor TPollAsynchSockets.Create; +var c: TPollSocketClass; +begin + inherited Create; + c := PollSocketClass; + fRead := TPollSockets.Create(c); + {$ifdef LINUXNOTBSD} + c := TPollSocketPoll; // epoll is overkill for short-living writes + {$endif} + fWrite := TPollSockets.Create(c); +end; + +destructor TPollAsynchSockets.Destroy; +begin + if not fRead.Terminated then + Terminate(5000); + inherited Destroy; + fRead.Free; + fWrite.Free; +end; + +function TPollAsynchSockets.Start(connection: TObject): boolean; +var slot: PPollSocketsSlot; +begin + result := false; + if (fRead.Terminated) or (connection=nil) then + exit; + InterlockedIncrement(fProcessing); + try + slot := SlotFromConnection(connection); + if (slot=nil) or (slot.socket=0) then + exit; + if not AsynchSocket(slot.socket) then + exit; // we expect non-blocking mode on a real working socket + result := fRead.Subscribe(slot.socket,TPollSocketTag(connection),[pseRead]); + // now, ProcessRead will handle pseRead + pseError/pseClosed on this socket + finally + InterlockedDecrement(fProcessing); + end; +end; + +function TPollAsynchSockets.Stop(connection: TObject): boolean; +var slot: PPollSocketsSlot; + sock: TSocket; + endtix: Int64; + lock: set of (r,w); +begin + result := false; + if fRead.Terminated or (connection=nil) then + exit; + InterlockedIncrement(fProcessing); + try + slot := SlotFromConnection(connection); + if slot=nil then + exit; + sock := slot.socket; + if sock<>0 then + try + slot.socket := 0; // notify ProcessRead/ProcessWrite to abort + slot.lastWSAError := WSAErrorAtShutdown(sock); + fRead.Unsubscribe(sock,TPollSocketTag(connection)); + fWrite.Unsubscribe(sock,TPollSocketTag(connection)); + result := true; + finally + DirectShutdown(sock); + endtix := GetTick64+10000; + lock := []; + repeat // acquire locks to avoid OnClose -> Connection.Free -> GPF + if not(r in lock) and slot.Lock(false) then + include(lock,r); + if not(w in lock) and slot.Lock(true) then + include(lock,w); + if lock=[r,w] then + break; + SleepHiRes(0); // 10 microsecs on POSIX + until GetTick64>=endtix; + end; + finally + InterlockedDecrement(fProcessing); + end; +end; + +function TPollAsynchSockets.GetCount: integer; +begin + if self=nil then + result := 0 else + result := fRead.Count; +end; + +procedure TPollAsynchSockets.Terminate(waitforMS: integer); +var endtix: Int64; +begin + fRead.Terminate; + fWrite.Terminate; + if waitforMS<=0 then + exit; + endtix := GetTick64+waitforMS; + repeat + SleepHiRes(1); + if fProcessing=0 then + break; + until GetTick64>endtix; +end; + +function TPollAsynchSockets.WriteString(connection: TObject; + const data: SockString): boolean; +begin + if self=nil then + result := false else + result := Write(connection,pointer(data)^,length(data)); +end; + +procedure AppendData(var buf: SockString; const data; datalen: PtrInt); +var buflen: PtrInt; +begin + if datalen>0 then begin + buflen := length(buf); + SetLength(buf,buflen+datalen); + move(data,PByteArray(buf)^[buflen],datalen); + end; +end; + +function TPollAsynchSockets.Write(connection: TObject; + const data; datalen, timeout: integer): boolean; +var tag: TPollSocketTag; + slot: PPollSocketsSlot; + P: PByte; + res,previous: integer; +begin + result := false; + if (datalen<=0) or (connection=nil) or fWrite.Terminated then + exit; + InterlockedIncrement(fProcessing); + try + tag := TPollSocketTag(connection); + slot := SlotFromConnection(connection); + if (slot=nil) or (slot.socket=0) then + exit; + if slot.TryLock(true,timeout) then // try and wait for another ProcessWrite + try + P := @data; + previous := length(slot.writebuf); + if (previous=0) and not (paoWritePollOnly in fOptions) then + repeat + // try to send now in non-blocking mode (works most of the time) + if fWrite.Terminated or (slot.socket=0) then + exit; + res := AsynchSend(slot.socket,P,datalen); + if slot.socket=0 then + exit; // Stop() called + if (res<0) and not WSAIsFatalError then + break; // fails now -> retry later in ProcessWrite + if res<=0 then + exit; // connection closed or broken -> abort + inc(fWriteCount); + inc(fWriteBytes,res); + dec(datalen,res); + if datalen=0 then begin + try // notify everything written + AfterWrite(connection); + result := true; + except + result := false; + end; + exit; + end; + inc(P,res); + until false; + // use fWrite output polling for the remaining data in ProcessWrite + AppendData(slot.writebuf,P^,datalen); + if previous>0 then // already subscribed + result := slot.socket<>0 else + if fWrite.Subscribe(slot.socket,tag,[pseWrite]) then + result := slot.socket<>0 else + slot.writebuf := ''; // subscription error -> abort + finally + slot.UnLock({writer=}true); + end; + finally + InterlockedDecrement(fProcessing); + end; +end; + +procedure TPollAsynchSockets.ProcessRead(timeoutMS: integer); +var notif: TPollSocketResult; + connection: TObject; + slot: PPollSocketsSlot; + res,added: integer; + temp: array[0..$7fff] of byte; // read up to 32KB per chunk + procedure CloseConnection(withinreadlock: boolean); + begin + if withinreadlock then + slot.UnLock({writer=}false); // Stop() will try to acquire this lock + Stop(connection); // shutdown and set socket:=0 + acquire locks + try + OnClose(connection); // now safe to perform connection.Free + except + connection := nil; // user code may be unstable + end; + slot := nil; // ignore pseClosed and slot.Unlock(false) + end; +begin + if (self=nil) or fRead.Terminated then + exit; + InterlockedIncrement(fProcessing); + try + if not fRead.GetOne(timeoutMS,notif) then + exit; + connection := TObject(notif.tag); + slot := SlotFromConnection(connection); + if (slot=nil) or (slot.socket=0) then + exit; + if pseError in notif.events then + if not OnError(connection,notif.events) then begin // false = shutdown + CloseConnection({withinlock=}false); + exit; + end; + if pseRead in notif.events then begin + if slot.Lock({writer=}false) then // paranoid thread-safe read + try + added := 0; + repeat + if fRead.Terminated or (slot.socket=0) then + exit; + res := AsynchRecv(slot.socket,@temp,sizeof(temp)); + if slot.socket=0 then + exit; // Stop() called + if (res<0) and not WSAIsFatalError then + break; // may block, try later + if res<=0 then begin + CloseConnection(true); + exit; // socket closed gracefully or unrecoverable error -> abort + end; + AppendData(slot.readbuf,temp,res); + inc(added,res); + until false; + if added>0 then + try + inc(fReadCount); + inc(fReadBytes,added); + if OnRead(connection)=sorClose then + CloseConnection(true); + except + CloseConnection(true); // force socket shutdown + end; + finally + slot.UnLock(false); // CloseConnection may set slot=nil + end; + end; + if (slot<>nil) and (slot.socket<>0) and (pseClosed in notif.events) then begin + CloseConnection(false); + exit; + end; + finally + InterlockedDecrement(fProcessing); + end; +end; + +procedure TPollAsynchSockets.ProcessWrite(timeoutMS: integer); +var notif: TPollSocketResult; + connection: TObject; + slot: PPollSocketsSlot; + buf: PByte; + buflen,res,sent: integer; +begin + if (self=nil) or fWrite.Terminated then + exit; + InterlockedIncrement(fProcessing); + try + if not fWrite.GetOne(timeoutMS,notif) then + exit; + if notif.events<>[pseWrite] then + exit; // only try if we are sure the socket is writable and safe + connection := TObject(notif.tag); + slot := SlotFromConnection(connection); + if (slot=nil) or (slot.socket=0) then + exit; + if slot.Lock({writer=}true) then // paranoid check + try + buflen := length(slot.writebuf); + if buflen<>0 then begin + buf := pointer(slot.writebuf); + sent := 0; + repeat + if fWrite.Terminated or (slot.socket=0) then + exit; + res := AsynchSend(slot.socket,buf,buflen); + if slot.socket=0 then + exit; // Stop() called + if (res<0) and not WSAIsFatalError then + break; // may block, try later + if res<=0 then + exit; // socket closed gracefully or unrecoverable error -> abort + inc(fWriteCount); + inc(sent,res); + inc(buf,res); + dec(buflen,res); + until buflen=0; + inc(fWriteBytes,sent); + delete(slot.writebuf,1,sent); + end; + if slot.writebuf='' then begin // no data any more to be sent + fWrite.Unsubscribe(slot.socket,notif.tag); + try + AfterWrite(connection); + except + end; + end; + finally + slot.UnLock(true); + end; + finally + InterlockedDecrement(fProcessing); + end; +end; + + +var + _MainHttpClass: THttpRequestClass; + +function MainHttpClass: THttpRequestClass; +begin + if _MainHttpClass = nil then begin + {$ifdef USEWININET} + _MainHttpClass := TWinHTTP; + {$else} + {$ifdef USELIBCURL} + _MainHttpClass := TCurlHTTP + {$else} + raise ECrtSocket.Create('No THttpRequest class known!'); + {$endif} + {$endif} + end; + result := _MainHttpClass; +end; + +procedure ReplaceMainHttpClass(aClass: THttpRequestClass); +begin + _MainHttpClass := aClass; +end; + +procedure Initialize; +var i: integer; +begin + for i := 0 to high(NormToUpper) do + NormToUpper[i] := i; + for i := ord('a') to ord('z') do + dec(NormToUpper[i],32); + IP4local := '127.0.0.1'; // use var string with refcount=1 to avoid allocation + JSON_CONTENT_TYPE_VAR := 'application/json; charset=UTF-8'; + {$ifdef MSWINDOWS} + Assert( + {$ifdef CPU64} + (sizeof(HTTP_REQUEST)=864) and + (sizeof(HTTP_SSL_INFO)=48) and + (sizeof(HTTP_DATA_CHUNK_INMEMORY)=32) and + (sizeof(HTTP_DATA_CHUNK_FILEHANDLE)=32) and + (sizeof(HTTP_REQUEST_HEADERS)=688) and + (sizeof(HTTP_RESPONSE_HEADERS)=512) and + (sizeof(HTTP_COOKED_URL)=40) and + (sizeof(HTTP_RESPONSE)=568) and + {$else} + (sizeof(HTTP_REQUEST)=472) and + (sizeof(HTTP_SSL_INFO)=28) and + (sizeof(HTTP_DATA_CHUNK_INMEMORY)=24) and + (sizeof(HTTP_DATA_CHUNK_FILEHANDLE)=32) and + (sizeof(HTTP_RESPONSE)=288) and + (sizeof(HTTP_REQUEST_HEADERS)=344) and + (sizeof(HTTP_RESPONSE_HEADERS)=256) and + (sizeof(HTTP_COOKED_URL)=24) and + {$endif CPU64} + (ord(reqUserAgent)=40) and + (ord(respLocation)=23) and (sizeof(THttpHeader)=4) and + (integer(HTTP_LOG_FIELD_TEST_SUB_STATUS)=HTTP_LOG_FIELD_SUB_STATUS)); + GetTick64 := GetProcAddress(GetModuleHandle(kernel32),'GetTickCount64'); + if not Assigned(GetTick64) then // fallback before Vista + GetTick64 := @GetTick64ForXP; + {$ifdef USEWININET} + FillChar(WinHttpAPI, SizeOf(WinHttpAPI), 0); + WinHttpAPIInitialize; + OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); + GetVersionEx(OSVersionInfo); + {$endif} + {$endif MSWINDOWS} + FillChar(WsaDataOnce,sizeof(WsaDataOnce),0); + if InitSocketInterface then + WSAStartup(WinsockLevel, WsaDataOnce); +end; + +initialization + Initialize; + +finalization + if WsaDataOnce.wVersion<>0 then + try + {$ifdef MSWINDOWS} + if Assigned(WSACleanup) then + WSACleanup; + {$endif} + finally + fillchar(WsaDataOnce,sizeof(WsaDataOnce),0); + end; + {$ifdef MSWINDOWS} + if Http.Module<>0 then begin + FreeLibrary(Http.Module); + Http.Module := 0; + end; + {$endif} + DestroySocketInterface; +end. diff --git a/mORMot/SynFPCLinux.pas b/mORMot/SynFPCLinux.pas new file mode 100644 index 00000000..6afc5e3e --- /dev/null +++ b/mORMot/SynFPCLinux.pas @@ -0,0 +1,1201 @@ +/// wrapper of some Windows-like functions translated to Linux/BSD for FPC +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynFPCLinux; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Alfred Glaenzer. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Alan Chate + - Arnaud Bouchez + + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. if you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. if you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + +} + +interface + + +{$ifndef FPC} + 'this unit is for FPC only - do not include it in any Delphi project!' +{$endif FPC} + + +{$I Synopse.inc} // set proper flags, and define LINUX for BSD and ANDROID + +uses + {$ifdef LINUX} + BaseUnix, + UnixType, + {$endif LINUX} + SysUtils; + +const + { HRESULT codes, delphi-like } + NOERROR = 0; + NO_ERROR = 0; + INVALID_HANDLE_VALUE = THandle(-1); + + LOCALE_USER_DEFAULT = $400; + + // for CompareStringW() + NORM_IGNORECASE = 1 shl ord(coIgnoreCase); // [widestringmanager.coIgnoreCase] + +/// compatibility function, wrapping Win32 API mutex initialization +procedure InitializeCriticalSection(var cs : TRTLCriticalSection); inline; + +/// compatibility function, wrapping Win32 API mutex finalization +procedure DeleteCriticalSection(var cs : TRTLCriticalSection); inline; + +{$ifdef LINUX} + +/// used by SynCommons to compute the sizes in byte +function getpagesize: Integer; cdecl; external 'c'; + +/// compatibility function, wrapping Win32 API high resolution timer +// - returns nanoseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD +procedure QueryPerformanceCounter(out Value: Int64); + +/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows +// - returns microseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD +procedure QueryPerformanceMicroSeconds(out Value: Int64); inline; + +/// compatibility function, wrapping Win32 API high resolution timer +// - hardcoded to 1e9 for clock_gettime() nanoseconds resolution on Linux/BSD +function QueryPerformanceFrequency(out Value: Int64): boolean; + +/// compatibility function, wrapping Win32 API file position change +function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; + lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; inline; + +/// compatibility function, wrapping Win32 API file size retrieval +function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; + +/// compatibility function, wrapping Win32 API file truncate at current position +procedure SetEndOfFile(hFile: cInt); inline; + +/// compatibility function, wrapping Win32 API file flush to disk +procedure FlushFileBuffers(hFile: cInt); inline; + +/// compatibility function, wrapping Win32 API last error code +function GetLastError: longint; inline; + +/// compatibility function, wrapping Win32 API last error code +procedure SetLastError(error: longint); inline; + +/// compatibility function, wrapping Win32 API text comparison +// - will use the system ICU library if available, or the widestringmanager +// - seldom called, unless our proprietary WIN32CASE collation is used in SynSQLite3 +function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; + +/// compatibility function, wrapping Win32 API text case conversion +function CharUpperBuffW(W: PWideChar; WLen: integer): integer; + +/// compatibility function, wrapping Win32 API text case conversion +function CharLowerBuffW(W: PWideChar; WLen: integer): integer; + +/// compatibility function, wrapping Win32 MultiByteToWideChar API conversion +// - will use the system ICU library for efficient conversion +function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; + SourceChars: PtrInt): PtrInt; + +/// compatibility function, wrapping Win32 WideCharToMultiByte API conversion +// - will use the system ICU library for efficient conversion +function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; + SourceChars: PtrInt): PtrInt; + +/// returns the current UTC time +// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available +function GetNowUTC: TDateTime; + +/// returns the current UTC time, as Unix Epoch seconds +// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available +function GetUnixUTC: Int64; + +/// returns the current UTC time, as Unix Epoch milliseconds +// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available +function GetUnixMSUTC: Int64; + +/// returns the current UTC time as TSystemTime +// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available +procedure GetNowUTCSystem(out result: TSystemTime); + +var + /// will contain the current Linux kernel revision, as one 24-bit integer + // - e.g. $030d02 for 3.13.2, or $020620 for 2.6.32 + KernelRevision: cardinal; + +/// calls the pthread_setname_np() function, if available on this system +// - under Linux/FPC, this API truncates the name to 16 chars +procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); + +/// calls mprotect() syscall or clib +function SynMProtect(addr:pointer; size:size_t; prot:integer): longint; + +{$ifdef BSD} +function fpsysctlhwint(hwid: cint): Int64; +function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; +{$endif BSD} + +{$ifndef DARWIN} // OSX has no clock_gettime() API + +{$ifdef BSD} +const // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h + CLOCK_REALTIME = 0; +{$ifdef OpenBSD} + CLOCK_MONOTONIC = 3; + CLOCK_REALTIME_COARSE = CLOCK_REALTIME; // no faster alternative + CLOCK_MONOTONIC_COARSE = CLOCK_MONOTONIC; +{$else} + CLOCK_MONOTONIC = 4; + CLOCK_REALTIME_COARSE = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+ + CLOCK_MONOTONIC_COARSE = 12; +{$endif OPENBSD} + +{$else} +const + CLOCK_REALTIME = 0; + CLOCK_MONOTONIC = 1; + CLOCK_REALTIME_COARSE = 5; // see http://lwn.net/Articles/347811 + CLOCK_MONOTONIC_COARSE = 6; +{$endif BSD} + +var + // contains CLOCK_REALTIME_COARSE since kernel 2.6.32 + CLOCK_REALTIME_FAST: integer = CLOCK_REALTIME; + // contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32 + CLOCK_MONOTONIC_FAST: integer = CLOCK_MONOTONIC; + +{$endif DARWIN} +{$endif LINUX} + +/// compatibility function, to be implemented according to the running OS +// - expect more or less the same result as the homonymous Win32 API function +// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available +function GetTickCount64: Int64; + +/// compatibility function, to be implemented according to the running OS +// - expect more or less the same result as the homonymous Win32 API function +// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available +function GetTickCount: cardinal; + +var + /// could be set to TRUE to force SleepHiRes(0) to call the sched_yield API + // - in practice, it has been reported as buggy under POSIX systems + // - even Linus Torvald himself raged against its usage - see e.g. + // https://www.realworldtech.com/forum/?threadid=189711&curpostid=189752 + // - you may tempt the devil and try it by yourself + SleepHiRes0Yield: boolean = false; + +/// similar to Windows sleep() API call, to be truly cross-platform +// - using millisecond resolution +// - SleepHiRes(0) calls ThreadSwitch on windows, but this POSIX version will +// wait 10 microsecond unless SleepHiRes0Yield is forced to true (bad idea) +// - in respect to RTL's Sleep() function, it will return on ESysEINTR +procedure SleepHiRes(ms: cardinal); + +/// check if any char is pending from StdInputHandle file descriptor +function UnixKeyPending: boolean; + + +{$ifdef LINUX} + +type + /// the libraries supported by TExternalLibrariesAPI + TExternalLibrary = ( + elPThread, elICU {$ifdef LINUXNOTBSD} , elSystemD {$endif}); + /// set of libraries supported by TExternalLibrariesAPI + TExternalLibraries = set of TExternalLibrary; + + /// implements late-binding of system libraries + // - about systemd: see https://www.freedesktop.org/wiki/Software/systemd + // and http://0pointer.de/blog/projects/socket-activation.html - to get headers + // on debian: `sudo apt install libsystemd-dev && cd /usr/include/systemd` + TExternalLibrariesAPI = object + private + Lock: TRTLCriticalSection; + Loaded: TExternalLibraries; + {$ifdef LINUX} + pthread: pointer; + {$ifdef LINUXNOTBSD} + systemd: pointer; + {$endif LINUXNOTBSD} + {$endif LINUX} + icu, icudata, icui18n: pointer; + procedure LoadIcuWithVersion; + procedure Done; + public + {$ifdef LINUXNOTBSD} + /// customize the name of a thread (truncated to 16 bytes) + // - see https://stackoverflow.com/a/7989973 + pthread_setname_np: function(thread: pointer; name: PAnsiChar): longint; cdecl; + /// systemd: returns how many file descriptors have been passed to process + // - if result=1 then socket for accepting connection is SD_LISTEN_FDS_START + sd_listen_fds: function(unset_environment: integer): integer; cdecl; + /// systemd: returns 1 if the file descriptor is an AF_UNIX socket of the specified type and path + sd_is_socket_unix: function(fd, typr, listening: integer; + var path: TFileName; pathLength: PtrUInt): integer; cdecl; + /// systemd: submit simple, plain text log entries to the system journal + // - priority value can be obtained using longint(LOG_TO_SYSLOG[logLevel]) + // - WARNING: args strings processed using C printf semantic, so % is a printf + // placeholder and should be either escaped using %% or all formatting args must be passed + sd_journal_print: function(priority: longint; args: array of const): longint; cdecl; + /// systemd: submit array of iov structures instead of the format string to the system journal. + // - each structure should reference one field of the entry to submit. + // - the second argument specifies the number of structures in the array. + sd_journal_sendv: function(const iov: Piovec; n: longint): longint; cdecl; + /// systemd: sends notification to systemd + // - see https://www.freedesktop.org/software/systemd/man/sd_notify.html + // status notification sample: sd.notify(0, 'READY=1'); + // watchdog notification: sd.notify(0, 'WATCHDOG=1'); + sd_notify: function(unset_environment: longint; state: PAnsiChar): longint; cdecl; + /// systemd: check whether the service manager expects watchdog keep-alive + // notifications from a service + // - if result > 0 then usec contains the notification interval (app should + // notify every usec/2) + sd_watchdog_enabled: function(unset_environment: longint; usec: Puint64): longint; cdecl; + {$endif LINUXNOTBSD} + /// Initialize an ICU text converter for a given encoding + ucnv_open: function (converterName: PAnsiChar; var err: SizeInt): pointer; cdecl; + /// finalize the ICU text converter for a given encoding + ucnv_close: procedure (converter: pointer); cdecl; + /// customize the ICU text converter substitute char + ucnv_setSubstChars: procedure (converter: pointer; + subChars: PAnsiChar; len: byte; var err: SizeInt); cdecl; + /// enable the ICU text converter fallback + ucnv_setFallback: procedure (cnv: pointer; usesFallback: LongBool); cdecl; + /// ICU text conversion from UTF-16 to a given encoding + ucnv_fromUChars: function (cnv: pointer; dest: PAnsiChar; destCapacity: cardinal; + src: PWideChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; + /// ICU text conversion from a given encoding to UTF-16 + ucnv_toUChars: function (cnv: pointer; dest: PWideChar; destCapacity: cardinal; + src: PAnsiChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; + /// ICU UTF-16 text conversion to uppercase + u_strToUpper: function (dest: PWideChar; destCapacity: cardinal; + src: PWideChar; srcLength: cardinal; locale: PAnsiChar; + var err: SizeInt): cardinal; cdecl; + /// ICU UTF-16 text conversion to lowercase + u_strToLower: function (dest: PWideChar; destCapacity: cardinal; + src: PWideChar; srcLength: cardinal; locale: PAnsiChar; + var err: SizeInt): cardinal; cdecl; + /// ICU UTF-16 text comparison + u_strCompare: function (s1: PWideChar; length1: cardinal; + s2: PWideChar; length2: cardinal; codePointOrder: LongBool): cardinal; cdecl; + /// ICU UTF-16 text comparison with options, e.g. for case-insensitive + u_strCaseCompare: function (s1: PWideChar; length1: cardinal; + s2: PWideChar; length2: cardinal; options: cardinal; + var err: SizeInt): cardinal; cdecl; + /// get the ICU data folder + u_getDataDirectory: function: PAnsiChar; cdecl; + /// set the ICU data folder + u_setDataDirectory: procedure(directory: PAnsiChar); cdecl; + /// initialize the ICU library + u_init: procedure(var status: SizeInt); cdecl; + /// Initialize an ICU text converter for a given codepage + // - returns nil if ICU is not available on this system + function ucnv(codepage: cardinal): pointer; + /// thread-safe loading of a system library + // - caller should then check the API function to be not nil + procedure EnsureLoaded(lib: TExternalLibrary); + end; + +var + /// late-binding of system libraries + ExternalLibraries: TExternalLibrariesAPI; + +{$ifdef LINUXNOTBSD} { the systemd API is Linux-specific } + +const + /// The first passed file descriptor is fd 3 + SD_LISTEN_FDS_START = 3; + + /// low-level libcurl library file name, depending on the running OS + LIBSYSTEMD_PATH = 'libsystemd.so.0'; + + ENV_INVOCATION_ID: PAnsiChar = 'INVOCATION_ID'; + +type + /// low-level exception raised during systemd library access + ESystemd = class(Exception); + +/// returns true in case process is started by systemd +// - For systemd v232+ +function ProcessIsStartedBySystemd: boolean; + +/// initialize the libsystemd API +// - do nothing if the library has already been loaded +// - will raise ESsytemd exception on any loading issue +procedure LibSystemdInitialize; + +/// returns TRUE if a systemd library is available +// - will load and initialize it, calling LibSystemdInitialize if necessary, +// catching any exception during the process +function SystemdIsAvailable: boolean; inline; + +{$endif LINUXNOTBSD} + +{$endif LINUX} + + +implementation + +{$ifdef LINUX} +uses + Classes, + Unix, + {$ifdef BSD} + sysctl, + {$else} + Linux, + SysCall, + {$endif BSD} + dl; +{$endif LINUX} + +procedure InitializeCriticalSection(var cs : TRTLCriticalSection); +begin + InitCriticalSection(cs); +end; + +procedure DeleteCriticalSection(var cs : TRTLCriticalSection); +begin + {$ifdef LINUXNOTBSD} + if cs.__m_kind<>0 then + {$else} + {$ifdef BSD} + {$ifdef Darwin} + if cs.sig<>0 then + {$else} + if Assigned(cs) then + {$endif Darwin} + {$endif BSD} + {$endif LINUXNOTBSD} + DoneCriticalSection(cs); +end; + +function UnixKeyPending: boolean; +var + fdsin: tfdSet; +begin + fpFD_ZERO(fdsin); + fpFD_SET(StdInputHandle,fdsin); + result := fpSelect(StdInputHandle+1,@fdsin,nil,nil,0)>0; +end; + +{$ifdef LINUX} + +const // Date Translation - see http://en.wikipedia.org/wiki/Julian_day + HoursPerDay = 24; + MinsPerHour = 60; + SecsPerMin = 60; + MinsPerDay = HoursPerDay*MinsPerHour; + SecsPerDay = MinsPerDay*SecsPerMin; + SecsPerHour = MinsPerHour*SecsPerMin; + C1970 = 2440588; + D0 = 1461; + D1 = 146097; + D2 = 1721119; + UnixDelta = 25569; + + C_THOUSAND = Int64(1000); + C_MILLION = Int64(C_THOUSAND * C_THOUSAND); + C_BILLION = Int64(C_THOUSAND * C_THOUSAND * C_THOUSAND); + +procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime); + {$ifdef HASINLINE}inline;{$endif} +var YYear,XYear,Temp,TempMonth: PtrUInt; +begin + Temp := ((JulianDN-D2)*4)-1; + JulianDN := Temp div D1; + XYear := (Temp-(JulianDN*D1)) or 3; + YYear := XYear div D0; + Temp := (((XYear-(YYear*D0)+4) shr 2)*5)-3; + TempMonth := Temp div 153; + result.Day := ((Temp-(TempMonth*153))+5) div 5; + if TempMonth>=10 then begin + inc(YYear); + dec(TempMonth,12-3); + end else + inc(TempMonth,3); + result.Month := TempMonth; + result.Year := YYear+(JulianDN*100); + // initialize fake dayOfWeek - as used by SynCommons.FromGlobalTime RCU128 + result.DayOfWeek := 0; +end; + +procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime); +var t: PtrUInt; +begin + t := epoch div SecsPerDay; + JulianToGregorian(t+C1970,result); + dec(epoch,t*SecsPerDay); + t := epoch div SecsPerHour; + result.Hour := t; + dec(epoch,t*SecsPerHour); + t := epoch div SecsPerMin; + result.Minute := t; + result.Second := epoch-t*SecsPerMin; +end; + +function GetTickCount: cardinal; +begin + result := cardinal(GetTickCount64); +end; + +{$ifdef DARWIN} +// clock_gettime() is not implemented: http://stackoverflow.com/a/5167506 + +type + TTimebaseInfoData = record + Numer: cardinal; + Denom: cardinal; + end; + +function mach_absolute_time: UInt64; + cdecl external 'libc.dylib' name 'mach_absolute_time'; +function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): Integer; + cdecl external 'libc.dylib' name 'mach_timebase_info'; + +var + mach_timeinfo: TTimebaseInfoData; + mach_timecoeff: double; + mach_timenanosecond: boolean; // very likely to be TRUE on Intel CPUs + +procedure QueryPerformanceCounter(out Value: Int64); +begin // returns time in nano second resolution + Value := mach_absolute_time; + if mach_timeinfo.Denom=1 then + if mach_timeinfo.Numer=1 then + // seems to be the case on Intel CPUs + exit else + Value := Value*mach_timeinfo.Numer else + // use floating point to avoid potential overflow + Value := round(Value*mach_timecoeff); +end; + +procedure QueryPerformanceMicroSeconds(out Value: Int64); +begin + if mach_timenanosecond then + Value := mach_absolute_time div C_THOUSAND else begin + QueryPerformanceCounter(Value); + Value := Value div C_THOUSAND; // ns to us + end; +end; + +function GetTickCount64: Int64; +begin + if mach_timenanosecond then + result := mach_absolute_time else + QueryPerformanceCounter(result); + result := result div C_MILLION; // ns to ms +end; + +function GetUnixUTC: Int64; +var tz: timeval; +begin + fpgettimeofday(@tz,nil); + result := tz.tv_sec; +end; + +function GetUnixMSUTC: Int64; +var tz: timeval; +begin + fpgettimeofday(@tz,nil); + result := (tz.tv_sec*C_THOUSAND)+tz.tv_usec div C_THOUSAND; // in milliseconds +end; + +procedure GetNowUTCSystem(out result: TSystemTime); +var tz: timeval; +begin + fpgettimeofday(@tz,nil); + EpochToSystemTime(tz.tv_sec,result); + result.MilliSecond := tz.tv_usec div C_THOUSAND; +end; + +{$else} + +{$ifdef BSD} + +function clock_gettime(ID: cardinal; r: ptimespec): Integer; + cdecl external 'libc.so' name 'clock_gettime'; +function clock_getres(ID: cardinal; r: ptimespec): Integer; + cdecl external 'libc.so' name 'clock_getres'; + +{$else} + +// libc's clock_gettime function uses vDSO (avoid syscall) while FPC by default +// is compiled without FPC_USE_LIBC defined and do a syscall each time +// GetTickCount64 fpc 2 494 563 op/sec +// GetTickCount64 libc 119 919 893 op/sec +// note: for high-resolution QueryPerformanceMicroSeconds, calling the kernel +// is also slower +function clock_gettime(clk_id : clockid_t; tp: ptimespec) : cint; + cdecl; external 'c' name 'clock_gettime'; + +{$endif BSD} + +function GetTickCount64: Int64; +var tp: timespec; +begin + clock_gettime(CLOCK_MONOTONIC_FAST,@tp); // likely = CLOCK_MONOTONIC_COARSE + Result := (Int64(tp.tv_sec) * C_THOUSAND) + (tp.tv_nsec div C_MILLION); // in ms +end; + +function GetUnixMSUTC: Int64; +var r: timespec; +begin + clock_gettime(CLOCK_REALTIME_FAST,@r); // likely = CLOCK_REALTIME_COARSE + result := (Int64(r.tv_sec) * C_THOUSAND) + (r.tv_nsec div C_MILLION); // in ms +end; + +function GetUnixUTC: Int64; +var r: timespec; +begin + clock_gettime(CLOCK_REALTIME_FAST,@r); + result := r.tv_sec; +end; + +procedure QueryPerformanceCounter(out Value: Int64); +var r : TTimeSpec; +begin + clock_gettime(CLOCK_MONOTONIC, @r); + value := r.tv_nsec+r.tv_sec*C_BILLION; // returns nanoseconds resolution +end; + +procedure QueryPerformanceMicroSeconds(out Value: Int64); +var r : TTimeSpec; +begin + clock_gettime(CLOCK_MONOTONIC, @r); + value := PtrUInt(r.tv_nsec) div C_THOUSAND+r.tv_sec*C_MILLION; // as microseconds +end; + +procedure GetNowUTCSystem(out result: TSystemTime); +var r: timespec; +begin + clock_gettime(CLOCK_REALTIME_FAST,@r); // faster than fpgettimeofday() + EpochToSystemTime(r.tv_sec,result); + result.MilliSecond := r.tv_nsec div C_MILLION; +end; + +{$endif DARWIN} + +{$ifdef BSD} +function fpsysctlhwint(hwid: cint): Int64; +var mib: array[0..1] of cint; + len: cint; +begin + result := 0; + mib[0] := CTL_HW; + mib[1] := hwid; + len := SizeOf(result); + fpsysctl(pointer(@mib),2,@result,@len,nil,0); +end; + +function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; +var mib: array[0..1] of cint; + len: cint; +begin + mib[0] := CTL_HW; + mib[1] := hwid; + FillChar(temp,SizeOf(temp),0); // use shortstring as temp 0-terminated buffer + len := SizeOf(temp); + fpsysctl(pointer(@mib),2,@temp,@len,nil,0); + if temp[0]<>#0 then + result := @temp else + result := nil; +end; +{$endif BSD} + +function GetNowUTC: TDateTime; +begin + result := GetUnixMSUTC / MSecsPerDay + UnixDelta; +end; + +function QueryPerformanceFrequency(out Value: Int64): boolean; +begin + Value := C_BILLION; // 1 second = 1e9 nanoseconds + result := true; +end; + +function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; + lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; +var offs: Int64; +begin + Int64Rec(offs).Lo := lDistanceToMove; + if lpDistanceToMoveHigh=nil then + Int64Rec(offs).Hi := 0 else + Int64Rec(offs).Hi := PDWord(lpDistanceToMoveHigh)^; + offs := FpLseek(hFile,offs,dwMoveMethod); + result := Int64Rec(offs).Lo; + if lpDistanceToMoveHigh<>nil then + PDWord(lpDistanceToMoveHigh)^ := Int64Rec(offs).Hi; +end; + +procedure SetEndOfFile(hFile: cInt); +begin + FpFtruncate(hFile,FPLseek(hFile,0,SEEK_CUR)); +end; + +procedure FlushFileBuffers(hFile: cInt); +begin + FpFsync(hFile); +end; + +function GetLastError: longint; +begin + result := fpgeterrno; +end; + +procedure SetLastError(error: longint); +begin + fpseterrno(error); +end; + +function CompareStringRTL(a, b: PWideChar; al, bl, flags: integer): integer; +var + U1, U2: UnicodeString; +begin + SetString(U1,a,al); + SetString(U2,b,bl); + result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(flags)); +end; + +function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; + cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; +const + U_COMPARE_CODE_POINT_ORDER = $8000; +var + err: SizeInt; +begin + if cchCount1 < 0 then + cchCount1 := StrLen(lpString1); + if cchCount2 < 0 then + cchCount2 := StrLen(lpString2); + with ExternalLibraries do + begin + if not (elICU in Loaded) then + EnsureLoaded(elICU); + if Assigned(ucnv_open) then + begin + err := 0; + if dwCmpFlags and NORM_IGNORECASE <> 0 then + result := u_strCaseCompare(lpString1, cchCount1, lpString2, cchCount2, + U_COMPARE_CODE_POINT_ORDER, err) + else + result := u_strCompare(lpString1, cchCount1, lpString2, cchCount2, true); + end + else + result := CompareStringRTL(lpString1, lpString2, cchCount1, cchCount2, dwCmpFlags); + end; + inc(result, 2); // caller would make -2 to get regular -1/0/1 comparison values +end; + +function CharUpperBuffW(W: PWideChar; WLen: integer): integer; +var + err: SizeInt; +begin + with ExternalLibraries do + begin + if not (elICU in Loaded) then + EnsureLoaded(elICU); + if Assigned(ucnv_open) then + begin + err := 0; + result := u_strToUpper(W, WLen, W, WLen, nil, err); + end + else + result := WLen; + end; +end; + +function CharLowerBuffW(W: PWideChar; WLen: integer): integer; +var + err: SizeInt; +begin + with ExternalLibraries do + begin + if not (elICU in Loaded) then + EnsureLoaded(elICU); + if Assigned(ucnv_open) then + begin + err := 0; + result := u_strToLower(W, WLen, W, WLen, nil, err); + end + else + result := WLen; + end; +end; + +function AnsiToWideRTL(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; + SourceChars: PtrInt): PtrInt; +var + tmp: UnicodeString; +begin + widestringmanager.Ansi2UnicodeMoveProc(Source, codepage, tmp, SourceChars); + result := length(tmp); + Move(pointer(tmp)^, Dest^, result * 2); +end; + +function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; + SourceChars: PtrInt): PtrInt; +var + cnv: pointer; + err: SizeInt; +begin + if codepage = CP_UTF8 then + exit(Utf8ToUnicode(Dest, Source, SourceChars)); + cnv := ExternalLibraries.ucnv(codepage); + if cnv = nil then + exit(AnsiToWideRTL(codepage, Source, Dest, SourceChars)); + err := 0; + result := ExternalLibraries.ucnv_toUChars( + cnv, Dest, SourceChars, Source, SourceChars, err); + if result < 0 then + result := 0; + ExternalLibraries.ucnv_close(cnv); +end; + +function WideToAnsiRTL(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; + SourceChars: PtrInt): PtrInt; +var + tmp: RawByteString; +begin + widestringmanager.Unicode2AnsiMoveProc(Source, tmp, codepage, SourceChars); + result := length(tmp); + Move(pointer(tmp)^, Dest^, result); +end; + +function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; + SourceChars: PtrInt): PtrInt; +var + cnv: pointer; + err: SizeInt; +begin + if codepage = CP_UTF8 then + // fallback to RTL + exit(UnicodeToUTF8(Dest, Source, SourceChars)); + cnv := ExternalLibraries.ucnv(codepage); + if cnv = nil then + exit(WideToAnsiRTL(codepage, Source, Dest, SourceChars)); + err := 0; + result := ExternalLibraries.ucnv_fromUChars( + cnv, Dest, SourceChars * 3, Source, SourceChars, err); + if result < 0 then + result := 0; + ExternalLibraries.ucnv_close(cnv); +end; + + +function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; +var FileInfo: TStat; +begin + if fpFstat(hFile,FileInfo)<>0 then + FileInfo.st_Size := 0; // returns 0 on error + result := Int64Rec(FileInfo.st_Size).Lo; + if lpFileSizeHigh<>nil then + lpFileSizeHigh^ := Int64Rec(FileInfo.st_Size).Hi; +end; + +procedure SleepHiRes(ms: cardinal); +var timeout: TTimespec; +begin + if ms=0 then // handle SleepHiRes(0) special case + if SleepHiRes0Yield then begin // reported as buggy by Alan on POSIX + ThreadSwitch; // call e.g. pthread's sched_yield API + exit; + end else begin + timeout.tv_sec := 0; + timeout.tv_nsec := 10000; // 10us is around timer resolution on modern HW + end else begin + timeout.tv_sec := ms div 1000; + timeout.tv_nsec := 1000000*(ms mod 1000); + end; + fpnanosleep(@timeout,nil) + // no retry loop on ESysEINTR (as with regular RTL's Sleep) +end; + +{$ifdef BSD} +function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer; + {$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect'; + {$else} cdecl external 'libc.so' name 'mprotect'; {$endif} +{$endif BSD} + +function SynMProtect(addr: pointer; size: size_t; prot: integer): longint; +begin + result := -1; + {$ifdef UNIX} + {$ifdef BSD} + result := mprotect(addr, size, prot); + {$else} + if Do_SysCall(syscall_nr_mprotect, PtrUInt(addr), size, prot) >= 0 then + result := 0; + {$endif BSD} + {$endif UNIX} +end; + +procedure GetKernelRevision; +var uts: UtsName; + P: PAnsiChar; + tp: timespec; + function GetNext: cardinal; + var c: cardinal; + begin + result := 0; + repeat + c := ord(P^)-48; + if c>9 then + break else + result := result*10+c; + inc(P); + until false; + if P^ in ['.','-',' '] then + inc(P); + end; +begin + if fpuname(uts)=0 then begin + P := @uts.release[0]; + KernelRevision := GetNext shl 16+GetNext shl 8+GetNext; + end else + uts.release[0] := #0; + {$ifdef DARWIN} + mach_timebase_info(mach_timeinfo); + mach_timecoeff := mach_timeinfo.Numer/mach_timeinfo.Denom; + mach_timenanosecond := (mach_timeinfo.Numer=1) and (mach_timeinfo.Denom=1); + {$else} + {$ifdef LINUX} + // try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks + if (CLOCK_REALTIME_COARSE <> CLOCK_REALTIME_FAST) and + (clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0) then + CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE; + if (CLOCK_MONOTONIC_COARSE <> CLOCK_MONOTONIC_FAST) and + (clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0) then + CLOCK_MONOTONIC_FAST := CLOCK_MONOTONIC_COARSE; + if (clock_gettime(CLOCK_REALTIME_FAST,@tp)<>0) or // paranoid check + (clock_gettime(CLOCK_MONOTONIC_FAST,@tp)<>0) then + raise Exception.CreateFmt('clock_gettime() not supported by %s kernel - errno=%d', + [PAnsiChar(@uts.release),GetLastError]); + {$endif LINUX} + {$endif DARWIN} +end; + + +{ TExternalLibrariesAPI } + +procedure TExternalLibrariesAPI.LoadIcuWithVersion; +const + NAMES: array[0..12] of string = ( + 'ucnv_open', 'ucnv_close', 'ucnv_setSubstChars', 'ucnv_setFallback', + 'ucnv_fromUChars', 'ucnv_toUChars', 'u_strToUpper', 'u_strToLower', + 'u_strCompare', 'u_strCaseCompare', 'u_getDataDirectory', + 'u_setDataDirectory', 'u_init'); +{$ifdef ANDROID} +// from https://developer.android.com/guide/topics/resources/internationalization + ICU_VER: array[1..13] of string = ( + '_3_8', '_4_2', '_44', '_46', '_48', '_50', '_51', '_53', '_55', '_56', '_58', '_60', '_63'); + SYSDATA: PAnsiChar = '/system/usr/icu'; +{$else} + SYSDATA: PAnsiChar = ''; +{$endif ANDROID} +var + i, j: integer; + err: SizeInt; + P: PPointer; + v, vers: string; + data: PAnsiChar; +begin + {$ifdef ANDROID} + for i := high(ICU_VER) downto 1 do + begin + if dlsym(icu, pointer(NAMES[0] + ICU_VER[i])) <> nil then + begin + vers := ICU_VER[i]; + break; + end; + end; + if vers <> '' then + {$endif ANDROID} + if dlsym(icu, 'ucnv_open') = nil then + for i := 80 downto 44 do + begin + str(i, v); + if dlsym(icu, pointer('ucnv_open_' + v)) <> nil then + begin + vers := '_' + v; + break; + end; + end; + P := @@ucnv_open; + for i := 0 to high(NAMES) do + begin + P[i] := dlsym(icu, pointer(NAMES[i] + vers)); + if P[i] = nil then + begin + @ucnv_open := nil; + exit; + end; + end; + data := u_getDataDirectory; + if (data = nil) or (data^ = #0) then + if SYSDATA <> '' then + u_setDataDirectory(SYSDATA); + err := 0; + u_init(err); +end; + +function TExternalLibrariesAPI.ucnv(codepage: cardinal): pointer; +var + s: shortstring; + err: SizeInt; + {$ifdef CPUINTEL} + mask: cardinal; + {$endif CPUINTEL} +begin + if not (elICU in Loaded) then + EnsureLoaded(elICU); + if not Assigned(ucnv_open) then + exit(nil); + str(codepage, s); + Move(s[1], s[3], ord(s[0])); + PWord(@s[1])^ := ord('c') + ord('p') shl 8; + inc(s[0], 3); + s[ord(s[0])] := #0; + {$ifdef CPUINTEL} + mask := GetMXCSR; + SetMXCSR(mask or $0080 {MM_MaskInvalidOp} or $1000 {MM_MaskPrecision}); + {$endif CPUINTEL} + err := 0; + result := ucnv_open(@s[1], err); + if result <> nil then + begin + err := 0; + ucnv_setSubstChars(result, '?', 1, err); + ucnv_setFallback(result, true); + end; + {$ifdef CPUINTEL} + SetMXCSR(mask); + {$endif CPUINTEL} +end; + +procedure TExternalLibrariesAPI.EnsureLoaded(lib: TExternalLibrary); +var + p: PPointer; + i, j: integer; +const + NAMES: array[0..5] of PAnsiChar = ( + 'sd_listen_fds', 'sd_is_socket_unix', 'sd_journal_print', 'sd_journal_sendv', + 'sd_notify', 'sd_watchdog_enabled'); +begin + if lib in Loaded then + exit; + EnterCriticalSection(Lock); + if not (lib in Loaded) then + case lib of + elPThread: + begin + {$ifdef LINUX} + pthread := dlopen({$ifdef ANDROID}'libc.so'{$else}'libpthread.so.0'{$endif}, RTLD_LAZY); + if pthread <> nil then + begin + {$ifdef LINUXNOTBSD} + @pthread_setname_np := dlsym(pthread, 'pthread_setname_np'); + {$endif LINUXNOTBSD} + end; + {$endif LINUX} + include(Loaded, elPThread); + end; + elICU: + begin + {$ifdef DARWIN} + icu := dlopen('libicuuc.dylib', RTLD_LAZY); + if icu <> nil then + icui18n := dlopen('libicui18n.dylib', RTLD_LAZY); + {$else} + // libicudata should be loaded first because other two depend on it + icudata := dlopen('libicudata.so', RTLD_LAZY); + if icudata <> nil then + begin + icu := dlopen('libicuuc.so', RTLD_LAZY); + if icu <> nil then + icui18n := dlopen('libicui18n.so', RTLD_LAZY); + end; + {$endif DARWIN} + if icui18n = nil then + begin + if icu <> nil then + dlclose(icu); + if icudata <> nil then + dlclose(icudata); + end + else + // ICU append a version prefix to all its functions e.g. ucnv_open_66 + LoadIcuWithVersion; + include(Loaded, elICU); + end; + {$ifdef LINUXNOTBSD} + elSystemD: + begin + systemd := dlopen(LIBSYSTEMD_PATH, RTLD_LAZY); + if systemd <> nil then + begin + p := @@sd_listen_fds; + for i := 0 to high(NAMES) do + begin + p^ := dlsym(systemd, NAMES[i]); + if p^ = nil then + begin + p := @@sd_listen_fds; + for j := 0 to i do + begin + p^ := nil; + inc(p); + end; + break; + end; + inc(p); + end; + end; + include(Loaded, elSystemD); + end; + {$endif LINUXNOTBSD} + end; + LeaveCriticalSection(Lock); +end; + +procedure TExternalLibrariesAPI.Done; +begin + EnterCriticalSection(Lock); + if elPThread in Loaded then + begin + {$ifdef LINUX} + {$ifdef LINUXNOTBSD} + @pthread_setname_np := nil; + {$endif LINUXNOTBSD} + if pthread <> nil then + dlclose(pthread); + {$endif LINUX} + end; + if elICU in Loaded then + begin + if icui18n <> nil then + dlclose(icui18n); + if icu <> nil then + dlclose(icu); + if icudata <> nil then + dlclose(icudata); + @ucnv_open := nil; + end; + {$ifdef LINUXNOTBSD} + if (elSystemD in Loaded) and (systemd <> nil) then + dlclose(systemd); + {$endif LINUXNOTBSD} + LeaveCriticalSection(Lock); + DeleteCriticalSection(Lock); +end; + +procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); +var trunc: array[0..15] of AnsiChar; // truncated to 16 bytes (including #0) + i,L: integer; +begin + {$ifdef LINUXNOTBSD} + if not(elPThread in ExternalLibraries.Loaded) then + ExternalLibraries.EnsureLoaded(elPThread); + if not Assigned(ExternalLibraries.pthread_setname_np) then + exit; + if Name = '' then + exit; + L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars + i := 1; + if Name[1] = 'T' then + if PCardinal(Name)^ = ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24 then + i := 5 + else + i := 2; + while i <= length(Name) do begin + if Name[i]>' ' then begin + trunc[L] := Name[i]; + inc(L); + if L = high(trunc) then + break; + end; + inc(i); + end; + if L = 0 then + exit; + trunc[L] := #0; + ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]); + {$endif LINUXNOTBSD} +end; + + +{$ifdef LINUXNOTBSD} + +function SystemdIsAvailable: boolean; +begin + if not(elSystemD in ExternalLibraries.Loaded) then + ExternalLibraries.EnsureLoaded(elSystemD); + result := Assigned(ExternalLibraries.sd_listen_fds); +end; + +function ProcessIsStartedBySystemd: boolean; +begin + result := SystemdIsAvailable and + // note: for example on Ubuntu 20.04 INVOCATION_ID is always defined + // from the other side PPID 1 can be set if we run under docker and started + // by init.d so let's verify both + (fpgetppid() = 1) and (fpGetenv(ENV_INVOCATION_ID) <> nil); +end; + +procedure LibSystemdInitialize; +begin + if not SystemdIsAvailable then + raise ESystemd.Create('Impossible to load ' + LIBSYSTEMD_PATH); +end; + +{$endif LINUXNOTBSD} + + +initialization + GetKernelRevision; + InitializeCriticalSection(ExternalLibraries.Lock); + +finalization + ExternalLibraries.Done; +{$endif LINUX} +end. diff --git a/mORMot/SynFPCSock.pas b/mORMot/SynFPCSock.pas new file mode 100644 index 00000000..a4bb3d35 --- /dev/null +++ b/mORMot/SynFPCSock.pas @@ -0,0 +1,1296 @@ +/// low level access to network Sockets for FPC (and Kylix) POSIX cross-platform +// - this unit is a part of the freeware Synopse framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynFPCSock; + +{ + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synapse library. + + The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic). + Portions created by Lukas Gebauer are Copyright (C) 2003. + All Rights Reserved. + + Portions created by Arnaud Bouchez are Copyright (C) 2023 Arnaud Bouchez. + All Rights Reserved. + + Contributor(s): + - Alfred Glaenzer + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Low level access to network Sockets + ************************************* + + Shared by Kylix and FPC for all POSIX systems. + +} + +{$ifdef FPC} + +{$MODE DELPHI} +{$H+} + +{.$define USELIBC} + +{$ifdef ANDROID} + {$define LINUX} // a Linux-based system +{$endif} + +// BSD definition of socketaddr +{$if + defined(OpenBSD) or + defined(FreeBSD) or + defined(Darwin) or + defined(Haiku) +} + {$DEFINE SOCK_HAS_SINLEN} // BSD definition of socketaddr +{$endif} +{$ifdef SUNOS} + {$DEFINE SOCK_HAS_SINLEN} +{$endif} + +{$else} + +{$ifdef LINUX} + {$define KYLIX3} +{$else} + this unit is for FPC or (Cross-)Kylix only! +{$endif} + +{$endif FPC} + +interface + +uses + SysUtils, + {$ifdef FPC} + BaseUnix, + Unix, + {$ifdef Linux} + Linux, // for epoll support + {$endif Linux} + termio, + netdb, + Sockets, // most definitions are inlined in SynFPCSock to avoid Lazarus problems with Sockets.pp + SynFPCLinux, + {$else} + {$ifdef KYLIX3} + LibC, + Types, + KernelIoctl, + SynKylix, + {$endif} + {$endif FPC} + SyncObjs, + Classes; + +const + InitSocketInterface = true; + +procedure DestroySocketInterface; + +{$MINENUMSIZE 4} + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + c6Localhost = '::1'; + cLocalHostStr = 'localhost'; + +{$ifdef FPC} +type + TSocket = longint; + + TFDSet = Baseunix.TFDSet; + PFDSet = ^TFDSet; + Ptimeval = Baseunix.ptimeval; + Ttimeval = Baseunix.ttimeval; + + PInAddr = ^TInAddr; + TInAddr = sockets.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = sockets.TInetSockAddr; + + PInAddr6 = ^TInAddr6; + TInAddr6 = sockets.Tin6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = sockets.TInetSockAddr6; + + TSockAddr = sockets.TSockAddr; + PSockAddr = sockets.PSockAddr; + +const + FIONREAD = termio.FIONREAD; + FIONBIO = termio.FIONBIO; + FIOASYNC = termio.FIOASYNC; + + IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = sockets.IP_TTL; { int; IP time to live. } + IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } + IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } + IP_RETOPTS = sockets.IP_RETOPTS; { bool } + IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SHUT_RD = sockets.SHUT_RD; + SHUT_WR = sockets.SHUT_WR; + SHUT_RDWR = sockets.SHUT_RDWR; + + SOL_SOCKET = sockets.SOL_SOCKET; + + SO_DEBUG = sockets.SO_DEBUG; + SO_REUSEADDR = sockets.SO_REUSEADDR; + {$ifdef BSD} + SO_REUSEPORT = sockets.SO_REUSEPORT; + {$endif} + SO_TYPE = sockets.SO_TYPE; + SO_ERROR = sockets.SO_ERROR; + SO_DONTROUTE = sockets.SO_DONTROUTE; + SO_BROADCAST = sockets.SO_BROADCAST; + SO_SNDBUF = sockets.SO_SNDBUF; + SO_RCVBUF = sockets.SO_RCVBUF; + SO_KEEPALIVE = sockets.SO_KEEPALIVE; + SO_OOBINLINE = sockets.SO_OOBINLINE; + SO_LINGER = sockets.SO_LINGER; + SO_RCVLOWAT = sockets.SO_RCVLOWAT; + SO_SNDLOWAT = sockets.SO_SNDLOWAT; + SO_RCVTIMEO = sockets.SO_RCVTIMEO; + SO_SNDTIMEO = sockets.SO_SNDTIMEO; +{$IFDEF BSD} + {$IFNDEF OPENBSD} + {$IFDEF DARWIN} + SO_NOSIGPIPE = $1022; + {$ELSE} + SO_NOSIGPIPE = $800; + {$ENDIF} + {$ENDIF} +{$ENDIF} + // we use Linux default here + SOMAXCONN = 128; + + IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; + + MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. + MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. + + {$ifdef BSD} + {$ifndef OpenBSD} + // Works under MAC OS X and FreeBSD, but is undocumented, so FPC doesn't include it + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + {$else} + MSG_NOSIGNAL = $400; + {$endif} + {$else} + {$ifdef SUNOS} + MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE. + {$else} + MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. + {$endif} + {$endif} + + { TCP options. } + TCP_NODELAY = $0001; + + { Address families. } + AF_UNSPEC = 0; { unspecified } + AF_LOCAL = 1; + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_UNIX = AF_LOCAL; + AF_MAX = 24; + + { Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_MAX = AF_MAX; + +const + WSAEINTR = ESysEINTR; + WSAEBADF = ESysEBADF; + WSAEACCES = ESysEACCES; + WSAEFAULT = ESysEFAULT; + WSAEINVAL = ESysEINVAL; + WSAEMFILE = ESysEMFILE; + WSAEWOULDBLOCK = ESysEWOULDBLOCK; // =WSATRY_AGAIN/ESysEAGAIN on POSIX + WSAEINPROGRESS = ESysEINPROGRESS; + WSAEALREADY = ESysEALREADY; + WSATRY_AGAIN = ESysEAGAIN; + WSAENOTSOCK = ESysENOTSOCK; + WSAEDESTADDRREQ = ESysEDESTADDRREQ; + WSAEMSGSIZE = ESysEMSGSIZE; + WSAEPROTOTYPE = ESysEPROTOTYPE; + WSAENOPROTOOPT = ESysENOPROTOOPT; + WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; + WSAEOPNOTSUPP = ESysEOPNOTSUPP; + WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; + WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; + WSAEADDRINUSE = ESysEADDRINUSE; + WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; + WSAENETDOWN = ESysENETDOWN; + WSAENETUNREACH = ESysENETUNREACH; + WSAENETRESET = ESysENETRESET; + WSAECONNABORTED = ESysECONNABORTED; + WSAECONNRESET = ESysECONNRESET; + WSAENOBUFS = ESysENOBUFS; + WSAEISCONN = ESysEISCONN; + WSAENOTCONN = ESysENOTCONN; + WSAESHUTDOWN = ESysESHUTDOWN; + WSAETOOMANYREFS = ESysETOOMANYREFS; + WSAETIMEDOUT = ESysETIMEDOUT; + WSAECONNREFUSED = ESysECONNREFUSED; + WSAELOOP = ESysELOOP; + WSAENAMETOOLONG = ESysENAMETOOLONG; + WSAEHOSTDOWN = ESysEHOSTDOWN; + WSAEHOSTUNREACH = ESysEHOSTUNREACH; + WSAENOTEMPTY = ESysENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = ESysEUSERS; + WSAEDQUOT = ESysEDQUOT; + WSAESTALE = ESysESTALE; + WSAEREMOTE = ESysEREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = 1; + WSANO_RECOVERY = 3; + WSANO_DATA = -6; + +{$else FPC} // Kylix3 definitions: + +type + TInAddr6 = packed record + case byte of + 0: (u6_addr8 : array[0..15] of byte); + 1: (u6_addr16 : array[0..7] of Word); + 2: (u6_addr32 : array[0..3] of Cardinal); + 3: (s6_addr8 : array[0..15] of shortint); + 4: (s6_addr : array[0..15] of shortint); + 5: (s6_addr16 : array[0..7] of smallint); + 6: (s6_addr32 : array[0..3] of LongInt); + end; + PInAddr6 = ^TInAddr6; + + TSockAddrIn6 = packed Record + sin6_family : sa_family_t; + sin6_port : word; + sin6_flowinfo : cardinal; + sin6_addr : TInAddr6; + sin6_scope_id : cardinal; + end; + +const + WSAEINTR = EINTR; + WSATRY_AGAIN = EAGAIN; + WSAENETDOWN = ENETDOWN; + WSAECONNABORTED = ECONNABORTED; + WSAECONNRESET = ECONNRESET; + WSAEWOULDBLOCK = EWOULDBLOCK; + WSAEPROTONOSUPPORT = EPROTONOSUPPORT; + WSAHOST_NOT_FOUND = HOST_NOT_FOUND; + WSAETIMEDOUT = ETIMEDOUT; + WSAEMFILE = EMFILE; + +{$endif FPC} + + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + + AF_INET6 = 10; { Internetwork Version 6 } + PF_INET6 = AF_INET6; + + 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 } + +type + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + + +type + { Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; + +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + end; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); + +var + in6addr_any, in6addr_loopback : TInAddr6; + +{$ifdef FPC} // some functions inlined redirection to Sockets.pp + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); inline; +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; inline; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); inline; +procedure FD_ZERO(var FDSet: TFDSet); inline; + +function ResolveIPToName(const IP: string; Family,SockProtocol,SockType: integer): string; +function ResolvePort(const Port: string; Family,SockProtocol,SockType: integer): Word; + +function fpbind(s:cint; addrx: psockaddr; addrlen: tsocklen): cint; inline; +function fplisten(s:cint; backlog: cint): cint; inline; +function fprecv(s:cint; buf: pointer; len: size_t; Flags: cint): ssize_t; inline; +function fpsend(s:cint; msg:pointer; len:size_t; flags:cint): ssize_t; inline; + +{$endif FPC} + +const + // we assume that the Posix OS has IP6 compatibility + SockEnhancedApi = true; + SockWship6Api = true; + +type + PVarSin = ^TVarSin; + TVarSin = packed record + {$ifdef SOCK_HAS_SINLEN} + sin_len: cuchar; + {$endif} + case integer of + 0: (AddressFamily: sa_family_t); + 1: ( + case sin_family: sa_family_t of + AF_INET: (sin_port: word; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6:(sin6_port: word; // see sockaddr_in6 + sin6_flowinfo: cardinal; + sin6_addr: TInAddr6; + sin6_scope_id: cardinal); + AF_UNIX: (sun_path: array[0..{$ifdef SOCK_HAS_SINLEN}103{$else}107{$endif}] of Char); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +function WSACleanup: Integer; +function WSAGetLastError: Integer; +function GetHostName: string; +function Shutdown(s: TSocket; how: Integer): Integer; +function SetSockOpt(s: TSocket; level,optname: Integer; optval: pointer; + optlen: Integer): Integer; +function GetSockOpt(s: TSocket; level,optname: Integer; optval: pointer; + var optlen: Integer): Integer; +function SendTo(s: TSocket; Buf: pointer; len,flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: pointer; len,flags: Integer; var from: TVarSin): Integer; +function ntohs(netshort: word): word; +function ntohl(netlong: cardinal): cardinal; +function Listen(s: TSocket; backlog: Integer): Integer; +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +function htons(hostshort: word): word; +function htonl(hostlong: cardinal): cardinal; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function CloseSocket(s: TSocket): Integer; +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; +function Socket(af,Struc,Protocol: Integer): TSocket; +function Select(nfds: Integer; readfds,writefds,exceptfds: PFDSet; + timeout: PTimeVal): Longint; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; const IP,Port: string; + Family,SockProtocol,SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(const Sin: TVarSin): string; +function GetSinPort(const Sin: TVarSin): Integer; +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, SockType: integer; + IPList: TStrings; IPListClear: boolean = true); + +const + // poll() flag when there is data to read + POLLIN = $001; + // poll() flag when there is urgent data to read + POLLPRI = $002; + // poll() flag when writing now will not block + POLLOUT = $004; + // poll() flag error condition (always implicitly polled for) + POLLERR = $008; + // poll() flag hung up (always implicitly polled for) + POLLHUP = $010; + // poll() flag invalid polling request (always implicitly polled for) + POLLNVAL = $020; + // poll() flag when normal data may be read + POLLRDNORM = $040; + // poll() flag when priority data may be read + POLLRDBAND = $080; + // poll() flag when writing now will not block + POLLWRNORM = $100; + // poll() flag when priority data may be written + POLLWRBAND = $200; + // poll() flag extension for Linux + POLLMSG = $400; + +type + /// polling request data structure for poll() + TPollFD = {packed} record + /// file descriptor to poll + fd: integer; + /// types of events poller cares about + // - mainly POLLIN and/or POLLOUT + events: Smallint; + /// types of events that actually occurred + // - caller could just reset revents := 0 to reuse the structure + revents: Smallint; + end; + PPollFD = ^TPollFD; + TPollFDDynArray = array of TPollFD; + +/// Poll the file descriptors described by the nfds structures starting at fds +// - if TIMEOUT is nonzero and not -1, allow TIMEOUT milliseconds for +// an event to occur; if TIMEOUT is -1, block until an event occurs +// - returns the number of file descriptors with events, zero if timed out, +// or -1 for errors +function poll(fds: PPollFD; nfds, timeout: integer): integer; + +{$ifdef Linux} +const + // associated file is available for read operations + EPOLLIN = $01; + // urgent data available for read operations + EPOLLPRI = $02; + // associated file is available for write operations + EPOLLOUT = $04; + // error condition happened on the associated file descriptor + EPOLLERR = $08; + // hang up happened on the associated file descriptor + EPOLLHUP = $10; + // sets the One-Shot behaviour for the associated file descriptor + // - i.e. after an event is pulled out, the file descriptor is disabled + EPOLLONESHOT = $40000000; + // sets the Edge-Triggered (ET) behaviour for the associated file descriptor + EPOLLET = $80000000; + + EPOLL_CTL_ADD = 1; + EPOLL_CTL_DEL = 2; + EPOLL_CTL_MOD = 3; + +type + /// application-level data structure for epoll + TEPollData = record + case integer of + 0: (ptr: pointer); + 1: (fd: integer); + 2: (u32: cardinal); + 3: (u64: Int64); + 4: (obj: TObject); + end; + PEPollData = ^TEPollData; + + /// epoll descriptor data structure + TEPollEvent = packed record + events: cardinal; + data: TEpollData; + end; + PEPollEvent = ^TEPollEvent; + TEPollEventDynArray = array of TEPollEvent; + +/// open an epoll file descriptor +function epoll_create(size: integer): integer; + {$ifdef FPC}inline;{$endif} {$ifdef KYLIX3}cdecl;{$endif} + +/// control interface for an epoll descriptor +function epoll_ctl(epfd, op, fd: integer; event: PEPollEvent): integer; + {$ifdef FPC}inline;{$endif} {$ifdef KYLIX3}cdecl;{$endif} + +/// wait for an I/O event on an epoll file descriptor +function epoll_wait(epfd: integer; events: PEPollEvent; maxevents, timeout: integer): integer; + {$ifdef FPC}inline;{$endif} {$ifdef KYLIX3}cdecl;{$endif} + +/// finalize an epoll file descriptor +// - call fpclose/libc.close +function epoll_close(epfd: integer): integer; +{$endif Linux} + +var + SynSockCS: TRTLCriticalSection; + +implementation + +{$ifdef USELIBC} +{$i SynFPCSockLIBC.inc} +{$endif} + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr32[0]=0) and (a^.u6_addr32[1]=0) and + (a^.u6_addr32[2]=0) and (a^.u6_addr32[3]=0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr32[0]=0) and (a^.u6_addr32[1]=0) and + (a^.u6_addr32[2]=0) and + (a^.u6_addr8[12]=0) and (a^.u6_addr8[13]=0) and + (a^.u6_addr8[14]=0) and (a^.u6_addr8[15]=1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr8[0]=$FE) and (a^.u6_addr8[1]=$80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr8[0]=$FE) and (a^.u6_addr8[1]=$C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + result := (a^.u6_addr8[0]=$FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + result := CompareMem(a,b,sizeof(TInAddr6)); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^,sizeof(TInAddr6),0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^,sizeof(TInAddr6),0); + a^.u6_addr8[15] := 1; +end; + + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synopse Sockets'; + szSystemStatus := 'Linux'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + result := 0; +end; + +function WSACleanup: Integer; +begin + result := 0; +end; + +function WSAGetLastError: Integer; +begin + result := {$ifdef KYLIX3}errno{$else}fpGetErrno{$endif}; +end; + +{$ifdef FPC} + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + result := fpFD_ISSET(socket,fdset) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_SET(Socket,fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_CLR(Socket,fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + fpFD_ZERO(fdset); +end; + +{$ifndef USELIBC} +function fpbind(s:cint; addrx: psockaddr; addrlen: tsocklen): cint; +begin + result := sockets.fpbind(s, addrx, addrlen); +end; + +function fplisten(s:cint; backlog : cint): cint; +begin + result := sockets.fplisten(s, backlog); +end; + +function fprecv(s:cint; buf: pointer; len: size_t; Flags: cint): ssize_t; +begin + result := sockets.fprecv(s, buf, len, Flags); +end; + +function fpsend(s:cint; msg:pointer; len:size_t; flags:cint): ssize_t; +begin + result := sockets.fpsend(s, msg, len, flags); +end; +{$endif USELIBC} + +{$endif FPC} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: result := SizeOf(TSockAddrIn); + AF_INET6: result := SizeOf(TSockAddrIn6); + AF_UNIX: result := SizeOf(sockaddr_un); + else result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin + {$ifdef KYLIX3} + if LibC.Bind(s,PSockAddr(@addr)^,SizeOfVarSin(addr))=0 then + {$else} + if fpBind(s,@addr,SizeOfVarSin(addr))=0 then + {$endif} + result := 0 else + result := SOCKET_ERROR; +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + {$ifdef KYLIX3} + if LibC.Connect(s,PSockAddr(@name)^,SizeOfVarSin(name))=0 then + {$else} + if fpConnect(s,@name,SizeOfVarSin(name))=0 then + {$endif} + result := 0 else + result := SOCKET_ERROR; +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var len: integer; +begin + len := SizeOf(name); + FillChar(name,len,0); + {$ifdef KYLIX3} + result := LibC.getsockname(s,PSockAddr(@name)^,PSocketLength(@len)^); + {$else} + result := fpGetSockName(s,@name,@len); + {$endif} +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var len: integer; +begin + len := SizeOf(name); + FillChar(name,len,0); + {$ifdef KYLIX3} + result := LibC.getpeername(s,PSockAddr(@name)^,PSocketLength(@len)^); + {$else} + result := fpGetPeerName(s,@name,@len); + {$endif} +end; + +function GetHostName: string; +{$ifdef KYLIX3} +var tmp: array[byte] of char; +begin + LibC.gethostname(tmp,sizeof(tmp)-1); + result := tmp; +end; +{$else} +begin + result := unix.GetHostName; +end; +{$endif} + +function SendTo(s: TSocket; Buf: pointer; len,flags: Integer; addrto: TVarSin): Integer; +begin + {$ifdef KYLIX3} + result := LibC.sendto(s,Buf^,len,flags,PSockAddr(@addrto)^,SizeOfVarSin(addrto)); + {$else} + result := fpSendTo(s,pointer(Buf),len,flags,@addrto,SizeOfVarSin(addrto)); + {$endif} +end; + +function RecvFrom(s: TSocket; Buf: pointer; len,flags: Integer; var from: TVarSin): Integer; +var x: integer; +begin + x := SizeOf(from); + {$ifdef KYLIX3} + result := LibC.recvfrom(s,Buf^,len,flags,PSockAddr(@from),PSocketLength(@x)); + {$else} + result := fpRecvFrom(s,pointer(Buf),len,flags,@from,@x); + {$endif} +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var x: integer; +begin + x := SizeOf(addr); + {$ifdef KYLIX3} + result := LibC.accept(s,PSockAddr(@addr),PSocketLength(@x)); + {$else} + result := fpAccept(s,@addr,@x); + {$endif} +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + {$ifdef KYLIX3} + result := LibC.shutdown(s,how); + {$else} + result := fpShutdown(s,how); + {$endif} +end; + +function SetSockOpt(s: TSocket; level,optname: Integer; optval: pointer; + optlen: Integer): Integer; +begin + result := {$ifdef KYLIX3}LibC.setsockopt{$else}fpsetsockopt{$endif}( + s,level,optname,optval ,optlen); +end; + +function GetSockOpt(s: TSocket; level,optname: Integer; optval: pointer; + var optlen: Integer): Integer; +begin + {$ifdef KYLIX3} + result := LibC.getsockopt(s,level,optname,pointer(optval),socklen_t(optlen)); + {$else} + result := fpgetsockopt(s,level,optname,pointer(optval),@optlen); + {$endif} +end; + +function ntohs(netshort: word): word; +begin + result := {$ifdef KYLIX3}LibC{$else}sockets{$endif}.ntohs(NetShort); +end; + +function ntohl(netlong: cardinal): cardinal; +begin + result := {$ifdef KYLIX3}LibC{$else}sockets{$endif}.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if {$ifdef KYLIX3}LibC.listen{$else}fpListen{$endif}(s,backlog)=0 then + result := 0 else + result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +begin + {$ifdef KYLIX3} + result := ioctl(s,cmd,@arg); + {$else} + result := fpIoctl(s,cmd,@arg); + {$endif} +end; + +function htons(hostshort: word): word; +begin + result := {$ifdef KYLIX3}LibC{$else}sockets{$endif}.htons(hostshort); +end; + +function htonl(hostlong: cardinal): cardinal; +begin + result := {$ifdef KYLIX3}LibC{$else}sockets{$endif}.htonl(hostlong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + {$ifdef KYLIX3} + result := Libc.__close(s); + {$else} + result := sockets.CloseSocket(s); + {$endif} +end; + +function Socket(af,Struc,Protocol: Integer): TSocket; +{$IF defined(BSD) AND NOT defined(OpenBSD)} +var + on_off: integer; +{$ENDIF} +begin + result := {$ifdef KYLIX3}LibC.socket{$else}fpSocket{$endif}(af,struc,protocol); +// ##### Patch for BSD to avoid "Project XXX raised exception class 'External: SIGPIPE'" error. +{$IF defined(BSD) AND NOT defined(OpenBSD)} + if result <> INVALID_SOCKET then begin + on_off := 1; + fpSetSockOpt(result,integer(SOL_SOCKET),integer(SO_NOSIGPIPE),@on_off,SizeOf(integer)); + end; +{$ENDIF} +end; + +function Select(nfds: Integer; readfds,writefds,exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + result := {$ifdef KYLIX3}LibC.select{$else}fpSelect{$endif}( + nfds,readfds,writefds,exceptfds,timeout); +end; + +function IsNewApi(Family: integer): Boolean; +begin + result := SockEnhancedApi; + if not result then + result := (Family=AF_INET6) and SockWship6Api; +end; + +function GetSinPort(const Sin: TVarSin): Integer; +begin + if (Sin.sin_family=AF_INET6) then + result := ntohs(Sin.sin6_port) else + result := ntohs(Sin.sin_port); +end; + +function poll(fds: PPollFD; nfds, timeout: integer): integer; +begin + {$ifdef KYLIX3} + result := libc.poll(pointer(fds),nfds,timeout); + {$else} + result := fppoll(pointer(fds),nfds,timeout); + {$endif} +end; + +{$ifdef KYLIX3} // those functions only use the new API + +function SetVarSin(var Sin: TVarSin; const IP,Port: string; + Family,SockProtocol,SockType: integer; PreferIP4: Boolean): integer; + function GetAddr(const IP, port: string; var Hints: addrinfo; var Sin: TVarSin): integer; + var Addr: PAddressInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype=SOCK_RAW then begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + result := LibC.getaddrinfo(pointer(IP), nil, @Hints, Addr); + end else + if (IP=cAnyHost) or (IP=c6AnyHost) then begin + Hints.ai_flags := AI_PASSIVE; + result := LibC.getaddrinfo(nil, pointer(Port), @Hints, Addr); + end else + if (IP = cLocalhost) or (IP = c6Localhost) then + result := LibC.getaddrinfo(nil, pointer(Port), @Hints, Addr) else + result := LibC.getaddrinfo(pointer(IP), pointer(Port), @Hints, Addr); + if (Result=0) and (Addr<>nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + LibC.freeaddrinfo(Addr); + end; + end; + +var Hints1, Hints2: addrinfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; +begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family=AF_UNSPEC then begin + if PreferIP4 then begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end else begin + Hints1.ai_family := AF_INET6; + Hints2.ai_family := AF_INET; + TwoPass := True; + end; + end else + Hints1.ai_family := Family; + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := SockType; + Hints2.ai_protocol := SockProtocol; + result := GetAddr(IP, Port, Hints1, Sin1); + if result=0 then + sin := sin1 else + if TwoPass then begin + result := GetAddr(IP, Port, Hints2, Sin2); + if result=0 then + sin := sin2; + end; +end; + +function GetSinIP(const Sin: TVarSin): string; +var host: array[0..NI_MAXHOST] of char; + serv: array[0..NI_MAXSERV] of char; + r: integer; +begin + r := LibC.getnameinfo(PSockAddr(@sin)^,SizeOfVarSin(sin), host,NI_MAXHOST, + serv,NI_MAXSERV, NI_NUMERICHOST+NI_NUMERICSERV); + if r=0 then + result := host else + result := ''; +end; + +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, SockType: integer; + IPList: TStrings; IPListClear: boolean); +var + Hints: TAddressInfo; + Addr: PAddressInfo; + AddrNext: PAddressInfo; + r, prev: integer; + host, serv: string; + hostlen, servlen: integer; +begin + if IPListClear then + IPList.Clear; + Addr := nil; + try // we force to find TCP/IP + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := Family; + Hints.ai_protocol := SockProtocol; + Hints.ai_socktype := SockType; + r := LibC.getaddrinfo(pointer(Name), nil, @Hints, Addr); + if r=0 then begin + AddrNext := Addr; + while not(AddrNext=nil) do begin + if not(((Family=AF_INET6) and (AddrNext^.ai_family=AF_INET)) + or ((Family=AF_INET) and (AddrNext^.ai_family=AF_INET6))) then begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host,hostlen); + setlength(serv,servlen); + r := LibC.getnameinfo(AddrNext^.ai_addr^, AddrNext^.ai_addrlen, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r=0 then begin + host := PChar(host); + IPList.Add(host); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + LibC.freeaddrinfo(Addr); + end; + if IPList.Count=0 then + IPList.Add(cAnyHost); +end; + +{$else} // FPC version + +function SetVarSin(var Sin: TVarSin; const IP,Port: string; + Family,SockProtocol,SockType: integer; PreferIP4: Boolean): integer; +var TwoPass: boolean; + f1,f2: integer; + + function GetAddr(f:integer): integer; + var a4: array[1..1] of TInAddr; + a6: array[1..1] of TInAddr6; + he: THostEntry; + begin + result := WSAEPROTONOSUPPORT; + case f of + AF_INET: begin + if IP=cAnyHost then begin + Sin.sin_family := AF_INET; + result := 0; + end else begin + if lowercase(IP)=cLocalHostStr then + a4[1].s_addr := htonl(INADDR_LOOPBACK) else begin + a4[1].s_addr := 0; + result := WSAHOST_NOT_FOUND; + a4[1] := StrTonetAddr(IP); + if a4[1].s_addr=INADDR_ANY then + if GetHostByName(ip,he) then + a4[1] := HostToNet(he.Addr) else + Resolvename(ip,a4); + end; + if a4[1].s_addr <> INADDR_ANY then begin + Sin.sin_family := AF_INET; + sin.sin_addr := a4[1]; + result := 0; + end; + end; + end; + AF_INET6: begin + if IP=c6AnyHost then begin + Sin.sin_family := AF_INET6; + result := 0; + end else begin + if lowercase(IP)=cLocalHostStr then + SET_LOOPBACK_ADDR6(@a6[1]) else begin + result := WSAHOST_NOT_FOUND; + SET_IN6_IF_ADDR_ANY(@a6[1]); + a6[1] := StrTonetAddr6(IP); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + Resolvename6(ip,a6); + end; + if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then begin + Sin.sin_family := AF_INET6; + sin.sin6_addr := a6[1]; + result := 0; + end; + end; + end; + end; + end; +begin + result := 0; + if (Family=AF_UNIX) then begin + Sin.AddressFamily := AF_UNIX; + Move(IP[1],Sin.sun_path,length(IP)); + Sin.sun_path[length(IP)]:=#0; + exit; + end; + FillChar(Sin,SizeOf(Sin),0); + Sin.sin_port := Resolveport(port,family,SockProtocol,SockType); + TwoPass := false; + if Family=AF_UNSPEC then begin + if PreferIP4 then begin + f1 := AF_INET; + f2 := AF_INET6; + TwoPass := true; + end else begin + f2 := AF_INET6; + f1 := AF_INET; + TwoPass := true; + end; + end else + f1 := Family; + result := GetAddr(f1); + if result <> 0 then + if TwoPass then + result := GetAddr(f2); +end; + +function GetSinIP(const Sin: TVarSin): string; +begin + result := ''; + case sin.AddressFamily of + AF_INET: result := NetAddrToStr(sin.sin_addr); + AF_INET6: result := NetAddrToStr6(sin.sin6_addr); + end; +end; + +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, SockType: integer; + IPList: TStrings; IPListClear: boolean); +var x,n: integer; + a4: array[1..255] of in_addr; + a6: array[1..255] of Tin6_addr; + he: THostEntry; +begin + if IPListClear then + IPList.Clear; + if (family=AF_INET) or (family=AF_UNSPEC) then begin + if lowercase(name)=cLocalHostStr then + IpList.Add(cLocalHost) + else if name=cAnyHost then + IpList.Add(cAnyHost) + else begin + a4[1] := StrTonetAddr(name); + if a4[1].s_addr=INADDR_ANY then + if GetHostByName(name,he) then begin + a4[1] := HostToNet(he.Addr); + x := 1; + end else + x := Resolvename(name,a4) else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr(a4[n])); + end; + end; + if (family=AF_INET6) or (family=AF_UNSPEC) then begin + if lowercase(name)=cLocalHostStr then + IpList.Add(c6LocalHost) + else if name=c6AnyHost then + IpList.Add(c6AnyHost) + else begin + a6[1] := StrTonetAddr6(name); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + x := Resolvename6(name,a6) else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr6(a6[n])); + end; + end; + if IPList.Count=0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(const Port: string; Family,SockProtocol,SockType: integer): Word; +var ProtoEnt: TProtocolEntry; + ServEnt: TServiceEntry; +begin + result := htons(StrToIntDef(Port,0)); + if result=0 then begin + ProtoEnt.Name := ''; + GetProtocolByNumber(SockProtocol,ProtoEnt); + ServEnt.port := 0; + GetServiceByName(Port,ProtoEnt.Name,ServEnt); + result := ServEnt.port; + end; +end; + +function ResolveIPToName(const IP: string; Family,SockProtocol,SockType: integer): string; +var n: integer; + a4: array[1..1] of TInAddr; + a6: array[1..1] of TInAddr6; + a: array[1..1] of string; +begin + result := IP; + a4[1] := StrToNetAddr(IP); + if a4[1].s_addr <> INADDR_ANY then begin + n := ResolveAddress(nettohost(a4[1]),a); + if n>0 then + result := a[1]; + end else begin + a6[1] := StrToNetAddr6(IP); + n := ResolveAddress6(a6[1],a); + if n>0 then + result := a[1]; + end; +end; + +{$endif KYLIX3} + +{$ifdef Linux} // epoll is Linux-specific + +{$ifdef FPC} // use Linux.pas wrappers +function epoll_create(size: integer): integer; +begin + result := Linux.epoll_create(size); +end; + +function epoll_ctl(epfd, op, fd: integer; event: PEPollEvent): integer; +begin + result := Linux.epoll_ctl(epfd, op, fd, pointer(event)); +end; + +function epoll_wait(epfd: integer; events: PEPollEvent; maxevents, timeout: integer): integer; +begin + result := Linux.epoll_wait(epfd, pointer(events), maxevents, timeout); +end; + +function epoll_close(epfd: integer): integer; +begin + result := fpClose(epfd); +end; +{$endif} + +{$ifdef KYLIX3} // use libc.so wrappers +function epoll_create; external libcmodulename name 'epoll_create'; +function epoll_ctl; external libcmodulename name 'epoll_ctl'; +function epoll_wait; external libcmodulename name 'epoll_wait'; + +function epoll_close(epfd: integer): integer; +begin + result := __close(epfd); +end; +{$endif} + +{$endif Linux} + +procedure DestroySocketInterface; +begin + // nothing to do, since we use either the FPC units, either LibC.pas +end; + +initialization + SET_IN6_IF_ADDR_ANY(@in6addr_any); + SET_LOOPBACK_ADDR6(@in6addr_loopback); + InitializeCriticalSection(SynSockCS); + +finalization + DeleteCriticalSection(SynSockCS); +end. diff --git a/mORMot/SynFPCSockLIBC.inc b/mORMot/SynFPCSockLIBC.inc new file mode 100644 index 00000000..e0424459 --- /dev/null +++ b/mORMot/SynFPCSockLIBC.inc @@ -0,0 +1,154 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +//{$define uselibc:=cdecl; external;} + +Uses + initc; + +threadvar internal_socketerror : cint; + +const + {$ifdef BEOS} + {$ifdef HAIKU} + libname = 'network'; + {$else} + libname = 'net'; + {$endif} + {$else} + libname='c'; + {$endif} + +function cfpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; cdecl; external libname name 'accept'; +function cfpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; cdecl; external libname name 'bind'; +function cfpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint; cdecl; external libname name 'connect'; +function cfpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint; cdecl; external libname name 'getpeername'; +function cfpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint; cdecl; external libname name 'getsockname'; +function cfpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint; cdecl; external libname name 'getsockopt'; +function cfplisten (s:cint; backlog : cint):cint; cdecl; external libname name 'listen'; +function cfprecv (s:cint; buf: pointer; len: size_t; flags: cint):ssize_t; cdecl; external libname name 'recv'; +function cfprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t; cdecl; external libname name 'recvfrom'; +//function cfprecvmsg (s:cint; msg: pmsghdr; flags:cint):ssize_t; cdecl; external libname name ''; +function cfpsend (s:cint; msg:pointer; len:size_t; flags:cint):ssize_t; cdecl; external libname name 'send'; +function cfpsendto (s:cint; msg:pointer; len:size_t; flags:cint; tox :psockaddr; tolen: tsocklen):ssize_t; cdecl; external libname name 'sendto'; +//function cfpsendmsg (s:cint; hdr: pmsghdr; flags:cint):ssize; cdecl; external libname name ''; +function cfpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint; cdecl; external libname name 'setsockopt'; +function cfpshutdown (s:cint; how:cint):cint; cdecl; external libname name 'shutdown'; +function cfpsocket (domain:cint; xtype:cint; protocol: cint):cint; cdecl; external libname name 'socket'; + +{$if defined(BEOS) and not defined(HAIKU)} +// function unavailable under BeOS +{$else} +function cfpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; cdecl; external libname name 'socketpair'; +{$endif} + + +function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; + +begin + fpaccept:=cfpaccept(s,addrx,addrlen); + internal_socketerror:=fpgeterrno; +end; + +function fpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; +begin + fpbind:=cfpbind (s,addrx,addrlen); + internal_socketerror:=fpgeterrno; +end; + +function fpconnect (s:cint; name : psockaddr; namelen : tsocklen):cint; +begin + fpconnect:=cfpconnect (s,name,namelen); + internal_socketerror:=fpgeterrno; +end; + +function fpgetpeername (s:cint; name : psockaddr; namelen : psocklen):cint; +begin + fpgetpeername:=cfpgetpeername (s,name,namelen); + internal_socketerror:=fpgeterrno; +end; + +function fpgetsockname (s:cint; name : psockaddr; namelen : psocklen):cint; +begin + fpgetsockname:=cfpgetsockname(s,name,namelen); + internal_socketerror:=fpgeterrno; +end; + +function fpgetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen : psocklen):cint; +begin + fpgetsockopt:=cfpgetsockopt(s,level,optname,optval,optlen); + internal_socketerror:=fpgeterrno; +end; + +function fplisten (s:cint; backlog : cint):cint; +begin + fplisten:=cfplisten(s,backlog); + internal_socketerror:=fpgeterrno; +end; + +function fprecv (s:cint; buf: pointer; len: size_t; flags:cint):ssize_t; +begin + fprecv:= cfprecv (s,buf,len,flags); + internal_socketerror:=fpgeterrno; +end; + +function fprecvfrom (s:cint; buf: pointer; len: size_t; flags: cint; from : psockaddr; fromlen : psocklen):ssize_t; +begin + fprecvfrom:= cfprecvfrom (s,buf,len,flags,from,fromlen); + internal_socketerror:=fpgeterrno; +end; + +function fpsend (s:cint; msg:pointer; len:size_t; flags:cint):ssize_t; +begin + fpsend:=cfpsend (s,msg,len,flags); + internal_socketerror:=fpgeterrno; +end; + +function fpsendto (s:cint; msg:pointer; len:size_t; flags:cint; tox :psockaddr; tolen: tsocklen):ssize_t; +begin + fpsendto:=cfpsendto (s,msg,len,flags,tox,tolen); + internal_socketerror:=fpgeterrno; +end; + +function fpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint; +begin + fpsetsockopt:=cfpsetsockopt(s,level,optname,optval,optlen); + internal_socketerror:=fpgeterrno; +end; + +function fpshutdown (s:cint; how:cint):cint; +begin + fpshutdown:=cfpshutdown(s,how); + internal_socketerror:=fpgeterrno; +end; + +function fpsocket (domain:cint; xtype:cint; protocol: cint):cint; +begin + fpsocket:=cfpsocket(domain,xtype,protocol); + internal_socketerror:=fpgeterrno; +end; + +{$if defined(BEOS) and not defined(HAIKU)} +// function unavailable under BeOS +function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; +begin + internal_socketerror:= -1; // TODO : check if it is an error +end; +{$else} +function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; +begin + fpsocketpair:=cfpsocketpair(d,xtype,protocol,sv); + internal_socketerror:=fpgeterrno; +end; +{$endif} diff --git a/mORMot/SynFPCTypInfo.pas b/mORMot/SynFPCTypInfo.pas new file mode 100644 index 00000000..e11c4d62 --- /dev/null +++ b/mORMot/SynFPCTypInfo.pas @@ -0,0 +1,200 @@ +/// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas +// - this unit is a part of the freeware Synopse mORMot framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynFPCTypInfo; + +{ + This file is part of Synopse mORMot framework. + + Synopse mORMot framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse mORMot framework. + + The Initial Developer of the Original Code is Alfred Glaenzer. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + - Arnaud Bouchez + + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. if you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. if you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + + Unit created to avoid polluting the SynCommons.pas/mORMot.pas namespace + with overloaded typinfo.pp types. + +} + +interface + +{$ifndef FPC} + 'this unit is for FPC only - do not include it in any Delphi project!' +{$endif FPC} + +{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER + +uses + SysUtils, + TypInfo; + +{$ifdef FPC_PROVIDE_ATTR_TABLE} +type + // if you have a compilation error here, your FPC trunk is too old + // - TTypeData.AttributeTable was introduced in SVN 42356-42411 (2019/07) + // -> undefine FPC_PROVIDE_ATTR_TABLE in Synopse.inc and recompile + PFPCAttributeTable = TypInfo.PAttributeTable; +{$endif FPC_PROVIDE_ATTR_TABLE} + +{$ifdef HASALIGNTYPEDATA} +function AlignTypeData(p: pointer): pointer; inline; +function AlignTypeDataClean(p: pointer): pointer; inline; +{$else} +type + AlignTypeData = pointer; + AlignTypeDataClean = pointer; +{$endif HASALIGNTYPEDATA} + + +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} +function AlignToPtr(p: pointer): pointer; inline; +function AlignPTypeInfo(p: pointer): pointer; inline; +{$else FPC_REQUIRES_PROPER_ALIGNMENT} +type + AlignToPtr = pointer; + AlignPTypeInfo = pointer; +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + +type + /// some type definition to avoid inclusion of TypInfo in SynCommons/mORMot.pas + PFPCInterfaceData = TypInfo.PInterfaceData; + PFPCVmtMethodParam = TypInfo.PVmtMethodParam; + PFPCIntfMethodTable = TypInfo.PIntfMethodTable; + PFPCIntfMethodEntry = TypInfo.PIntfMethodEntry; +{$ifdef FPC_NEWRTTI} + PFPCRecInitData = TypInfo.PRecInitData; + +{$endif FPC_NEWRTTI} + +procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); +procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); +procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); +procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); +procedure FPCRecordAddRef(var Data; TypeInfo : pointer); + + +implementation + +procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); + external name 'FPC_DYNARRAY_CLEAR'; +procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); + external name 'FPC_FINALIZE_ARRAY'; +procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); + external name 'FPC_FINALIZE'; +procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); + external name 'FPC_COPY'; +procedure FPCRecordAddRef(var Data; TypeInfo : pointer); + external name 'FPC_ADDREF'; + +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp +function AlignToPtr(p: pointer): pointer; +begin + result := align(p,sizeof(p)); +end; + +function AlignTypeData(p: pointer): pointer; +{$packrecords c} + type + TAlignCheck = record // match RTTI TTypeInfo definition + b : byte; // = TTypeKind + q : qword; // = this is where the PTypeData begins + end; +{$packrecords default} +begin +{$ifdef VER3_0} + result := Pointer(align(p,SizeOf(Pointer))); +{$else VER3_0} + result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); +{$endif VER3_0} + {$ifdef FPC_PROVIDE_ATTR_TABLE} + inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table + result := Pointer(align(result,PtrInt(@TAlignCheck(nil^).q))); + {$endif FPC_PROVIDE_ATTR_TABLE} +end; +{$else} +{$ifdef FPC_PROVIDE_ATTR_TABLE} +function AlignTypeData(p: pointer): pointer; +begin + result := p; + inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table +end; +{$endif FPC_PROVIDE_ATTR_TABLE} +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp + +function AlignTypeDataClean(p: pointer): pointer; +{$packrecords c} + type + TAlignCheck = record // match RTTI TTypeInfo definition + b : byte; // = TTypeKind + q : qword; // = this is where the PTypeData begins + end; +{$packrecords default} +begin + {$ifdef VER3_0} + result := Pointer(align(p,SizeOf(Pointer))); + {$else VER3_0} + result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); + {$endif VER3_0} +end; + +function AlignPTypeInfo(p: pointer): pointer; inline; +{$packrecords c} + type + TAlignCheck = record + b : byte; + p : pointer; + end; +{$packrecords default} +begin + Result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).p))) + +end; + +{$else} +{$ifdef HASALIGNTYPEDATA} +function AlignTypeDataClean(p: pointer): pointer; +begin + result := p; +end; +{$endif HASALIGNTYPEDATA} + +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + +end. diff --git a/mORMot/SynWinSock.pas b/mORMot/SynWinSock.pas new file mode 100644 index 00000000..873a62eb --- /dev/null +++ b/mORMot/SynWinSock.pas @@ -0,0 +1,1959 @@ +/// low level access to network Sockets for the Win32 platform +// - this unit is a part of the freeware Synopse framework, +// licensed under a MPL/GPL/LGPL tri-license; version 1.18 +unit SynWinSock; + +{ + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synapse library. + + The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic). + Portions created by Lukas Gebauer are Copyright (C) 2003. + All Rights Reserved. + + Portions created by Arnaud Bouchez are Copyright (C) 2023 Arnaud Bouchez. + All Rights Reserved. + + Contributor(s): + - Arnaud Bouchez, Jan 2009, for SynCrtSock: see https://synopse.info + Delphi 2009/2010 compatibility (Jan 2010): the WinSock library + expects Ansi encoded parameters + - Svetozar Belic (transmogrifix) + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** + +} + +{.$DEFINE WINSOCK1} +{If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install an update from microsoft} + +{.$DEFINE FORCEOLDAPI} +{If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. For IPv6 support you must have the new API! } + +{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER + +interface +{$ifdef MSWINDOWS} +uses + SysUtils, + Classes, + Windows; + +function InitSocketInterface(const stack: TFileName=''): Boolean; +function DestroySocketInterface: Boolean; + +const +{$ifdef WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$endif} + +type + u_char = AnsiChar; + u_short = Word; + u_int = integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; + {$ifdef FPC} + TSocket = PtrInt; + {$else} + {$ifdef UNICODE} + TSocket = NativeInt; + {$else} + TSocket = integer; + {$endif UNICODE} + {$endif} + + +const + {$ifdef WINSOCK1} + DLLStackName: PChar = 'wsock32.dll'; + {$ELSE} + DLLStackName: PChar = 'ws2_32.dll'; + {$endif} + DLLwship6: PChar = 'wship6.dll'; + DLLSecur32: PChar = 'secur32.dll'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + + +const + FD_SETSIZE = 64; + +type + PFDSet = ^TFDSet; + TFDSet = record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + + PInAddr = ^TInAddr; + TInAddr = packed record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = packed record + case integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of AnsiChar); + 1: (sa_family: u_short; + sa_data: array[0..13] of AnsiChar) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = packed record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = packed record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: integer; + end; + + PHostEnt = ^THostEnt; + THostEnt = packed record + h_name: PAnsiChar; + h_aliases: ^PAnsiChar; + h_addrtype: Smallint; + h_length: Smallint; + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = packed record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; + n_addrtype: Smallint; + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = packed record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; + s_port: Smallint; + s_proto: PAnsiChar; + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = packed record + p_name: PAnsiChar; + p_aliases: ^PAnsiChar; + p_proto: Smallint; + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$ifdef WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$endif} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = packed record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PAnsiChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address AnsiString. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: u_short; + l_linger: u_short; + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); // legacy error + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; + + SHUT_RD = 0; + SHUT_WR = 1; + SHUT_RDWR = 2; + +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; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +function FD_ISSET(Socket: TSocket; const FDSet: TFDSet): boolean; +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + + +// poll() emulation via WSAPoll() extension API available since Vista + +const + // poll/WSAPoll flag when normal data may be read + POLLRDNORM = $0100; + // poll/WSAPoll flag when priority data may be read + POLLRDBAND = $0200; + // poll/WSAPoll flag when there is data to read + POLLIN = POLLRDNORM or POLLRDBAND; + // poll/WSAPoll flag when there is urgent data to read + POLLPRI = $0400; + // poll/WSAPoll flag when writing now will not block + POLLOUT = $0010; + // poll/WSAPoll flag error condition (always implicitly polled for) + POLLERR = $0001; + // poll/WSAPoll flag hung up (always implicitly polled for) + POLLHUP = $0002; + // poll/WSAPoll flag invalid polling request (always implicitly polled for) + POLLNVAL = $0004; + // poll/WSAPoll flag when writing now will not block + POLLWRNORM = $0010; + // poll/WSAPoll flag when priority data may be written + POLLWRBAND = $0020; + +type + /// polling request data structure for poll/WSAPoll + TPollFD = record + /// file descriptor to poll + fd: TSocket; + /// types of events poller cares about + // - mainly POLLIN and/or POLLOUT + events: SHORT; + /// types of events that actually occurred + // - caller could just reset revents := 0 to reuse the structure + revents: SHORT; + end; + PPollFD = ^TPollFD; + TPollFDDynArray = array of TPollFD; + +/// Poll the file descriptors described by the NFDS structures starting at fds +// - under Windows, will call WSAPoll() emulation API - see +// https://blogs.msdn.microsoft.com/wndp/2006/10/26 +// - if TIMEOUT is nonzero and not -1, allow TIMEOUT milliseconds for +// an event to occur; if TIMEOUT is -1, block until an event occurs +// - returns the number of file descriptors with events, zero if timed out, +// or -1 for errors +// - before Vista, will return -1 since the API extension was not yet defined +// - in practice, this API is actually slightly SLOWER than optimized Select() :( +function poll(fds: PPollFD; nfds, timeout: integer): integer; + + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): integer; stdcall; + TWSACleanup = function: integer; stdcall; + TWSAGetLastError = function: integer; stdcall; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; stdcall; + TGetServByPort = function(port: integer; proto: PAnsiChar): PServEnt; stdcall; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; stdcall; + TGetProtoByNumber = function(proto: integer): PProtoEnt; stdcall; + TGetHostByName = function(name: PAnsiChar): PHostEnt; stdcall; + TGetHostByAddr = function(addr: Pointer; len, Struc: integer): PHostEnt; stdcall; + TGetHostName = function(name: PAnsiChar; len: integer): integer; stdcall; + TShutdown = function(s: TSocket; how: integer): integer; stdcall; + TSetSockOpt = function(s: TSocket; level, optname: integer; optval: PAnsiChar; + optlen: integer): integer; stdcall; + TGetSockOpt = function(s: TSocket; level, optname: integer; optval: PAnsiChar; + var optlen: integer): integer; stdcall; + TSendTo = function(s: TSocket; Buf: pointer; len, flags: integer; addrto: PSockAddr; + tolen: integer): integer; stdcall; + TSend = function(s: TSocket; Buf: pointer; len, flags: integer): integer; stdcall; + TRecv = function(s: TSocket; Buf: pointer; len, flags: integer): integer; stdcall; + TRecvFrom = function(s: TSocket; Buf: pointer; len, flags: integer; from: PSockAddr; + fromlen: PInteger): integer; stdcall; + Tntohs = function(netshort: u_short): u_short; stdcall; + Tntohl = function(netlong: u_long): u_long; stdcall; + TListen = function(s: TSocket; backlog: integer): integer; stdcall; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): integer; stdcall; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; stdcall; + TInet_addr = function(cp: PAnsiChar): u_long; stdcall; + Thtons = function(hostshort: u_short): u_short; stdcall; + Thtonl = function(hostlong: u_long): u_long; stdcall; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: integer): integer; stdcall; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: integer): integer; stdcall; + TConnect = function(s: TSocket; name: PSockAddr; namelen: integer): integer; stdcall; + TCloseSocket = function(s: TSocket): integer; stdcall; + TBind = function(s: TSocket; addr: PSockAddr; namelen: integer): integer; stdcall; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: integer): TSocket; stdcall; + TTSocket = function(af, Struc, Protocol: integer): TSocket; stdcall; + TSelect = function(nfds: integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; stdcall; + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; stdcall; + TFreeAddrInfo = procedure(ai: PAddrInfo); stdcall; + TGetNameInfo = function( addr: PSockAddr; namelen: integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; stdcall; + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; stdcall; + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; stdcall; + TWSAPoll = function(fds: PPollFD; nfds, timeout: integer): integer; stdcall; + +var + WSAStartup: TWSAStartup; + WSACleanup: TWSACleanup; + WSAGetLastError: TWSAGetLastError; + GetServByName: TGetServByName; + GetServByPort: TGetServByPort; + GetProtoByName: TGetProtoByName; + GetProtoByNumber: TGetProtoByNumber; + GetHostByName: TGetHostByName; + GetHostByAddr: TGetHostByAddr; + ssGetHostName: TGetHostName; + Shutdown: TShutdown; + SetSockOpt: TSetSockOpt; + GetSockOpt: TGetSockOpt; + SendTo: TSendTo; + Send: TSend; + Recv: TRecv; + RecvFrom: TRecvFrom; + ntohs: Tntohs; + ntohl: Tntohl; + Listen: TListen; + IoctlSocket: TIoctlSocket; + Inet_ntoa: TInet_ntoa; + Inet_addr: TInet_addr; + htons: Thtons; + htonl: Thtonl; + ssGetSockName: TGetSockName; + ssGetPeerName: TGetPeerName; + ssConnect: TConnect; + CloseSocket: TCloseSocket; + ssBind: TBind; + ssAccept: TAccept; + Socket: TTSocket; + Select: TSelect; + GetAddrInfo: TGetAddrInfo; + FreeAddrInfo: TFreeAddrInfo; + GetNameInfo: TGetNameInfo; + __WSAFDIsSet: T__WSAFDIsSet; + WSAIoctl: TWSAIoctl; + WSAPoll: TWSAPoll; + +var + SynSockCS: TRTLCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + SockSChannelApi: Boolean; + +type + PVarSin = ^TVarSin; + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of AnsiChar); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(const sin: TVarSin): integer; + {$ifdef UNICODE}inline;{$endif} + +function GetSockName(s: TSocket; var name: TVarSin): integer; +function GetPeerName(s: TSocket; var name: TVarSin): integer; +function GetHostName: AnsiString; +function Bind(s: TSocket; const addr: TVarSin): integer; +function Connect(s: TSocket; const name: TVarSin): integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; + {$ifdef UNICODE}inline;{$endif} +function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(const Sin: TVarSin): AnsiString; +procedure GetSinIPShort(const Sin: TVarSin; var result: shortstring); +function GetSinPort(const Sin: TVarSin): integer; +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, SockType: integer; + IPList: TStrings; IPListClear: boolean = true); +function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType: integer): Word; + + +{ SChannel low-level API } + +type + TCredHandle = record + dwLower: pointer; + dwUpper: pointer; + end; + PCredHandle = ^TCredHandle; + + TCtxtHandle = type TCredHandle; + PCtxtHandle = ^TCtxtHandle; + + {$ifdef DELPHI5OROLDER} + PCardinal = ^Cardinal; + {$endif} + + TSChannelCred = record + dwVersion: cardinal; + cCreds: cardinal; + paCred: pointer; + hRootStore: THandle; + cMappers: cardinal; + aphMappers: pointer; + cSupportedAlgs: cardinal; + palgSupportedAlgs: PCardinal; + grbitEnabledProtocols: cardinal; + dwMinimumCipherStrength: cardinal; + dwMaximumCipherStrength: cardinal; + dwSessionLifespan: cardinal; + dwFlags: cardinal; + dwCredFormat: cardinal; + end; + PSChannelCred = ^TSChannelCred; + + TSecBuffer = record + cbBuffer: cardinal; + BufferType: cardinal; + pvBuffer: pointer; + end; + PSecBuffer = ^TSecBuffer; + + TSecBufferDesc = record + ulVersion: cardinal; + cBuffers: cardinal; + pBuffers: PSecBuffer; + end; + PSecBufferDesc = ^TSecBufferDesc; + + TTimeStamp = record + dwLowDateTime: cardinal; + dwHighDateTime: cardinal; + end; + PTimeStamp = ^TTimeStamp; + + TSecPkgContextStreamSizes = record + cbHeader: cardinal; + cbTrailer: cardinal; + cbMaximumMessage: cardinal; + cBuffers: cardinal; + cbBlockSize: cardinal; + end; + PSecPkgContextStreamSizes = ^TSecPkgContextStreamSizes; + + ESChannel = class(Exception); + + {$ifdef USERECORDWITHMETHODS}TSChannelClient = record + {$else}TSChannelClient = object{$endif} + private + Cred: TCredHandle; + Ctxt: TCtxtHandle; + Sizes: TSecPkgContextStreamSizes; + Data, Input: AnsiString; + InputSize, DataPos, DataCount, InputCount: integer; + SessionClosed: boolean; + procedure HandshakeLoop(aSocket: THandle); + procedure AppendData(const aBuffer: TSecBuffer); + public + Initialized: boolean; + procedure AfterConnection(aSocket: THandle; aAddress: PAnsiChar); + procedure BeforeDisconnection(aSocket: THandle); + function Receive(aSocket: THandle; aBuffer: pointer; aLength: integer): integer; + function Send(aSocket: THandle; aBuffer: pointer; aLength: integer): integer; + end; + +var + AcquireCredentialsHandle: function(pszPrincipal: PAnsiChar; + pszPackage: PAnsiChar; fCredentialUse: cardinal; pvLogonID: PInt64; + pAuthData: PSChannelCred; pGetKeyFn: pointer; pvGetKeyArgument: pointer; + phCredential: PCredHandle; ptsExpiry: PTimeStamp): cardinal; stdcall; + FreeCredentialsHandle: function(phCredential: PCredHandle): cardinal; stdcall; + InitializeSecurityContext: function(phCredential: PCredHandle; + phContext: PCtxtHandle; pszTargetName: PAnsiChar; fContextReq: cardinal; + Reserved1: cardinal; TargetDataRep: cardinal; pInput: PSecBufferDesc; + Reserved2: cardinal; phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; + pfContextAttr: PCardinal; ptsExpiry: PTimeStamp): cardinal; stdcall; + DeleteSecurityContext: function(phContext: PCtxtHandle): cardinal; stdcall; + ApplyControlToken: function(phContext: PCtxtHandle; + pInput: PSecBufferDesc): cardinal; stdcall; + QueryContextAttributes: function(phContext: PCtxtHandle; + ulAttribute: cardinal; pBuffer: pointer): cardinal; stdcall; + FreeContextBuffer: function(pvContextBuffer: pointer): cardinal; stdcall; + EncryptMessage: function(phContext: PCtxtHandle; fQOP: cardinal; + pMessage: PSecBufferDesc; MessageSeqNo: cardinal): cardinal; stdcall; + DecryptMessage: function(phContext: PCtxtHandle; pMessage: PSecBufferDesc; + MessageSeqNo: cardinal; pfQOP: PCardinal): cardinal; stdcall; + +const + SP_PROT_TLS1 = $0C0; + SP_PROT_TLS1_SERVER = $040; + SP_PROT_TLS1_CLIENT = $080; + SP_PROT_TLS1_1 = $300; + SP_PROT_TLS1_1_SERVER = $100; + SP_PROT_TLS1_1_CLIENT = $200; + SP_PROT_TLS1_2 = $C00; + SP_PROT_TLS1_2_SERVER = $400; + SP_PROT_TLS1_2_CLIENT = $800; + + SECPKG_CRED_INBOUND = 1; + SECPKG_CRED_OUTBOUND = 2; + + ISC_REQ_DELEGATE = $00000001; + ISC_REQ_MUTUAL_AUTH = $00000002; + ISC_REQ_REPLAY_DETECT = $00000004; + ISC_REQ_SEQUENCE_DETECT = $00000008; + ISC_REQ_CONFIDENTIALITY = $00000010; + ISC_REQ_USE_SESSION_KEY = $00000020; + ISC_REQ_PROMPT_FOR_CREDS = $00000040; + ISC_REQ_USE_SUPPLIED_CREDS = $00000080; + ISC_REQ_ALLOCATE_MEMORY = $00000100; + ISC_REQ_USE_DCE_STYLE = $00000200; + ISC_REQ_DATAGRAM = $00000400; + ISC_REQ_CONNECTION = $00000800; + ISC_REQ_CALL_LEVEL = $00001000; + ISC_REQ_FRAGMENT_SUPPLIED = $00002000; + ISC_REQ_EXTENDED_ERROR = $00004000; + ISC_REQ_STREAM = $00008000; + ISC_REQ_INTEGRITY = $00010000; + ISC_REQ_IDENTIFY = $00020000; + ISC_REQ_NULL_SESSION = $00040000; + ISC_REQ_MANUAL_CRED_VALIDATION = $00080000; + ISC_REQ_RESERVED1 = $00100000; + ISC_REQ_FRAGMENT_TO_FIT = $00200000; + ISC_REQ_FLAGS = + ISC_REQ_SEQUENCE_DETECT or ISC_REQ_REPLAY_DETECT or + ISC_REQ_CONFIDENTIALITY or ISC_REQ_EXTENDED_ERROR or + ISC_REQ_ALLOCATE_MEMORY or ISC_REQ_STREAM or + ISC_REQ_MANUAL_CRED_VALIDATION; + + SECBUFFER_VERSION = 0; + SECBUFFER_EMPTY = 0; + SECBUFFER_DATA = 1; + SECBUFFER_TOKEN = 2; + SECBUFFER_EXTRA = 5; + SECBUFFER_STREAM_TRAILER = 6; + SECBUFFER_STREAM_HEADER = 7; + + SEC_E_OK = 0; + SEC_I_CONTINUE_NEEDED = $00090312; + SEC_I_INCOMPLETE_CREDENTIALS = $00090320; + SEC_I_RENEGOTIATE = $00090321; + SEC_I_CONTEXT_EXPIRED = $00090317; + SEC_E_INCOMPLETE_MESSAGE = $80090318; + SEC_E_INVALID_TOKEN = $80090308; + + UNISP_NAME = 'Microsoft Unified Security Protocol Provider'; + SECPKG_ATTR_STREAM_SIZES = 4; + SECURITY_NATIVE_DREP = $10; + SCHANNEL_SHUTDOWN = 1; +{$endif} +implementation +{$ifdef MSWINDOWS} +var + SynSockCount: integer; + LibHandle: {$ifdef FPC}TLibHandle{$else}HMODULE{$endif}; + Libwship6Handle: {$ifdef FPC}TLibHandle{$else}HMODULE{$endif}; + LibSecurHandle: {$ifdef FPC}TLibHandle{$else}HMODULE{$endif}; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + result := (CompareMem(a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY(const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6(const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +// faster purepascal versions of FD_ISSET/FD_CLR/FD_SET/FD_ZERO API functions + +function FD_ISSET(Socket: TSocket; const FDSet: TFDSet): boolean; +var + i: integer; +begin + result := true; + for i := 0 to FDSet.fd_count - 1 do + if FDSet.fd_array[i] = Socket then + exit; // found item + result := false; +end; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + i: integer; +begin + for i := 0 to FDSet.fd_count - 1 do + if FDSet.fd_array[i] = Socket then begin + dec(FDSet.fd_count); + if i < FDSet.fd_count then + move(FDSet.fd_array[i + 1], FDSet.fd_array[i], (FDSet.fd_count - i) * sizeof(TSocket)); + break; + end; +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +var + i: integer; +begin + if FDSet.fd_count >= FD_SETSIZE then + exit; + for i := 0 to FDSet.fd_count - 1 do + if FDSet.fd_array[i] = Socket then + exit; // already set + FDSet.fd_array[FDSet.fd_count] := Socket; + inc(FDSet.fd_count); +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +function SizeOfVarSin(const sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + result := SizeOf(TSockAddrIn); + AF_INET6: + result := SizeOf(TSockAddrIn6); + else + result := 0; + end; +end; + +function GetSockName(s: TSocket; var name: TVarSin): integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + result := ssGetSockName(s, @name, len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + result := ssGetPeerName(s, @name, len); +end; + +function GetHostName: AnsiString; +var + s: array[0..255] of AnsiChar; +begin + ssGetHostName(@s, 255); + result := s; +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + result := ssAccept(s, @addr, x); +end; + +function Bind(s: TSocket; const addr: TVarSin): integer; +begin + result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): integer; +begin + result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function IsNewApi(Family: integer): Boolean; +begin + result := SockEnhancedApi; + if not result then + result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; const IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: AnsiString; var Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + result := GetAddrInfo(pointer(IP), nil, @Hints, Addr); + end + else begin + if (IP = cAnyHost) or (IP = c6AnyHost) then begin + Hints.ai_flags := AI_PASSIVE; + result := GetAddrInfo(nil, pointer(port), @Hints, Addr); + end + else if (IP = cLocalhost) or (IP = c6Localhost) then + result := GetAddrInfo(nil, pointer(port), @Hints, Addr) + else + result := GetAddrInfo(pointer(IP), pointer(port), @Hints, Addr); + end; + if result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + FreeAddrInfo(Addr); + end; + end; + +begin + result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(Family) then begin + EnterCriticalSection(SynSockCS); + try + Sin.sin_family := AF_INET; + ProtoEnt := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := GetServByName(pointer(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := htons(StrToIntDef(string(Port), 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else begin + Sin.sin_addr.s_addr := inet_addr(pointer(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then begin + HostEnt := GetHostByName(pointer(IP)); + result := WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + LeaveCriticalSection(SynSockCS); + end; + end + else begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then begin + if PreferIP4 then begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + Hints1.ai_socktype := SockType; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_protocol := Hints1.ai_protocol; + r := GetAddr(IP, Port, Hints1, Sin1); + result := r; + Sin := Sin1; + if r <> 0 then + if TwoPass then begin + r := GetAddr(IP, Port, Hints2, Sin2); + result := r; + if r = 0 then + Sin := Sin2; + end; + end; +end; + +function GetSinIP(const Sin: TVarSin): AnsiString; +var + p: PAnsiChar; + host: array[0..NI_MAXHOST] of AnsiChar; + serv: array[0..NI_MAXSERV] of AnsiChar; + hostlen, servlen: integer; + r: integer; +begin + result := ''; + if not IsNewApi(Sin.AddressFamily) then begin + p := inet_ntoa(Sin.sin_addr); + if p <> nil then + result := p; + end + else begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + r := getnameinfo(@Sin, SizeOfVarSin(Sin), host, hostlen, serv, servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + result := host; + end; +end; + +function StrLen255(S: PAnsiChar): integer; +begin + for result := 0 to 254 do + if S[result] = #0 then + exit; + result := 255; +end; + +procedure GetSinIPShort(const Sin: TVarSin; var result: shortstring); +var + p: PAnsiChar; + host: array[0..NI_MAXHOST] of AnsiChar; + serv: array[0..NI_MAXSERV] of AnsiChar; + hostlen, servlen: integer; + r: integer; +begin + result[0] := #0; + if not IsNewApi(Sin.AddressFamily) then begin + p := inet_ntoa(Sin.sin_addr); + if p <> nil then + SetString(result, p, StrLen255(p)); + end + else begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + r := getnameinfo(@Sin, SizeOfVarSin(Sin), host, hostlen, serv, servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + SetString(result, PAnsiChar(@host), StrLen255(host)); + end; +end; + +function GetSinPort(const Sin: TVarSin): integer; +begin + if (Sin.sin_family = AF_INET6) then + result := ntohs(Sin.sin6_port) + else + result := ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(const Name: AnsiString; Family, SockProtocol, + SockType: integer; IPList: TStrings; IPListClear: boolean); +type + TaPInAddr = array[0..250] of PInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host: array[0..NI_MAXHOST] of AnsiChar; + serv: array[0..NI_MAXSERV] of AnsiChar; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: ^TaPInAddr; + i: integer; + InAddr: TInAddr; +begin + if IPListClear then + IPList.Clear; + if not IsNewApi(Family) then begin + IP := inet_addr(pointer(Name)); + if IP = u_long(INADDR_NONE) then begin + EnterCriticalSection(SynSockCS); + try + RemoteHost := GetHostByName(pointer(Name)); + if RemoteHost <> nil then begin + PAdrPtr := pointer(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do begin + InAddr := PAdrPtr^[i]^; + IPList.Add(Format('%d.%d.%d.%d', [InAddr.S_bytes[0], + InAddr.S_bytes[1], InAddr.S_bytes[2], InAddr.S_bytes[3]])); + Inc(i); + end; + end; + finally + LeaveCriticalSection(SynSockCS); + end; + end + else + IPList.Add(string(Name)); + end + else begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + r := GetAddrInfo(pointer(Name), nil, @Hints, Addr); + if r = 0 then begin + AddrNext := Addr; + while not (AddrNext = nil) do begin + if not (((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) or + ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, host, hostlen, + serv, servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + IPList.Add(string(host)); + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(const Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + result := 0; + if not IsNewApi(Family) then begin + EnterCriticalSection(SynSockCS); + try + ProtoEnt := GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := GetServByName(pointer(Port), ProtoEnt^.p_name); + if ServEnt = nil then + result := StrToIntDef(string(Port), 0) + else + result := htons(ServEnt^.s_port); + finally + LeaveCriticalSection(SynSockCS); + end; + end + else begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := AI_PASSIVE; + r := GetAddrInfo(nil, pointer(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then begin + if Addr^.ai_family = AF_INET then + result := htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + result := htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(const IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host: array[0..NI_MAXHOST] of AnsiChar; + serv: array[0..NI_MAXSERV] of AnsiChar; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + result := IP; + if not IsNewApi(Family) then begin + IPn := inet_addr(pointer(IP)); + if IPn <> u_long(INADDR_NONE) then begin + EnterCriticalSection(SynSockCS); + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + result := RemoteHost^.h_name; + finally + LeaveCriticalSection(SynSockCS); + end; + end; + end + else begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + r := GetAddrInfo(pointer(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr) then begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, host, hostlen, + serv, servlen, NI_NUMERICSERV); + if r = 0 then + result := host; + end; + finally + if Assigned(Addr) then + FreeAddrInfo(Addr); + end; + end; +end; + +function poll(fds: PPollFD; nfds, timeout: integer): integer; +begin + if Assigned(WSAPoll) then + result := WSAPoll(fds, nfds, timeout) + else + result := -1; // not available on XP/2K +end; + +function InitSocketInterface(const Stack: TFileName = ''): Boolean; +begin + result := False; + EnterCriticalSection(SynSockCS); + try + if SynSockCount = 0 then begin + SockEnhancedApi := false; + SockSChannelApi := false; + SockWship6Api := false; + if Stack = '' then + LibHandle := LoadLibrary(DLLStackName) + else + LibHandle := LoadLibrary(pointer(Stack)); + if LibHandle <> 0 then begin + WSAPoll := GetProcAddress(LibHandle, 'WSAPoll'); + WSAIoctl := GetProcAddress(LibHandle, 'WSAIoctl'); + __WSAFDIsSet := GetProcAddress(LibHandle, '__WSAFDIsSet'); + CloseSocket := GetProcAddress(LibHandle, 'closesocket'); + IoctlSocket := GetProcAddress(LibHandle, 'ioctlsocket'); + WSAGetLastError := GetProcAddress(LibHandle, 'WSAGetLastError'); + WSAStartup := GetProcAddress(LibHandle, 'WSAStartup'); + WSACleanup := GetProcAddress(LibHandle, 'WSACleanup'); + ssAccept := GetProcAddress(LibHandle, 'accept'); + ssBind := GetProcAddress(LibHandle, 'bind'); + ssConnect := GetProcAddress(LibHandle, 'connect'); + ssGetPeerName := GetProcAddress(LibHandle, 'getpeername'); + ssGetSockName := GetProcAddress(LibHandle, 'getsockname'); + GetSockOpt := GetProcAddress(LibHandle, 'getsockopt'); + Htonl := GetProcAddress(LibHandle, 'htonl'); + Htons := GetProcAddress(LibHandle, 'htons'); + Inet_Addr := GetProcAddress(LibHandle, 'inet_addr'); + Inet_Ntoa := GetProcAddress(LibHandle, 'inet_ntoa'); + Listen := GetProcAddress(LibHandle, 'listen'); + Ntohl := GetProcAddress(LibHandle, 'ntohl'); + Ntohs := GetProcAddress(LibHandle, 'ntohs'); + Recv := GetProcAddress(LibHandle, 'recv'); + RecvFrom := GetProcAddress(LibHandle, 'recvfrom'); + Select := GetProcAddress(LibHandle, 'select'); + Send := GetProcAddress(LibHandle, 'send'); + SendTo := GetProcAddress(LibHandle, 'sendto'); + SetSockOpt := GetProcAddress(LibHandle, 'setsockopt'); + ShutDown := GetProcAddress(LibHandle, 'shutdown'); + Socket := GetProcAddress(LibHandle, 'socket'); + GetHostByAddr := GetProcAddress(LibHandle, 'gethostbyaddr'); + GetHostByName := GetProcAddress(LibHandle, 'gethostbyname'); + GetProtoByName := GetProcAddress(LibHandle, 'getprotobyname'); + GetProtoByNumber := GetProcAddress(LibHandle, 'getprotobynumber'); + GetServByName := GetProcAddress(LibHandle, 'getservbyname'); + GetServByPort := GetProcAddress(LibHandle, 'getservbyport'); + ssGetHostName := GetProcAddress(LibHandle, 'gethostname'); + {$ifndef FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, 'getaddrinfo'); + FreeAddrInfo := GetProcAddress(LibHandle, 'freeaddrinfo'); + GetNameInfo := GetProcAddress(LibHandle, 'getnameinfo'); + SockEnhancedApi := Assigned(GetAddrInfo) and + Assigned(FreeAddrInfo) and Assigned(GetNameInfo); + if not SockEnhancedApi then begin + LibWship6Handle := LoadLibrary(DLLWship6); + if LibWship6Handle <> 0 then begin + GetAddrInfo := GetProcAddress(LibWship6Handle, 'getaddrinfo'); + FreeAddrInfo := GetProcAddress(LibWship6Handle, 'freeaddrinfo'); + GetNameInfo := GetProcAddress(LibWship6Handle, 'getnameinfo'); + SockWship6Api := Assigned(GetAddrInfo) and + Assigned(FreeAddrInfo) and Assigned(GetNameInfo); + end; + end; + {$endif} + if not SockSChannelApi then begin + LibSecurHandle := LoadLibrary(DLLSecur32); + if LibSecurHandle <> 0 then begin + AcquireCredentialsHandle := GetProcAddress(LibSecurHandle, 'AcquireCredentialsHandleA'); + FreeCredentialsHandle := GetProcAddress(LibSecurHandle, 'FreeCredentialsHandle'); + InitializeSecurityContext := GetProcAddress(LibSecurHandle, 'InitializeSecurityContextA'); + DeleteSecurityContext := GetProcAddress(LibSecurHandle, 'DeleteSecurityContext'); + ApplyControlToken := GetProcAddress(LibSecurHandle, 'ApplyControlToken'); + QueryContextAttributes := GetProcAddress(LibSecurHandle, 'QueryContextAttributesA'); + FreeContextBuffer := GetProcAddress(LibSecurHandle, 'FreeContextBuffer'); + EncryptMessage := GetProcAddress(LibSecurHandle, 'EncryptMessage'); + DecryptMessage := GetProcAddress(LibSecurHandle, 'DecryptMessage'); + SockSChannelApi := Assigned(AcquireCredentialsHandle) and + Assigned(InitializeSecurityContext) and + Assigned(QueryContextAttributes) and + Assigned(EncryptMessage) and Assigned(DecryptMessage); + end; + end; + result := True; + end; + end + else + result := True; + if result then + Inc(SynSockCount); + finally + LeaveCriticalSection(SynSockCS); + end; +end; + +function DestroySocketInterface: Boolean; +begin + EnterCriticalSection(SynSockCS); + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then begin + if LibHandle <> 0 then begin + FreeLibrary(libHandle); + LibHandle := 0; + // HH reset routine pointers to avoid jumping into limbo + WSAPoll := nil; + WSAIoctl := nil; + __WSAFDIsSet := nil; + CloseSocket := nil; + IoctlSocket := nil; + WSAGetLastError := nil; + WSAStartup := nil; + WSACleanup := nil; + ssAccept := nil; + ssBind := nil; + ssConnect := nil; + ssGetPeerName := nil; + ssGetSockName := nil; + GetSockOpt := nil; + Htonl := nil; + Htons := nil; + Inet_Addr := nil; + Inet_Ntoa := nil; + Listen := nil; + Ntohl := nil; + Ntohs := nil; + Recv := nil; + RecvFrom := nil; + Select := nil; + Send := nil; + SendTo := nil; + SetSockOpt := nil; + ShutDown := nil; + Socket := nil; + GetHostByAddr := nil; + GetHostByName := nil; + GetProtoByName := nil; + GetProtoByNumber := nil; + GetServByName := nil; + GetServByPort := nil; + ssGetHostName := nil; + {$ifndef FORCEOLDAPI} + GetAddrInfo := nil; + FreeAddrInfo := nil; + GetNameInfo := nil; + GetAddrInfo := nil; + FreeAddrInfo := nil; + GetNameInfo := nil; + {$endif} + AcquireCredentialsHandle := nil; + FreeCredentialsHandle := nil; + InitializeSecurityContext := nil; + DeleteSecurityContext := nil; + ApplyControlToken := nil; + QueryContextAttributes := nil; + FreeContextBuffer := nil; + EncryptMessage := nil; + DecryptMessage := nil; + end; + if LibWship6Handle <> 0 then begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + LeaveCriticalSection(SynSockCS); + end; + result := True; +end; + + + + +{ TSChannel } + +procedure RaiseLastError; // not defined e.g. with Delphi 5 +var + LastError: Integer; +begin + LastError := GetLastError; + raise ESChannel.CreateFmt('System Error %d [%s]', [LastError, SysErrorMessage(LastError)]); +end; + +function CheckSEC_E_OK(res: integer): cardinal; +begin + if res <> SEC_E_OK then + RaiseLastError; + result := res; +end; + +function CheckSocket(res: integer): cardinal; +begin + if res = SOCKET_ERROR then + raise ESChannel.CreateFmt('Socket Error %d', [WSAGetLastError]); + if res = 0 then + raise ESChannel.Create('Handshake aborted'); + result := res; +end; + +const + TLSRECMAXSIZE = 19000; // stack buffers for TSChannelClient.Receive/Send + +type + {$ifdef USERECORDWITHMETHODS}THandshakeBuf = record + {$else}THandshakeBuf = object{$endif} + public + buf: array[0..2] of TSecBuffer; + input, output: TSecBufferDesc; + procedure Init; + end; + +procedure THandshakeBuf.Init; +begin + input.ulVersion := SECBUFFER_VERSION; + input.cBuffers := 2; + input.pBuffers := @buf[0]; + buf[0].cbBuffer := 0; + buf[0].BufferType := SECBUFFER_TOKEN; + buf[0].pvBuffer := nil; + buf[1].cbBuffer := 0; + buf[1].BufferType := SECBUFFER_EMPTY; + buf[1].pvBuffer := nil; + output.ulVersion := SECBUFFER_VERSION; + output.cBuffers := 1; + output.pBuffers := @buf[2]; + buf[2].cbBuffer := 0; + buf[2].BufferType := SECBUFFER_TOKEN; + buf[2].pvBuffer := nil; +end; + +procedure TSChannelClient.AppendData(const aBuffer: TSecBuffer); +var + newlen: integer; +begin + newlen := DataCount + integer(aBuffer.cbBuffer); + if newlen > Length(Data) then + SetLength(Data, newlen); + Move(aBuffer.pvBuffer^, PByteArray(Data)[DataCount], aBuffer.cbBuffer); + inc(DataCount, aBuffer.cbBuffer); +end; + +procedure TSChannelClient.AfterConnection(aSocket: THandle; aAddress: PAnsiChar); +var + buf: THandshakeBuf; + res, f: cardinal; +begin + if not SockSChannelApi then + raise ESChannel.Create('SChannel API not available'); + CheckSEC_E_OK(AcquireCredentialsHandle(nil, UNISP_NAME, SECPKG_CRED_OUTBOUND, + nil, nil, nil, nil, @Cred, nil)); + DataPos := 0; + DataCount := 0; + buf.Init; + res := InitializeSecurityContext(@Cred, nil, aAddress, ISC_REQ_FLAGS, 0, + SECURITY_NATIVE_DREP, nil, 0, @Ctxt, @buf.output, @f, nil); + if res <> SEC_I_CONTINUE_NEEDED then + RaiseLastError; + CheckSocket(SynWinSock.Send(aSocket, buf.buf[2].pvBuffer, buf.buf[2].cbBuffer, 0)); + CheckSEC_E_OK(FreeContextBuffer(buf.buf[2].pvBuffer)); + SetLength(Data, TLSRECMAXSIZE); + HandshakeLoop(aSocket); + CheckSEC_E_OK(QueryContextAttributes(@Ctxt, SECPKG_ATTR_STREAM_SIZES, @Sizes)); + InputSize := Sizes.cbHeader + Sizes.cbMaximumMessage + Sizes.cbTrailer; + if InputSize > TLSRECMAXSIZE then + raise ESChannel.CreateFmt('InputSize=%d>%d', [InputSize, TLSRECMAXSIZE]); + SetLength(Input, InputSize); + InputCount := 0; + Initialized := true; +end; + +procedure TSChannelClient.HandshakeLoop(aSocket: THandle); +var + buf: THandshakeBuf; + res, f: cardinal; +begin + res := SEC_I_CONTINUE_NEEDED; + while (res = SEC_I_CONTINUE_NEEDED) or (res = SEC_E_INCOMPLETE_MESSAGE) do begin + inc(DataCount, CheckSocket(Recv(aSocket, + @PByteArray(Data)[DataCount], length(Data) - DataCount, 0))); + buf.Init; + buf.buf[0].cbBuffer := DataCount; + buf.buf[0].BufferType := SECBUFFER_TOKEN; + buf.buf[0].pvBuffer := pointer(Data); + res := InitializeSecurityContext(@Cred, @Ctxt, nil, ISC_REQ_FLAGS, 0, + SECURITY_NATIVE_DREP, @buf.input, 0, @Ctxt, @buf.output, @f, nil); + if res = SEC_I_INCOMPLETE_CREDENTIALS then + // check https://stackoverflow.com/a/47479968/458259 + res := InitializeSecurityContext(@Cred, @Ctxt, nil, ISC_REQ_FLAGS, 0, + SECURITY_NATIVE_DREP, @buf.input, 0, @Ctxt, @buf.output, @f, nil); + if (res = SEC_E_OK) or (res = SEC_I_CONTINUE_NEEDED) or + ((f and ISC_REQ_EXTENDED_ERROR) <> 0) then begin + if (buf.buf[2].cbBuffer <> 0) and (buf.buf[2].pvBuffer <> nil) then begin + CheckSocket( + SynWinSock.Send(aSocket, buf.buf[2].pvBuffer, buf.buf[2].cbBuffer, 0)); + CheckSEC_E_OK(FreeContextBuffer(buf.buf[2].pvBuffer)); + end; + end; + if buf.buf[1].BufferType = SECBUFFER_EXTRA then begin + // reuse pending Data bytes to avoid SEC_E_INVALID_TOKEN + Move(PByteArray(Data)[cardinal(DataCount) - buf.buf[1].cbBuffer], + PByteArray(Data)[0], buf.buf[1].cbBuffer); + DataCount := buf.buf[1].cbBuffer; + end else + if res <> SEC_E_INCOMPLETE_MESSAGE then + DataCount := 0; + end; + // TODO: handle SEC_I_INCOMPLETE_CREDENTIALS ? + // see https://github.com/curl/curl/blob/master/lib/vtls/schannel.c + CheckSEC_E_OK(res); +end; + +procedure TSChannelClient.BeforeDisconnection(aSocket: THandle); +var + desc: TSecBufferDesc; + buf: TSecBuffer; + dt, f: cardinal; +begin + if Initialized then + try + if aSocket > 0 then begin + desc.ulVersion := SECBUFFER_VERSION; + desc.cBuffers := 1; + desc.pBuffers := @buf; + buf.cbBuffer := 4; + buf.BufferType := SECBUFFER_TOKEN; + dt := SCHANNEL_SHUTDOWN; + buf.pvBuffer := @dt; + if ApplyControlToken(@Ctxt, @desc) = SEC_E_OK then begin + buf.cbBuffer := 0; + buf.BufferType := SECBUFFER_TOKEN; + buf.pvBuffer := nil; + if InitializeSecurityContext(@Cred, @Ctxt, nil, ISC_REQ_FLAGS, 0, + SECURITY_NATIVE_DREP, nil, 0, @Ctxt, @desc, @f, nil) = SEC_E_OK then begin + SynWinSock.Send(aSocket, buf.pvBuffer, buf.cbBuffer, 0); + FreeContextBuffer(buf.pvBuffer); + end; + end; + end; + DeleteSecurityContext(@Ctxt); + FreeCredentialsHandle(@Cred); + finally + Cred.dwLower := nil; + Cred.dwUpper := nil; + Initialized := false; + end; +end; + +function TSChannelClient.Receive(aSocket: THandle; + aBuffer: pointer; aLength: integer): integer; +var + desc: TSecBufferDesc; + buf: array[0..3] of TSecBuffer; + res: cardinal; + read, i: integer; + needsRenegotiate: boolean; + function DecryptInput: cardinal; + begin + buf[0].cbBuffer := InputCount; + buf[0].BufferType := SECBUFFER_DATA; + buf[0].pvBuffer := pointer(Input); + buf[1].cbBuffer := 0; + buf[1].BufferType := SECBUFFER_EMPTY; + buf[1].pvBuffer := nil; + buf[2].cbBuffer := 0; + buf[2].BufferType := SECBUFFER_EMPTY; + buf[2].pvBuffer := nil; + buf[3].cbBuffer := 0; + buf[3].BufferType := SECBUFFER_EMPTY; + buf[3].pvBuffer := nil; + result := DecryptMessage(@Ctxt, @desc, 0, nil); + end; +begin + if not Initialized then begin // use plain socket API + result := Recv(aSocket, aBuffer, aLength, MSG_NOSIGNAL); + exit; + end; + result := 0; + if not SessionClosed then + while DataCount = 0 do + try + DataPos := 0; + desc.ulVersion := SECBUFFER_VERSION; + desc.cBuffers := 4; + desc.pBuffers := @buf[0]; + repeat + read := Recv(aSocket, @PByteArray(Input)[InputCount], + InputSize - InputCount, MSG_NOSIGNAL); + if read <= 0 then begin + result := read; // return socket error (may be WSATRY_AGAIN) + exit; + end; + inc(InputCount, read); + res := DecryptInput; + until res <> SEC_E_INCOMPLETE_MESSAGE; + needsRenegotiate := false; + repeat + case res of + SEC_I_RENEGOTIATE: needsRenegotiate := true; + SEC_I_CONTEXT_EXPIRED: SessionClosed := true; + SEC_E_INCOMPLETE_MESSAGE: break; + else CheckSEC_E_OK(res); + end; + InputCount := 0; + for i := 1 to 3 do + case buf[i].BufferType of + SECBUFFER_DATA: AppendData(buf[i]); + SECBUFFER_EXTRA: begin + Move(buf[i].pvBuffer^, pointer(Input)^, buf[i].cbBuffer); + InputCount := buf[i].cbBuffer; + end; + end; + if InputCount = 0 then + break; + res := DecryptInput; + until false; + if needsRenegotiate then + HandshakeLoop(aSocket); + except + exit; // shutdown the connection on ESChannel fatal error + end; + result := DataCount; + if aLength < result then + result := aLength; + Move(PByteArray(Data)[DataPos], aBuffer^, result); + inc(DataPos, result); + dec(DataCount, result); +end; + +function TSChannelClient.Send(aSocket: THandle; aBuffer: pointer; aLength: integer): integer; +var + desc: TSecBufferDesc; + buf: array[0..3] of TSecBuffer; + res, sent, s, len, trailer, pending, templen: cardinal; + temp: array[0..TLSRECMAXSIZE] of byte; +begin + if not Initialized then begin // use plain socket API + result := SynWinSock.Send(aSocket, aBuffer, aLength, MSG_NOSIGNAL); + exit; + end; + result := 0; + desc.ulVersion := SECBUFFER_VERSION; + desc.cBuffers := 4; + desc.pBuffers := @buf[0]; + pending := aLength; + while pending > 0 do begin + templen := pending; + if templen > Sizes.cbMaximumMessage then + templen := Sizes.cbMaximumMessage; + Move(aBuffer^, temp[Sizes.cbHeader], templen); + inc(PByte(aBuffer), templen); + dec(pending, templen); + trailer := Sizes.cbHeader + templen; + buf[0].cbBuffer := Sizes.cbHeader; + buf[0].BufferType := SECBUFFER_STREAM_HEADER; + buf[0].pvBuffer := @temp; + buf[1].cbBuffer := templen; + buf[1].BufferType := SECBUFFER_DATA; + buf[1].pvBuffer := @temp[Sizes.cbHeader]; + buf[2].cbBuffer := Sizes.cbTrailer; + buf[2].BufferType := SECBUFFER_STREAM_TRAILER; + buf[2].pvBuffer := @temp[trailer]; + buf[3].cbBuffer := 0; + buf[3].BufferType := SECBUFFER_EMPTY; + buf[3].pvBuffer := nil; + if EncryptMessage(@Ctxt, 0, @desc, 0) <> SEC_E_OK then + exit; // shutdown the connection on SChannel error + len := buf[0].cbBuffer + buf[1].cbBuffer + buf[2].cbBuffer; + sent := 0; + repeat + s := SynWinSock.Send(aSocket, @temp[sent], len, MSG_NOSIGNAL); + if s = len then + break; // whole message sent + if s = 0 then + exit; // report connection closed + if integer(s) < 0 then begin + res := WSAGetLastError; + if res <> WSATRY_AGAIN then begin + result := s; + exit; // report socket fatal error + end; + end + else begin + dec(len, s); + inc(sent, s); + end; + Sleep(1); // try again + until false; + end; + result := aLength; +end; + +initialization + assert(SizeOf(TInAddr) = SizeOf(cardinal)); + assert(SizeOf(TSockAddrIn) = 16); + assert(SizeOf(TInAddr6) = 16); + + InitializeCriticalSection(SynSockCS); + SET_IN6_IF_ADDR_ANY(@in6addr_any); + SET_LOOPBACK_ADDR6(@in6addr_loopback); + +finalization + SynSockCount := -254; // force release library + DestroySocketInterface; + DeleteCriticalSection(SynSockCS); +{$endif} +end. + diff --git a/mORMot/Synopse.inc b/mORMot/Synopse.inc new file mode 100644 index 00000000..5c493374 --- /dev/null +++ b/mORMot/Synopse.inc @@ -0,0 +1,740 @@ +{ + This file is part of Synopse framework. + + Synopse framework. Copyright (C) 2023 Arnaud Bouchez + Synopse Informatique - https://synopse.info + + *** BEGIN LICENSE BLOCK ***** + Version: MPL 1.1/GPL 2.0/LGPL 2.1 + + The contents of this file are subject to the Mozilla Public License Version + 1.1 (the "License"); you may not use this file except in compliance with + the License. You may obtain a copy of the License at + http://www.mozilla.org/MPL + + Software distributed under the License is distributed on an "AS IS" basis, + WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + for the specific language governing rights and limitations under the License. + + The Original Code is Synopse framework. + + The Initial Developer of the Original Code is Arnaud Bouchez. + + Portions created by the Initial Developer are Copyright (C) 2023 + the Initial Developer. All Rights Reserved. + + Contributor(s): + Alfred Glaenzer (alf) + + Alternatively, the contents of this file may be used under the terms of + either the GNU General Public License Version 2 or later (the "GPL"), or + the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), + in which case the provisions of the GPL or the LGPL are applicable instead + of those above. If you wish to allow use of your version of this file only + under the terms of either the GPL or the LGPL, and not to allow others to + use your version of this file under the terms of the MPL, indicate your + decision by deleting the provisions above and replace them with the notice + and other provisions required by the GPL or the LGPL. If you do not delete + the provisions above, a recipient may use your version of this file under + the terms of any one of the MPL, the GPL or the LGPL. + + ***** END LICENSE BLOCK ***** +} + +{$define PUREPASCAL} +{$define ABSOLUTEPASCAL} +{$define ABSOLUTEPASCALORNOTINTEL} + + +(********************** User-Trigerred Conditionals **********************) + +{ Those conditionals below can be enabled in your project Options, + to tune the compilation depending your setup or your project expectations. } + +{.$define PUREPASCAL} +// define this if your compiler doesn't support Delphi's x86 asm +// - is set automaticaly in case of a 64 bits compiler (only FPC exists now) + +{$define USENORMTOUPPER} +// if defined, text functions will use the NormToUpper[] array, as defined +// in our custom SysUtils.pas (not the LVCL version) -> when using LVCL, +// define the global LVCL compiler directive, and this unit will initialize +// its own NormToUpper[] array +// -> define ENHANCEDRTL conditional below if our Enhanced RTL IS installed +// -> in practice, this conditional is ALWAYS DEFINED, since needed by SQLite3 + +{.$define ENHANCEDRTL} +// define this if you DID install our Enhanced Runtime library or the LVCL: +// - it's better to define this conditional globaly in the Project/Options window +// - we need to hack the "legacy" LoadResString() procedure and add a +// LoadResStringTranslate() function, for on the fly resourcestring i18n +// - it will also define the TwoDigitLookup[] array and some very fast x86 asm +// IntToStr() and other functions, available in our Enhanced Runtime library +// (and our LVCL library) +// - it will be unset automaticaly (see below) for Delphi 2009 and up +// - this conditional must be defined in both SQLite3Commons and SQLite3i18n units, +// or (even better) globally in the Project options + +{.$define USEPACKAGES} +// define this if you compile the unit within a Delphi package +// - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G) +// to access 'VarCopyProc' from unit 'SynCommons'" +// - shall be set at the package options level, and left untouched by default +// - note: you should probably also set "Generate DCUs only" in Project Options +// -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation + +{.$define DOPATCHTRTL} +// if defined, some low-level patches are applied to Delphi or FPC RTL +// - you should better use it, but we have unset it by default + +{.$define NEWRTTINOTUSED} +// if defined, the new RTTI (available since Delphi 2010) won't be linked to +// the executable: resulting file size will be much smaller, and mORMot won't +// be affected (unless you use the enhanced RTTI for record/dynamic array JSON +// serialization) - left undefined by default to ensure minimal impact + +{.$define NOSETTHREADNAME} +// if defined, SetThreadName() would not raise the exception used to set the +// thread name: to be defined if you have issues when debugging your application + +{.$define NOEXCEPTIONINTERCEPT} +// if defined, exceptions shall not be intercepted and logged + +{.$define USELOCKERDEBUG} +// by default, some IAutoLocker instances would use TAutoLocker, unless this +// conditional is defined to use more verbose TAutoLockerDebug +// (may be used for race condition debugging, in multi-threaded apps) + +{.$define OLDTEXTWRITERFORMAT} +// force TTextWriter.Add(Format) to handle the alternate deprecated $ % tags + +{.$define FORCE_STRSSE42} +// sse4.2 string instructions may read up to 16 bytes after the actual end buffer +// -> define this if you want StrLen/StrComp/strspn/strcspn to use SSE4.2 opcodes +// but you would eventually experiment weird random GPF in your project, raising +// unexpected SIGABRT/SIGSEGV under POSIX system: so is disabled below for our +// LINUX conditional - and use at your own risk under Windows! + +{.$define DISABLE_SSE42} +// if defined, no SSE4.2 nor AES-NI instruction will be used, i.e. disable +// FORCE_STRSSE42 and all crc32c opcodes - is set for FPC DARWIN target + +{.$define WITH_ERMS} +// you may define this to enable REP MOVSB/STOSB for Fillchar/Move if cfERMS +// flag is available in Intel's CpuFeatures +// -> disabled by default, since in practice it is (much) slower for small blocks + +{.$define NOXPOWEREDNAME} +// define this to avoid sending "X-Powered-By: Synopse mORMot" HTTP header + +{.$define SQLVIRTUALLOGS} +// enable low-level logging of SQlite3 virtual table query planner costs +// -> to be defined only for internal debugging + +{.$define NOSYNDBZEOS} +// made SynDBZeos.pas a "void" unit - defined for FPC/Lazarus packages only + +{.$define DDDNOSYNDB} +// SynDB / external SQL DB won't be linked to the executable by dddInfraSettings +{.$define DDDNOMONGODB} +// Mongo DB client won't be linked to the executable by dddInfraSettings + + +{$ifdef FPC} + +(********************** FPC Conditionals **********************) + +{ Free Pascal adaptation notes: + - we use the Delphi compatibility mode + - from system.pp use these constants (Win32/64 values listed): + LineEnding = #13#10; + DirectorySeparator = '\'; + - for Cross-Platform and all CPU: + integer is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits + cardinal is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits + PtrUInt is an unsigned integer type of same size as a pointer / register + -> must be used for pointer arithmetic + -> may be used in loops + PtrInt is a signed integer type of same size as a pointer / register + -> must be used for pointer arithmetic + -> may be used in loops + all 32 bits x86 asm code is replaced by a pascal only version, if the + conditional PUREPASCAL is defined (e.g. for CPUX64) +} + + {$ifndef FPC_DELPHI} + {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility + {$endif} + + {$INLINE ON} + {$MINENUMSIZE 1} + {$PACKRECORDS DEFAULT} // force normal alignment + {$PACKSET 1} + {$PACKENUM 1} + {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases + + {$undef ENHANCEDRTL} // there is no version of our Enhanced RTL for FPC + {$define HASINLINE} + {$define HASUINT64} + {$define HASINLINENOTX86} + {$define NODELPHIASM} // ignore low-level System.@LStrFromPCharLen calls + {$define HASTTHREADSTART} + {$define HASINTERFACEASTOBJECT} + {$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC + {$define DOUBLETOSHORT_USEGRISU} // fast double to text + {$define DELPHI5ORFPC} + {$define FPC_OR_PUREPASCAL} + {$define FPC_OR_KYLIX} + {$define FPC_OR_UNICODE} + {$define USERECORDWITHMETHODS} + {$define FPC_OR_DELPHIXE} + {$define FPC_OR_DELPHIXE4} + {$define FPC_ENUMHASINNER} + {$define USE_VTYPE_STATIC} // in our inlined VarClear() + + // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :( + {$ifdef VER2_7} + {$define ISFPC27} + {$endif} + {$ifdef VER3_0} + {$define ISFPC27} + {$define ISFPC30} + {$define HASDIRECTTYPEINFO} + // PTypeInfo would be stored with no pointer de-reference + // => Delphi and newer FPC uses a pointer reference to ease exe linking + {$endif} + {$ifdef VER3_1} // trunk before 3.2 + {$define ISFPC27} + {$define ISFPC30} + {.$define HASDIRECTTYPEINFO} + // define this for trunk revisions older than June 2016 - see + // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change + {$endif} + {$ifdef VER3_1_1} // if FPC_FULLVERSION>30100 ... ifend is not Delphi 5 compatible :( + {$define ISFPC32} + {$endif} + {$ifdef VER3_2} + {$define ISFPC27} + {$define ISFPC30} + {$define ISFPC32} + {$ifdef VER3_2_2} + {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet + {$endif VER3_2_2} + {$endif} + {$ifdef VER3_3} // trunk before 3.4 + {$define ISFPC27} + {$define ISFPC30} + {$define ISFPC32} + {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet + {$endif} + {$ifdef VER3_4} + {$define ISFPC27} + {$define ISFPC30} + {$define ISFPC32} + {$define ISFPC34} + {$define FPC_PROVIDE_ATTR_TABLE} // introducing TTypeData.AttributeTable + {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU + {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet + {$endif} + {$if not defined(VER3_0) and not defined(VER3_2) and not defined(VER2)} + {$define FPC_PROVIDE_ATTR_TABLE} // to be defined since SVN 42356-42411 + // on compilation error in SynFPCTypInfo, undefine the above conditional + // see https://lists.freepascal.org/pipermail/fpc-announce/2019-July/000612.html + {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU + // see https://gitlab.com/freepascal.org/fpc/source/-/issues/38018 + {$ifend} + + {$ifdef ANDROID} + {$define LINUX} // a Linux-based system + {$endif} + + // define FPCSQLITE3STATIC to enable static-linked SQLite3 engine for FPC + // -> expect *.o files download from https://synopse.info/files/sqlite3fpc.7z + // -> could be disabled to force external .so/.dll linking + {$ifdef MSWINDOWS} + {$ifdef CPUX86} + {$define FPCSQLITE3STATIC} // use static\i386-win32\sqlite3.o + {$else} + {$define FPCSQLITE3STATIC} // use static\x86_64-win64\sqlite3.o + {$endif} + {$endif} + {$ifdef LINUX} + {$ifdef CPUX86} + {$define FPCSQLITE3STATIC} // use static/i386-linux\sqlite3.o + {$endif} + {$ifdef CPUX64} + {$define FPCSQLITE3STATIC} // use static/x86_64-linux\sqlite3.o + {$endif} + {$ifdef CPUARM} + {$define FPCSQLITE3STATIC} // use static/arm-linux\sqlite3.o + {$endif} + {$ifdef CPUAARCH64} + {$define FPCSQLITE3STATIC} // use:static/aarch64-linux\sqlite3.o + {$endif} + {$endif} + + {$ifdef BSD} + // LINUX conditional includes Darwin and BSD family like FreeBSD + {$define LINUX} // not true, but a POSIX/BSD system - see LINUXNOTBSD + {$undef FORCE_STRSSE42} // fails otherwise for sure + {$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized) + {$ifdef DARWIN} + {$define FPCSQLITE3STATIC} // we supply Darwin static libs + {$ifdef CPUINTEL} + {$define FPC_PIC} // may have not be defined by the compiler options + {$endif} + {$else} + {$define BSDNOTDARWIN} // OSX has some non-standard API calls + {$endif} + {$ifdef FREEBSD} + {$ifdef CPUX86} + {$define FPCSQLITE3STATIC} // we supply i386 static libs + {$endif CPUX86} + {$ifdef CPUX64} + {$define FPCSQLITE3STATIC} // we supply x64 static libs + {$endif CPUX64} + {$endif} + {$ifdef OPENBSD} + {$ifdef CPUX86} + {$define FPCSQLITE3STATIC} // we supply i386 static libs + {$endif CPUX86} + {$ifdef CPUX64} + {$define FPCSQLITE3STATIC} // we supply x64 static libs + {$endif CPUX64} + {$endif} + {$else} + {$ifdef LINUX} + {$define LINUXNOTBSD} // e.g. to disable epoll API + {$define FPCLINUXNOTBSD} + {$endif} + {$endif} + + {$ifdef LINUX} + {$undef FORCE_STRSSE42} // avoid fatal SIGABRT/SIGSEGV on POSIX systems + {$define FPCLINUX} + {$ifdef CPUX64} + {$define CPUX64LINUX} // e.g. for tuned server-side asm + {$endif CPUX64} + {$endif} + {$ifdef FPC_PIC} + {$define PUREPASCAL} // most asm code is not PIC-safe with global constants + {$endif} + + {$ifdef MSWINDOWS} + {$ifdef FPC_X64MM} + {$ifndef FPC_X64MM_WIN} // SynFPCx64MM not yet fully validated on Windows + {$undef FPC_X64MM} + {$endif FPC_X64MM_WIN} + {$endif FPC_X64MM} + {$endif MSWINDOWS} + + {$ifdef CPU64} + {$define FPC_64} + {$define PUREPASCAL} // e.g. x64, AARCH64 + {$ifdef CPUX64} + {$define CPUINTEL} + {$define FPC_CPUINTEL} + {$ifndef BSD} + {$define CPUX64ASM} // Delphi XE4 or Darwin asm are buggy :( + {$define ASMX64AVX} // only FPC supports AVX/AVX2/AVX512 + {$define HASAESNI} // SynCrypto rejected by Darwin asm + {$endif BSD} + {$define FPC_X64} // supports AVX/AVX2/AVX512 - which Delphi doesn't + {$ASMMODE INTEL} // to share asm code with Delphi + {$endif CPUX64} + {$ifdef CPUAARCH64} + {$define CPUARM3264} + {$endif CPUAARCH64} + {$else} + {$define FPC_32} + {$define STRCNT32} // 32-bit TAnsiRec.RefCnt on 32-bit CPU + {$define DACNT32} // 32-bit dynarray refcnt on 32-bit CPU + {$ifdef CPUARM} + {$define PUREPASCAL} // ARM32 + {$define CPUARM3264} + {$endif CPUARM} + {$ifdef CPUX86} + {$define CPUINTEL} + {$define FPC_CPUINTEL} + {$define FPC_X86} + {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type + {$ASMMODE INTEL} // as Delphi expects + {$define HASAESNI} // should be commented to test project with valgrind + {$ifndef FPC_PIC} + {$define CPUX86NOTPIC} // use "absolute" instead of local register + {$endif FPC_PIC} + {$ifndef OPENBSD} + {$define FPC_X86ASM} // if assembler knows popcnt/crc32c opcodes + {$endif OPENBSD} + {$endif CPUX86} + {$endif CPU64} + + {$ifdef CPUARM3264} + {$ifdef BSD} + {$undef USE_VTYPE_STATIC} // circumvent bug in VarClear() on BSD + ARM + {$endif BSD} + {$endif CPUARM3264} + + {$ifdef ISFPC30} + {$ifndef MSWINDOWS} + // define FPCUSEVERSIONINFO to link low-level executable file information + // units in SynCommons.pas + // => disabled by default, to reduce the executable overhead + {.$define FPCUSEVERSIONINFO} + {$endif MSWINDOWS} + {$endif ISFPC30} + + {$ifdef ISFPC32} + // FPC has its own RTTI layout only since late 3.x + {$define FPC_NEWRTTI} + // when http://bugs.freepascal.org/view.php?id=26774 has been fixed + {$ifdef CPUINTEL} + {$define HASINTERFACERTTI} + {$endif} + {$ifdef CPUARM3264} + {$define HASINTERFACERTTI} + {$endif} + {$endif} + + {$ifdef FPC_NEWRTTI} + {$define ISDELPHI2010_OR_FPC_NEWRTTI} + {$else} + {$define DELPHI_OR_FPC_OLDRTTI} + {$define FPC_OLDRTTI} + {$endif} + {$define ISDELPHI2010_OR_FPC} // eltype2 field + + {$ifdef FPC_HAS_CPSTRING} + // see http://wiki.freepascal.org/FPC_Unicode_support + {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode} + {$endif} + {$ifdef ISFPC27} + {$define ISFPC271} + {$define HASVARUSTRING} + {$define HASVARUSTRARG} + // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed + // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54 + // => this will change the TInvokeableVariantType.SetProperty() signature + {$define FPC_VARIANTSETVAR} + {$endif ISFPC27} + {$ifdef FPC_PROVIDE_ATTR_TABLE} + {$define HASALIGNTYPEDATA} // to ignore attributes RTTI table + {$endif FPC_PROVIDE_ATTR_TABLE} + {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + {$define FPC_ENUMHASINNER} + {$define HASALIGNTYPEDATA} // to ensure proper RTTI alignment + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + + +{$else FPC} + +(********************** Delphi Conditionals **********************) + + {$define DELPHI_OR_FPC_OLDRTTI} + {$define USE_VTYPE_STATIC} // "and VTYPE_STATIC" test before VarClear() + {$define STRCNT32} // always 32-bit TAnsiRec.RefCnt on Delphi + {$define DACNT32} // always 32-bit dynarray refcnt on Delphi + {$undef FPC_X64MM} // this is a FPC-specific memory manager + + {$A+} // force normal alignment + + {$ifdef LVCL} + {$define OWNNORMTOUPPER} // NormToUpper[] exists only in our enhanced RTL + {$define NOVARIANTS} // LVCL does not support variants + {$define EXTENDEDTOSHORT_USESTR} // no FloatToText implemented in LVCL + {$endif LVCL} + + {$ifdef UNICODE} + {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library + {$define HASVARUSTRING} + {$define HASCODEPAGE} + {$define FPC_OR_UNICODE} + {$define USERECORDWITHMETHODS} + { due to a bug in Delphi 2009+, we need to fake inheritance of record, + since TDynArrayHashed = object(TDynArray) fails to initialize + http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 } + {$define UNDIRECTDYNARRAY} + {$endif UNICODE} + + {$ifndef PUREPASCAL} + {$define CPUINTEL} // Delphi only for Intel by now + {$endif} + {$ifdef CPUX64} + {$define CPU64} // Delphi compiler for 64 bit CPU + {$define CPU64DELPHI} + {$undef CPU32} + {$define PUREPASCAL} // no x86 32 bit asm to be used + {$define EXTENDEDTOSHORT_USESTR} // FloatToText() much slower in x64 mode + {$define DOUBLETOSHORT_USEGRISU} // fast double to text + {$else CPUX64} + {$define CPU32} // Delphi compiler for 32 bit CPU + {$define CPU32DELPHI} + {$undef CPU64} + {$define CPUX86} // for compatibility with older versions of Delphi + {$define CPUX86NOTPIC} // use "absolute" instead of local register + {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type + {$endif CPUX64} + + {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6 or newer + {$define HASINTERFACERTTI} // interface RTTI (not FPC) + {$ifdef LINUX} + {$if RTLVersion = 14.5} + {$define KYLIX3} + {$define FPC_OR_KYLIX} + // Kylix 3 will be handled just like Delphi 7 + {$undef ENHANCEDRTL} // Enhanced Runtime library not fully tested yet + {$define EXTENDEDTOSHORT_USESTR} + {$define DOPATCHTRTL} // nice speed up for server apps + {$define NOVARCOPYPROC} + {$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so + {$define LINUXNOTBSD} // e.g. to disable epoll API + {$else} + Kylix1/2 or Delphi Tokyo/ARC are unsupported + {$ifend} + {$else} + {$ifdef VER140} + {$define ISDELPHI6ANDUP} // Delphi 6 or newer + {$define DELPHI6OROLDER} + {$define NOVARCOPYPROC} + {$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library + {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7 + {$else} + {$define ISDELPHI7ANDUP} // Delphi 7 or newer + {$define WITHUXTHEME} // VCL handle UI theming + {$define HASUINT64} + {$warn UNSAFE_CODE OFF} // Delphi for .Net does not exist any more! + {$warn UNSAFE_TYPE OFF} + {$warn UNSAFE_CAST OFF} + {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints + {$endif} + {$ifdef USEPACKAGES} + {$undef DOPATCHTRTL} + {$endif} + {$endif LINUX} + {$if CompilerVersion >= 17} + {$define ISDELPHI2005ANDUP} // Delphi 2005 or newer + {$if CompilerVersion >= 18} + {$define ISDELPHI2006ANDUP} // Delphi 2006 or newer + {$define HASNEWFILEAGE} + {$define HASINLINE} + {$define HASINLINEDELPHI} + {$define HASINLINENOTX86} + {$define HASREGION} + {$define HASFASTMM4} + // try to define this so that GetMemoryInfo/TSynMonitorMemory returns + // low-level FastMM4 information + {.$define WITH_FASTMM4STATS} + {$ifend} + {$ifdef VER180} + {$define ISDELPHI20062007} // to circumvent some specific bugs + {$endif} + {$ifdef VER185} + {$define ISDELPHI20062007} + {$endif} + {$if CompilerVersion > 18} + {$define ISDELPHI2007ANDUP} // Delphi 2007 or newer + {$ifend} + {$if CompilerVersion = 20} + {$define ISDELPHI20092010} // specific compilation issues + {$ifend} + {$if CompilerVersion = 21} + {$define ISDELPHI20092010} //specific compilation issues + {$ifend} + {$if CompilerVersion >= 21.0} + {$define ISDELPHI2010} + {$define ISDELPHI2010_OR_FPC} // eltype2 field + {$define ISDELPHI2010_OR_FPC_NEWRTTI} + {$define HASTTHREADSTART} + {$define HASINTERFACEASTOBJECT} + {$ifdef NEWRTTINOTUSED} // option reduce EXE size by disabling much RTTI + {$WEAKLINKRTTI ON} + {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} + {$endif NEWRTTINOTUSED} + {$ifend} + {$if CompilerVersion >= 22.0} + {$define FPC_OR_DELPHIXE} // Delphi 2007/2009/2010 inlining bugs + {$define ISDELPHIXE} + {$ifend} + {$if CompilerVersion >= 23.0} + // Delphi XE2 has some cross-platform features + // e.g. {$ifdef ISDELPHIXE2}VCL.Graphics{$else}Graphics{$endif} + {$define ISDELPHIXE2} + {$define HASVARUSTRARG} + {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet + {$ifend} + {$if CompilerVersion >= 24.0} + {$define ISDELPHIXE3} + {$ifend} + {$if CompilerVersion >= 25.0} + {$define ISDELPHIXE4} + {$define FPC_OR_DELPHIXE4} // circumvent Internal Error: C2130 on XE3 + {$define HASAESNI} + {$ifend} + {$if CompilerVersion >= 26.0} + {$define ISDELPHIXE5} + {$define PUBLISHRECORD} + // if defined, will handle RTTI available only since Delphi XE5 for + // record published properties + {$ifend} + {$if CompilerVersion >= 27.0} + {$define ISDELPHIXE6} + {$ifend} + {$if CompilerVersion >= 28.0} + {$define ISDELPHIXE7} + {$ifdef CPU64} + {$define CPUX64ASM} // e.g. Delphi XE4 SSE asm is buggy :( + {$endif} + {$ifend} + {$if CompilerVersion >= 29.0} + {$define ISDELPHIXE8} + {$ifend} + {$if CompilerVersion >= 30.0} + {$define ISDELPHI10} + {$ifend} + {$if CompilerVersion >= 31.0} + {$define ISDELPHI101} + {$ifend} + {$if CompilerVersion >= 32.0} + {$define ISDELPHI102} + {$ifdef CPUX64} + {$ifdef VER320withoutAprilUpdate} + // circumvent early Delphi 10.2 Tokyo Win64 compiler bug + {$undef HASINLINE} + {$define HASINLINENOTX86} + {$endif} + {$endif} + {$ifend} + {$if CompilerVersion >= 33.0} + {$define ISDELPHI103} + {$ifend} + {$if CompilerVersion >= 34.0} + {$define ISDELPHI104} + {$ifend} + {$if CompilerVersion >= 35.0} + {$define ISDELPHI11} + {$ifend} + {$ifend CompilerVersion >= 17} + {$ifopt O-} // if we don't expect fast code, don't optimize the framework + {$undef ENHANCEDRTL} + {$undef DOPATCHTRTL} + {$endif} + {$ELSE} + // Delphi 5 or older + {$define DELPHI6OROLDER} + {$define DELPHI5OROLDER} + {$define DELPHI5ORFPC} + {$define MSWINDOWS} + {$define NOVARIANTS} + {$define NOVARCOPYPROC} + {$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library + {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7 + {$undef DOPATCHTRTL} + {$ENDIF CONDITIONALEXPRESSIONS} + +{$endif FPC} + + +(********************** Shared Conditionals **********************) + +{$ifdef PUREPASCAL} + {$define NODELPHIASM} + {$define FPC_OR_PUREPASCAL} +{$else} +{$endif PUREPASCAL} + +{$H+} // we use long strings +{$R-} // disable Range checking in our code +{$S-} // disable Stack checking in our code +{$X+} // expect extended syntax +{$W-} // disable stack frame generation +{$Q-} // disable overflow checking in our code +{$B-} // expect short circuit boolean +{$V-} // disable Var-String Checking +{$T-} // Typed @ operator +{$Z1} // enumerators stored as byte by default + +{$ifndef FPC} + {$P+} // Open string params + {$ifdef VER150} + {$WARN SYMBOL_DEPRECATED OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$ENDIF} + {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer + {$WARN SYMBOL_PLATFORM OFF} + {$WARN UNIT_PLATFORM OFF} + {$endif} +{$endif FPC} + +{$ifdef CPUINTEL} + {$ifdef CPUX86} // safest to reset x87 exceptions + {$ifndef PUREPASCAL} + {$ifndef DELPHI5OROLDER} + {$define RESETFPUEXCEPTION} + {$endif} + {$endif} + {$endif} + {$ifdef DISABLE_SSE42} + {$undef FORCE_STRSSE42} + {$endif DISABLE_SSE42} +{$else} + {$undef HASAESNI} // AES-NI is an Intel-specific feature + {$define ABSOLUTEPASCALORNOTINTEL} +{$endif CPUINTEL} + +{$ifdef ABSOLUTEPASCAL} + {$define ABSOLUTEORPUREPASCAL} + {$define ABSOLUTEPASCALORNOTINTEL} + {$define PUREPASCAL} +{$endif ABSOLUTEPASCAL} +{$ifdef PUREPASCAL} + {$define ABSOLUTEORPUREPASCAL} +{$endif PUREPASCAL} + +{$define WITHLOG} +// if defined, logging will be supported via the TSQLLog family +// - should be left defined: TSQLog.Family.Level default setting won't log +// anything, so there won't be any noticeable performance penalty to have +// this WITHLOG conditional defined, which is expected by high-level part +// of the framework, like DDD or UI units + +{$ifdef FPC} + {$ifndef FPCSQLITE3STATIC} // see above about this FPC-specific conditional + {$define NOSQLITE3STATIC} + {$endif} +{$else} + // there is a linking bug with Delphi XE4 on Win64 + {$ifdef CPUX64} + {$if CompilerVersion = 25.0} // exactly XE4 + {$define NOSQLITE3STATIC} + // :( to avoid "Fatal: F2084 Internal Error: AV004A7B1F-R03BDA7B0-0" + {$ifend} + {$endif} // other Win32/Win64 Delphi platforms should work as expected +{$endif FPC} + +{$ifdef NOSQLITE3STATIC} + // our proprietary crypto expects a statically linked custom sqlite3.c + {$define NOSQLITE3ENCRYPT} +{$endif NOSQLITE3STATIC} + +{$ifdef MSWINDOWS} + {$define USEWININET} // publish TWinINet/TWinHttp/TWinHttpAPI classes + {.$define ONLYUSEHTTPSOCKET} // for testing (no benefit vs http.sys) + {.$define USELIBCURL} // for testing (no benefit vs WinHTTP) +{$else} + {$define ONLYUSEHTTPSOCKET} // http.sys server is Windows-specific + // cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl + {$define USELIBCURL} + {$ifdef ANDROID} + // for Android, consider using https://github.com/gcesarmza/curl-android-ios + // static libraries and force USELIBCURL in the project conditionals + {$define LIBCURLSTATIC} + {$endif ANDROID} +{$endif MSWINDOWS} + +{$ifdef USELIBCURL} + {.$define LIBCURLMULTI} + // enable https://curl.haxx.se/libcurl/c/libcurl-multi.html interface +{$endif USELIBCURL} + diff --git a/public/gitrevision.txt b/public/gitrevision.txt index 891bda92..d290b3af 100644 --- a/public/gitrevision.txt +++ b/public/gitrevision.txt @@ -1 +1 @@ -[master]v2.4.0d-2890(29c1f4e) +[master]v2.4.0e-2897(ee9d6aa)