diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatform.inc b/contrib/mORMot/CrossPlatform/SynCrossPlatform.inc index 984cc9f..045e293 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatform.inc +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatform.inc @@ -2,7 +2,7 @@ { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -21,7 +21,7 @@ The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas index 89c03db..1f6b40e 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformCrypto.pas @@ -6,7 +6,7 @@ unit SynCrossPlatformCrypto; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrossPlatformCrypto; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformJSON.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformJSON.pas index 2570650..ea14163 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformJSON.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformJSON.pas @@ -6,7 +6,7 @@ unit SynCrossPlatformJSON; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrossPlatformJSON; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -1682,7 +1682,7 @@ begin VKind := jvObject else if VKind<>jvObject then raise EJSONException.CreateFmt('AddNameValue(%s) over array',[aName]); - if VCount<=length(Values) then begin + if VCount=length(Values) then begin SetLength(Values,VCount+VCount shr 3+32); SetLength(Names,VCount+VCount shr 3+32); end; @@ -1697,7 +1697,7 @@ begin VKind := jvArray else if VKind<>jvArray then raise EJSONException.Create('AddValue() over object'); - if VCount<=length(Values) then + if VCount=length(Values) then SetLength(Values,VCount+VCount shr 3+32); Values[VCount] := aValue; inc(VCount); diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformREST.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformREST.pas index 5acb124..19f66f9 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformREST.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformREST.pas @@ -6,7 +6,7 @@ unit SynCrossPlatformREST; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrossPlatformREST; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -253,8 +253,8 @@ type /// a set of published property Kind TSQLFieldKinds = set of TSQLFieldKind; - { TODO: TID should be a string since number is limited to 53-bit in JavaScript - -> define and use an explicit Int52 type for SMS } + { 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; @@ -2895,7 +2895,7 @@ begin end; /// marshall {result:...,id:...} and {result:...} body answers -function CallGetResult(const aCall: TSQLRestURIParams; var outID: integer): variant; +function CallGetResult(const aCall: TSQLRestURIParams; var outID: TID): variant; {$ifndef ISSMS} var doc: TJSONVariantData; jsonres: string; @@ -2922,7 +2922,7 @@ end; function TSQLRestClientURI.CallBackGetResult(const aMethodName: string; const aNameValueParameters: array of const; aTable: TSQLRecordClass; aID: TID): string; var Call: TSQLRestURIParams; - dummyID: integer; + dummyID: TID; begin CallBackGet(aMethodName,aNameValueParameters,Call,aTable,aID); result := CallGetResult(Call,dummyID); @@ -3038,7 +3038,7 @@ begin onError(self); exit; end; - var outID: integer; + var outID: TID; var result := CallGetResult(Call,outID); // from {result:...,id:...} if VarIsValidRef(result) then begin if (aCaller.fInstanceImplementation=sicClientDriven) and (outID<>0) then @@ -3067,7 +3067,7 @@ function TSQLRestClientURI.CallRemoteServiceSynch(aCaller: TServiceClientAbstrac const aInputParams: array of variant; aReturnsCustomAnswer: boolean): TVariantDynArray; var Call: TSQLRestURIParams; outResult: variant; - outID: integer; + outID: TID; procedure RaiseError; begin raise EServiceException.CreateFmt('Error calling %s.%s - returned status %d', @@ -3119,7 +3119,8 @@ var Call: TSQLRestURIParams; result: variant; bodyerror: string; arr: PJSONVariantData; - i,outID: integer; + i: integer; + outID: TID; begin params.Init; for i := 0 to high(aInputParams) do @@ -3671,7 +3672,7 @@ end; constructor TServiceClientAbstract.Create(aClient: TSQLRestClientURI); var Call: TSQLRestURIParams; // manual synchronous call - dummyID: integer; + dummyID: TID; result: variant; contract: string; begin diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas index 1f0d3c9..1cc4dfb 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformSpecific.pas @@ -6,7 +6,7 @@ unit SynCrossPlatformSpecific; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrossPlatformSpecific; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas index d038c6f..8a69505 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformSynLZ.pas @@ -8,7 +8,7 @@ interface { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -27,7 +27,7 @@ interface The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -86,10 +86,10 @@ type {$ifdef FPC} PBytes = PAnsiChar; {$else} - PtrUInt = {$ifdef CPUX64} NativeUInt {$else} cardinal {$endif}; + PtrUInt = {$ifdef UNICODE} NativeUInt {$else} cardinal {$endif}; TBytes = array[0..maxInt-1] of byte; PBytes = ^TBytes; -{$endif} +{$endif FPC} function SynLZcomp(src: pointer; size: cardinal; dst: pointer): cardinal; var dst_beg, // initial dst value @@ -190,7 +190,7 @@ function SynLZdecomp(src: pointer; size: cardinal; dst: pointer): cardinal; var last_hashed, // initial src and dst value src_end: PtrUInt; CW, CWbit: cardinal; - v, t, h, o: cardinal; + v, t, h, o: PtrUInt; i: integer; offset: array[0..4095] of PtrUInt; // 16KB hashing code label nextCW; diff --git a/contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas b/contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas index 49aec4c..b3e5eca 100644 --- a/contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas +++ b/contrib/mORMot/CrossPlatform/SynCrossPlatformTests.pas @@ -6,7 +6,7 @@ unit SynCrossPlatformTests; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrossPlatformTests; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/PasZip.pas b/contrib/mORMot/PasZip.pas index 5eaf4d2..0fb1ee8 100644 --- a/contrib/mORMot/PasZip.pas +++ b/contrib/mORMot/PasZip.pas @@ -6,7 +6,7 @@ unit PasZip; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info This library is free software; you can redistribute it and/or modify it @@ -52,7 +52,7 @@ uses Windows, {$else} Types, -{$endif} +{$endif MSWINDOWS} SysUtils; type @@ -62,10 +62,11 @@ type {$else} RawByteZip = AnsiString; TZipName = AnsiString; -{$endif} +{$endif HASCODEPAGE} + {$ifdef DELPHI5OROLDER} PCardinal = ^cardinal; -{$endif} +{$endif DELPHI5OROLDER} /// compress memory using the ZLib DEFLATE algorithm function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; @@ -81,6 +82,7 @@ function UncompressString(const data: RawByteZip): RawByteZip; {$ifdef MSWINDOWS} { use Windows MapFile } + function CompressFile(const srcFile, dstFile: TFileName; failIfGrow: boolean = false): boolean; function UncompressFile(const srcFile, dstFile: TFileName; @@ -169,7 +171,7 @@ const $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d); -{$endif} +{$endif DYNAMIC_CRC_TABLE} {$ifdef MSWINDOWS} @@ -304,9 +306,9 @@ type constructor Create(const aFileName: TFileName); overload; /// compress (using the deflate method) a memory buffer, and add it to the zip file // - by default, the 1st of January, 2010 is used if not date is supplied - procedure AddDeflated(const aZipName: TZipName; Buf: pointer; Size: - integer; CompressLevel: integer = 6; FileAge: integer = 1 + 1 shl 5 + 30 - shl 9); overload; + procedure AddDeflated(const aZipName: TZipName; + Buf: pointer; Size: integer; CompressLevel: integer = 6; + FileAge: integer = 1 + 1 shl 5 + 30 shl 9); overload; /// compress (using the deflate method) a file, and add it to the zip file procedure AddDeflated(const aFileName: TFileName; RemovePath: boolean = true; CompressLevel: integer = 6); overload; @@ -345,10 +347,10 @@ begin // should be fast enough in practice, especially inlined repeat Dst^ := PByteArray(Src)[PtrUInt(Dst)]; inc(Dst); - until PtrUInt(Dst)=Count; + until PtrUInt(Dst) = Count; end; {$else} -procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: Integer); +procedure MoveWithOverlap(Src: PByte; Dst: PByte; Count: integer); {$ifdef FPC} nostackframe; assembler; {$endif} asm // eax=source edx=dest ecx=count push edx @@ -370,7 +372,7 @@ asm // eax=source edx=dest ecx=count pop edi @exit: end; -{$endif} +{$endif PUREPASCAL} //----------------- general library stuff @@ -415,20 +417,19 @@ type ); // inflate codes private state - PInflateCodesState = ^TInflateCodesState; TInflateCodesState = record Mode: TInflateCodesMode; // current inflate codes mode // mode dependent information Len: Cardinal; - Sub: record // submode + Sub: record // submode case Byte of - 0:(Code: record // if Len or Distance, where in tree + 0:(Code: record // if Len or Distance, where in tree Tree: PInflateHuft; // pointer into tree - need: Cardinal; // bits needed + need: Cardinal; // bits needed end); - 1:(lit: Cardinal); // if icmLit, literal - 2:(copy: record // if EXT or icmCopy, where and how much - get: Cardinal; // bits to get for extra + 1:(lit: Cardinal); // if icmLit, literal + 2:(copy: record // if EXT or icmCopy, where and how much + get: Cardinal; // bits to get for extra Distance: Cardinal; // distance back to copy from end); end; @@ -438,8 +439,10 @@ type LiteralTree: PInflateHuft; // literal/length/eob tree DistanceTree: PInflateHuft; // distance tree end; + PInflateCodesState = ^TInflateCodesState; - TInflateBlockMode = (ibmZType, // get type bits (3, including end bit) + TInflateBlockMode = ( + ibmZType, // get type bits (3, including end bit) ibmLens, // get lengths for stored ibmStored, // processing stored block ibmTable, // get table lengths @@ -452,27 +455,26 @@ type ); // inflate blocks semi-private state - PInflateBlocksState = ^TInflateBlocksState; TInflateBlocksState = record - Mode: TInflateBlockMode; // current inflate block mode + Mode: TInflateBlockMode; // current inflate block mode // mode dependent information - Sub: record // submode + Sub: record // submode case Byte of - 0: (left: Cardinal); // if ibmStored, bytes left to copy - 1: (Trees: record // if DistanceTree, decoding info for trees + 0: (left: Cardinal); // if ibmStored, bytes left to copy + 1: (Trees: record // if DistanceTree, decoding info for trees Table: Cardinal; // table lengths (14 Bits) Index: Cardinal; // index into blens (or BitOrder) blens: TPACardinal; // bit lengths of codes BB: Cardinal; // bit length tree depth TB: PInflateHuft; // bit length decoding tree end); - 2: (decode: record // if ibmCodes, current state + 2: (decode: record // if ibmCodes, current state TL: PInflateHuft; TD: PInflateHuft; // trees to free codes: PInflateCodesState; end); end; - Last: Boolean; // True if this block is the last block + Last: boolean; // True if this block is the last block // mode independent information bitk: Cardinal; // bits in bit buffer bitb: Cardinal; // bit buffer @@ -482,6 +484,7 @@ type read: PByte; // window read pointer write: PByte; // window write pointer end; + PInflateBlocksState = ^TInflateBlocksState; // The application must update NextInput and AvailableInput when AvailableInput has dropped to zero. It must update // NextOutput and AvailableOutput when AvailableOutput has dropped to zero. All other fields are set by the @@ -540,21 +543,21 @@ type fc: record case Byte of 0: - (Frequency: Word); // frequency count + (Frequency: word); // frequency count 1: - (Code: Word); // bit string + (Code: word); // bit string end; dl: record case Byte of 0: - (dad: Word); // father node in Huffman tree + (dad: word); // father node in Huffman tree 1: - (Len: Word); // length of bit string + (Len: word); // length of bit string end; end; TLiteralTree = array[0..HEAP_SIZE - 1] of TTreeEntry; // literal and length tree - TDistanceTree = array[0..2 * D_CODES] of TTreeEntry; // distance tree - THuffmanTree = array[0..2 * BL_CODES] of TTreeEntry; // Huffman tree for bit lengths + TDistanceTree = array[0..2 * D_CODES] of TTreeEntry; // distance tree + THuffmanTree = array[0..2 * BL_CODES] of TTreeEntry; // Huffman tree for bit lengths PTree = ^TTree; TTree = array[0..(MaxInt div SizeOf(TTreeEntry)) - 1] of TTreeEntry; // generic tree type @@ -562,15 +565,15 @@ type TStaticTreeDescriptor = record StaticTree: PTree; // static tree or nil ExtraBits: TPAInteger; // extra bits for each code or nil - ExtraBase: Integer; // base index for ExtraBits - Elements: Integer; // max number of elements in the tree - MaxLength: Integer; // max bit length for the codes + ExtraBase: integer; // base index for ExtraBits + Elements: integer; // max number of elements in the tree + MaxLength: integer; // max bit length for the codes end; PTreeDescriptor = ^TTreeDescriptor; TTreeDescriptor = record DynamicTree: PTree; - MaxCode: Integer; // largest code with non zero frequency + MaxCode: integer; // largest code with non zero frequency StaticDescriptor: PStaticTreeDescriptor; // the corresponding static tree end; @@ -578,9 +581,9 @@ type TDeflateState = record ZState: PZState; // pointer back to this zlib stream PendingBuffer: TPAByte; // output still pending - PendingBufferSize: Integer; + PendingBufferSize: integer; PendingOutput: PByte; // next pending byte to output to the stream - Pending: Integer; // nb of bytes in the pending buffer + Pending: integer; // nb of bytes in the pending buffer WindowSize: Cardinal; // LZ77 window size (32K by default) WindowBits: Cardinal; // log2(WindowSize) (8..16) WindowMask: Cardinal; // WindowSize - 1 @@ -596,7 +599,7 @@ type // Actual size of Window: 2 * WSize, except when the user input buffer // is directly used as sliding window. - CurrentWindowSize: Integer; + CurrentWindowSize: integer; // Link to older string with same hash index. to limit the size of this // array to 64K, this link is maintained only for the last 32K strings. @@ -616,10 +619,10 @@ type // Window position at the beginning of the current output block. Gets // negative when the window is moved backwards. - BlockStart: Integer; + BlockStart: integer; MatchLength: Cardinal; // length of best match PreviousMatch: Cardinal; // previous match - MatchAvailable: Boolean; // set if previous match exists + MatchAvailable: boolean; // set if previous match exists StringStart: Cardinal; // start of string to insert MatchStart: Cardinal; // start of matching string Lookahead: Cardinal; // number of valid bytes ahead in window @@ -635,11 +638,11 @@ type DistanceDescriptor: TTreeDescriptor; // Descriptor for distance tree BitLengthDescriptor: TTreeDescriptor; // Descriptor for bit length tree - BitLengthCounts: array[0..MAX_BITS] of Word; // number of codes at each bit length for an optimal tree + BitLengthCounts: array[0..MAX_BITS] of word; // number of codes at each bit length for an optimal tree - Heap: array[0..2 * L_CODES] of Integer; // heap used to build the Huffman trees - HeapLength: Integer; // number of elements in the heap - HeapMaximum: Integer; // element of largest frequency + Heap: array[0..2 * L_CODES] of integer; // heap used to build the Huffman trees + HeapLength: integer; // number of elements in the heap + HeapMaximum: integer; // element of largest frequency // The sons of Heap[N] are Heap[2 * N] and Heap[2 * N + 1]. Heap[0] is not used. // The same heap array is used to build all trees. @@ -669,13 +672,13 @@ type // Buffer for distances. To simplify the code, DistanceBuffer and LiteralBuffer have // the same number of elements. To use different lengths, an extra flag array would be necessary. DistanceBuffer: TPAWord; - OptimalLength: Integer; // bit length of current block with optimal trees - StaticLength: Integer; // bit length of current block with static trees - CompressedLength: Integer; // total bit length of compressed file + OptimalLength: integer; // bit length of current block with optimal trees + StaticLength: integer; // bit length of current block with static trees + CompressedLength: integer; // total bit length of compressed file Matches: Cardinal; // number of string matches in current block - LastEOBLength: Integer; // bit length of EOB code for last block - BitsBuffer: Word; // Output buffer. Bits are inserted starting at the bottom (least significant bits). - ValidBits: Integer; // Number of valid bits in BitsBuffer. All Bits above the last valid bit are always zero. + LastEOBLength: integer; // bit length of EOB code for last block + BitsBuffer: word; // Output buffer. Bits are inserted starting at the bottom (least significant bits). + ValidBits: integer; // Number of valid bits in BitsBuffer. All Bits above the last valid bit are always zero. end; //----------------- Huffmann trees @@ -853,7 +856,7 @@ const ); // first normalized distance for each code (0 = distance of 1) - BaseDistance: array[0..D_CODES - 1] of Integer = ( + BaseDistance: array[0..D_CODES - 1] of integer = ( 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 @@ -867,17 +870,19 @@ const REPZ_11_138 = 18; // repeat a zero length 11-138 times (7 Bits of repeat count) // extra bits for each length code - ExtraLengthBits: array[0..LENGTH_CODES - 1] of Integer = ( - 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0 + ExtraLengthBits: array[0..LENGTH_CODES - 1] of integer = ( + 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, + 4, 4, 4, 4, 5, 5, 5, 5, 0 ); // extra bits for each distance code - ExtraDistanceBits: array[0..D_CODES - 1] of Integer = ( - 0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10 ,10, 11, 11, 12, 12, 13, 13 + ExtraDistanceBits: array[0..D_CODES - 1] of integer = ( + 0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, + 9, 9, 10 ,10, 11, 11, 12, 12, 13, 13 ); // extra bits for each bit length code - ExtraBitLengthBits: array[0..BL_CODES - 1] of Integer = ( + ExtraBitLengthBits: array[0..BL_CODES - 1] of integer = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3, 7 ); @@ -918,10 +923,11 @@ const //----------------- Inflate support const - InflateMask: array[0..16] of Cardinal = ($0000, $0001, $0003, $0007, $000F, - $001F, $003F, $007F, $00FF, $01FF, $03FF, $07FF, $0FFF, $1FFF, $3FFF, $7FFF, $FFFF); + InflateMask: array[0..16] of Cardinal = ( + $0000, $0001, $0003, $0007, $000F, $001F, $003F, $007F, + $00FF, $01FF, $03FF, $07FF, $0FFF, $1FFF, $3FFF, $7FFF, $FFFF); -function InflateFlush(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer; +function InflateFlush(var S: TInflateBlocksState; var Z: TZState; R: integer): integer; // copies as much as possible from the sliding window to the output area var N: Cardinal; @@ -952,7 +958,8 @@ begin Inc(Q, N); // see if more to copy at beginning of window - if Q = S.zend then begin + if Q = S.zend then + begin // wrap pointers Q := S.Window; if S.write = S.zend then @@ -976,11 +983,11 @@ begin Z.NextOutput := P; S.Read := Q; - Result := R; + result := R; end; function InflateFast(LiteralBits, DistanceBits: Cardinal; TL, TD: PInflateHuft; - var S: TInflateBlocksState; var Z: TZState): Integer; + var S: TInflateBlocksState; var Z: TZState): integer; // Called with number of bytes left to write in window at least 258 (the maximum string length) and number of input // bytes available at least ten. The ten bytes are six bytes for the longest length/distance pair plus four bytes for // overloading the bit buffer. @@ -1017,7 +1024,8 @@ begin // assume called with (M >= 258) and (N >= 10) repeat // get literal/length Code - while K < 20 do begin + while K < 20 do + begin Dec(N); BitsBuffer := BitsBuffer or (cardinal(P^) shl K); Inc(K, 8); @@ -1027,7 +1035,8 @@ begin Temp := @PHuftField(TL)[BitsBuffer and ml]; Extra := Temp.exop; - if Extra = 0 then begin + if Extra = 0 then + begin BitsBuffer := BitsBuffer shr Temp.Bits; Dec(K, Temp.Bits); Q^ := Temp.Base; @@ -1043,14 +1052,16 @@ begin BitsBuffer := BitsBuffer shr Temp.Bits; Dec(K, Temp.Bits); - if (Extra and 16) <> 0 then begin + if (Extra and 16) <> 0 then + begin // get extra bits for length Extra := Extra and 15; C := Temp.Base + (BitsBuffer and InflateMask[Extra]); BitsBuffer := BitsBuffer shr Extra; Dec(K, Extra); // decode distance base of block to copy - while K < 15 do begin + while K < 15 do + begin Dec(N); BitsBuffer := BitsBuffer or (Cardinal(P^) shl K); Inc(P); @@ -1062,10 +1073,12 @@ begin repeat BitsBuffer := BitsBuffer shr Temp.Bits; Dec(K, Temp.Bits); - if (Extra and 16) <> 0 then begin + if (Extra and 16) <> 0 then + begin // get extra bits to add to distance base Extra := Extra and 15; - while K < Extra do begin + while K < Extra do + begin Dec(N); BitsBuffer := BitsBuffer or (Cardinal(P^) shl K); Inc(P); @@ -1077,19 +1090,22 @@ begin // do the copy Dec(M, C); // offset before Dest - if (PtrUInt(Q) - PtrUInt(S.Window)) >= D then begin + if (PtrUInt(Q) - PtrUInt(S.Window)) >= D then + begin // copy without extra R := Q; Dec(R, D); end - else begin + else + begin // offset after destination, // bytes from offset to end Extra := D - (PtrUInt(Q) - PtrUInt(S.Window)); R := S.zend; // pointer to offset Dec(R, Extra); - if C > Extra then begin + if C > Extra then + begin // copy to end of window Dec(C, Extra); MoveWithOverlap(R, Q, Extra); @@ -1104,11 +1120,13 @@ begin inc(Q,Extra); Break; end - else if (Extra and 64) = 0 then begin + else if (Extra and 64) = 0 then + begin Inc(Temp, Temp.Base + (BitsBuffer and InflateMask[Extra])); Extra := Temp.exop; end - else begin + else + begin C := Z.AvailableInput - N; if (K shr 3) < C then C := K shr 3; @@ -1121,17 +1139,19 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := Z_DATA_ERROR; - Exit; + result := Z_DATA_ERROR; + exit; end; until False; Break; end; - if (Extra and 64) = 0 then begin + if (Extra and 64) = 0 then + begin Inc(Temp, Temp.Base + (BitsBuffer and InflateMask[Extra])); Extra := Temp.exop; - if Extra = 0 then begin + if Extra = 0 then + begin BitsBuffer := BitsBuffer shr Temp.Bits; Dec(K, Temp.Bits); Q^ := Temp.Base; @@ -1140,7 +1160,8 @@ begin Break; end; end - else if (Extra and 32) <> 0 then begin + else if (Extra and 32) <> 0 then + begin C := Z.AvailableInput - N; if (K shr 3) < C then C := K shr 3; @@ -1153,10 +1174,11 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := Z_STREAM_END; - Exit; + result := Z_STREAM_END; + exit; end - else begin + else + begin C := Z.AvailableInput - N; if (K shr 3) < C then C := K shr 3; @@ -1169,8 +1191,8 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := Z_DATA_ERROR; - Exit; + result := Z_DATA_ERROR; + exit; end; until False; if (M < 258) or (N < 10) then @@ -1190,21 +1212,21 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := Z_OK; + result := Z_OK; end; function InflateCodesNew(LiteralBits: Cardinal; DistanceBits: Cardinal; TL, TD: PInflateHuft; var Z: TZState): PInflateCodesState; begin GetMem(result, SizeOf(TInflateCodesState)); - Result.Mode := icmStart; - Result.LiteralTreeBits := LiteralBits; - Result.DistanceTreeBits := DistanceBits; - Result.LiteralTree := TL; - Result.DistanceTree := TD; + result.Mode := icmStart; + result.LiteralTreeBits := LiteralBits; + result.DistanceTreeBits := DistanceBits; + result.LiteralTree := TL; + result.DistanceTree := TD; end; -function InflateCodes(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer; +function InflateCodes(var S: TInflateBlocksState; var Z: TZState; R: integer): integer; var J: Cardinal; // temporary storage Temp: PInflateHuft; @@ -1232,11 +1254,13 @@ begin M := PtrUInt(S.zend) - PtrUInt(Q); // process input and output based on current state - while True do begin + while True do + begin case C.Mode of icmStart: begin - if (M >= 258) and (N >= 10) then begin + if (M >= 258) and (N >= 10) then + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; @@ -1255,7 +1279,8 @@ begin M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); - if R <> Z_OK then begin + if R <> Z_OK then + begin if R = Z_STREAM_END then C.mode := icmWash else @@ -1270,18 +1295,20 @@ begin icmLen: // I: get length/literal/eob next begin J := C.sub.Code.need; - while K < J do begin + while K < J do + begin if N <> 0 then R := Z_OK - else begin + else + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; Dec(N); BitsBuffer := BitsBuffer or (Cardinal(P^) shl K); @@ -1295,26 +1322,30 @@ begin Extra := Temp.exop; // literal - if Extra = 0 then begin + if Extra = 0 then + begin C.sub.lit := Temp.Base; C.mode := icmLit; Continue; end; // length - if (Extra and 16) <> 0 then begin + if (Extra and 16) <> 0 then + begin C.sub.copy.get := Extra and 15; C.Len := Temp.Base; C.mode := icmLenNext; Continue; end; // next table - if (Extra and 64) = 0 then begin + if (Extra and 64) = 0 then + begin C.sub.Code.need := Extra; C.sub.Code.Tree := @PHuftField(Temp)[Temp.Base]; Continue; end; // end of block - if (Extra and 32) <> 0 then begin + if (Extra and 32) <> 0 then + begin C.mode := icmWash; Continue; end; @@ -1327,24 +1358,26 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; icmLenNext: // I: getting length extra (have base) begin J := C.sub.copy.get; - while K < J do begin + while K < J do + begin if N <> 0 then R := Z_OK - else begin + else + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; Dec(N); BitsBuffer := BitsBuffer or (Cardinal(P^) shl K); @@ -1361,18 +1394,20 @@ begin icmDistance: // I: get distance next begin J := C.sub.Code.need; - while K < J do begin + while K < J do + begin if N <> 0 then R := Z_OK - else begin + else + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; Dec(N); BitsBuffer := BitsBuffer or (PtrUInt(P^) shl K); @@ -1385,14 +1420,16 @@ begin Extra := Temp.exop; // distance - if (Extra and 16) <> 0 then begin + if (Extra and 16) <> 0 then + begin C.sub.copy.get := Extra and 15; C.sub.copy.Distance := Temp.Base; C.mode := icmDistExt; Continue; end; // next table - if (Extra and 64) = 0 then begin + if (Extra and 64) = 0 then + begin C.sub.Code.need := Extra; C.sub.Code.Tree := @PHuftField(Temp)[Temp.Base]; Continue; @@ -1406,24 +1443,26 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; icmDistExt: // I: getting distance extra begin J := C.sub.copy.get; - while K < J do begin + while K < J do + begin if N <> 0 then R := Z_OK - else begin + else + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; Dec(N); BitsBuffer := BitsBuffer or (Cardinal(P^) shl K); @@ -1439,21 +1478,26 @@ begin begin F := Q; Dec(F, C.sub.copy.Distance); - if (PtrUInt(Q) - PtrUInt(S.Window)) < C.sub.copy.Distance then begin + if (PtrUInt(Q) - PtrUInt(S.Window)) < C.sub.copy.Distance then + begin F := S.zend; Dec(F, C.sub.copy.Distance - (PtrUInt(Q) - PtrUInt(S.Window))); end; - while C.Len <> 0 do begin - if M = 0 then begin - if (Q = S.zend) and (S.read <> S.Window) then begin + while C.Len <> 0 do + begin + if M = 0 then + begin + if (Q = S.zend) and (S.read <> S.Window) then + begin Q := S.Window; if PtrUInt(Q) < PtrUInt(S.read) then M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); end; - if M = 0 then begin + if M = 0 then + begin S.write := Q; R := InflateFlush(S, Z, R); Q := S.write; @@ -1461,22 +1505,24 @@ begin M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); - if (Q = S.zend) and (S.read <> S.Window) then begin + if (Q = S.zend) and (S.read <> S.Window) then + begin Q := S.Window; if PtrUInt(Q) < PtrUInt(S.read) then M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); end; - if M = 0 then begin + if M = 0 then + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; end; end; @@ -1493,15 +1539,18 @@ begin end; icmLit: // O: got literal, waiting for output space begin - if M = 0 then begin - if (Q = S.zend) and (S.read <> S.Window) then begin + if M = 0 then + begin + if (Q = S.zend) and (S.read <> S.Window) then + begin Q := S.Window; if PtrUInt(Q) < PtrUInt(S.read) then M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); end; - if M = 0 then begin + if M = 0 then + begin S.write := Q; R := InflateFlush(S, Z, R); Q := S.write; @@ -1509,22 +1558,24 @@ begin M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); - if (Q = S.zend) and (S.read <> S.Window) then begin + if (Q = S.zend) and (S.read <> S.Window) then + begin Q := S.Window; if PtrUInt(Q) < PtrUInt(S.read) then M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); end; - if M = 0 then begin + if M = 0 then + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; end; end; @@ -1537,7 +1588,8 @@ begin icmWash: // O: got eob, possibly More output begin // return unused byte, if any - if K > 7 then begin + if K > 7 then + begin Dec(K, 8); Inc(N); Dec(P); @@ -1550,15 +1602,16 @@ begin M := PtrUInt(S.read) - PtrUInt(Q) - 1 else M := PtrUInt(S.zend) - PtrUInt(Q); - if S.read <> S.write then begin + if S.read <> S.write then + begin S.bitb := BitsBuffer; S.bitk := K; Z.AvailableInput := N; Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; C.mode := icmZEnd; end; @@ -1571,8 +1624,8 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; icmBadCode: // X: got error begin @@ -1583,8 +1636,8 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; else begin @@ -1595,13 +1648,11 @@ begin Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; end; end; - - Result := Z_STREAM_ERROR; end; type @@ -1617,7 +1668,8 @@ const // Tables for deflate from PKZIP'S appnote.txt // copy lengths for literal codes 257..285 (actually lengths - 2; also see note #13 above about 258) CopyLengths: TDeflateLengths = (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, - 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0); + 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, + 227, 258, 0, 0); INVALID_CODE = 112; // extra bits for literal codes 257..285 CopyLiteralExtra: TDeflateLengths = (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, @@ -1667,7 +1719,7 @@ const function BuildHuffmanTables(const B: TACardinal; N, S: Cardinal; const D, Extra: TDeflateLengths; Temp: PPInflateHuft; var M: Cardinal; HP: PHuftField; - var HN: Cardinal; var V: TDeflateWorkArea): Integer; + var HN: Cardinal; var V: TDeflateWorkArea): integer; // Given a list of code lengths and a maximum table size, make a set of tables to decode that set of codes. Returns Z_OK // on success, Z_BUF_ERROR if the given code set is incomplete (the tables are still built in this case), Z_DATA_ERROR @@ -1690,20 +1742,20 @@ function BuildHuffmanTables(const B: TACardinal; N, S: Cardinal; const D, var A: Cardinal; // counter for codes of length K F: Cardinal; // I repeats in table every F entries - G: Integer; // maximum code Length - H: Integer; // table Level + G: integer; // maximum code Length + H: integer; // table Level I: Cardinal; // counter, current code J: Cardinal; // counter - K: Integer; // number of bits in current code - L: Integer; // bits per table (returned in M) + K: integer; // number of bits in current code + L: integer; // bits per table (returned in M) Mask: Cardinal; // (1 shl W) - 1, to avoid cc - O bug on HP P: TPCardinal; // pointer into C[], B[], or V[] Q: PInflateHuft; // points to current table R: TInflateHuft; // table entry for structure assignment XP: TPCardinal; // pointer into X - Y: Integer; // number of dummy codes added + Y: integer; // number of dummy codes added Z: Cardinal; // number of entries in current table - W: Integer; // bits before this table = (L * H) + W: integer; // bits before this table = (L * H) C: array[0..BMAX] of Cardinal; // bit length count table U: array[0..BMAX - 1] of PInflateHuft; // table stack X: array[0..BMAX] of Cardinal; // bit offsets, then code stack @@ -1716,11 +1768,12 @@ begin Inc(C[B[I]]); // nil input -> all zero length codes - if C[0] = N then begin + if C[0] = N then + begin Temp^ := nil; M := 0; - Result := Z_OK; - Exit; + result := Z_OK; + exit; end; // find minimum and maximum length, bound [M] by those @@ -1743,28 +1796,32 @@ begin // adjust last length count to fill out codes if needed Y := 1 shl J; - while J < I do begin + while J < I do + begin Dec(Y, C[J]); - if Y < 0 then begin + if Y < 0 then + begin // bad input: more codes than bits - Result := Z_DATA_ERROR; - Exit; + result := Z_DATA_ERROR; + exit; end; Inc(J); Y := Y shl 1; end; Dec(Y, C[I]); - if Y < 0 then begin + if Y < 0 then + begin // bad input: more codes than bits - Result := Z_DATA_ERROR; - Exit; + result := Z_DATA_ERROR; + exit; end; Inc(C[I], Y); // generate starting offsets into the value table for each length X[1] := 0; J := 0; - for I := 1 to G - 1 do begin + for I := 1 to G - 1 do + begin inc(J, C[I]); X[I + 1] := J; end; @@ -1839,8 +1896,8 @@ begin Z := 1 shl J; // allocate new table (note: doesn't matter for fixed) if HN + Z > MANY then begin - Result := Z_MEM_ERROR; - Exit; + result := Z_MEM_ERROR; + exit; end; Q := @HP[HN]; @@ -1919,20 +1976,20 @@ begin // Return Z_BUF_ERROR if we were given an incomplete table if (Y <> 0) and (G <> 1) then - Result := Z_BUF_ERROR + result := Z_BUF_ERROR else - Result := Z_OK; + result := Z_OK; end; function InflateTreesBits(var C: TACardinal; var BB: Cardinal; var TB: - PInflateHuft; HP: PHuftField; var Z: TZState): Integer; + PInflateHuft; HP: PHuftField; var Z: TZState): integer; // C holds 19 code lengths // BB - bits tree desired/actual depth // TB - bits tree result // HP - space for trees // Z - for messages var - R: Integer; + R: integer; HN: Cardinal; // hufts used in space V: TDeflateWorkArea; // work area for BuildHuffmanTables begin @@ -1940,12 +1997,12 @@ begin R := BuildHuffmanTables(C, 19, 19, CopyLengths, CopyLiteralExtra, @TB, BB, HP, HN, V); if (R = Z_BUF_ERROR) or (BB = 0) then R := Z_DATA_ERROR; - Result := R; + result := R; end; function InflateTreesDynamic(NL: Cardinal; ND: Cardinal; var C: TACardinal; var LiteralBits: Cardinal; var DistanceBits: Cardinal; var TL: PInflateHuft; - var TD: PInflateHuft; HP: PHuftField; var Z: TZState): Integer; + var TD: PInflateHuft; HP: PHuftField; var Z: TZState): integer; // NL - number of literal/length codes // ND - number of distance codes // C - code lengths @@ -1956,19 +2013,19 @@ function InflateTreesDynamic(NL: Cardinal; ND: Cardinal; var C: TACardinal; // HP - space for trees // Z - for messages var - R: Integer; + R: integer; HN: Cardinal; // hufts used in space V: TDeflateWorkArea; // work area for BuildHuffmanTables begin HN := 0; // allocate work area - Result := Z_OK; + result := Z_OK; // build literal/length tree R := BuildHuffmanTables(C, NL, 257, CopyLengths, CopyLiteralExtra, @TL, LiteralBits, HP, HN, V); if (R <> Z_OK) or (LiteralBits = 0) then begin - Result := R; - Exit; + result := R; + exit; end; // build distance tree R := BuildHuffmanTables(TPACardinal(@C[NL])^, ND, 0, CopyOffsets, CopyExtra, @TD, @@ -1978,7 +2035,7 @@ begin R := Z_DATA_ERROR else if R <> Z_MEM_ERROR then R := Z_DATA_ERROR; - Result := R; + result := R; end; end; @@ -1988,7 +2045,7 @@ const var // build fixed tables only once -> keep them here - FixedBuild: Boolean; + FixedBuild: boolean; FixedTablesMemory: array[0..FIXEDH - 1] of TInflateHuft; FixedLiteralBits: Cardinal; FixedDistanceBits: Cardinal; @@ -1996,9 +2053,9 @@ var FixedDistanceTable: array[0..32 - 1] of TInflateHuft; function InflateTreesFixed(var LiteralBits: Cardinal; var DistanceBits: Cardinal; - var TL, TD: PInflateHuft; var Z: TZState): Integer; + var TL, TD: PInflateHuft; var Z: TZState): integer; var - K: Integer; // temporary variable + K: integer; // temporary variable C: TDeflateWorkArea; // length list for BuildHuffmanTables V: TDeflateWorkArea; // work area for BuildHuffmanTables F: Cardinal; // number of hufts used in FixedTablesMemory @@ -2030,7 +2087,7 @@ begin DistanceBits := FixedDistanceBits; TL := @FixedLiteralTable; TD := @FixedDistanceTable; - Result := Z_OK; + result := Z_OK; end; @@ -2091,7 +2148,7 @@ var begin GetMem(S, SizeOf(TInflateBlocksState)); if S = nil then - Result := S + result := S else try GetMem(S.hufts, SizeOf(TInflateHuft) * MANY); @@ -2100,7 +2157,7 @@ begin Inc(S.zend, W); S.mode := ibmZType; InflateBlockReset(S^, Z); - Result := S; + result := S; except if Assigned(S.Window) then FreeMem(S.Window); @@ -2111,7 +2168,7 @@ begin end; end; -function InflateBlocks(var S: TInflateBlocksState; var Z: TZState; R: Integer): Integer; +function InflateBlocks(var S: TInflateBlocksState; var Z: TZState; R: integer): integer; // R contains the initial return code var Temp: Cardinal; @@ -2128,7 +2185,7 @@ var I, J, C: Cardinal; CodeState: PInflateCodesState; - function UpdatePointers: Integer; + function UpdatePointers: integer; begin S.bitb := B; S.bitk := K; @@ -2136,7 +2193,7 @@ var Inc(Z.TotalInput, PtrUInt(P) - PtrUInt(Z.NextInput)); Z.NextInput := P; S.write := Q; - Result := InflateFlush(S, Z, R); + result := InflateFlush(S, Z, R); end; begin @@ -2160,8 +2217,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2170,7 +2227,7 @@ begin end; Temp := B and 7; - S.last := Boolean(Temp and 1); + S.last := boolean(Temp and 1); case Temp shr 1 of 0: // stored begin @@ -2190,8 +2247,8 @@ begin TL, TD, Z); if S.sub.decode.codes = nil then begin R := Z_MEM_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; B := B shr 3; Dec(K, 3); @@ -2209,8 +2266,8 @@ begin Dec(K, 3); S.mode := ibmBlockBad; R := Z_DATA_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; end; end; @@ -2220,8 +2277,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2232,8 +2289,8 @@ begin if (((not B) shr 16) and $FFFF) <> (B and $FFFF) then begin S.mode := ibmBlockBad; R := Z_DATA_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; S.sub.left := B and $FFFF; K := 0; @@ -2248,8 +2305,8 @@ begin ibmStored: begin if N = 0 then begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; if M = 0 then begin @@ -2278,8 +2335,8 @@ begin end; if M = 0 then begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; end; end; @@ -2309,8 +2366,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2323,8 +2380,8 @@ begin if ((Temp and $1F) > 29) or (((Temp shr 5) and $1F) > 29) then begin S.mode := ibmBlockBad; R := Z_DATA_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Temp := 258 + (Temp and $1F) + ((Temp shr 5) and $1F); GetMem(S.sub.trees.blens, Temp * SizeOf(Cardinal)); @@ -2341,8 +2398,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2367,8 +2424,8 @@ begin R := Temp; if R = Z_DATA_ERROR then S.mode := ibmBlockBad; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; S.sub.trees.Index := 0; S.mode := ibmDistTree; @@ -2384,8 +2441,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2419,8 +2476,8 @@ begin if N <> 0 then R := Z_OK else begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; Dec(N); B := B or (Cardinal(P^) shl K); @@ -2442,8 +2499,8 @@ begin FreeMem(S.sub.trees.blens); S.mode := ibmBlockBad; R := Z_DATA_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; if C = 16 then @@ -2467,17 +2524,17 @@ begin S.sub.trees.blens^, LiteralBits, DistanceBits, TL, TD, S.hufts, Z); FreeMem(S.sub.trees.blens); if Temp <> Z_OK then begin - if Integer(Temp) = Z_DATA_ERROR then + if integer(Temp) = Z_DATA_ERROR then S.mode := ibmBlockBad; R := Temp; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; CodeState := InflateCodesNew(LiteralBits, DistanceBits, TL, TD, Z); if CodeState = nil then begin R := Z_MEM_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; S.sub.decode.codes := CodeState; S.mode := ibmCodes; @@ -2494,8 +2551,8 @@ begin R := InflateCodes(S, Z, R); if R <> Z_STREAM_END then begin - Result := InflateFlush(S, Z, R); - Exit; + result := InflateFlush(S, Z, R); + exit; end; R := Z_OK; Freemem(S.sub.decode.codes); @@ -2521,27 +2578,27 @@ begin R := InflateFlush(S, Z, R); Q := S.write; if S.read <> S.write then begin - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; S.mode := ibmBlockDone; end; ibmBlockDone: begin R := Z_STREAM_END; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; ibmBlockBad: begin R := Z_DATA_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; else R := Z_STREAM_ERROR; - Result := UpdatePointers; - Exit; + result := UpdatePointers; + exit; end; // case S.mode of end; end; @@ -2596,7 +2653,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; if (Scan^ <> Match^) then Break; until (PtrUInt(Scan) >= PtrUInt(StrEnd)); - result := MAX_MATCH - Integer(PtrUInt(StrEnd) - PtrUInt(Scan)); + result := MAX_MATCH - integer(PtrUInt(StrEnd) - PtrUInt(Scan)); end; const @@ -2676,9 +2733,9 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; until (CurrentMatch <= Limit) or (ChainLength = 0); if BestLen <= S.Lookahead then - Result := BestLen + result := BestLen else - Result := S.Lookahead; + result := S.Lookahead; end; procedure FillWindow(var S: TDeflateState); @@ -2688,7 +2745,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; // On exit at least one byte has been read, or AvailableInput = 0. Reads are performed for at least two bytes (required // for the zip translate_eol option -> not supported here). - function ReadBuffer(ZState: PZState; Buffer: PByte; Size: Cardinal): Integer; + function ReadBuffer(ZState: PZState; Buffer: PByte; Size: Cardinal): integer; // Reads a new buffer from the current input stream, updates the Adler32 and total number of bytes read. All Deflate // input goes through this function so some applications may wish to modify it to avoid allocating a large // ZState.NextInput buffer and copying from it (see also FlushPending). @@ -2699,14 +2756,14 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; if Len > Size then Len := Size; if Len = 0 then begin - Result := 0; - Exit; + result := 0; + exit; end; Dec(ZState.AvailableInput, Len); Move(ZState.NextInput^, Buffer^, Len); Inc(ZState.NextInput, Len); Inc(ZState.TotalInput, Len); - Result := Len; + result := Len; end; var @@ -2715,7 +2772,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; More: Cardinal; // amount of free space at the end of the window begin repeat - More := S.CurrentWindowSize - Integer(S.Lookahead) - Integer(S.StringStart); + More := S.CurrentWindowSize - integer(S.Lookahead) - integer(S.StringStart); if (More = 0) and (S.StringStart = 0) and (S.Lookahead = 0) then More := S.WindowSize else if More = Cardinal(-1) then begin @@ -2729,7 +2786,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; Dec(S.MatchStart, S.WindowSize); Dec(S.StringStart, S.WindowSize); // we now have StringStart >= MaxDistance - Dec(S.BlockStart, Integer(S.WindowSize)); + Dec(S.BlockStart, integer(S.WindowSize)); // Slide the hash table (could be avoided with 32 bit values at the expense of memory usage). We slide even when // Level = 0 to keep the hash table consistent if we switch back to Level > 0 later. (Using Level 0 permanently @@ -2757,7 +2814,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; if S.ZState.AvailableInput = 0 then - Exit; + exit; // If there was no sliding: // StringStart <= S.WindowSize + MaxDistance - 1 and Lookahead <= MIN_LOOKAHEAD - 1 and @@ -2785,7 +2842,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; procedure InitializeBlock(var S: TDeflateState); var - N: Integer; + N: integer; begin // initialize the trees for N := 0 to L_CODES - 1 do @@ -2801,7 +2858,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; S.LastLiteral := 0; end; - procedure FlushBlockOnly(var S: TDeflateState; EOF: Boolean); + procedure FlushBlockOnly(var S: TDeflateState; EOF: boolean); // Flushs the current block with given end-of-file flag. // StringStart must be set to the end of the current match. @@ -2832,7 +2889,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; function TreeFlushBlock(var S: TDeflateState; Buffer: PByte; StoredLength: - Integer; EOF: Boolean): Integer; + integer; EOF: boolean): integer; // Determines the best encoding for the current block: dynamic trees, static trees or store, and outputs the encoded // block. Buffer contains the input block (or nil if too old), StoredLength the length of this block and EOF if this // is the last block. @@ -2841,37 +2898,37 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; procedure BuildTree(var S: TDeflateState; var Descriptor: TTreeDescriptor); // Constructs a Huffman tree and assigns the code bit strings and lengths. // Updates the total bit length for the current block. The field Frequency must be set for all tree elements on entry. - // Result: the fields Len and Code are set to the optimal bit length and corresponding Code. The length OptimalLength + // result: the fields Len and Code are set to the optimal bit length and corresponding Code. The length OptimalLength // is updated; StaticLength is also updated if STree is not nil. The field MaxCode is set. - procedure GenerateCodes(Tree: PTree; MaxCode: Integer; const - BitLengthCounts: array of Word); + procedure GenerateCodes(Tree: PTree; MaxCode: integer; const + BitLengthCounts: array of word); // Generates the codes for a given tree and bit counts (which need not be optimal). // The array BitLengthCounts contains the bit length statistics for the given tree and the field Len is set for all // Tree elements. MaxCode is the largest code with non zero frequency and BitLengthCounts are the number of codes at // each bit length. // On exit the field code is set for all tree elements of non zero code length. - function BitReverse(Code: Word; Len: Integer): Word; + function BitReverse(Code: word; Len: integer): word; // Reverses the first Len bits of Code, using straightforward code (a faster // imMethod would use a table) begin - Result := 0; + result := 0; repeat - Result := Result or (Code and 1); + result := result or (Code and 1); Code := Code shr 1; - Result := Result shl 1; + result := result shl 1; Dec(Len); until Len <= 0; - Result := Result shr 1; + result := result shr 1; end; var - NextCode: array[0..MAX_BITS] of Word; // next code value for each bit length - Code: Word; // running code value - Bits: Integer; // bit Index - N: Integer; // code Index - Len: Integer; + NextCode: array[0..MAX_BITS] of word; // next code value for each bit length + Code: word; // running code value + Bits: integer; // bit Index + N: integer; // code Index + Len: integer; begin Code := 0; // The distribution counts are first used to generate the code values without bit reversal. @@ -2889,12 +2946,12 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; end; - procedure RestoreHeap(var S: TDeflateState; const Tree: TTree; K: Integer); + procedure RestoreHeap(var S: TDeflateState; const Tree: TTree; K: integer); // Restores the heap property by moving down tree starting at node K, // exchanging a Node with the smallest of its two sons if necessary, stopping // when the heap property is re-established (each father smaller than its two sons). var - V, J: Integer; + V, J: integer; begin V := S.Heap[K]; J := K shl 1; // left son of K @@ -2927,21 +2984,21 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; TTreeDescriptor); // Computes the optimal bit lengths for a tree and update the total bit length for the current block. // The fields Frequency and dad are set, Heap[HeapMaximum] and above are the tree nodes sorted by increasing frequency. - // Result: The field Len is set to the optimal bit length, the array BitLengthCounts contains the frequencies for each + // result: The field Len is set to the optimal bit length, the array BitLengthCounts contains the frequencies for each // bit length. The length OptimalLength is updated. StaticLength is also updated if STree is not nil. var Tree: PTree; - MaxCode: Integer; + MaxCode: integer; STree: PTree; Extra: TPAInteger; - Base: Integer; - MaxLength: Integer; - H: Integer; // heap Index - N, M: Integer; // iterate over the tree elements - Bits: Word; // bit length - ExtraBits: Integer; - F: Word; // frequency - Overflow: Integer; // number of elements with bit length too large + Base: integer; + MaxLength: integer; + H: integer; // heap Index + N, M: integer; // iterate over the tree elements + Bits: word; // bit length + ExtraBits: integer; + F: word; // frequency + Overflow: integer; // number of elements with bit length too large begin Tree := Descriptor.DynamicTree; MaxCode := Descriptor.MaxCode; @@ -2974,13 +3031,13 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; if N >= Base then ExtraBits := Extra[N - Base]; F := Tree[N].fc.Frequency; - Inc(S.OptimalLength, Integer(F) * (Bits + ExtraBits)); + Inc(S.OptimalLength, integer(F) * (Bits + ExtraBits)); if Assigned(STree) then - Inc(S.StaticLength, Integer(F) * (STree[N].dl.Len + ExtraBits)); + Inc(S.StaticLength, integer(F) * (STree[N].dl.Len + ExtraBits)); end; // This happens for example on obj2 and pic of the Calgary corpus if Overflow = 0 then - Exit; + exit; // find the first bit length which could increase repeat @@ -3011,7 +3068,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; Continue; if Tree[M].dl.Len <> Bits then begin Inc(S.OptimalLength, (Bits - Tree[M].dl.Len) * Tree[M].fc.Frequency); - Tree[M].dl.Len := Word(Bits); + Tree[M].dl.Len := word(Bits); end; Dec(N); end; @@ -3021,10 +3078,10 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; var Tree: PTree; STree: PTree; - Elements: Integer; - N, M: Integer; // iterate over heap elements - MaxCode: Integer; // largest code with non zero frequency - Node: Integer; // new node being created + Elements: integer; + N, M: integer; // iterate over heap elements + MaxCode: integer; // largest code with non zero frequency + Node: integer; // new node being created begin Tree := Descriptor.DynamicTree; @@ -3100,8 +3157,8 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; else S.Depth[Node] := Byte(S.Depth[M] + 1); - Tree[M].dl.Dad := Word(Node); - Tree[N].dl.Dad := Word(Node); + Tree[M].dl.Dad := word(Node); + Tree[N].dl.Dad := word(Node); // and insert the new node in the heap S.Heap[1] := Node; Inc(Node); @@ -3125,7 +3182,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; if S.ValidBits > 8 then begin S.PendingBuffer[S.Pending] := Byte(S.BitsBuffer and $FF); Inc(S.Pending); - S.PendingBuffer[S.Pending] := Byte(Word(S.BitsBuffer) shr 8); + S.PendingBuffer[S.Pending] := Byte(word(S.BitsBuffer) shr 8); Inc(S.Pending); end else if S.ValidBits > 0 then begin @@ -3136,13 +3193,13 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; S.ValidBits := 0; end; - procedure SendBits(var S: TDeflateState; Value: Word; Length: Integer); + procedure SendBits(var S: TDeflateState; Value: word; Length: integer); // Value contains what is to be sent // Length is the number of bits to send begin // If there's not enough room in BitsBuffer use (valid) bits from BitsBuffer and // (16 - ValidBits) bits from Value, leaving (width - (16 - ValidBits)) unused bits in Value. - if (S.ValidBits > Integer(BufferSize) - Length) then begin + if (S.ValidBits > integer(BufferSize) - Length) then begin S.BitsBuffer := S.BitsBuffer or (Value shl S.ValidBits); S.PendingBuffer[S.Pending] := S.BitsBuffer and $FF; Inc(S.Pending); @@ -3157,23 +3214,23 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; end; - procedure SendAllTrees(var S: TDeflateState; lcodes, dcodes, blcodes: Integer); + procedure SendAllTrees(var S: TDeflateState; lcodes, dcodes, blcodes: integer); // Sends the header for a block using dynamic Huffman trees: the counts, the // lengths of the bit length codes, the literal tree and the distance tree. // lcodes must be >= 257, dcodes >= 1 and blcodes >= 4 procedure SendTree(var S: TDeflateState; const Tree: array of TTreeEntry; - MaxCode: Integer); + MaxCode: integer); // Sends the given tree in compressed form using the codes in BitLengthTree. // MaxCode is the tree's largest code of non zero frequency. var - N: Integer; // iterates over all tree elements - PreviousLen: Integer; // last emitted length - CurrentLen: Integer; // length of current code - NextLen: Integer; // length of next code - Count: Integer; // repeat count of the current code - MaxCount: Integer; // max repeat count - MinCount: Integer; // min repeat count + N: integer; // iterates over all tree elements + PreviousLen: integer; // last emitted length + CurrentLen: integer; // length of current code + NextLen: integer; // length of next code + Count: integer; // repeat count of the current code + MaxCount: integer; // max repeat count + MinCount: integer; // min repeat count begin PreviousLen := -1; NextLen := Tree[0].dl.Len; @@ -3231,7 +3288,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; var - Rank: Integer; + Rank: integer; begin SendBits(S, lcodes - 257, 5); // not +255 as stated in appnote.txt SendBits(S, dcodes - 1, 5); @@ -3242,22 +3299,22 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; SendTree(S, S.DistanceTree, dcodes - 1); end; - function BuildBitLengthTree(var S: TDeflateState): Integer; + function BuildBitLengthTree(var S: TDeflateState): integer; // Constructs the Huffman tree for the bit lengths and returns the Index in BitLengthOrder // of the last bit length code to send. procedure ScanTree(var S: TDeflateState; var Tree: array of TTreeEntry; - MaxCode: Integer); + MaxCode: integer); // Scans a given tree to determine the frequencies of the codes in the bit length tree. // MaxCode is the tree's largest code of non zero frequency. var - N: Integer; // iterates over all tree elements - PreviousLen: Integer; // last emitted length - CurrentLen: Integer; // Length of current code - NextLen: Integer; // length of next code - Count: Integer; // repeat count of the current xode - MaxCount: Integer; // max repeat count - MinCount: Integer; // min repeat count + N: integer; // iterates over all tree elements + PreviousLen: integer; // last emitted length + CurrentLen: integer; // Length of current code + NextLen: integer; // length of next code + Count: integer; // repeat count of the current xode + MaxCount: integer; // max repeat count + MinCount: integer; // min repeat count begin PreviousLen := -1; NextLen := Tree[0].dl.Len; @@ -3269,7 +3326,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; MaxCount := 138; MinCount := 3; end; - Tree[MaxCode + 1].dl.Len := Word($FFFF); // guard + Tree[MaxCode + 1].dl.Len := word($FFFF); // guard for N := 0 to MaxCode do begin CurrentLen := NextLen; @@ -3317,21 +3374,21 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; // Determine the number of bit length codes to send. The pkzip format requires that at least 4 bit length codes // be sent. (appnote.txt says 3 but the actual value used is 4.) - for Result := BL_CODES - 1 downto 3 do - if S.BitLengthTree[BitLengthOrder[Result]].dl.Len <> 0 then + for result := BL_CODES - 1 downto 3 do + if S.BitLengthTree[BitLengthOrder[result]].dl.Len <> 0 then Break; // update OptimalLength to include the bit length tree and counts - Inc(S.OptimalLength, 3 * (Result + 1) + 14); + Inc(S.OptimalLength, 3 * (result + 1) + 14); end; procedure TreeStroredBlock(var S: TDeflateState; Buffer: PByte; - StoredLength: Integer; EOF: Boolean); + StoredLength: integer; EOF: boolean); // sends a stored block // Buffer contains the input data, Len the buffer length and EOF is True if this is the last block for a file. procedure CopyBlock(var S: TDeflateState; Buffer: PByte; Len: Cardinal; - Header: Boolean); + Header: boolean); // copies a stored block, storing first the length and its one's complement if requested // Buffer contains the input data, Len the buffer length and Header is True if the block Header must be written too. begin @@ -3339,13 +3396,13 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; S.LastEOBLength := 8; // enough lookahead for Inflate if Header then begin - S.PendingBuffer[S.Pending] := Byte(Word(Len) and $FF); + S.PendingBuffer[S.Pending] := Byte(word(Len) and $FF); Inc(S.Pending); - S.PendingBuffer[S.Pending] := Byte(Word(Len) shr 8); + S.PendingBuffer[S.Pending] := Byte(word(Len) shr 8); Inc(S.Pending); - S.PendingBuffer[S.Pending] := Byte(Word(not Len) and $FF); + S.PendingBuffer[S.Pending] := Byte(word(not Len) and $FF); Inc(S.Pending); - S.PendingBuffer[S.Pending] := Byte(Word(not Len) shr 8); + S.PendingBuffer[S.Pending] := Byte(word(not Len) shr 8); Inc(S.Pending); end; @@ -3359,7 +3416,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; begin SendBits(S, (STORED_BLOCK shl 1) + Ord(EOF), 3); // send block type - S.CompressedLength := (S.CompressedLength + 10) and Integer(not 7); + S.CompressedLength := (S.CompressedLength + 10) and integer(not 7); Inc(S.CompressedLength, (StoredLength + 4) shl 3); // copy with header @@ -3371,10 +3428,10 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; // sends the block data compressed using the given Huffman trees var Distance: Cardinal; // distance of matched string - lc: Integer; // match length or unmatched char (if Distance = 0) + lc: integer; // match length or unmatched char (if Distance = 0) I: Cardinal; Code: Cardinal; // the code to send - Extra: Integer; // number of extra bits to send + Extra: integer; // number of extra bits to send begin I := 0; @@ -3422,8 +3479,8 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; end; var - OptimalByteLength, StaticByteLength: Integer; // OptimalLength and StaticLength in bytes - MacBLIndex: Integer; // index of last bit length code of non zero frequency + OptimalByteLength, StaticByteLength: integer; // OptimalLength and StaticLength in bytes + MacBLIndex: integer; // index of last bit length code of non zero frequency begin // construct the literal and distance trees // After this, OptimalLength and StaticLength are the total bit lengths of @@ -3473,27 +3530,27 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; Inc(S.CompressedLength, 7); end; - Result := S.CompressedLength shr 3; + result := S.CompressedLength shr 3; end; begin if S.BlockStart >= 0 then TreeFlushBlock(S, @S.Window[Cardinal(S.BlockStart)], - Integer(S.StringStart) - S.BlockStart, EOF) + integer(S.StringStart) - S.BlockStart, EOF) else - TreeFlushBlock(S, nil, Integer(S.StringStart) - S.BlockStart, EOF); + TreeFlushBlock(S, nil, integer(S.StringStart) - S.BlockStart, EOF); S.BlockStart := S.StringStart; FlushPending(S.ZState^); end; - function TreeTally(var S: TDeflateState; Distance: Cardinal; lc: Cardinal): Boolean; + function TreeTally(var S: TDeflateState; Distance: Cardinal; lc: Cardinal): boolean; // Saves the match info and tallies the frequency counts. Returns True if the current block must be flushed. // Distance is the distance of the matched string and lc either match length minus MIN_MATCH or the unmatch character // (if Distance = 0). var - Code: Word; + Code: word; begin - S.DistanceBuffer[S.LastLiteral] := Word(Distance); + S.DistanceBuffer[S.LastLiteral] := word(Distance); S.LiteralBuffer[S.LastLiteral] := Byte(lc); Inc(S.LastLiteral); if (Distance = 0) then begin @@ -3512,7 +3569,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; Inc(S.DistanceTree[Code].fc.Frequency); end; - Result := (S.LastLiteral = S.LiteralBufferSize - 1); + result := (S.LastLiteral = S.LiteralBufferSize - 1); // We avoid equality with LiteralBufferSize because stored blocks are restricted to 64K - 1 bytes. end; @@ -3526,7 +3583,7 @@ function CompressMem(src, dst: pointer; srcLen, dstLen: integer): integer; and S.HashMask; MatchHead := S.Head[S.InsertHash]; S.Previous[(Str) and S.WindowMask] := MatchHead; - S.Head[S.InsertHash] := Word(Str); + S.Head[S.InsertHash] := word(Str); end; const @@ -3537,7 +3594,7 @@ var // We overlay PendingBuffer and DistanceBuffer + LiteralBuffer. This works since the average // output size for (length, distance) codes is <= 24 Bits. HashHead: Cardinal; // head of the hash chain - BlockFlush: Boolean; // set if current block must be flushed + BlockFlush: boolean; // set if current block must be flushed S: TDeflateState; begin result := 0; @@ -3558,14 +3615,14 @@ begin S.HashMask := S.HashSize - 1; S.HashShift := (S.HashBits + MIN_MATCH - 1) div MIN_MATCH; GetMem(S.Window, S.WindowSize * (2 * SizeOf(Byte))); - GetMem(S.Previous, S.WindowSize * SizeOf(Word)); - GetMem(S.Head, S.HashSize * SizeOf(Word)); + GetMem(S.Previous, S.WindowSize * SizeOf(word)); + GetMem(S.Head, S.HashSize * SizeOf(word)); S.LiteralBufferSize := 1 shl (CMemLevel + 6); // 16K elements by default - GetMem(Overlay, S.LiteralBufferSize * (SizeOf(Word) + 2)); + GetMem(Overlay, S.LiteralBufferSize * (SizeOf(word) + 2)); S.PendingBuffer := TPAByte(Overlay); - S.PendingBufferSize := S.LiteralBufferSize * (SizeOf(Word) + 2); + S.PendingBufferSize := S.LiteralBufferSize * (SizeOf(word) + 2); S.DistanceBuffer := @Overlay[S.LiteralBufferSize shr 1]; - S.LiteralBuffer := @S.PendingBuffer[(1 + SizeOf(Word)) * S.LiteralBufferSize]; + S.LiteralBuffer := @S.PendingBuffer[(1 + SizeOf(word)) * S.LiteralBufferSize]; S.PendingOutput := PByte(S.PendingBuffer); S.LiteralDescriptor.DynamicTree := @S.LiteralTree; S.LiteralDescriptor.StaticDescriptor := @StaticLiteralDescriptor; @@ -4323,7 +4380,7 @@ begin inc(Str1); inc(Str2); until false; - Result := ord(C1) - ord(C2); + result := ord(C1) - ord(C2); end else result := 1 // Str2='' @@ -4366,20 +4423,20 @@ end; {$ifdef DELPHI5OROLDER} function DirectoryExists(const Directory: string): boolean; var - Code: Integer; + Code: integer; begin Code := GetFileAttributes(pointer(Directory)); result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); end; {$endif} -function ForceDirectories(const Dir: TFileName): Boolean; +function ForceDirectories(const Dir: TFileName): boolean; begin if (Length(Dir) < 3) or DirectoryExists(Dir) or (ExtractFileDir(Dir) = Dir) then // avoid 'x:\' problem. - Result := true + result := true else - Result := ForceDirectories(ExtractFileDir(Dir)) and CreateDir(Dir); + result := ForceDirectories(ExtractFileDir(Dir)) and CreateDir(Dir); end; function TZipRead.CheckFile(aIndex: integer; DestPath: TFileName): boolean; @@ -4678,7 +4735,7 @@ end; initialization {$ifdef DYNAMIC_CRC_TABLE} InitCrc32Tab; -{$endif} +{$endif DYNAMIC_CRC_TABLE} end. diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas index 0f10edc..e64fe5b 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomAuthInterfaces.pas @@ -6,7 +6,7 @@ unit dddDomAuthInterfaces; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddDomAuthInterfaces; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas index 3d202ae..ad8353e 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomCountry.pas @@ -6,7 +6,7 @@ unit dddDomCountry; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddDomCountry; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas index 10aea0e..f5cc91d 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomEmailInterfaces.pas @@ -1,4 +1,4 @@ -unit DomUserInterfaces; +unit dddDomEmailInterfaces; interface diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas index e610f54..c351b43 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserCQRS.pas @@ -6,7 +6,7 @@ unit dddDomUserCQRS; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddDomUserCQRS; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas index 3039138..0bdb15c 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserInterfaces.pas @@ -6,7 +6,7 @@ unit dddDomUserInterfaces; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddDomUserInterfaces; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas index 62e91b4..822f075 100644 --- a/contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas +++ b/contrib/mORMot/SQLite3/DDD/dom/dddDomUserTypes.pas @@ -6,7 +6,7 @@ unit dddDomUserTypes; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddDomUserTypes; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas index 29afa87..63e5d41 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraApps.pas @@ -6,7 +6,7 @@ unit dddInfraApps; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraApps; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -595,7 +595,8 @@ type procedure ExecuteDisconnect; procedure ExecuteDisconnectAfterError; procedure ExecuteSocket; - function TrySend(const aFrame: RawByteString; ImmediateDisconnectAfterError: boolean = true): Boolean; virtual; + function TrySend(const aFrame: RawByteString; + ImmediateDisconnectAfterError: boolean = true): Boolean; virtual; // inherited classes could override those methods for process customization procedure InternalExecuteConnected; virtual; procedure InternalExecuteDisconnect; virtual; diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas index d72747d..cfe359a 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraAuthRest.pas @@ -6,7 +6,7 @@ unit dddInfraAuthRest; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraAuthRest; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas index d107f62..f3dd27a 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmail.pas @@ -6,7 +6,7 @@ unit dddInfraEmail; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraEmail; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas index c5923ef..be11199 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraEmailer.pas @@ -6,7 +6,7 @@ unit dddInfraEmailer; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraEmailer; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas index 2f10739..b5b8a8a 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraRepoUser.pas @@ -6,7 +6,7 @@ unit dddInfraRepoUser; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraRepoUser; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas b/contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas index 053efd8..0c20842 100644 --- a/contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas +++ b/contrib/mORMot/SQLite3/DDD/infra/dddInfraSettings.pas @@ -6,7 +6,7 @@ unit dddInfraSettings; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit dddInfraSettings; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/Documentation/Synopse SQLite3 Framework.pro b/contrib/mORMot/SQLite3/Documentation/Synopse SQLite3 Framework.pro index faa7ec5..3d8423b 100644 --- a/contrib/mORMot/SQLite3/Documentation/Synopse SQLite3 Framework.pro +++ b/contrib/mORMot/SQLite3/Documentation/Synopse SQLite3 Framework.pro @@ -28,7 +28,7 @@ HtmlSideBar=Overview/Meet the mORMot:SOURCE,Download/How to install:TITL_113,API ; the sidebar first links, for html export {\b Document License} -{\i Synopse mORMot Framework Documentation}.\line Copyright (C) 2008-2020 Arnaud Bouchez.\line Synopse Informatique - @https://synopse.info +{\i Synopse mORMot Framework Documentation}.\line Copyright (C) 2008-2022 Arnaud Bouchez.\line Synopse Informatique - @https://synopse.info The {\i Synopse mORMot Framework Source Code} is licensed under GPL / LGPL / MPL licensing terms, free to be included in any application. ;This documentation has been generated using {\i Synopse SynProject} - @https://synopse.info/fossil/wiki?name=SynProject ;This document is a free document; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. @@ -136,7 +136,7 @@ The main approach of this framework is to avoid @*RAD@ in the development of pro : Expected Use Any application which need moderate database usage (up to some GB of data) with easy setup and administration, together with a secure @*ACID@ behavior in a Client-Server environment should consider using the {\i Synopse mORMot Framework}. : Requirement Exceptions -This framework was developed in order to run mainly under any {\i Delphi} compiler, from version {\i Delphi} 6 to version {\i Delphi 10.3 Rio}. +This framework was developed in order to run mainly under any {\i Delphi} compiler, from version {\i Delphi} 6 to the latest Delphi version ({\i Delphi 11 Alexandria} at time of this writing). On the {\i server side}, it targets both {\i Win32} and {\i Win64} platforms (using the 64-bit compiler included in latest {\i Delphi} XE2 and up). For clients, in addition to those {\i Win32} / {\i Win64} platforms, you have cross-platform code generation abilities, for any {\i Delphi} or {\i @*FreePascal@} target (including {\i @*OSX@} and mobile {\i iOS} or {\i Android}), or AJAX / HTML5 clients via {\i @*Smart Mobile Studio@} - see @90@. =[License] @@ -464,7 +464,7 @@ The {\i Synopse mORMot Framework} shall provide User Interface and Report genera Such a ribbon-oriented interface shall be made available, in a per-table approach, and associated reports. Here is a sample of screen content, using proprietary TMS components: %synfiletms.png -And here is the same application compiled using only VCL components, available from {\i Delphi} 6 up to {\i Delphi 10.3 Rio}: +And here is the same application compiled using only VCL components, available from {\i Delphi} 6 up to the latest available {\i Delphi} version: %synfilevcl.png [SRS-DI-2.3.1] @@ -570,7 +570,7 @@ DisplayName=mORMot Framework Overview :Synopse mORMot Overview %IamLost.png -{\i Synopse mORMot} is an Open Source @*Client-Server@ @*ORM@ @*SOA@ @*MVC@ framework for {\i Delphi} 6 up to {\i Delphi 10.3 Rio} and @*FPC@, targeting {\i Win/@*Linux@} for the server, and any platform for clients (including mobile or AJAX). +{\i Synopse mORMot} is an Open Source @*Client-Server@ @*ORM@ @*SOA@ @*MVC@ framework for {\i Delphi} 6 up to the latest available {\i Delphi} version and @*FPC@ 3.2, targeting {\i Win/@*Linux@} for the server, and any platform for clients (including mobile or AJAX). The main features of {\i mORMot} are therefore: - {\i ORM/ODM}: objects persistence on almost any database (SQL or NoSQL); - {\i SOA}: organize your business logic into @*REST@ services; @@ -708,7 +708,7 @@ At first, some points can be highlighted, which make this framework distinct to - More than 1800 pages of documentation; - {\i Delphi}, {\i FreePascal}, mobile and @*AJAX@ clients can share the same server, and ORM/SOA client access code can be generated on request for any kind of application - see @86@; - Full source code provided - so you can enhance it to fulfill any need; -- Works from {\i Delphi} 6 up to {\i Delphi 10.3 Rio} and FPC 2.6.4/2.7.1/3.x, truly Unicode (uses @*UTF-8@ encoding in its kernel, just like JSON), with any version of {\i Delphi} (no need to upgrade your IDE). +- Works from {\i Delphi} 6 up to the latest available {\i Delphi} version and FPC 3.2.x, truly Unicode (uses @*UTF-8@ encoding in its kernel, just like JSON), with any version of {\i Delphi} (no need to upgrade your IDE). \page : Benefits As you can see from the previous section, {\i mORMot} provides a comprehensive set of features that can help you to manage your crosscutting concerns though a reusable set of components and core functionality. @@ -1364,7 +1364,7 @@ In the following next paragraphs, we'll comment some main features of the lowest - {\f1\fs20 @*TDocVariant@} custom {\f1\fs20 variant} type for dynamic schema-less {\i object} or {\i array} storage. Other shared features available in {\f1\fs20 SynTests.pas} and {\f1\fs20 SynLog.pas} will be detailed later, i.e. @*Test@ing and @*Log@ging - see @12@. :32 Unicode and UTF-8 -Our {\i mORMot} Framework has 100% UNICODE compatibility, that is compilation under {\i Delphi} 2009 and up (including latest {\i Delphi 10.3 Rio} revision). The code has been deeply rewritten and @*test@ed, in order to provide compatibility with the {\f1\fs20 String=UnicodeString} paradigm of these compilers. But the code will also handle safely Unicode for older versions, i.e. from {\i Delphi} 6 up to {\i Delphi} 2007. +Our {\i mORMot} Framework has 100% UNICODE compatibility, that is compilation under {\i Delphi} 2009 and up (including the latest available {\i Delphi} version). The code has been deeply rewritten and @*test@ed, in order to provide compatibility with the {\f1\fs20 String=UnicodeString} paradigm of these compilers. But the code will also handle safely Unicode for older versions, i.e. from {\i Delphi} 6 up to {\i Delphi} 2007. From its core to its uppermost features, our framework is natively @**UTF-8@, which is the de-facto character encoding for @*JSON@, {\i @*SQLite3@}, and most supported database engines. This allows our code to offer fast streaming/parsing in a @*SAX@-like mode, avoiding any conversion between encodings from the storage layer to your business logic. We also needed to establish a secure way to use strings, in order to handle all versions of {\i Delphi} (even pre-Unicode versions, especially the {\i Delphi} 7 version we like so much), and provide compatibility with the {\i @*FreePascal@ Compiler}. This consistency allows to circumvent any RTL bug or limitation, and ease long-term support of your project. Some string types have been defined, and used in the code for best cross-compiler efficiency: - {\f1\fs20 @**RawUTF8@} is used for every internal data usage, since both {\i SQLite3} and JSON do expect UTF-8 encoding; @@ -1463,7 +1463,7 @@ Here is how those new methods work: ! if GroupA.Find(v)<0 then // fast binary search ! ShowMessage('Error: 1500 not found!'); Some unique methods like {\f1\fs20 Slice, Reverse} or {\f1\fs20 AddArray} are also available, and mimic well-known Python methods. -Still closer to the generic paradigm, working for {\i Delphi} 6 up to {\i Delphi 10.3 Rio}, without the need of the slow enhanced RTTI, nor the executable size overhead and compilation issues of generics... +Still closer to the generic paradigm, working for {\i Delphi} 6 up to the latest available {\i Delphi} version, without the need of the slow enhanced RTTI, nor the executable size overhead and compilation issues of generics... : Capacity handling via an external Count One common speed issue with the default usage of {\f1\fs20 TDynArray} is that the internal memory buffer is reallocated when you change its length, just like a regular {\i Delphi} {\i dynamic array}. That is, whenever you call {\f1\fs20 Add} or {\f1\fs20 Delete} methods, an internal call to {\f1\fs20 SetLength(DynArrayVariable)} is performed. This could be slow, because it always executes some extra code, including a call to {\f1\fs20 ReallocMem}. @@ -1829,7 +1829,7 @@ When working with complex documents, e.g. with @*BSON@ / {\i @*MongoDB@} documen : Advanced TDocVariant process :194 Number values options By default, {\f1\fs20 TDocVariantData} will only recognize {\f1\fs20 integer}, {\f1\fs20 Int64} and {\f1\fs20 currency} - see @33@ - as number values. Any floating point value which may not be translated to/from @*JSON@ textual representation safely will be stored as a JSON string, i.e. if it does match an integer or up to 4 fixed decimals, with 64-bit precision. We stated that JSON serialization should be conservative, i.e. serializing then unserializing (or the other way round) should return the very same value; parsing JSON is a matter of (difficult) choices - see @http://seriot.ch/parsing_json.php#5 - and we choose to be paranoid and not loose information by default. -You can set the {\f1\fs20 @*dvoAllowDoubleValue@} option to {\f1\fs20 TDocVariantData}, so that such floating-point numbers will be recognized and stored as {\f1\fs20 @*double@}. In this case, only {\f1\fs20 varDouble} storage will be used for the {\f1\fs20 variant} values, i.e. 64-bit IEEE 754 {\f1\fs20 double} values, handling 5.0 x 10^-324 .. 1.7 x 10^308 range. With such floating-point values, you may loose precision and digits during the JSON serialization process: this is why it is not enabled by default. +You can use the {\f1\fs20 @*_JsonFastFloat()@} wrapper or set the {\f1\fs20 @**dvoAllowDoubleValue@} option to {\f1\fs20 TDocVariantData}, so that such floating-point numbers will be recognized and stored as {\f1\fs20 @**double@}. In this case, only {\f1\fs20 varDouble} storage will be used for the {\f1\fs20 variant} values, i.e. 64-bit IEEE 754 {\f1\fs20 double} values, handling 5.0 x 10^-324 .. 1.7 x 10^308 range. With such floating-point values, you may loose precision and digits during the JSON serialization process: this is why it is not enabled by default. Also note that some JSON engines do not support 64-bit integer numbers. For instance, {\f1\fs20 @*JavaScript@} engines handle only up to @*53-bit@ of information without precision loss (called the {\i significand} bits), due to their internal storage as a 8 bytes IEEE 754 container. In some cases, it is safest to use JSON string representation of such numbers, as is done with the {\f1\fs20 woIDAsIDstr} value of {\f1\fs20 TTextWriterWriteObjectOption} for safe serialization of {\f1\fs20 TSQLRecord.ID} ORM values. If you want to work with high-precision floating point numbers, consider using {\f1\fs20 @*TDecimal128@} values, as implemented in {\f1\fs20 SynMongoDB.pas}, which supports 128-bit high precision decimal, as defined by the {\i IEEE 754-2008 128-bit decimal floating point} standard, and handled in {\i MongoDB} 3.4+. Their conversion to/from text - therefore to/from JSON - won't loose nor round any digit, as soon as the value fits in its 128-bit storage. : Object or array document creation options @@ -4610,7 +4610,7 @@ In the above query expression, the {\f1\fs20 rank()} function is used over the d In any database, there is a need to define how column data is to be compared. It is needed for proper search and ordering of the data. This is the purpose of so-called {\i @**collation@s}. By default, when {\i SQLite} compares two strings, it uses a collating sequence or collating function (two words for the same thing) to determine which string is greater or if the two strings are equal. {\i SQLite} has three built-in collating functions: BINARY, NOCASE, and RTRIM: - BINARY - Compares string data using {\f1\fs20 memcmp()}, regardless of text encoding. -- NOCASE - The same as binary, except the 26 upper case characters of ASCII are folded to their lower case equivalents before the comparison is performed. Note that only ASCII characters are case folded. Plain {\i SQLite} does not attempt to do full @*Unicode@ case folding due to the size of the tables required - but you could use {\i mORMot}'s SYSTEMNOCASE or WIN32CASE/WIN32NOCASE custom collations for enhanced case folding support (see below); +- NOCASE - The same as binary, except the 26 upper case characters of ASCII are folded to their lower case equivalents before the comparison is performed. Note that only ASCII characters are case folded. Plain {\i SQLite} does not attempt to do full @*Unicode@ case folding due to the size of the tables required - but you could use {\i mORMot}'s SYSTEMNOCASE, or WIN32CASE/WIN32NOCASE custom collations for enhanced case folding support (see below); - RTRIM - The same as binary, except that trailing space characters are ignored. In the {\i mORMot} ORM, we defined some additional kind of collations, via some internal calls to the {\f1\fs20 sqlite3_create_collation()} API: |%25%60 @@ -4632,6 +4632,7 @@ The following collations are therefore available when using {\i SQLite3} within |NOCASE|Default ASCII 7 bit comparison |RTRIM|Default {\f1\fs20 memcmp()} comparison with right trim |SYSTEMNOCASE|{\i mORMot}'s Win-1252 8 bit comparison +;|UNICODENOCASE|{\i mORMot}'s Unicode 10.0 comparison |ISO8601|{\i mORMot}'s date/time comparison |WIN32CASE|{\i mORMot}'s comparison using case-insensitive Windows API |WIN32NOCASE|{\i mORMot}'s comparison using not case-insensitive Windows API @@ -4639,17 +4640,17 @@ The following collations are therefore available when using {\i SQLite3} within Note that WIN32CASE/WIN32NOCASE will be slower than the others, but will handle properly any kind of complex scripting. For instance, if you want to use the Unicode-ready Windows API at database level, you can set for each database model: ! aModel.SetCustomCollationForAll(sftUTF8Text,'WIN32CASE'); ! aModel.SetCustomCollationForAll(sftDateTime,'NOCASE'); +On non-Windows platform, it will either use the system ICU library (if available), or fallback to the FPC RTL with temporary {\f1\fs20 UnicodeString} values - which requires to include `cwstrings` in your project uses clause. Note that depending on the library used, the results may not be consistent: so if you move a {\i SQLite3} database file e.g. from a Windows system to a Linux system with WIN32CASE collation, you should better regenerate all your indexes! If you use non-default collations (i.e. SYSTEMNOCASE/ISO8601/WIN32CASE/WIN32NOCASE), you may have trouble running requests with "plain" {\i SQLite3} tools. But you can use our {\f1\fs20 @*SynDBExplorer@} safely, since it will declare all the above collations. When using external databases - see @27@, if the content is retrieved directly from the database driver and by-passes the virtual table mechanism - see @20@, returned data may not match your expectations according to the custom collations: you will need to customize the external tables definition by hand, with the proper SQL statement of each external DB engine. +Note that {\i @*mORMot 2@} offers a new UNICODENOCASE collation, which follows Unicode 10.0 without any Windows or ICU API call, so is consistent on all systems - and is also faster. : REGEXP operator -Our {\i SQLite3} engine can use {\i @**regular expression@} within its SQL queries, by enabling the {\f1\fs20 @**REGEXP@} operator in addition to standard SQL operators ({\f1\fs20 = == != <> IS IN LIKE GLOB MATCH}). It will use the Open Source PCRE library to perform the queries. -In order to enable the operator, you should include unit {\f1\fs20 SynSQLite3RegEx.pas} to your uses clause, and register the {\f1\fs20 RegExp()} SQL function to a given {\i SQLite3} database instance, as such: -!uses SynCommons, mORmot, mORMotSQLite3, -!! SynSQLite3RegEx; -! ... +Our {\i SQLite3} engine can use {\i @**regular expression@} within its SQL queries, by enabling the {\f1\fs20 @**REGEXP@} operator in addition to standard SQL operators ({\f1\fs20 = == != <> IS IN LIKE GLOB MATCH}). +: Default REGEXP Engine +By default, and since mORMot 1.18.6218 (25 January 2021), our static {\i SQlite3} engine includes a compact and efficient enough C extension, as available from the official {\i SQLite3} project source code tree. It is included with the official amalgamation file during our compilation phase. +So you don't need to do anything to be able to use the REGEX operator in your queries: !Server := TSQLRestServerDB.Create(Model,'test.db3'); !try -!! CreateRegExpFunction(Server.DB.DB); ! with TSQLRecordPeople.CreateAndFillPrepare(Client, !! 'FirstName REGEXP ?',['\bFinley\b']) do ! try @@ -4667,6 +4668,20 @@ The above code will execute the following SQL statement (with a prepared paramet ! SELECT * from People WHERE Firstname REGEXP '\bFinley\b'; That is, it will find all objects where {\f1\fs20 TSQLRecordPeople.FirstName} will contain the {\f1\fs20 'Finley'} word - in a regular expression, {\f1\fs20 \\b} defines a word {\f1\fs20 b}oundary search. In fact, the {\f1\fs20 REGEXP} operator is a special syntax for the {\f1\fs20 regexp()} user function. No {\f1\fs20 regexp()} user function is defined by default and so use of the {\f1\fs20 REGEXP} operator will normally result in an error message. Calling {\f1\fs20 CreateRegExFunction()} for a given connection will add a SQL function named "{\f1\fs20 regexp()}" at run-time, which will be called in order to implement the {\f1\fs20 REGEXP} operator. +: PCRE REGEXP Engine +If you want to use the Open Source PCRE library to perform the searches, instead of this default C extension, you should include the {\f1\fs20 SynSQLite3RegEx.pas} unit to your uses clause, and register the {\f1\fs20 RegExp()} SQL function to a given {\i SQLite3} database instance, as such: +!uses SynCommons, mORmot, mORMotSQLite3, +!! SynSQLite3RegEx; +! ... +!Server := TSQLRestServerDB.Create(Model,'test.db3'); +!try +!! CreateRegExpFunction(Server.DB.DB); +! with TSQLRecordPeople.CreateAndFillPrepare(Client, +!! 'FirstName REGEXP ?',['\bFinley\b']) do +! try +! while FillOne do begin +! Check(LastName='Morse'); +! ... It will use the statically linked PCRE library as available since {\i Delphi} XE, or will rely on the {\f1\fs20 PCRE.pas} wrapper unit as published at @http://www.regular-expressions.info/download/TPerlRegEx.zip for older versions of {\i Delphi}. This unit will call directly the @*UTF-8@ API of the PCRE library, and maintain a per-connection cache of compiled regular expressions to ensure the best performance possible. :60 ACID and speed @@ -4752,7 +4767,8 @@ Note that the virtual table module name is retrieved from the class name. For in To handle external databases, two dedicated classes, named {\f1\fs20 TSQLVirtualTableExternal} and {\f1\fs20 TSQLVirtualTableCursorExternal} will be defined in a similar manner - see @%%HierExternalTables@ @30@. As you probably have already stated, all those Virtual Table mechanism is implemented in {\f1\fs20 mORMot.pas}. Therefore, it is independent from the {\i @*SQLite3@} engine, even if, to my knowledge, there is no other SQL database engine around able to implement this pretty nice feature. : Defining a Virtual Table module -Here is how the {\f1\fs20 TSQLVirtualTableLog} class type is defined, which will implement a @*Virtual Table@ module named "{\f1\fs20 Log}". Adding a new module is just made by overriding some {\i Delphi} methods: +Here is how the {\f1\fs20 TSQLVirtualTableLog} class type is defined, which will implement a @*Virtual Table@ module named "{\f1\fs20 Log}". Note that the {\i SQLite3} virtual table module name will be computed from the class name, trimming its first characters, e.g. {\f1\fs20 TSQLVirtualTable{\b Log}} will trim trailing {\f1\fs20 TSQLVirtualTable} and define a {\f1\fs20 'Log'} virtual module. +Adding a new module is just made by overriding some {\i Delphi} methods: ! TSQLVirtualTableLog = class(TSQLVirtualTable) ! protected ! fLogFile: TSynLogFile; @@ -7431,7 +7447,7 @@ In practice, for your project, you will have several possibilities to create a C |SOA Interfaces|RPC REST|RPC |SOA Methods|Full REST/HTTP|Verbose |MVC Web|Web site + AJAX|HTML-oriented -|ORM REST|Tests or internal use|Security/design flows +|ORM REST|Tests or internal use|Security/design flaws |% In a nutshell, - {\i SOA Interfaces} - see @63@ - is the preferred way to build both public and private services: both client and server code will be defined from {\f1\fs20 interface} types, including sessions management, stubbing/mocking, documentation generation, and security features. @@ -9668,7 +9684,7 @@ If you compare with existing mocking frameworks, even in other languages / platf - Most common parameters and results can be defined as simple {\f1\fs20 array of const} in the {\i Delphi} code, or by supplying JSON arrays (needed e.g. for more complex structures like {\f1\fs20 record} values); - Execution trace retrieval in easy to read or write text format (and not via complex "fluent" interface e.g. with {\f1\fs20 When} clauses); - Auto-release of the {\f1\fs20 TInterfaceStub TInterfaceMock TInterfaceMockSpy} generator instance, when the interface is no longer required, to minimize the code to type, and avoid potential memory leaks; -- Works from {\i Delphi} 6 up to {\i Delphi 10.3 Rio} - since no use of syntax sugar like generics, nor the {\f1\fs20 RTTI.pas} features; +- Works from {\i Delphi} 6 up to the latest available {\i Delphi} version - since no use of syntax sugar like generics, nor the {\f1\fs20 RTTI.pas} features; - Very good performance (the faster {\i Delphi} mocking framework, for sure), due to very low overhead and its reuse of {\i mORMot}'s low-level interface-based services kernel using JSON serialization, which does not rely on the slow and limited {\f1\fs20 TVirtualInterface}. : Stubbing complex return values Just imagine that the {\f1\fs20 ForgotMyPassword} method does perform an internal test: @@ -9881,7 +9897,7 @@ Here are the key features of the current implementation of services using interf |Server factory|You can get an implementation on the server side |Client factory|You can get a "fake" implementation on the client side, remotely calling the server to execute the process |Cross-platform clients|A {\i mORMot} server is able to generate cross-platform client code via a set of templates - see @86@ -|Auto marshalling|The contract is transparently implemented: no additional code is needed e.g. on the client side, and will handle simple types (strings, numbers, dates, sets and enumerations) and high-level types (objects, collections, records, dynamic arrays, variants) from {\i Delphi} 6 up to {\i Delphi 10.3 Rio} +|Auto marshalling|The contract is transparently implemented: no additional code is needed e.g. on the client side, and will handle simple types (strings, numbers, dates, sets and enumerations) and high-level types (objects, collections, records, dynamic arrays, variants) from {\i Delphi} 6 up to the latest available {\i Delphi} version |Flexible|Methods accept per-value or per-reference parameters |Instance lifetime|An implementation class can be:\line - Created on every call,\line - Shared among all calls,\line - Shared for a particular user or group,\line - Dedicated to the thread it runs on,\line - Alive as long as the client-side interface is not released,\line - Or as long as an @*authentication@ session exists |@*Stateless@|Following a standard request/reply pattern @@ -9983,7 +9999,7 @@ You can therefore define complex {\f1\fs20 interface} types, as such: ! /// validates ArgsInputIsOctetStream raw binary upload ! function DirectCall(const Data: TSQLRawBlob): integer; ! end; -Note how {\f1\fs20 SpecialCall} and {\f1\fs20 ComplexCall} methods have quite complex parameters definitions, including dynamic arrays, sets and records. DirectCall will use binary POST, by-passing @*Base64@ JSON encoding - see @197@. The framework will handle {\f1\fs20 const} and {\f1\fs20 var} parameters as expected, i.e. as input/output parameters, also on the client side. Any simple types of dynamic arrays (like {\f1\fs20 TIntegerDynArray}, {\f1\fs20 TRawUTF8DynArray}, or {\f1\fs20 TWideStringDynArray}) will be serialized as plain JSON arrays - the framework is able to handle any dynamic array definition, but will serialize those simple types in a more AJAX compatible way, thanks to the enhanced RTTI available since to {\i Delphi} 2010. +Note how {\f1\fs20 SpecialCall} and {\f1\fs20 ComplexCall} methods have quite complex parameters definitions, including dynamic arrays, sets and records. {\f1\fs20 DirectCall} will use binary POST, by-passing @*Base64@ JSON encoding - see @197@. The framework will handle {\f1\fs20 const} and {\f1\fs20 var} parameters as expected, i.e. as input/output parameters, also on the client side. Any simple types of dynamic arrays (like {\f1\fs20 TIntegerDynArray}, {\f1\fs20 TRawUTF8DynArray}, or {\f1\fs20 TWideStringDynArray}) will be serialized as plain JSON arrays - the framework is able to handle any dynamic array definition, but will serialize those simple types in a more AJAX compatible way, thanks to the enhanced RTTI available since to {\i Delphi} 2010. : TPersistent / TSQLRecord parameters As stated above, {\i mORMot} does not allow a method {\f1\fs20 function} to return a {\f1\fs20 class} instance. That is, you can't define such a method: @@ -13659,7 +13675,7 @@ By default, the following security groups are created on a void database: |%14%12%14%11%11%12%12%12 |\b Group|POST SQL|SELECT SQL|Auth R|Auth W|Tables R|Tables W|Services\b0 |Admin|Yes|Yes|Yes|Yes|Yes|Yes|Yes -|Supervisor|Yes|No|Yes|No|Yes|Yes|Yes +|Supervisor|No|Yes|Yes|No|Yes|Yes|Yes |User|No|No|No|No|Yes|Yes|Yes |Guest|No|No|No|No|Yes|No|No |% @@ -15736,7 +15752,7 @@ And even better, testing-driven coding can be encouraged: It could sounds like a waste of time, but such coding improve your code quality a lot, and, at least, it help you write and optimize every implementation feature. The framework has been implemented using this approach, and provide all the tools to write tests. In addition to what other {\i Delphi} frameworks offer (e.g. {\i DUnit / DUnitX}), the {\f1\fs20 SynTests.pas} unit is very much integrated with other elements of the framework (like logging), is cross-platform and cross-compiler, and provides a complete {\i stubbing / mocking} mechanism to cover @62@. : Involved classes in Unitary testing -The @!TSynTest,TSynTestCase,TSynTests!Lib\SynTests.pas@ unit defines two classes (both inheriting from {\f1\fs20 TSynTest}), implementing a complete Unitary testing mechanism similar to {\i DUnit}, with less code overhead, and direct interface with the framework units and requirements (@*UTF-8@ ready, code compilation from {\i Delphi} 6 up to {\i Delphi 10.3 Rio} and FPC, no external dependency). +The @!TSynTest,TSynTestCase,TSynTests!Lib\SynTests.pas@ unit defines two classes (both inheriting from {\f1\fs20 TSynTest}), implementing a complete Unitary testing mechanism similar to {\i DUnit}, with less code overhead, and direct interface with the framework units and requirements (@*UTF-8@ ready, code compilation from {\i Delphi} 6 up to the latest available {\i Delphi} version and FPC, no external dependency). The following diagram defines this class hierarchy: \graph HierTSynTest TSynTest classes hierarchy \TSynTests\TSynTest @@ -15850,12 +15866,10 @@ Before any release all unitary regression tests are performed with the following - {\i Delphi} 2007; - {\i Delphi} 2010 (we assume that if it works with {\i Delphi} 2010, it will work with {\i Delphi} 2009, with the exception of {\f1\fs20 generic} compilation); - {\i Delphi} XE4; -- {\i Delphi} XE6; - {\i Delphi} XE7; -- {\i Delphi} 10 Seattle; -- {\i Delphi} 10.1 Berlin; -- {\i Delphi} 10.2 Tokyo; +- {\i Delphi} XE8; - {\i Delphi} 10.3 Rio; +- {\i Delphi} 10.4 Sidney; - {\i @*CrossKylix@} 3.0; - {\i @*FPC@} 3.x - preferred is {\i 3.2 fixes}. Target platforms are {\i Win32} and {\i Win64} for {\i Delphi} and {\i FPC}, plus {\i Linux 32/64} for {\i FPC} and {\i CrossKylix}. @@ -16223,17 +16237,17 @@ Follow these steps: - Finally, click on the "{\i Zip Archive}" link, available at the end of the "{\i Overview}" header, right ahead to the "{\i Other Links}" title. This link will build a {\f1\fs20 .zip} archive of the complete source code and download it to your browser. : Expected compilation platform The framework source code tree will compile and is tested for the following platforms: -- {\i Delphi} 6 up to {\i Delphi 10.3 Rio} compiler and IDE, with {\i @*FreePascal@ Compiler} (FPC) 3.x and {\i @*Lazarus@} support; +- {\i Delphi} 6 up to the latest {\i Delphi} compiler and IDE version, with {\i @*FreePascal@ Compiler} (FPC) 3.x and {\i @*Lazarus@} support; - Server side on Windows 32-bit and @**64-bit@ platforms (FPC or {\i Delphi} XE2 and up expected when targeting {\i Win64}); - {\i @*Linux@} 32-bit and 64-bit platform for servers using the FPC 3.2 fixes branch - now stable and tested in production since years (especially {\i @*Debian@/@*Ubuntu@} on {\f1\fs20 x86_64}); - VCL client on Win32/Win64 - GUI may be compiled optionally with third-party non Open-Source @*TMS@ Components, instead of default VCL components - see @http://www.tmssoftware.com/site/tmspack.asp - @69@ clients on any supported platforms; - @90@ startup with 2.1, for creating @*AJAX@ / @*JavaScript@ / HTML5 / Mobile clients. Some part of the library (e.g. {\f1\fs20 SynCommons.pas}, {\f1\fs20 SynTests.pas}, {\f1\fs20 SynLog.pas} {\f1\fs20 SynPDF.pas} or the @27@ units) are also compatible with {\i Delphi} 5. -If you want to compile {\i mORMot} unit into @*packages@, to avoid an obfuscated {\i [DCC Error] @*E2201@ Need imported data reference ($G) to access 'VarCopyProc'} error at compilation, you should defined the {\f1\fs20 USEPACKAGES} conditional in your project's options. Open {\f1\fs20 SynCommons.inc} for a description of this conditional, and all over definitions global to all {\i mORMot} units - see @45@. +If you want to compile {\i mORMot} unit into @**packages@, to avoid an obfuscated {\i [DCC Error] @*E2201@ Need imported data reference ($G) to access 'VarCopyProc'} error at compilation, you should defined the {\f1\fs20 USEPACKAGES} conditional in your project's options. Open {\f1\fs20 SynCommons.inc} for a description of this conditional, and all over definitions global to all {\i mORMot} units - see @45@. To avoid related {\i @*E1025@ Unsupported language feature: 'Object'} compilation error, you should probably also set "{\i Generate DCUs only}" in project's options "{\i C/C++ output file generator}". The framework source code implementation and design tried to be as cross-platform and cross-compiler as possible, since the beginning. It is a lot of work to maintain compatibility towards so many tools and platforms, but we think it is always worth it - especially if you try not depend on {\i Delphi} only, which as shown some backward compatibility issues during its lifetime. For HTML5 and Mobile clients, our main platform is {\i Smart Mobile Studio}, which is a great combination of ease of use, a powerful {\i SmartPascal} dialect, small applications (much smaller than FMX), with potential packaging as native iOS or {\i Android} applications (via {\i @*PhoneGap@}). -The latest versions of the {\i FreePascal Compiler} together with its great {\i Lazarus} IDE, are now very stable and easy to work with. We don't support {\i CodeTyphon}, since we found some licensing issue with some part of it (e.g. {\i Orca} GUI library origin is doubtful). So we recommend using {\i @*fpcupdeluxe@} - see @203@ - which is maintained by Alfred, a {\i mORMot} contributor. This is amazing to build the whole set of compilers and IDE, with a lot of components, for several platforms (this is a cross-platform project), just from the sources. I like {\i Lazarus} stability and speed much more than {\i Delphi} (did you ever tried to browse and debug {\i included} {\f1\fs20 $I ...} files in the {\i Delphi} IDE? with Lazarus, it is painless), even if the compiler is slower than {\i Delphi}'s, and if the debugger is less integrated and even more unstable than {\i Delphi}'s under Windows (yes, it is possible!). At least, it works, and the {\i Lazarus} IDE is small and efficient. Official {\i @*Linux@} support is available for {\i mORMot} servers, with full features in the {\i FPC} 3.2 branch - we use it on producing on {\i Linux} 64-bit since years. +The latest versions of the {\i FreePascal Compiler} together with its great {\i Lazarus} IDE, are now very stable and easy to work with. We don't support {\i CodeTyphon}, since we found some licensing issue with some part of it (e.g. {\i Orca} GUI library origin is doubtful). So we recommend using {\i @*fpcupdeluxe@} - see @203@ - which is maintained by Alfred, a {\i mORMot} contributor. This is amazing to build the whole set of compilers and IDE, with a lot of components, for several platforms (this is a cross-platform project), just from the sources. I like {\i Lazarus} stability and speed much more than {\i Delphi} (did you ever tried to browse and debug {\i included} {\f1\fs20 $I ...} files in the {\i Delphi} IDE? with Lazarus, it is painless), even if the compiler is slower than {\i Delphi}'s, and if the debugger is less integrated and even more unstable than {\i Delphi}'s under Windows (yes, it is possible!). At least, it works, and the {\i Lazarus} IDE is small and efficient. Official {\i @*Linux@} support is available for {\i mORMot} servers, with full features in the {\i FPC} 3.2 branch - we use it on production with {\i Linux} 64-bit since years. : SQLite3 static linking for Delphi and FPC {\i Preliminary note}: if you retrieved the source code from @https://github.com/synopse/mORMot you will have all the needed {\f1\fs20 .obj/.o} static files available in the expected folders. Just ignore this chapter. In order to maintain our @https://synopse.info/fossil/timeline source code repository in a decent size, we excluded the {\f1\fs20 sqlite3.obj/.o} storage in it, but provide the full source code of the {\i @*SQlite3@} engine in a custom {\f1\fs20 sqlite3.c} file, ready to be compiled with all conditional defined as expected by {\f1\fs20 SynSQlite3Static.pas}. You need to add the official {\i SQlite3} amalgamation file from @https://www.sqlite.org/download.html and put its content into a {\f1\fs20 SQLite3\\amalgamation} sub-folder, for proper compilation. Our custom {\f1\fs20 sqlite3.c} file will add encryption feature to the engine. Also look into {\f1\fs20 SynSQlite3Static.pas} comments if there is any manual patch needed for proper compilation of the amalgamation sourece. @@ -16374,7 +16388,7 @@ See @86@ for more information. \page :113 Delphi Installation {\i Note: for FPC setup, see @125@.} -To setup mORMot for {\i Delphi 6} up to {\i Delphi 10.3 Rio}, you have two ways: either download the framework from archives, or clone our {\i GitHub} repository at @https://github.com/synopse/mORMot +To setup mORMot for {\i Delphi 6} up to the latest {\i Delphi} version, you have two ways: either download the framework from archives, or clone our {\i GitHub} repository at @https://github.com/synopse/mORMot : Manual download Download and uncompress the framework archives, including all sub-folders, into a local directory of your computer (for instance, {\f1\fs20 D:\\Dev\\mORMot}). |%70 @@ -16429,11 +16443,12 @@ But since the FPC trunk may be unstable, we will propose to put in place a stabl For this task, don't download an existing binary release of FPC / Lazarus, but use the {\i @**fpcupdeluxe@} tool, as published at @http://wiki.freepascal.org/fpcupdeluxe - it will allow to build your environment directly from the sources, and install it in a dedicated folder. Several FPC / Lazarus installations, with dedicated revision numbers, may coexist on the same computer: just ensure you run Lazarus from the shortcut created by {\i fpcupdeluxe}. - Download the latest release of the tool from @https://github.com/LongDirtyAnimAlf/fpcupdeluxe/releases - Unpack it in a dedicated folder, and run its executable. -- On the main screen, locate on the left the two versions listboxes. Select "fixes" for both {\i FPC version} and {\i Lazarus version}. +- On the main screen, locate on the left the two versions listboxes. Select "{\f1\fs20 3.2}" for {\i FPC version} and "{\f1\fs20 2.1.0}" for {\i Lazarus version}. +- Important note: if you want to cross-compile from Windows to other systems, e.g. install a Linux cross-compiler on Windows, ensure you installed the {\i Win32} FPC compiler and Lazarus, {\i not the Win64} version, which is known to have troubles with {\f1\fs20 currency} support; - Then build the FPC and Lazarus binaries directly from the latest sources, by clicking on "Install/update FPC+Laz". -Those "fixes" branches are currently used for building our production projects, so are expected to be properly tested and supported. \line At the time of the writing of this documentation, our Lazarus IDE (on Linux) reports using: -- FPC fixes SVN 45428 (3.2.0) -- Lazarus fixes SVN 63179 (2.0.9). +Those branches are currently used for building our production projects, so are expected to be properly tested and supported. \line At the time of the writing of this documentation, our Lazarus IDE (on Linux) reports using: +- FPC SVN 45643 (3.2.0) +- Lazarus SVN 64940 (2.1.0). One big advantage of {\i fpcupdeluxe} is that you can very easily install cross-compilers for the CPU / OS combinations enumerated at @202@.\line Just go to the "Cross" tab, then select the target systems, and click on "Install compiler".\line It may be needed to download the cross-compiler binaries (once): just select "Yes" when prompted. You could install {\i mORMot} using {\i fpcupdeluxe}, but we recommend you clone our @https://github.com/synopse/mORMot repository, and setup the expected project paths, as detailed above at @113@. If you don't want to define a given version, the current {\i trunk} should/could work, if it didn't include any regression at the time you get it - this is why we provide "supported" branches.\line If you want to use the {\i FPC trunk}, please modify line #262 in {\f1\fs20 Synopse.inc} to enable the {\f1\fs20 FPC_PROVIDE_ATTR_TABLE} conditional and support the latest trunk RTTI changes: @@ -16839,7 +16854,7 @@ The {\i Office UI licensing program} was designed by {\i Microsoft} for software If you want to design your user interface using a Office 2007/2010 ribbon look, please take a look at those official guidelines: @http://msdn.microsoft.com/en-us/library/cc872782.aspx Here is the screen content, using the TMS components: %synfiletms.png -And here is the same application compiled using only VCL components, available from {\i Delphi} 6 up to {\i Delphi 10.3 Rio}: +And here is the same application compiled using only VCL components, available from {\i Delphi} 6 up to the latest {\i Delphi} version: %synfilevcl.png We did not use yet the Ribbon component as was introduced in {\i Delphi} 2009. Its action-driven design won't make it easy to interface with the event-driven design of our User Interface handling, and we have to confess that this component has rather bad reputation (at least in the {\i Delphi} 2009 version). Feel free to adapt our Open Source code to use it - we'll be very pleased to release a new version supporting it, but we don't have time nor necessity to do it by ourself. : Enumeration types @@ -18465,7 +18480,7 @@ But please do not forget to put somewhere in your credit window or documentation For instance, if you select the MPL license, here are the requirements: - You accept the license terms with no restriction - see @http://www.mozilla.org/MPL/2.0/FAQ.html for additional information; - You have to publish any modified unit (e.g. {\f1\fs20 SynTaskDialog.pas}) in a public web site (e.g. {\f1\fs20 http://SoftwareCompany.com/MPL}), with a description of applied modifications, and no removal of the original license header in source code; -- You make appear some notice available in the program (About box, documentation, online help), stating e.g.\line {\i This software uses some third-party code of the Synopse mORMot framework (C) 2020 Arnaud Bouchez - {\f1\fs20 https://synopse.info} - under Mozilla Public License 1.1; modified source code is available at {\f1\fs20 http://SoftwareCompany.com/MPL}.} +- You make appear some notice available in the program (About box, documentation, online help), stating e.g.\line {\i This software uses some third-party code of the Synopse mORMot framework (C) 2022 Arnaud Bouchez - {\f1\fs20 https://synopse.info} - under Mozilla Public License 1.1; modified source code is available at {\f1\fs20 http://SoftwareCompany.com/MPL}.} : Derivate Open Source works If you want to include part of the framework source code in your own open-source project, you may publish it with a comment similar to this one (as included in the great {\i DelphiWebScript} project by Eric Grange - @http://code.google.com/p/dwscript ): ${ @@ -18478,7 +18493,7 @@ $ $ Sample based on official mORMot's sample $ "SQLite3\Samples\09 - HttpApi web server\HttpApiServer.dpr" $ -$ Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez +$ Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez $ Synopse Informatique - https://synopse.info $ $ Original tri-license: MPL 1.1/GPL 2.0/LGPL 2.1 diff --git a/contrib/mORMot/SQLite3/Samples/11 - Exception logging/LogViewMain.lfm b/contrib/mORMot/SQLite3/Samples/11 - Exception logging/LogViewMain.lfm index 77b5835..f7fb22a 100644 --- a/contrib/mORMot/SQLite3/Samples/11 - Exception logging/LogViewMain.lfm +++ b/contrib/mORMot/SQLite3/Samples/11 - Exception logging/LogViewMain.lfm @@ -14,51 +14,42 @@ object MainLogView: TMainLogView OnCreate = FormCreate OnKeyDown = FormKeyDown OnShow = FormShow - LCLVersion = '2.0.8.0' - object Splitter2: TSplitter - Cursor = crVSplit - Left = 0 - Height = 4 - Top = 635 - Width = 860 - Align = alBottom - ResizeAnchor = akBottom - end + LCLVersion = '2.0.11.0' object Splitter3: TSplitter Left = 837 - Height = 635 + Height = 583 Top = 0 Width = 4 Visible = False end object Splitter1: TSplitter Left = 829 - Height = 635 + Height = 583 Top = 0 Width = 4 Visible = False end object Splitter4: TSplitter Left = 833 - Height = 635 + Height = 583 Top = 0 Width = 4 Visible = False end object PanelLeft: TPanel Left = 257 - Height = 635 + Height = 583 Top = 0 Width = 150 Align = alLeft - ClientHeight = 635 + ClientHeight = 583 ClientWidth = 150 Constraints.MinWidth = 150 TabOrder = 0 object ImageLogo: TImage Left = 8 Height = 32 - Top = 591 + Top = 539 Width = 137 Anchors = [akLeft, akRight, akBottom] Center = True @@ -421,9 +412,27 @@ object MainLogView: TMainLogView TopIndex = -1 end end + object Splitter2: TSplitter + Cursor = crVSplit + Left = 0 + Height = 4 + Top = 583 + Width = 860 + Align = alBottom + ResizeAnchor = akBottom + end + object PanelBottom: TPanel + Left = 0 + Height = 52 + Top = 587 + Width = 860 + Align = alBottom + TabOrder = 9 + OnResize = PanelBottomResize + end object List: TDrawGrid Left = 841 - Height = 635 + Height = 583 Top = 0 Width = 19 Align = alClient @@ -447,7 +456,7 @@ object MainLogView: TMainLogView end object ProfileList: TDrawGrid Left = 407 - Height = 635 + Height = 583 Top = 0 Width = 274 Align = alLeft @@ -468,17 +477,17 @@ object MainLogView: TMainLogView end object PanelThread: TPanel Left = 681 - Height = 635 + Height = 583 Top = 0 Width = 148 Align = alLeft - ClientHeight = 635 + ClientHeight = 583 ClientWidth = 148 TabOrder = 3 Visible = False object ThreadListBox: TCheckListBox Left = 1 - Height = 593 + Height = 541 Top = 1 Width = 146 Align = alClient @@ -492,7 +501,7 @@ object MainLogView: TMainLogView object pnlThreadBottom: TPanel Left = 1 Height = 40 - Top = 594 + Top = 542 Width = 146 Align = alBottom ClientHeight = 40 @@ -512,11 +521,11 @@ object MainLogView: TMainLogView end object PanelBrowse: TPanel Left = 0 - Height = 635 + Height = 583 Top = 0 Width = 257 Align = alLeft - ClientHeight = 635 + ClientHeight = 583 ClientWidth = 257 Constraints.MinWidth = 80 TabOrder = 4 diff --git a/contrib/mORMot/SQLite3/Samples/24 - MongoDB/MongoDBTestCases.pas b/contrib/mORMot/SQLite3/Samples/24 - MongoDB/MongoDBTestCases.pas index 8c425c6..a5fc2c7 100644 --- a/contrib/mORMot/SQLite3/Samples/24 - MongoDB/MongoDBTestCases.pas +++ b/contrib/mORMot/SQLite3/Samples/24 - MongoDB/MongoDBTestCases.pas @@ -57,6 +57,7 @@ type fInts: TIntegerDynArray; fCreateTime: TCreateTime; fData: TSQLRawBlob; + fFP: double; published property Name: RawUTF8 read fName write fName stored AS_UNIQUE; property Age: integer read fAge write fAge; @@ -65,6 +66,7 @@ type property Ints: TIntegerDynArray index 1 read fInts write fInts; property Data: TSQLRawBlob read fData write fData; property CreateTime: TCreateTime read fCreateTime write fCreateTime; + property FP: double read fFP write fFP; end; TTestORM = class(TSynTestCase) @@ -183,8 +185,9 @@ begin Check(serverTime<>0); CheckSame(Now,serverTime,0.5); if System.Pos('MongoDB',Owner.CustomVersions)=0 then - Owner.CustomVersions := Owner.CustomVersions+'Using '+ - string(fClient.ServerBuildInfoText); + Owner.CustomVersions := format('%sUsing %s'#13#10'Running on %s'#13#10+ + 'Compiled with mORMot '+SYNOPSE_FRAMEWORK_VERSION, + [Owner.CustomVersions,fClient.ServerBuildInfoText,OSVersionText]); fExpectedCount := COLL_COUNT; end; @@ -452,6 +455,7 @@ begin R.Value := _ObjFast(['num',i]); R.Ints := nil; R.DynArray(1).Add(i); + R.FP := i*7.3445; Check(fClient.BatchAdd(R,True)>=0); end; finally @@ -473,6 +477,7 @@ begin Check(Length(R.Ints)=1); Check(R.Ints[0]=aID); Check(R.CreateTime>=fStartTimeStamp); + CheckSame(R.FP,aID*7.3445); end; procedure TTestORM.Retrieve; diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCModel.pas b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCModel.pas index ca5b357..57cc4a1 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCModel.pas +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCModel.pas @@ -19,12 +19,14 @@ type fTitle: RawUTF8; fLanguage: RawUTF8; fAbout: RawUTF8; + fLink: RawUTF8; published property Title: RawUTF8 index 80 read fTitle write fTitle; property Language: RawUTF8 index 3 read fLanguage write fLanguage; property Description: RawUTF8 index 120 read fDescription write fDescription; property Copyright: RawUTF8 index 80 read fCopyright write fCopyright; property About: RawUTF8 read fAbout write fAbout; + property Link: RawUTF8 index 60 read fLink write fLink; end; TSQLRecordTimeStamped = class(TSQLRecord) @@ -46,6 +48,7 @@ type fHashedPassword: RawUTF8; fLogonName: RawUTF8; public + function ComputeHash(const PlainPassword: RawUTF8): RawUTF8; virtual; procedure SetPlainPassword(const PlainPassword: RawUTF8); function CheckPlainPassword(const PlainPassword: RawUTF8): boolean; function Name: RawUTF8; @@ -96,6 +99,7 @@ type OrderID: TIntegerDynArray; procedure Init(aRest: TSQLRest); function Get(tagID: integer): RawUTF8; + function GetIDFromIdent(const Ident: RawUTF8): integer; procedure SaveOccurence(aRest: TSQLRest); procedure SortTagsByIdent(var Tags: TIntegerDynArray); function GetAsDocVariantArray: Variant; @@ -106,6 +110,7 @@ type fAbstract: RawUTF8; fPublishedMonth: Integer; fTags: TIntegerDynArray; + fLegacyHash: Int64; public class function CurrentPublishedMonth: Integer; class procedure InitializeTable(Server: TSQLRestServer; const FieldName: RawUTF8; @@ -118,6 +123,8 @@ type property Abstract: RawUTF8 read fAbstract write fAbstract; // "index 1" below to allow writing e.g. aArticle.DynArray(1).Delete(aIndex) property Tags: TIntegerDynArray index 1 read fTags write fTags; + // xxhash32 of legacy post_url + property LegacyHash: Int64 read fLegacyHash write fLegacyHash; end; TSQLArticleSearch = class(TSQLRecordFTS4Porter) @@ -157,6 +164,8 @@ procedure DotClearFlatImport(Rest: TSQLRest; const aFlatFile: RawUTF8; var aTagsLookup: TSQLTags; const aDotClearRoot: RawUTF8; const aStaticFolder: TFileName); +function ComputeLegacyHash(url: PUTF8Char): cardinal; + implementation @@ -176,12 +185,16 @@ end; { TSQLSomeone } -const - SALT = 'mORMot'; +function TSQLSomeone.ComputeHash(const PlainPassword: RawUTF8): RawUTF8; +var dig: THash256; +begin + PBKDF2_SHA3(SHA3_224,PlainPassword,LogonName+'@mORMot',30,@dig); + BinToHexLower(@dig,28,result); +end; function TSQLSomeone.CheckPlainPassword(const PlainPassword: RawUTF8): boolean; begin - result := fHashedPassword=SHA256(SALT+LogonName+PlainPassword); + result := fHashedPassword=ComputeHash(PlainPassword); end; function TSQLSomeone.Name: RawUTF8; @@ -191,7 +204,7 @@ end; procedure TSQLSomeone.SetPlainPassword(const PlainPassword: RawUTF8); begin - fHashedPassword := SHA256(SALT+LogonName+PlainPassword); + fHashedPassword := ComputeHash(PlainPassword); end; @@ -233,6 +246,8 @@ begin inherited; if (FieldName='') or (FieldName='PublishedMonth') then Server.CreateSQLIndex(TSQLArticle,'PublishedMonth',false); + if (FieldName='') or (FieldName='LegacyHash') then + Server.CreateSQLIndex(TSQLArticle,'LegacyHash',false); end; procedure TSQLArticle.SetPublishedMonth(FromTime: TTimeLog); @@ -260,8 +275,20 @@ begin result := ''; end; +function TSQLTags.GetIDFromIdent(const Ident: RawUTF8): integer; +var i: PtrInt; +begin + if Ident<>'' then + for i := 0 to length(Lookup)-1 do + if IdemPropNameU(Lookup[i].Ident,Ident) then begin + result := i+1; + exit; + end; + result := 0; +end; + function TSQLTags.GetAsDocVariantArray: Variant; -var i,ndx: Integer; +var i,ndx: PtrInt; begin TDocVariant.NewFast(result); with Lock.ProtectMethod do @@ -438,21 +465,46 @@ begin until P=nil; end; +function HttpGet(const aURI: SockString; outHeaders: PSockString=nil; + forceNotSocket: boolean=false; outStatus: PInteger=nil): SockString; +begin + result := ''; + if outStatus<>nil then + outStatus^ := 404; +end; + +function ComputeLegacyHash(url: PUTF8Char): cardinal; +var c: ansichar; +begin + result := 0; + if url<>nil then + repeat + case url^ of + #0: exit; + 'a'..'z', 'A'..'Z', '0'..'9': begin + c := upcase(url^); + result := crc32c(result, @c, 1); + end; + end; + inc(url); + until false; +end; + procedure DotClearFlatImport(Rest: TSQLRest; const aFlatFile: RawUTF8; var aTagsLookup: TSQLTags; const aDotClearRoot: RawUTF8; const aStaticFolder: TFileName); var T,tagTable,postTable: TDotClearTable; - data,urls: TRawUTF8List; + data: TRawUTF8List; + urls: TIntegerDynArray; info: TSQLBlogInfo; article: TSQLArticle; comment: TSQLComment; tag: TSQLTag; - tags: TRawUTF8DynArray; + tags, notfound: TRawUTF8DynArray; tagID: TIDDynArray; tagsCount: integer; batch: TSQLRestBatch; PublicFolder: TFileName; - notfound: TRawUTF8DynArray; r,ndx,post_url,meta_id,meta_type,tag_post_id,postID,post_id: integer; function FixLinks(P: PUTF8Char): RawUTF8; @@ -501,13 +553,20 @@ var T,tagTable,postTable: TDotClearTable; continue; AddNoJSONEscape(B,H-B); P := H; + if IdemPChar(P,'HTTP://BLOG.SYNOPSE.INFO/') then + inc(P,24) + else if IdemPChar(P,'HTTPS://BLOG.SYNOPSE.INFO/') then + inc(P,25); if IdemPChar(P,'HTTP://SYNOPSE.INFO') then begin AddShort('https://synopse.info'); inc(P,19); end else if P^='/' then begin + if P[1]='?' then + inc(P); if IdemPChar(P+1,'POST/') then begin GetUrl(P+6); - i := urls.IndexOf(urlnoparam); + i := IntegerScanIndex(pointer(urls),length(urls), + ComputeLegacyHash(pointer(urlnoparam))); if i>=0 then begin AddShort('articleView?id='); Add(i+1); @@ -582,7 +641,6 @@ begin end; auto1 := TAutoFree.Several([ @data,TDotClearTable.Parse(aFlatFile), - @urls,TRawUTF8ListHashed.Create, @batch,TSQLRestBatch.Create(Rest,TSQLTag,5000)]); auto2 := TSQLRecord.AutoFree([ // avoid several try..finally @info,TSQLBlogInfo, @article,TSQLArticle, @comment,TSQLComment, @tag,TSQLTag]); @@ -614,7 +672,7 @@ begin post_url := postTable.FieldIndexExisting('post_url'); if postTable.Step(true) then repeat - urls.Add(postTable.FieldBuffer(post_url)); + AddInteger(urls,ComputeLegacyHash(postTable.FieldBuffer(post_url))); until not postTable.Step; article.Author := TSQLAuthor(1); article.AuthorName := 'synopse'; @@ -631,6 +689,7 @@ begin article.ModifiedAt := Iso8601ToTimeLog(postTable.GetU(r,'post_upddt')); article.SetPublishedMonth(article.CreatedAt); postID := postTable.GetAsInteger(r,post_id); + article.LegacyHash := ComputeLegacyHash(postTable.Get(r,post_url)); article.Tags := nil; if tagTable.Step(true) then repeat diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCServer.dpr b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCServer.dpr index 9262703..bc05d6f 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCServer.dpr +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCServer.dpr @@ -38,17 +38,25 @@ var aModel: TSQLModel; aApplication: TBlogApplication; aHTTPServer: TSQLHttpServer; begin - //with TSQLLog.Family do Level := LOG_VERBOSE; + with TSQLLog.Family do begin + Level := LOG_VERBOSE; + PerThreadLog := ptIdentifiedInOnFile; + RotateFileCount := 10; + RotateFileSizeKB := 20 shl 10; + FileExistsAction := acAppend; // as expected by rotation + end; aModel := CreateModel; try aServer := TSQLRestServerDB.Create(aModel,ChangeFileExt(ExeVersion.ProgramFileName,'.db')); try aServer.DB.Synchronous := smNormal; aServer.DB.LockingMode := lmExclusive; + aServer.Options := aServer.Options+[rsoNoTableURI]; aServer.CreateMissingTables; aApplication := TBlogApplication.Create; try aApplication.Start(aServer); + aServer.ServiceMethodRegisterPublishedMethods('', aApplication); aHTTPServer := TSQLHttpServer.Create('8092',aServer {$ifndef ONLYUSEHTTPSOCKET},'+',useHttpApiRegisteringURI{$endif}); try diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCViewModel.pas b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCViewModel.pas index 9b04a97..dfc2678 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCViewModel.pas +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/MVCViewModel.pas @@ -12,6 +12,7 @@ uses SynCommons, SynLog, SynTests, + SynCrtSock, mORMot, mORMotMVC, MVCModel; @@ -31,8 +32,9 @@ type out Comments: TObjectList); procedure AuthorView( var ID: TID; out Author: TSQLAuthor; out Articles: variant); - function Login( - const LogonName,PlainPassword: RawUTF8): TMVCAction; + procedure LoginView; + function Login(const LogonName,PlainPassword, + NewPlainPassword1,NewPlainPassword2: RawUTF8): TMVCAction; function Logout: TMVCAction; function ArticleComment(ID: TID; const Title,Comment: RawUTF8): TMVCAction; function ArticleMatch(const Match: RawUTF8): TMVCAction; @@ -71,7 +73,13 @@ type procedure TagToText(const Value: variant; out result: variant); public procedure Start(aServer: TSQLRestServer); reintroduce; + published + // low-level blog/post blog/tag blog/rss endpoints + procedure Post(Ctxt: TSQLRestServerURIContext); + procedure Tag(Ctxt: TSQLRestServerURIContext); + procedure Rss(Ctxt: TSQLRestServerURIContext); public + // IBlogApplication implemented methods procedure Default(var Scope: variant); procedure ArticleView(ID: TID; var WithComments: boolean; Direction: integer; var Scope: variant; @@ -79,7 +87,9 @@ type out Comments: TObjectList); procedure AuthorView( var ID: TID; out Author: TSQLAuthor; out Articles: variant); - function Login(const LogonName,PlainPassword: RawUTF8): TMVCAction; + procedure LoginView; + function Login(const LogonName,PlainPassword, + NewPlainPassword1,NewPlainPassword2: RawUTF8): TMVCAction; function Logout: TMVCAction; function ArticleComment(ID: TID; const Title,Comment: RawUTF8): TMVCAction; function ArticleMatch(const Match: RawUTF8): TMVCAction; @@ -130,6 +140,10 @@ begin finally Free; end; + _Safe(fBlogMainInfo)^.AddValue('engine',RawUTF8ToVariant( + 'Website powered by mORMot MVC '+SYNOPSE_FRAMEWORK_VERSION+ + ', compiled with '+GetDelphiCompilerVersion+ + ', running on '+RawUTF8(ToText(OSVersion32))+'.')); end; procedure TBlogApplication.MonthToText(const Value: variant; @@ -172,29 +186,28 @@ begin auto := TSQLRecord.AutoFree([ // avoid several try..finally @info,TSQLBlogInfo, @article,TSQLArticle, @comment,TSQLComment, @tag,TSQLTag]); if not RestModel.Retrieve('',info) then begin // retrieve first item - tmp := StringFromFile('/home/ab/Downloads/2020-06-16-a8003957c2ae6bde5be6ea279c9c9ce4-backup.txt'); + tmp := StringFromFile(ExeVersion.ProgramFilePath+'2021-01-20-16-37-default-backup.txt'); info.Language := 'en'; if tmp<>'' then begin info.Title := 'Synopse Blog'; info.Description := 'Articles, announcements, news, updates and more '+ - 'about our Open Source projects'; + 'about Synopse Open Source projects'; info.About := 'Latest information about Synopse Open Source librairies, '+ 'mainly the mORMot ORM/SOA/MVC framework, and SynPDF.'; + info.Link := 'https://blog.synopse.info'; end else begin info.Title := 'mORMot BLOG'; info.Description := 'Sample Blog Web Application using Synopse mORMot MVC'; info.About := TSynTestCase.RandomTextParagraph(10,'!'); + info.Link := 'http://localhost:8092'; end; - info.About := info.About+#13#10'Website powered by mORMot MVC '+ - SYNOPSE_FRAMEWORK_VERSION+', compiled with '+GetDelphiCompilerVersion+ - ', running on '+ToText(OSVersion32)+'.'; info.Copyright := '©'+ToUTF8(CurrentYear)+'Synopse Informatique'; RestModel.Add(info,true); end; if RestModel.TableHasRows(TSQLArticle) then exit; if tmp<>'' then begin - DotClearFlatImport(RestModel,tmp,fTagsLookup,'http://blog.synopse.info', + DotClearFlatImport(RestModel,tmp,fTagsLookup,'https://blog.synopse.info', (TMVCRunOnRestServer(fMainRunner).Views as TMVCViewsMustache).ViewStaticFolder); exit; end; @@ -271,20 +284,24 @@ begin fDefaultData.AddNewProp('tags',fTagsLookup.GetAsDocVariantArray,info); end; -procedure TBlogApplication.FlushAnyCache; -begin - inherited FlushAnyCache; // call fMainRunner.NotifyContentChanged - fDefaultData.Clear; -end; - - -{ TBlogApplication - Commands } - const ARTICLE_FIELDS = 'RowID,Title,Tags,Abstract,ContentHtml,Author,AuthorName,CreatedAt'; ARTICLE_DEFAULT_LIMIT = ' limit 20'; ARTICLE_DEFAULT_ORDER: RawUTF8 = 'order by RowID desc'+ARTICLE_DEFAULT_LIMIT; +procedure TBlogApplication.FlushAnyCache; +begin + inherited FlushAnyCache; // call fMainRunner.NotifyContentChanged + fDefaultData.Clear; + // get last 20 articles + fDefaultData.SetValue('Articles', + RestModel.RetrieveDocVariantArray(TSQLArticle,'', + ARTICLE_DEFAULT_ORDER,[],ARTICLE_FIELDS,nil,@fDefaultLastID)); +end; + + +{ TBlogApplication - Commands } + procedure TBlogApplication.Default(var Scope: variant); var scop: PDocVariantData; lastID: TID; @@ -320,14 +337,12 @@ begin whereClause := whereClause+' and IntegerDynArrayContains(Tags,?)'; end; SetVariantNull(Scope); - if (lastID=0) and (tag=0) then begin // use simple cache if no parameters - if not fDefaultData.AddExistingProp('Articles',Scope) then begin - articles := RestModel.RetrieveDocVariantArray(TSQLArticle,'', - ARTICLE_DEFAULT_ORDER,[],ARTICLE_FIELDS,nil,@fDefaultLastID); - fDefaultData.AddNewProp('Articles',articles,Scope); - end; + if (lastID=0) and (tag=0) then begin + // use simple cache if no parameters + fDefaultData.AddExistingProp('Articles',Scope); // set by FlushAnyCache lastID := fDefaultLastID; - end else begin // use more complex request using lastID + tag parameters + end else begin + // use more complex request using lastID + tag parameters articles := RestModel.RetrieveDocVariantArray(TSQLArticle,'', whereClause+ARTICLE_DEFAULT_ORDER,[lastID,tag],ARTICLE_FIELDS,nil,@lastID); scope := _ObjFast(['Articles',articles]); @@ -370,12 +385,31 @@ begin raise EMVCApplication.CreateGotoError(HTTP_NOTFOUND); end; -function TBlogApplication.Login(const LogonName, PlainPassword: RawUTF8): TMVCAction; +procedure TBlogApplication.LoginView; +begin +end; + +function TBlogApplication.Login(const LogonName, PlainPassword, + NewPlainPassword1, NewPlainPassword2: RawUTF8): TMVCAction; var Author: TSQLAuthor; SessionInfo: TCookieData; + newpwd: RawUTF8; begin - if CurrentSession.CheckAndRetrieve<>0 then begin - GotoError(result,HTTP_BADREQUEST); + if LogonName='' then begin + GotoView(result,'LoginView',[]); + exit; + end; + newpwd := Trim(NewPlainPassword1); + if newpwd<>'' then begin + if (newpwd<>NewPlainPassword2) or + (newpwd=PlainPassword) or + (CurrentSession.CheckAndRetrieve(@SessionInfo,TypeInfo(TCookieData))=0) or + (SessionInfo.AuthorName<>LogonName) then begin + GotoError(result,HTTP_NOTACCEPTABLE); + exit; + end; + end else if CurrentSession.CheckAndRetrieve<>0 then begin + GotoError(result,'Already Logged In',HTTP_BADREQUEST); exit; end; Author := TSQLAuthor.Create(RestModel,'LogonName=?',[LogonName]); @@ -385,6 +419,10 @@ begin SessionInfo.AuthorID := Author.ID; SessionInfo.AuthorRights := Author.Rights; CurrentSession.Initialize(@SessionInfo,TypeInfo(TCookieData)); + if newpwd<>'' then begin + Author.SetPlainPassword(newpwd); + RestModel.Update(Author,'HashedPassword'); + end; GotoDefault(result); end else GotoError(result,sErrorInvalidLogin); @@ -481,6 +519,83 @@ begin end; end; +procedure TBlogApplication.Post(Ctxt: TSQLRestServerURIContext); +var hash, id: Int64; +begin + hash := ComputeLegacyHash(pointer(UrlDecode(Ctxt.URIAfterRoot,5,-1))); + id := RestModel.OneFieldValueInt64(TSQLArticle,'ID', + FormatUTF8('LegacyHash=:(%):', [hash])); + Ctxt.Redirect(FormatUTF8('/%/articleview?id=%',[RestModel.Model.Root,id])); +end; + +procedure TBlogApplication.Tag(Ctxt: TSQLRestServerURIContext); +var + id: integer; +begin + id := fTagsLookup.GetIDFromIdent(copy(Ctxt.UriAfterRoot, 5, 100)); + Ctxt.Redirect(FormatUTF8('/%/default?scope={tag:%}',[RestModel.Model.Root,id])); +end; + +function Esc(const Msg: RawUTF8): RawUTF8; +var i: integer; + ins: RawUTF8; +begin + // fast enough for our purpose to compute some RSS cache + result := Msg; + for i := length(Msg) downto 1 do begin + case Msg[i] of + '"': ins := '"'; + '&': ins := '&'; + '<': ins := '<'; + '>': ins := '>'; + else Continue; + end; + result[i] := ';'; + insert(ins,result,i); + end; +end; + +procedure TBlogApplication.Rss(Ctxt: TSQLRestServerURIContext); + function ComputeRss: variant; + var xml, lng, link: RawUTF8; + art: integer; + begin + with _Safe(fBlogMainInfo)^ do + begin + link := U['Link']; + if (link<>'') and (link[length(link)]='/') then + SetLength(link,length(link)-1); + lng := U['Language']; + if lng='' then + lng := 'en_US'; + FormatUTF8(''+ + '%'+ + '%%'+ + '%%', + [Esc(U['Title']),link,Esc(U['Description']), + DateTimeToHTTPDate(NowUTC,'+0000'),lng],xml); + end; + with _Safe(fDefaultData.GetValue('Articles'))^ do + for art := 0 to Count-1 do + with _Safe(Values[art])^ do + xml := FormatUTF8('%'#13'%'+ + '%/articleview?id=%%blog'+ + '%'+ + '', + [xml,Esc(U['Title']),link,I['ID'], + DateTimeToHTTPDate(TimeLogToDateTime(I['CreatedAt']),'+0000'), + Esc(U['AuthorName']),U['Abstract'],U['Content']]); + RawUTF8ToVariant(xml+'',result); + end; +var + rss: variant; +begin + if not fDefaultData.ExistsOrLock('rss',rss) then + fDefaultData.ReplaceAndUnlock('rss',ComputeRss,rss); + Ctxt.Returns(ToUTF8(rss),HTTP_SUCCESS, + HEADER_CONTENT_TYPE+'application/rss+xml; charset=UTF-8',{handle304=}true); +end; + initialization {$ifndef DELPHI2010} // manual definition mandatory only if Delphi 2010 RTTI is not available diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/ArticleView.html b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/ArticleView.html index c4536ff..210a0da 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/ArticleView.html +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/ArticleView.html @@ -1,51 +1,51 @@ {{>header}} {{>masthead}} -
-

{{article.title}}

-
- Written by {{article.AuthorName}} ({{author.FirstName}} {{author.FamilyName}}) on {{TimeLogToText article.CreatedAt}}
- {{#article.tags}}{{TagToText .}} {{/article.tags}} -
-
-
-
- {{#article}} - {{#ContentHtml}}{{{abstract}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml abstract}}}{{/ContentHtml}} -
- {{#ContentHtml}}{{{content}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml content}}}{{/ContentHtml}} - {{/article}} -
- - - {{#WithComments}} - {{#Comments}} -
-

{{Title}}

-

{{#ContentHtml}}{{{Content}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml Content}}}{{/ContentHtml}}

-
-
- {{/Comments}} - {{^Comments}}
No comment yet.
{{/Comments}} -

Hide Comments

- {{#main.session.AuthorRights.Comment}} - -
-
- {{#Scope}}
{{CommentError}}
{{/Scope}} - - - -
-
- {{/main.session.AuthorRights.Comment}} -

- {{/WithComments}} - {{^WithComments}} -

Show Comments

- {{/WithComments}} +
+

{{article.title}}

+
+ Written by {{article.AuthorName}} ({{author.FirstName}} {{author.FamilyName}}) on {{TimeLogToText article.CreatedAt}}
+ {{#article.tags}}{{TagToText .}} {{/article.tags}} +
+
+
+
+ {{#article}} + {{#ContentHtml}}{{{abstract}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml abstract}}}{{/ContentHtml}} +
+ {{#ContentHtml}}{{{content}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml content}}}{{/ContentHtml}} + {{/article}} +
+ + + {{#WithComments}} + {{#Comments}} +
+

{{Title}}

+

{{#ContentHtml}}{{{Content}}}{{/ContentHtml}}{{^ContentHtml}}{{{WikiToHtml Content}}}{{/ContentHtml}}

+
+
+ {{/Comments}} + {{^Comments}}
No comment yet.
{{/Comments}} +

Hide Comments

+ {{#main.session.AuthorRights.Comment}} + +
+
+ {{#Scope}}
{{CommentError}}
{{/Scope}} + + + +
+
+ {{/main.session.AuthorRights.Comment}} +

+ {{/WithComments}} + {{^WithComments}} +

Show Comments

+ {{/WithComments}} {{>footer}} \ No newline at end of file diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/AuthorView.html b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/AuthorView.html index 0b0dca9..2f8dfee 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/AuthorView.html +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/AuthorView.html @@ -1,15 +1,25 @@ {{>header}} {{>masthead}} -
-

User {{Author.LogonName}}

-
{{Author.FirstName}} {{Author.FamilyName}} -
-
-
-
-
Information about {{Author.LogonName}}
-
- {{{TSQLAuthor.HtmlTable Author}}} -
+
+

User {{Author.LogonName}}

+
{{Author.FirstName}} {{Author.FamilyName}} +
+
+
+
+
Information about {{Author.LogonName}}
+
+ {{{TSQLAuthor.HtmlTable Author}}} + {{#main.session}} +
+ Change {{AuthorName}} Password: + + + + + +
+ {{/main.session}} +
{{>articlerow}} {{>footer}} \ No newline at end of file diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/footer.partial b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/footer.partial index 48b5f19..2480572 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/footer.partial +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/footer.partial @@ -22,8 +22,23 @@

Proudly using the Open Source mORMot ORM/SOA/MVC Framework.
+ {{{main.blog.engine}}}
{{{main.blog.copyright}}} - page generated in [[GENERATION_TIME_TAG]]

-

Back to top

+ + {{#main.session}} +

+

+ Signed in as {{AuthorName}} + +
+

+ {{/main.session}}
\ No newline at end of file diff --git a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/masthead.partial b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/masthead.partial index a56a4bf..9343fe5 100644 --- a/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/masthead.partial +++ b/contrib/mORMot/SQLite3/Samples/30 - MVC Server/Views/masthead.partial @@ -3,44 +3,23 @@
-
- -
- {{main.blog.title}} -
-
-
-
- -
-
-
-
-
- -
+
+ +
+ {{main.blog.title}} +
+
+
+
+ +
+
+
+
diff --git a/contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr b/contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr index 799d71b..349943c 100644 --- a/contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr +++ b/contrib/mORMot/SQLite3/Samples/31 - WebSockets/Project31ChatClient.dpr @@ -8,6 +8,7 @@ uses SysUtils, Classes, SynCommons, + SynTable, mORMot, mORMotHttpClient, Project31ChatCallbackInterface in 'Project31ChatCallbackInterface.pas'; diff --git a/contrib/mORMot/SQLite3/Samples/33 - ECC/ECCProcess.pas b/contrib/mORMot/SQLite3/Samples/33 - ECC/ECCProcess.pas index 7088813..7068bfc 100644 --- a/contrib/mORMot/SQLite3/Samples/33 - ECC/ECCProcess.pas +++ b/contrib/mORMot/SQLite3/Samples/33 - ECC/ECCProcess.pas @@ -3,7 +3,7 @@ unit ECCProcess; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -22,7 +22,7 @@ unit ECCProcess; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.dpr b/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.dpr index 0a82d99..ddad0a9 100644 --- a/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.dpr +++ b/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.dpr @@ -28,7 +28,7 @@ uses BaseUnix, {$endif} {$ifdef LINUXNOTBSD} - SynSystemd, + SynFPCLinux, mORMotService, {$endif} mORMotHttpServer; // HTTP server for RESTful server @@ -163,12 +163,12 @@ const UNIX_SOCK_PATH = '/tmp/rest-bench.socket'; {$ifdef LINUX} -/// killa process after X second without GEt requests +/// killa process after X second without Get requests function inactivityWatchdog(p: pointer): ptrint; var currentRC: TSynMonitorCount64; begin repeat - sleep(10000); /// once per 10 second + sleep(10000); // once per 10 second if aRestServer = nil then // not initialized continue; currentRC := aRestServer.Stats.Read; @@ -182,6 +182,7 @@ begin Result := 0; end; {$endif} + begin // set logging abilities SQLite3Log.Family.Level := LOG_VERBOSE; @@ -190,10 +191,10 @@ begin SQLite3Log.Family.NoFile := true; // do not create log files for benchmark {$ifdef UNIX} {$ifdef LINUXNOTBSD} - if SynSystemd.ProcessIsStartedBySystemd then begin + if ProcessIsStartedBySystemd then begin SQLite3Log.Family.EchoToConsole := SQLite3Log.Family.Level; SQLite3Log.Family.EchoToConsoleUseJournal := true; - if sd.listen_fds(0) = 1 then + if ExternalLibraries.sd_listen_fds(0) = 1 then url := '' // force to use socket passed by systemd else url := '8888'; diff --git a/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.lpi b/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.lpi index 3661fca..2d9fc39 100644 --- a/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.lpi +++ b/contrib/mORMot/SQLite3/Samples/36 - Simple REST Benchmark/RESTBenchmark.lpi @@ -43,6 +43,15 @@ + + + + + + + + + diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/SynJSONTreeview/SynJSONTreeView.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/SynJSONTreeview/SynJSONTreeView.pas index b76bca2..3324d2f 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/SynJSONTreeview/SynJSONTreeView.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/SynJSONTreeview/SynJSONTreeView.pas @@ -7,7 +7,7 @@ unit SynJSONTreeView; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -26,7 +26,7 @@ unit SynJSONTreeView; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestMidasVCL.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestMidasVCL.pas index e0ca5a9..c2b9dbe 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestMidasVCL.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestMidasVCL.pas @@ -6,7 +6,7 @@ unit SynRestMidasVCL; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynRestMidasVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestVCL.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestVCL.pas index 11547b1..6fe61cf 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestVCL.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/EMartin/TSynRestDataset/SynRestVCL.pas @@ -6,7 +6,7 @@ unit SynRestVCL; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynRestVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/George/REST-tester/mORMotRESTFPCInterfaces.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/George/REST-tester/mORMotRESTFPCInterfaces.pas index b4107fc..313d9f8 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/George/REST-tester/mORMotRESTFPCInterfaces.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/George/REST-tester/mORMotRESTFPCInterfaces.pas @@ -7,7 +7,7 @@ unit mORMotRESTFPCInterfaces; This unit has been generated by a mORMot 1.18.2797 server. Any manual modification of this file may be lost after regeneration. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info This unit is released under a MPL/GPL/LGPL tri-license, diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/FMXUtil.inc.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/FMXUtil.inc.pas index 9f6bf27..324c72a 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/FMXUtil.inc.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/FMXUtil.inc.pas @@ -1,10 +1,57 @@ +{$IF (CompilerVersion <= 25)} +type + //other name of constants in XE4 + TStyledSettingHelper = record helper for TStyledSetting + const Family = TStyledSetting.ssFamily; + const Size = TStyledSetting.ssSize; + const Style = TStyledSetting.ssStyle; + const FontColor = TStyledSetting.ssFontColor; + const Other = TStyledSetting.ssOther; + end; + + TTextAlignHelper = record helper for TTextAlign + const Center = TTextAlign.taCenter; + const Leading = TTextAlign.taLeading; + const Trailing = TTextAlign.taTrailing; + end; + + TFmxFormBorderStyleHelper = record helper for TFmxFormBorderStyle + const None = TFmxFormBorderStyle.bsNone; + const Single = TFmxFormBorderStyle.bsSingle; + const Sizeable = TFmxFormBorderStyle.bsSizeable; + const ToolWindow = TFmxFormBorderStyle.bsToolWindow; + const SizeToolWin = TFmxFormBorderStyle.bsSizeToolWin; + end; + + TFormPositionHelper = record helper for TFormPosition + //(poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly, + //poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter); + const OwnerFormCenter = TFormPosition.poOwnerFormCenter; + const ScreenCenter = TFormPosition.poScreenCenter; + end; + + TBrushKindHelper = record helper for TBrushKind + //(bkNone, bkSolid, bkGradient, bkBitmap, bkResource); + const None = TBrushKind.bkNone; + end; + + TAlignLayoutHelper = record helper for TAlignLayout + //(alNone, alTop, alLeft, alRight, alBottom, alMostTop, alMostBottom, alMostLeft, alMostRight, alClient, + //alContents, alCenter, alVertCenter, alHorzCenter, alHorizontal, alVertical, alScale, alFit, alFitLeft, alFitRight); + const Top = TAlignLayout.alTop; + end; + +{$IFEND} + var _ScreenDPI_X : Single = 0; function ScalingByScreenDPI_N( F:TForm = NIL ):Single; var p : TPointF; + {$IF (CompilerVersion >= 28)} M : TDeviceDisplayMetrics; + {$IFEND} i : integer; h : THandle; begin @@ -29,6 +76,7 @@ begin end; {$ENDIF} + {$IF (CompilerVersion >= 28)} //TDeviceDisplayMetrics is available since XE8 if TPlatformServices.Current.SupportsPlatformService( IFMXDeviceMetricsService ) then begin M := (TPlatformServices.Current.GetPlatformService( @@ -38,6 +86,7 @@ begin {$IFDEF MSWINDOWS}96{$ENDIF} ; end; + {$IFEND} end; function ScalingByScreenDPI( F:TForm = NIL ):TPointF; diff --git a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/SynTaskDialog.pas b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/SynTaskDialog.pas index d9e6c62..2b6a1c4 100644 --- a/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/SynTaskDialog.pas +++ b/contrib/mORMot/SQLite3/Samples/ThirdPartyDemos/Ondrej/SynTaskDialog4Lazarus/SynTaskDialog.pas @@ -6,7 +6,7 @@ unit SynTaskDialog; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynTaskDialog; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -139,8 +139,12 @@ uses {$endif} {$IFDEF FMX} System.UITypes, System.Types, System.UIConsts, - FMX.Menus, FMX.Types, FMX.Layouts, FMX.ComboEdit, - FMX.Graphics, FMX.Forms, FMX.Controls, FMX.StdCtrls, FMX.ExtCtrls, + FMX.Menus, FMX.Types, FMX.Layouts, + {$IF (CompilerVersion >= 26.0)}// Delphi XE5 UP + FMX.ComboEdit, + FMX.Graphics, + {$IFEND} + FMX.Forms, FMX.Controls, FMX.StdCtrls, FMX.ExtCtrls, FMX.ListBox, FMX.Edit, FMX.Objects, FMX.Platform, {$IFDEF MSWINDOWS} FMX.Platform.Win diff --git a/contrib/mORMot/SQLite3/TestSQL3.dpr b/contrib/mORMot/SQLite3/TestSQL3.dpr index 7c203ba..39afa90 100644 --- a/contrib/mORMot/SQLite3/TestSQL3.dpr +++ b/contrib/mORMot/SQLite3/TestSQL3.dpr @@ -127,6 +127,7 @@ uses SynZipFiles in '..\SynZipFiles.pas', {$endif LVCL} {$ifdef MSWINDOWS} + Windows, {$ifndef CPU64} SynSMAPI in '..\SynSMAPI.pas', SynSM in '..\SynSM.pas', @@ -164,10 +165,12 @@ uses // SynDBFirebird in '..\SynDBFirebird.pas', // SynDBDataSet in '..\SynDBDataSet.pas', // SynDBFireDAC in '..\SynDBDataSet\SynDBFireDAC.pas', + // SynDBUniDAC in '..\SynDBDataSet\SynDBUniDAC.pas', {$ifdef USEZEOS} SynDBZeos in '..\SynDBZeos.pas', {$endif} {$ifndef DELPHI5OROLDER} + // SynDBVCL in '..\SynDBVCL.pas', SynDBRemote in '..\SynDBRemote.pas', mORMotDB in 'mORMotDB.pas', mORMotMongoDB in 'mORMotMongoDB.pas', diff --git a/contrib/mORMot/SQLite3/TestSQL3FPCInterfaces.pas b/contrib/mORMot/SQLite3/TestSQL3FPCInterfaces.pas index 280b329..089cbde 100644 --- a/contrib/mORMot/SQLite3/TestSQL3FPCInterfaces.pas +++ b/contrib/mORMot/SQLite3/TestSQL3FPCInterfaces.pas @@ -7,7 +7,7 @@ unit TestSQL3FPCInterfaces; This unit has been generated by a mORMot 1.18.2718 server. Any manual modification of this file may be lost after regeneration. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info This unit is released under a MPL/GPL/LGPL tri-license, diff --git a/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.c b/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.c new file mode 100644 index 0000000..3b8d574 --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.c @@ -0,0 +1,666 @@ +/* +** Name: cipher_common.c +** Purpose: Implementation of SQLite codecs +** Author: Ulrich Telle +** Created: 2020-02-02 +** Copyright: (c) 2006-2020 Ulrich Telle +** License: MIT +*/ + +#include "cipher_common.h" + +static unsigned char padding[] = +"\x28\xBF\x4E\x5E\x4E\x75\x8A\x41\x64\x00\x4E\x56\xFF\xFA\x01\x08\x2E\x2E\x00\xB6\xD0\x68\x3E\x80\x2F\x0C\xA9\xFE\x64\x53\x69\x7A"; + +/* --- Codec Descriptor Table --- */ + +/* +** Common configuration parameters +** +** - cipher : default cipher type +** - hmac_check : flag whether page hmac should be verified on read +*/ + +static CipherParams commonParams[] = +{ + { "cipher", CODEC_TYPE, CODEC_TYPE, 1, CODEC_TYPE_MAX }, + { "hmac_check", 1, 1, 0, 1 }, + CIPHER_PARAMS_SENTINEL +}; + +SQLITE_PRIVATE int +sqlite3mcGetCipherParameter(CipherParams* cipherParams, const char* paramName) +{ + int value = -1; + for (; strlen(cipherParams->m_name) > 0; ++cipherParams) + { + if (sqlite3_stricmp(paramName, cipherParams->m_name) == 0) break; + } + if (strlen(cipherParams->m_name) > 0) + { + value = cipherParams->m_value; + cipherParams->m_value = cipherParams->m_default; + } + return value; +} + +static CodecParameter globalCodecParameterTable[] = +{ + { "global", CODEC_TYPE_UNKNOWN, commonParams }, +#if HAVE_CIPHER_AES_128_CBC + { "aes128cbc", CODEC_TYPE_AES128, mcAES128Params }, +#endif +#if HAVE_CIPHER_AES_256_CBC + { "aes256cbc", CODEC_TYPE_AES256, mcAES256Params }, +#endif +#if HAVE_CIPHER_CHACHA20 + { "chacha20", CODEC_TYPE_CHACHA20, mcChaCha20Params }, +#endif +#if HAVE_CIPHER_SQLCIPHER + { "sqlcipher", CODEC_TYPE_SQLCIPHER, mcSQLCipherParams }, +#endif +#if HAVE_CIPHER_RC4 + { "rc4", CODEC_TYPE_RC4, mcRC4Params }, +#endif + { "", CODEC_TYPE_UNKNOWN, NULL } +}; + +#define CODEC_TYPE_UNKNOWN 0 +#define CODEC_TYPE_AES128 1 +#define CODEC_TYPE_AES256 2 +#define CODEC_TYPE_CHACHA20 3 +#define CODEC_TYPE_SQLCIPHER 4 +#define CODEC_TYPE_RC4 5 + +SQLITE_PRIVATE CodecParameter* +sqlite3mcCloneCodecParameterTable() +{ + /* Count number of codecs and cipher parameters */ + int nTables = 0; + int nParams = 0; + int j, k, n; + CipherParams* cloneCipherParams; + CodecParameter* cloneCodecParams; + + for (j = 0; strlen(globalCodecParameterTable[j].m_name) > 0; ++j) + { + CipherParams* params = globalCodecParameterTable[j].m_params; + for (k = 0; strlen(params[k].m_name) > 0; ++k); + nParams += k; + } + nTables = j; + + /* Allocate memory for cloned codec parameter tables (including sentinel for each table) */ + cloneCipherParams = (CipherParams*) sqlite3_malloc((nParams + nTables) * sizeof(CipherParams)); + cloneCodecParams = (CodecParameter*) sqlite3_malloc((nTables + 1) * sizeof(CodecParameter)); + + /* Create copy of tables */ + if (cloneCodecParams != NULL) + { + int offset = 0; + for (j = 0; j < nTables; ++j) + { + CipherParams* params = globalCodecParameterTable[j].m_params; + cloneCodecParams[j].m_name = globalCodecParameterTable[j].m_name; + cloneCodecParams[j].m_params = &cloneCipherParams[offset]; + for (n = 0; strlen(params[n].m_name) > 0; ++n); + /* Copy all parameters of the current table (including sentinel) */ + for (k = 0; k <= n; ++k) + { + cloneCipherParams[offset + k].m_name = params[k].m_name; + cloneCipherParams[offset + k].m_value = params[k].m_value; + cloneCipherParams[offset + k].m_default = params[k].m_default; + cloneCipherParams[offset + k].m_minValue = params[k].m_minValue; + cloneCipherParams[offset + k].m_maxValue = params[k].m_maxValue; + } + offset += (n + 1); + } + cloneCodecParams[nTables].m_name = globalCodecParameterTable[nTables].m_name; + cloneCodecParams[nTables].m_params = NULL; + } + else + { + sqlite3_free(cloneCipherParams); + } + return cloneCodecParams; +} + +SQLITE_PRIVATE void +sqlite3mcFreeCodecParameterTable(CodecParameter* codecParams) +{ + sqlite3_free(codecParams[0].m_params); + sqlite3_free(codecParams); +} + +static const CipherDescriptor mcSentinelDescriptor = +{ + "", NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL +}; + +static const CipherDescriptor mcDummyDescriptor = +{ + "@dummy@", NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL +}; + +static const CipherDescriptor* codecDescriptorTable[] = +{ +#if HAVE_CIPHER_AES_128_CBC + &mcAES128Descriptor, +#else + &mcDummyDescriptor, +#endif +#if HAVE_CIPHER_AES_256_CBC + &mcAES256Descriptor, +#else + &mcDummyDescriptor, +#endif +#if HAVE_CIPHER_CHACHA20 + &mcChaCha20Descriptor, +#else + &mcDummyDescriptor, +#endif +#if HAVE_CIPHER_SQLCIPHER + &mcSQLCipherDescriptor, +#else + &mcDummyDescriptor, +#endif +#if HAVE_CIPHER_RC4 + &mcRC4Descriptor, +#else + &mcDummyDescriptor, +#endif + &mcSentinelDescriptor +}; + +/* --- Codec --- */ + +SQLITE_PRIVATE CodecParameter* +sqlite3mcGetCodecParams(sqlite3* db); + +SQLITE_PRIVATE int +sqlite3mcGetCipherType(sqlite3* db) +{ + CodecParameter* codecParams = (db != NULL) ? sqlite3mcGetCodecParams(db) : globalCodecParameterTable; + CipherParams* cipherParamTable = (codecParams != NULL) ? codecParams[0].m_params : commonParams; + int cipherType = CODEC_TYPE; + CipherParams* cipher = cipherParamTable; + for (; strlen(cipher->m_name) > 0; ++cipher) + { + if (sqlite3_stricmp("cipher", cipher->m_name) == 0) break; + } + if (strlen(cipher->m_name) > 0) + { + cipherType = cipher->m_value; + cipher->m_value = cipher->m_default; + } + return cipherType; +} + +SQLITE_PRIVATE CipherParams* +sqlite3mcGetCipherParams(sqlite3* db, int cypherType) +{ + CodecParameter* codecParams = (db != NULL) ? sqlite3mcGetCodecParams(db) : globalCodecParameterTable; + CipherParams* cipherParamTable = (codecParams != NULL) ? codecParams[cypherType].m_params : globalCodecParameterTable[cypherType].m_params; + return cipherParamTable; +} + +SQLITE_PRIVATE int +sqlite3mcCodecInit(Codec* codec) +{ + int rc = SQLITE_OK; + if (codec != NULL) + { + codec->m_isEncrypted = 0; + codec->m_hmacCheck = 1; + + codec->m_hasReadCipher = 0; + codec->m_readCipherType = CODEC_TYPE_UNKNOWN; + codec->m_readCipher = NULL; + codec->m_readReserved = -1; + + codec->m_hasWriteCipher = 0; + codec->m_writeCipherType = CODEC_TYPE_UNKNOWN; + codec->m_writeCipher = NULL; + codec->m_writeReserved = -1; + + codec->m_db = NULL; + codec->m_bt = NULL; + codec->m_btShared = NULL; + memset(codec->m_page, 0, sizeof(codec->m_page)); + codec->m_pageSize = 0; + codec->m_reserved = 0; + codec->m_hasKeySalt = 0; + memset(codec->m_keySalt, 0, sizeof(codec->m_keySalt)); + } + else + { + rc = SQLITE_NOMEM; + } + return rc; +} + +SQLITE_PRIVATE void +sqlite3mcCodecTerm(Codec* codec) +{ + if (codec->m_readCipher != NULL) + { + codecDescriptorTable[codec->m_readCipherType - 1]->m_freeCipher(codec->m_readCipher); + codec->m_readCipher = NULL; + } + if (codec->m_writeCipher != NULL) + { + codecDescriptorTable[codec->m_writeCipherType - 1]->m_freeCipher(codec->m_writeCipher); + codec->m_writeCipher = NULL; + } + memset(codec, 0, sizeof(Codec)); +} + +SQLITE_PRIVATE void +sqlite3mcClearKeySalt(Codec* codec) +{ + codec->m_hasKeySalt = 0; + memset(codec->m_keySalt, 0, sizeof(codec->m_keySalt)); +} + +SQLITE_PRIVATE int +sqlite3mcCodecSetup(Codec* codec, int cipherType, char* userPassword, int passwordLength) +{ + int rc = SQLITE_OK; + CipherParams* globalParams = sqlite3mcGetCipherParams(codec->m_db, 0); + codec->m_isEncrypted = 1; + codec->m_hmacCheck = sqlite3mcGetCipherParameter(globalParams, "hmac_check"); + codec->m_hasReadCipher = 1; + codec->m_hasWriteCipher = 1; + codec->m_readCipherType = cipherType; + codec->m_readCipher = codecDescriptorTable[codec->m_readCipherType-1]->m_allocateCipher(codec->m_db); + if (codec->m_readCipher != NULL) + { + unsigned char* keySalt = (codec->m_hasKeySalt != 0) ? codec->m_keySalt : NULL; + sqlite3mcGenerateReadKey(codec, userPassword, passwordLength, keySalt); + rc = sqlite3mcCopyCipher(codec, 1); + } + else + { + rc = SQLITE_NOMEM; + } + return rc; +} + +SQLITE_PRIVATE int +sqlite3mcSetupWriteCipher(Codec* codec, int cipherType, char* userPassword, int passwordLength) +{ + int rc = SQLITE_OK; + CipherParams* globalParams = sqlite3mcGetCipherParams(codec->m_db, 0); + if (codec->m_writeCipher != NULL) + { + codecDescriptorTable[codec->m_writeCipherType-1]->m_freeCipher(codec->m_writeCipher); + } + codec->m_isEncrypted = 1; + codec->m_hmacCheck = sqlite3mcGetCipherParameter(globalParams, "hmac_check"); + codec->m_hasWriteCipher = 1; + codec->m_writeCipherType = cipherType; + codec->m_writeCipher = codecDescriptorTable[codec->m_writeCipherType-1]->m_allocateCipher(codec->m_db); + if (codec->m_writeCipher != NULL) + { + unsigned char* keySalt = (codec->m_hasKeySalt != 0) ? codec->m_keySalt : NULL; + sqlite3mcGenerateWriteKey(codec, userPassword, passwordLength, keySalt); + } + else + { + rc = SQLITE_NOMEM; + } + return rc; +} + +SQLITE_PRIVATE void +sqlite3mcSetIsEncrypted(Codec* codec, int isEncrypted) +{ + codec->m_isEncrypted = isEncrypted; +} + +SQLITE_PRIVATE void +sqlite3mcSetReadCipherType(Codec* codec, int cipherType) +{ + codec->m_readCipherType = cipherType; +} + +SQLITE_PRIVATE void +sqlite3mcSetWriteCipherType(Codec* codec, int cipherType) +{ + codec->m_writeCipherType = cipherType; +} + +SQLITE_PRIVATE void +sqlite3mcSetHasReadCipher(Codec* codec, int hasReadCipher) +{ + codec->m_hasReadCipher = hasReadCipher; +} + +SQLITE_PRIVATE void +sqlite3mcSetHasWriteCipher(Codec* codec, int hasWriteCipher) +{ + codec->m_hasWriteCipher = hasWriteCipher; +} + +SQLITE_PRIVATE void +sqlite3mcSetDb(Codec* codec, sqlite3* db) +{ + codec->m_db = db; +} + +SQLITE_PRIVATE void +sqlite3mcSetBtree(Codec* codec, Btree* bt) +{ + codec->m_bt = bt; + codec->m_btShared = bt->pBt; +} + +SQLITE_PRIVATE void +sqlite3mcSetReadReserved(Codec* codec, int reserved) +{ + codec->m_readReserved = reserved; +} + +SQLITE_PRIVATE void +sqlite3mcSetWriteReserved(Codec* codec, int reserved) +{ + codec->m_writeReserved = reserved; +} + +SQLITE_PRIVATE int +sqlite3mcIsEncrypted(Codec* codec) +{ + return codec->m_isEncrypted; +} + +SQLITE_PRIVATE int +sqlite3mcHasReadCipher(Codec* codec) +{ + return codec->m_hasReadCipher; +} + +SQLITE_PRIVATE int +sqlite3mcHasWriteCipher(Codec* codec) +{ + return codec->m_hasWriteCipher; +} + +SQLITE_PRIVATE Btree* +sqlite3mcGetBtree(Codec* codec) +{ + return codec->m_bt; +} + +SQLITE_PRIVATE BtShared* +sqlite3mcGetBtShared(Codec* codec) +{ + return codec->m_btShared; +} + +SQLITE_PRIVATE int +sqlite3mcGetPageSize(Codec* codec) +{ + return codec->m_btShared->pageSize; +} + +SQLITE_PRIVATE int +sqlite3mcGetReadReserved(Codec* codec) +{ + return codec->m_readReserved; +} + +SQLITE_PRIVATE int +sqlite3mcGetWriteReserved(Codec* codec) +{ + return codec->m_writeReserved; +} + +SQLITE_PRIVATE unsigned char* +sqlite3mcGetPageBuffer(Codec* codec) +{ + return &codec->m_page[4]; +} + +SQLITE_PRIVATE int +sqlite3mcGetLegacyReadCipher(Codec* codec) +{ + int legacy = (codec->m_hasReadCipher && codec->m_readCipher != NULL) ? codecDescriptorTable[codec->m_readCipherType - 1]->m_getLegacy(codec->m_readCipher) : 0; + return legacy; +} + +SQLITE_PRIVATE int +sqlite3mcGetLegacyWriteCipher(Codec* codec) +{ + int legacy = (codec->m_hasWriteCipher && codec->m_writeCipher != NULL) ? codecDescriptorTable[codec->m_writeCipherType - 1]->m_getLegacy(codec->m_writeCipher) : -1; + return legacy; +} + +SQLITE_PRIVATE int +sqlite3mcGetPageSizeReadCipher(Codec* codec) +{ + int pageSize = (codec->m_hasReadCipher && codec->m_readCipher != NULL) ? codecDescriptorTable[codec->m_readCipherType - 1]->m_getPageSize(codec->m_readCipher) : 0; + return pageSize; +} + +SQLITE_PRIVATE int +sqlite3mcGetPageSizeWriteCipher(Codec* codec) +{ + int pageSize = (codec->m_hasWriteCipher && codec->m_writeCipher != NULL) ? codecDescriptorTable[codec->m_writeCipherType - 1]->m_getPageSize(codec->m_writeCipher) : -1; + return pageSize; +} + +SQLITE_PRIVATE int +sqlite3mcGetReservedReadCipher(Codec* codec) +{ + int reserved = (codec->m_hasReadCipher && codec->m_readCipher != NULL) ? codecDescriptorTable[codec->m_readCipherType-1]->m_getReserved(codec->m_readCipher) : -1; + return reserved; +} + +SQLITE_PRIVATE int +sqlite3mcGetReservedWriteCipher(Codec* codec) +{ + int reserved = (codec->m_hasWriteCipher && codec->m_writeCipher != NULL) ? codecDescriptorTable[codec->m_writeCipherType-1]->m_getReserved(codec->m_writeCipher) : -1; + return reserved; +} + +SQLITE_PRIVATE int +sqlite3mcReservedEqual(Codec* codec) +{ + int readReserved = (codec->m_hasReadCipher && codec->m_readCipher != NULL) ? codecDescriptorTable[codec->m_readCipherType-1]->m_getReserved(codec->m_readCipher) : -1; + int writeReserved = (codec->m_hasWriteCipher && codec->m_writeCipher != NULL) ? codecDescriptorTable[codec->m_writeCipherType-1]->m_getReserved(codec->m_writeCipher) : -1; + return (readReserved == writeReserved); +} + +SQLITE_PRIVATE unsigned char* +sqlite3mcGetSaltWriteCipher(Codec* codec) +{ + unsigned char* salt = (codec->m_hasWriteCipher && codec->m_writeCipher != NULL) ? codecDescriptorTable[codec->m_writeCipherType - 1]->m_getSalt(codec->m_writeCipher) : NULL; + return salt; +} + +SQLITE_PRIVATE int +sqlite3mcCodecCopy(Codec* codec, Codec* other) +{ + int rc = SQLITE_OK; + codec->m_isEncrypted = other->m_isEncrypted; + codec->m_hmacCheck = other->m_hmacCheck; + codec->m_hasReadCipher = other->m_hasReadCipher; + codec->m_hasWriteCipher = other->m_hasWriteCipher; + codec->m_readCipherType = other->m_readCipherType; + codec->m_writeCipherType = other->m_writeCipherType; + codec->m_readCipher = NULL; + codec->m_writeCipher = NULL; + codec->m_readReserved = other->m_readReserved; + codec->m_writeReserved = other->m_writeReserved; + + if (codec->m_hasReadCipher) + { + codec->m_readCipher = codecDescriptorTable[codec->m_readCipherType - 1]->m_allocateCipher(codec->m_db); + if (codec->m_readCipher != NULL) + { + codecDescriptorTable[codec->m_readCipherType - 1]->m_cloneCipher(codec->m_readCipher, other->m_readCipher); + } + else + { + rc = SQLITE_NOMEM; + } + } + + if (codec->m_hasWriteCipher) + { + codec->m_writeCipher = codecDescriptorTable[codec->m_writeCipherType - 1]->m_allocateCipher(codec->m_db); + if (codec->m_writeCipher != NULL) + { + codecDescriptorTable[codec->m_writeCipherType - 1]->m_cloneCipher(codec->m_writeCipher, other->m_writeCipher); + } + else + { + rc = SQLITE_NOMEM; + } + } + codec->m_db = other->m_db; + codec->m_bt = other->m_bt; + codec->m_btShared = other->m_btShared; + return rc; +} + +SQLITE_PRIVATE int +sqlite3mcCodecCompare(Codec* codec1, Codec* codec2) +{ + int equal = 0; + if (codec1->m_hasReadCipher == codec2->m_hasReadCipher && + codec1->m_hasWriteCipher == codec2->m_hasWriteCipher) + { + int eqRead = (codec1->m_hasReadCipher) ? codec1->m_readCipherType == codec2->m_readCipherType : 1; + int eqWrite = (codec1->m_hasWriteCipher) ? codec1->m_writeCipherType == codec2->m_writeCipherType : 1; + if (eqRead && eqWrite) + { + eqRead = (codec1->m_hasReadCipher) ? codecDescriptorTable[codec1->m_readCipherType - 1]->m_compareCipher(codec1->m_readCipher, codec2->m_readCipher) : 1; + eqWrite = (codec1->m_hasWriteCipher) ? codecDescriptorTable[codec1->m_writeCipherType - 1]->m_compareCipher(codec1->m_writeCipher, codec2->m_writeCipher) : 1; + equal = eqRead && eqWrite; + } + } + return equal; +} + +SQLITE_PRIVATE int +sqlite3mcCopyCipher(Codec* codec, int read2write) +{ + int rc = SQLITE_OK; + if (read2write) + { + if (codec->m_writeCipher != NULL && codec->m_writeCipherType != codec->m_readCipherType) + { + codecDescriptorTable[codec->m_writeCipherType-1]->m_freeCipher(codec->m_writeCipher); + codec->m_writeCipher = NULL; + } + if (codec->m_writeCipher == NULL) + { + codec->m_writeCipherType = codec->m_readCipherType; + codec->m_writeCipher = codecDescriptorTable[codec->m_writeCipherType-1]->m_allocateCipher(codec->m_db); + } + if (codec->m_writeCipher != NULL) + { + codecDescriptorTable[codec->m_writeCipherType-1]->m_cloneCipher(codec->m_writeCipher, codec->m_readCipher); + } + else + { + rc = SQLITE_NOMEM; + } + } + else + { + if (codec->m_readCipher != NULL && codec->m_readCipherType != codec->m_writeCipherType) + { + codecDescriptorTable[codec->m_readCipherType-1]->m_freeCipher(codec->m_readCipher); + codec->m_readCipher = NULL; + } + if (codec->m_readCipher == NULL) + { + codec->m_readCipherType = codec->m_writeCipherType; + codec->m_readCipher = codecDescriptorTable[codec->m_readCipherType-1]->m_allocateCipher(codec->m_db); + } + if (codec->m_readCipher != NULL) + { + codecDescriptorTable[codec->m_readCipherType-1]->m_cloneCipher(codec->m_readCipher, codec->m_writeCipher); + } + else + { + rc = SQLITE_NOMEM; + } + } + return rc; +} + +SQLITE_PRIVATE void +sqlite3mcPadPassword(char* password, int pswdlen, unsigned char pswd[32]) +{ + int j; + int p = 0; + int m = pswdlen; + if (m > 32) m = 32; + + for (j = 0; j < m; j++) + { + pswd[p++] = (unsigned char) password[j]; + } + for (j = 0; p < 32 && j < 32; j++) + { + pswd[p++] = padding[j]; + } +} + +SQLITE_PRIVATE void +sqlite3mcGenerateReadKey(Codec* codec, char* userPassword, int passwordLength, unsigned char* cipherSalt) +{ + codecDescriptorTable[codec->m_readCipherType-1]->m_generateKey(codec->m_readCipher, codec->m_btShared, userPassword, passwordLength, 0, cipherSalt); +} + +SQLITE_PRIVATE void +sqlite3mcGenerateWriteKey(Codec* codec, char* userPassword, int passwordLength, unsigned char* cipherSalt) +{ + codecDescriptorTable[codec->m_writeCipherType-1]->m_generateKey(codec->m_writeCipher, codec->m_btShared, userPassword, passwordLength, 1, cipherSalt); +} + +SQLITE_PRIVATE int +sqlite3mcEncrypt(Codec* codec, int page, unsigned char* data, int len, int useWriteKey) +{ + int cipherType = (useWriteKey) ? codec->m_writeCipherType : codec->m_readCipherType; + void* cipher = (useWriteKey) ? codec->m_writeCipher : codec->m_readCipher; + int reserved = (useWriteKey) ? (codec->m_writeReserved >= 0) ? codec->m_writeReserved : codec->m_reserved + : (codec->m_readReserved >= 0) ? codec->m_readReserved : codec->m_reserved; + return codecDescriptorTable[cipherType-1]->m_encryptPage(cipher, page, data, len, reserved); +} + +SQLITE_PRIVATE int +sqlite3mcDecrypt(Codec* codec, int page, unsigned char* data, int len) +{ + int cipherType = codec->m_readCipherType; + void* cipher = codec->m_readCipher; + int reserved = (codec->m_readReserved >= 0) ? codec->m_readReserved : codec->m_reserved; + return codecDescriptorTable[cipherType-1]->m_decryptPage(cipher, page, data, len, reserved, codec->m_hmacCheck); +} + +SQLITE_PRIVATE void +sqlite3mcConfigureSQLCipherVersion(sqlite3* db, int configDefault, int legacyVersion) +{ + static char* stdNames[] = { "legacy_page_size", "kdf_iter", "hmac_use", "kdf_algorithm", "hmac_algorithm", NULL }; + static char* defNames[] = { "default:legacy_page_size", "default:kdf_iter", "default:hmac_use", "default:kdf_algorithm", "default:hmac_algorithm", NULL }; + static int versionParams[SQLCIPHER_VERSION_MAX][5] = + { + { 1024, 4000, 0, SQLCIPHER_KDF_ALGORITHM_SHA1, SQLCIPHER_HMAC_ALGORITHM_SHA1 }, + { 1024, 4000, 1, SQLCIPHER_KDF_ALGORITHM_SHA1, SQLCIPHER_HMAC_ALGORITHM_SHA1 }, + { 1024, 64000, 1, SQLCIPHER_KDF_ALGORITHM_SHA1, SQLCIPHER_HMAC_ALGORITHM_SHA1 }, + { 4096, 256000, 1, SQLCIPHER_KDF_ALGORITHM_SHA512, SQLCIPHER_HMAC_ALGORITHM_SHA512 } + }; + if (legacyVersion > 0 && legacyVersion <= SQLCIPHER_VERSION_MAX) + { + char** names = (configDefault != 0) ? defNames : stdNames; + int* values = &versionParams[legacyVersion - 1][0]; + int j; + for (j = 0; names[j] != NULL; ++j) + { + sqlite3mc_config_cipher(db, "sqlcipher", names[j], values[j]); + } + } +} diff --git a/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.h b/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.h new file mode 100644 index 0000000..75f1e5b --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/ciphers/cipher_common.h @@ -0,0 +1,233 @@ +/* +** Name: cipher_common.h +** Purpose: Header for the ciphers of SQLite3 Multiple Ciphers +** Author: Ulrich Telle +** Created: 2020-02-02 +** Copyright: (c) 2006-2020 Ulrich Telle +** License: MIT +*/ + +#ifndef CIPHER_COMMON_H_ +#define CIPHER_COMMON_H_ + +#include "sqlite3mc.h" + +/* +// ATTENTION: Macro similar to that in pager.c +// TODO: Check in case of new version of SQLite +*/ +#define WX_PAGER_MJ_PGNO(x) ((PENDING_BYTE/(x))+1) + +#define CODEC_TYPE_DEFAULT CODEC_TYPE_CHACHA20 + +#ifndef CODEC_TYPE +#define CODEC_TYPE CODEC_TYPE_DEFAULT +#endif + +#if CODEC_TYPE < 1 || CODEC_TYPE > CODEC_TYPE_MAX +#error "Invalid codec type selected" +#endif + +#define MAXKEYLENGTH 32 +#define KEYLENGTH_AES128 16 +#define KEYLENGTH_AES256 32 +#define KEYSALT_LENGTH 16 + +#define CODEC_SHA_ITER 4001 + +typedef struct _Codec +{ + int m_isEncrypted; + int m_hmacCheck; + /* Read cipher */ + int m_hasReadCipher; + int m_readCipherType; + void* m_readCipher; + int m_readReserved; + /* Write cipher */ + int m_hasWriteCipher; + int m_writeCipherType; + void* m_writeCipher; + int m_writeReserved; + + sqlite3* m_db; /* Pointer to DB */ + Btree* m_bt; /* Pointer to B-tree used by DB */ + BtShared* m_btShared; /* Pointer to shared B-tree used by DB */ + unsigned char m_page[SQLITE_MAX_PAGE_SIZE + 24]; + int m_pageSize; + int m_reserved; + int m_hasKeySalt; + unsigned char m_keySalt[KEYSALT_LENGTH]; +} Codec; + +#define CIPHER_PARAMS_SENTINEL { "", 0, 0, 0, 0 } +#define CIPHER_PAGE1_OFFSET 24 + +typedef struct _CipherParams +{ + char* m_name; + int m_value; + int m_default; + int m_minValue; + int m_maxValue; +} CipherParams; + +typedef struct _CodecParameter +{ + char* m_name; + int m_id; + CipherParams* m_params; +} CodecParameter; + +typedef void* (*AllocateCipher_t)(sqlite3* db); +typedef void (*FreeCipher_t)(void* cipher); +typedef void (*CloneCipher_t)(void* cipherTo, void* cipherFrom); +typedef int (*CompareCipher_t)(void* cipher1, void* cipher2); +typedef int (*GetLegacy_t)(void* cipher); +typedef int (*GetPageSize_t)(void* cipher); +typedef int (*GetReserved_t)(void* cipher); +typedef unsigned char* (*GetSalt_t)(void* cipher); +typedef void (*GenerateKey_t)(void* cipher, BtShared* pBt, char* userPassword, int passwordLength, int rekey, unsigned char* cipherSalt); +typedef int (*EncryptPage_t)(void* cipher, int page, unsigned char* data, int len, int reserved); +typedef int (*DecryptPage_t)(void* cipher, int page, unsigned char* data, int len, int reserved, int hmacCheck); + +typedef struct _CodecDescriptor +{ + char m_name[32]; + AllocateCipher_t m_allocateCipher; + FreeCipher_t m_freeCipher; + CloneCipher_t m_cloneCipher; + CompareCipher_t m_compareCipher; + GetLegacy_t m_getLegacy; + GetPageSize_t m_getPageSize; + GetReserved_t m_getReserved; + GetSalt_t m_getSalt; + GenerateKey_t m_generateKey; + EncryptPage_t m_encryptPage; + DecryptPage_t m_decryptPage; +} CipherDescriptor; + +SQLITE_PRIVATE int sqlite3mcGetCipherParameter(CipherParams* cipherParams, const char* paramName); +SQLITE_PRIVATE int sqlite3mcGetCipherType(sqlite3* db); +SQLITE_PRIVATE CipherParams* sqlite3mcGetCipherParams(sqlite3* db, int cypherType); +SQLITE_PRIVATE int sqlite3mcCodecInit(Codec* codec); +SQLITE_PRIVATE void sqlite3mcCodecTerm(Codec* codec); +SQLITE_PRIVATE void sqlite3mcClearKeySalt(Codec* codec); +SQLITE_PRIVATE int sqlite3mcCodecSetup(Codec* codec, int cipherType, char* userPassword, int passwordLength); +SQLITE_PRIVATE int sqlite3mcSetupWriteCipher(Codec* codec, int cipherType, char* userPassword, int passwordLength); +SQLITE_PRIVATE void sqlite3mcSetIsEncrypted(Codec* codec, int isEncrypted); +SQLITE_PRIVATE void sqlite3mcSetReadCipherType(Codec* codec, int cipherType); +SQLITE_PRIVATE void sqlite3mcSetWriteCipherType(Codec* codec, int cipherType); +SQLITE_PRIVATE void sqlite3mcSetHasReadCipher(Codec* codec, int hasReadCipher); +SQLITE_PRIVATE void sqlite3mcSetHasWriteCipher(Codec* codec, int hasWriteCipher); +SQLITE_PRIVATE void sqlite3mcSetDb(Codec* codec, sqlite3* db); +SQLITE_PRIVATE void sqlite3mcSetBtree(Codec* codec, Btree* bt); +SQLITE_PRIVATE void sqlite3mcSetReadReserved(Codec* codec, int reserved); +SQLITE_PRIVATE void sqlite3mcSetWriteReserved(Codec* codec, int reserved); +SQLITE_PRIVATE int sqlite3mcIsEncrypted(Codec* codec); +SQLITE_PRIVATE int sqlite3mcHasReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcHasWriteCipher(Codec* codec); +SQLITE_PRIVATE Btree* sqlite3mcGetBtree(Codec* codec); +SQLITE_PRIVATE BtShared* sqlite3mcGetBtShared(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSize(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReadReserved(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetWriteReserved(Codec* codec); +SQLITE_PRIVATE unsigned char* sqlite3mcGetPageBuffer(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetLegacyReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetLegacyWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSizeReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSizeWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReservedReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReservedWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcReservedEqual(Codec* codec); +SQLITE_PRIVATE unsigned char* sqlite3mcGetSaltWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcCodecCopy(Codec* codec, Codec* other); +SQLITE_PRIVATE int sqlite3mcCodecCompare(Codec* codec1, Codec* codec2); + +SQLITE_PRIVATE void sqlite3mcGenerateReadKey(Codec* codec, char* userPassword, int passwordLength, unsigned char* cipherSalt); + +SQLITE_PRIVATE void sqlite3mcGenerateWriteKey(Codec* codec, char* userPassword, int passwordLength, unsigned char* cipherSalt); + +SQLITE_PRIVATE int sqlite3mcEncrypt(Codec* codec, int page, unsigned char* data, int len, int useWriteKey); + +SQLITE_PRIVATE int sqlite3mcDecrypt(Codec* codec, int page, unsigned char* data, int len); + +SQLITE_PRIVATE int sqlite3mcCopyCipher(Codec* codec, int read2write); + +SQLITE_PRIVATE int sqlite3mcCodecSetup(Codec* codec, int cipherType, char* userPassword, int passwordLength); +SQLITE_PRIVATE int sqlite3mcSetupWriteCipher(Codec* codec, int cipherType, char* userPassword, int passwordLength); + +SQLITE_PRIVATE void sqlite3mcSetIsEncrypted(Codec* codec, int isEncrypted); +SQLITE_PRIVATE void sqlite3mcSetReadCipherType(Codec* codec, int cipherType); +SQLITE_PRIVATE void sqlite3mcSetWriteCipherType(Codec* codec, int cipherType); +SQLITE_PRIVATE void sqlite3mcSetHasReadCipher(Codec* codec, int hasReadCipher); +SQLITE_PRIVATE void sqlite3mcSetHasWriteCipher(Codec* codec, int hasWriteCipher); +SQLITE_PRIVATE void sqlite3mcSetDb(Codec* codec, sqlite3* db); +SQLITE_PRIVATE void sqlite3mcSetBtree(Codec* codec, Btree* bt); +SQLITE_PRIVATE void sqlite3mcSetReadReserved(Codec* codec, int reserved); +SQLITE_PRIVATE void sqlite3mcSetWriteReserved(Codec* codec, int reserved); + +SQLITE_PRIVATE int sqlite3mcIsEncrypted(Codec* codec); +SQLITE_PRIVATE int sqlite3mcHasReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcHasWriteCipher(Codec* codec); +SQLITE_PRIVATE Btree* sqlite3mcGetBtree(Codec* codec); +SQLITE_PRIVATE BtShared* sqlite3mcGetBtShared(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSize(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReadReserved(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetWriteReserved(Codec* codec); +SQLITE_PRIVATE unsigned char* sqlite3mcGetPageBuffer(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetLegacyReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetLegacyWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSizeReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetPageSizeWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReservedReadCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcGetReservedWriteCipher(Codec* codec); +SQLITE_PRIVATE int sqlite3mcReservedEqual(Codec* codec); + +SQLITE_PRIVATE void sqlite3mcPadPassword(char* password, int pswdlen, unsigned char pswd[32]); +SQLITE_PRIVATE void sqlite3mcRC4(unsigned char* key, int keylen, unsigned char* textin, int textlen, unsigned char* textout); +SQLITE_PRIVATE void sqlite3mcGetMD5Binary(unsigned char* data, int length, unsigned char* digest); +SQLITE_PRIVATE void sqlite3mcGetSHABinary(unsigned char* data, int length, unsigned char* digest); +SQLITE_PRIVATE void sqlite3mcGenerateInitialVector(int seed, unsigned char iv[16]); + +SQLITE_PRIVATE int sqlite3mcIsHexKey(const unsigned char* hex, int len); +SQLITE_PRIVATE int sqlite3mcConvertHex2Int(char c); +SQLITE_PRIVATE void sqlite3mcConvertHex2Bin(const unsigned char* hex, int len, unsigned char* bin); + +SQLITE_PRIVATE int sqlite3mcConfigureFromUri(sqlite3* db, const char *zDbName, int configDefault); +SQLITE_PRIVATE void sqlite3mcConfigureSQLCipherVersion(sqlite3* db, int configDefault, int legacyVersion); + +SQLITE_PRIVATE int sqlite3mcCodecAttach(sqlite3* db, int nDb, const char* zPath, const void* zKey, int nKey); +SQLITE_PRIVATE void sqlite3mcCodecGetKey(sqlite3* db, int nDb, void** zKey, int* nKey); + +/* Debugging */ + +#if 0 +#define SQLITE3MC_DEBUG +#define SQLITE3MC_DEBUG_DATA +#endif + +#ifdef SQLITE3MC_DEBUG +#define SQLITE3MC_DEBUG_LOG(...) { fprintf(stdout, __VA_ARGS__); fflush(stdout); } +#else +#define SQLITE3MC_DEBUG_LOG(...) +#endif + +#ifdef SQLITE3MC_DEBUG_DATA +#define SQLITE3MC_DEBUG_HEX(DESC,BUFFER,LEN) \ + { \ + int count; \ + printf(DESC); \ + for (count = 0; count < LEN; ++count) \ + { \ + if (count % 16 == 0) printf("\n%05x: ", count); \ + printf("%02x ", ((unsigned char*) BUFFER)[count]); \ + } \ + printf("\n"); \ + fflush(stdout); \ + } +#else +#define SQLITE3MC_DEBUG_HEX(DESC,BUFFER,LEN) +#endif + +#endif diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win32.bat b/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win32.bat index 2719928..00031dd 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win32.bat +++ b/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win32.bat @@ -1,7 +1,10 @@ @echo off +set DST2=..\..\..\lib2\static\delphi\sqlite3.obj + attrib -r ..\sqlite3.obj del ..\sqlite3.obj +del %DST2% set bcc=d:\dev\DelphiXE7 rem set bcc=d:\dev\bcc @@ -10,9 +13,9 @@ echo --------------------------------------------------- echo Compiling for Delphi Win32 using %bcc% %bcc%\bin\bcc32 -6 -Oi -O2 -c -d -u- sqlite3mc.c -copy sqlite3mc.obj ..\sqlite3.obj -del sqlite3mc.obj +copy sqlite3mc.obj ..\sqlite3.obj +copy sqlite3mc.obj %DST2% attrib +r ..\sqlite3.obj rem pause diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win64.bat b/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win64.bat index d99980b..190a41c 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win64.bat +++ b/contrib/mORMot/SQLite3/amalgamation/compile-delphi-win64.bat @@ -1,17 +1,21 @@ @echo off +set DST2=..\..\..\lib2\static\delphi\sqlite3.o + attrib -r ..\sqlite3.o del ..\sqlite3.o +del %DST2% set bcc=d:\dev\DelphiXE7 -rem set bcc=d:\Dev\bcc64ce +rem set bcc=d:\Dev\bcc\bcc64ce echo --------------------------------------------------- echo Compiling for Delphi Win64 using %bcc% -%bcc%\bin\bcc64 -isystem "%bcc%\include" -isystem "%bcc%\include\windows\sdk" -isystem "%bcc%\include\dinkumware64" -isystem "%bcc%\include\windows\crtl" -O2 -c -DWIN64 sqlite3mc.c +%bcc%\bin\bcc64 -Wno-pointer-sign -isystem "%bcc%\include" -isystem "%bcc%\include\windows\sdk" -isystem "%bcc%\include\dinkumware64" -isystem "%bcc%\include\windows\crtl" -O2 -c -DWIN64 sqlite3mc.c + copy sqlite3mc.o ..\sqlite3.o -del sqlite3mc.o +copy sqlite3mc.o %DST2% attrib +r ..\sqlite3.o rem pause diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-android.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-android.sh new file mode 100644 index 0000000..d6e3b6d --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-android.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +ARCH=aarch64-android + +CROSS=/home/ab/fpcup/cross/bin/all-android/bin +GCC=$CROSS/clang +DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o + +rm $DST +rm $DST2 +rm sqlite3-$ARCH.o + +echo +echo --------------------------------------------------- +echo Compiling for FPC on $ARCH using $GCC +$GCC --target=aarch64-linux-android21 -static -fPIC -Wno-pointer-sign -O2 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$ARCH.o +# -fPIC is needed for proper linking + +#$CROSS/llvm-strip sqlite3-$ARCH.o +# striping remove all exported symbols :( + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 + diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-linux.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-linux.sh index ffe3383..eb1c5f3 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-linux.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-aarch64-linux.sh @@ -5,13 +5,19 @@ ARCH=aarch64-linux CROSS=/home/ab/fpcup/cross/bin/$ARCH GCC=$CROSS/$ARCH-gcc DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $ARCH using $GCC $GCC -static -O1 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$ARCH.o -cp sqlite3-$ARCH.o $DST + +$CROSS/$ARCH-strip -d -x sqlite3-$ARCH.o + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-android.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-android.sh new file mode 100644 index 0000000..0553e61 --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-android.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +ARCH=arm-android + +CROSS=/home/ab/fpcup/cross/bin/all-android +GCC=$CROSS/bin/clang +DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o + +rm $DST +rm $DST2 +rm sqlite3-$ARCH.o + +echo +echo --------------------------------------------------- +echo Compiling for FPC on $ARCH using $GCC +$GCC --target=armv7a-linux-androideabi21 -static -O2 -Wno-pointer-sign -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -D__ARM_PCS_VFP -c sqlite3mc.c -o sqlite3-$ARCH.o + +#$CROSS/bin/llvm-strip sqlite3-$ARCH.o +# striping remove all exported symbols :( + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 + diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-linux.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-linux.sh index 660364d..34e268a 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-linux.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-arm-linux.sh @@ -5,13 +5,19 @@ ARCH=arm-linux CROSS=/home/ab/fpcup/cross/bin/$ARCH GCC=$CROSS/arm-linux-gnueabihf-gcc DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $ARCH using $GCC $GCC -static -O1 -marm -march=armv7-a+fp -I$CROSS/include -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -D__ARM_PCS_VFP -mfloat-abi=hard -c sqlite3mc.c -o sqlite3-$ARCH.o -cp sqlite3-$ARCH.o $DST + +$CROSS/arm-linux-gnueabihf-strip -d -x sqlite3-$ARCH.o + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-android.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-android.sh new file mode 100644 index 0000000..b7b616e --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-android.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +ARCH=i386-android + +CROSS=/home/ab/fpcup/cross/bin/all-android +GCC=$CROSS/bin/clang +DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o + +rm $DST +rm $DST2 +rm sqlite3-$ARCH.o + +echo +echo --------------------------------------------------- +echo Compiling for FPC on $ARCH using $GCC +$GCC --target=i686-linux-androideabi21 -static -Wno-pointer-sign -O2 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -D__ARM_PCS_VFP -c sqlite3mc.c -o sqlite3-$ARCH.o + +#$CROSS/bin/llvm-strip sqlite3-$ARCH.o +# strip blows all external symbols + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 + diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-darwin.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-darwin.sh index 2347f73..e25138d 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-darwin.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-darwin.sh @@ -2,18 +2,24 @@ ARCH=i386-darwin DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o -CROSS=/home/ab/fpcup/cross +#CROSS=/home/ab/fpcup/cross +# use older but working fpcupdeluxe cross compiler +CROSS=/home/abouchez/fpcupdeluxe/__darwin SDK=$CROSS/lib/x86-darwin/MacOSX10.11.sdk\usr GCC=$CROSS/bin/x86-darwin/i386-apple-darwin15 rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $ARCH using $GCC -$GCC-clang -static -target i386-apple-darwin15 -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -I$SDK/include -c sqlite3mc.c -o sqlite3-$ARCH.o +$GCC-clang -static -target i386-apple-darwin15 -Wno-pointer-sign -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -I$SDK/include -c sqlite3mc.c -o sqlite3-$ARCH.o cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 $GCC-libtool -static sqlite3-$ARCH.o -o ../../static/$ARCH/libsqlite3.a +$GCC-libtool -static sqlite3-$ARCH.o -o ../../../lib2/static/$ARCH/libsqlite3.a diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-freebsd.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-freebsd.sh index 8241870..0ccb9cf 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-freebsd.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-freebsd.sh @@ -5,13 +5,19 @@ FPCARCHVERSION=12 CROSS=/home/ab/fpcup/cross/bin/$FPCARCH GCC=$CROSS/$FPCARCH$FPCARCHVERSION-gcc DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST + +$CROSS/$FPCARCH$FPCARCHVERSION-strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.bat b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.bat index 98c1141..ec36e97 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.bat +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.bat @@ -6,15 +6,19 @@ set GCCPATH=d:\fpcup\__win\bin\%FPCARCH% set GCC=%FPCARCH%-gcc set DST=..\..\static\%FPCARCH%\sqlite3.o +set DST2=..\..\..\lib2\static\%FPCARCH%\sqlite3.o set path=%path%;%GCCPATH% del %DST% +del %DST2% del sqlite3-%FPCARCH%.o echo. echo --------------------------------------------------- echo Compiling for FPC on %FPCARCH% using %GCC% %GCC% -static -w -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-%FPCARCH%.o + copy sqlite3-%FPCARCH%.o %DST% +copy sqlite3-%FPCARCH%.o %DST2% rem pause \ No newline at end of file diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.sh index 998241f..4014e99 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-linux.sh @@ -3,13 +3,19 @@ FPCARCH=i386-linux GCC=gcc-7 DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST + +strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-openbsd.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-openbsd.sh index 3a44d9a..921cde1 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-openbsd.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-openbsd.sh @@ -5,13 +5,19 @@ FPCARCHVERSION= CROSS=/home/ab/fpcup/cross/bin/$FPCARCH GCC=$CROSS/$FPCARCH$FPCARCHVERSION-gcc DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -O2 -m32 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST + +$CROSS/$FPCARCH$FPCARCHVERSION-strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-win32.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-win32.sh index 0923dd9..ff9f48c 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-win32.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-i386-win32.sh @@ -3,13 +3,18 @@ ARCH=i386-win32 GCC=i686-w64-mingw32-gcc DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $ARCH using $GCC $GCC -O2 -m32 -DWIN32 -DNDEBUG -D_WINDOWS -c sqlite3mc.c -o sqlite3-$ARCH.o -cp sqlite3-$ARCH.o $DST +i686-w64-mingw32-strip -d -x sqlite3-$ARCH.o + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-android.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-android.sh new file mode 100644 index 0000000..0af678e --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-android.sh @@ -0,0 +1,24 @@ +#!/bin/sh + +ARCH=x86_64-android + +CROSS=/home/ab/fpcup/cross/bin/all-android/bin +GCC=$CROSS/clang +DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o + +rm $DST +rm $DST2 +rm sqlite3-$ARCH.o + +echo +echo --------------------------------------------------- +echo Compiling for FPC on $ARCH using $GCC +$GCC --target=x86_64-linux-android21 -static -O2 -Wno-pointer-sign -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$ARCH.o + +#$CROSS/llvm-strip sqlite3-$ARCH.o +# striping remove all exported symbols :( + +cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 + diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-darwin.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-darwin.sh index 6d94959..8ef63e0 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-darwin.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-darwin.sh @@ -2,18 +2,24 @@ ARCH=x86_64-darwin DST=../../static/$ARCH/sqlite3.o +DST2=../../../lib2/static/$ARCH/sqlite3.o -CROSS=/home/ab/fpcup/cross +#CROSS=/home/ab/fpcup/cross +# use older but working fpcupdeluxe cross compiler +CROSS=/home/abouchez/fpcupdeluxe/__darwin SDK=$CROSS/lib/x86-darwin/MacOSX10.11.sdk\usr GCC=$CROSS/bin/x86-darwin/x86_64-apple-darwin15 rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $ARCH using $GCC -$GCC-clang -static -target x86_64-apple-darwin15 -O2 -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -I$SDK/include -c sqlite3mc.c -o sqlite3-$ARCH.o +$GCC-clang -static -target x86_64-apple-darwin15 -O2 -m64 -Wno-pointer-sign -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -I$SDK/include -c sqlite3mc.c -o sqlite3-$ARCH.o cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 $GCC-libtool -static sqlite3-$ARCH.o -o ../../static/$ARCH/libsqlite3.a +$GCC-libtool -static sqlite3-$ARCH.o -o ../../../lib2/static/$ARCH/libsqlite3.a diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-freebsd.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-freebsd.sh index 490d2fc..4ed01a7 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-freebsd.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-freebsd.sh @@ -5,13 +5,19 @@ FPCARCHVERSION=12 CROSS=/home/ab/fpcup/cross/bin/$FPCARCH GCC=$CROSS/$FPCARCH$FPCARCHVERSION-gcc DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -O2 -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST + +$CROSS/$FPCARCH$FPCARCHVERSION-strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.bat b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.bat index ac13b61..75f8495 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.bat +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.bat @@ -6,15 +6,21 @@ set GCCPATH=d:\fpcup\__win\bin\%FPCARCH% set GCC=%FPCARCH%-gcc set DST=..\..\static\%FPCARCH%\sqlite3.o +set DST2=..\..\..\lib2\static\%FPCARCH%\sqlite3.o set path=%path%;%GCCPATH% del %DST% +del %DST2% del sqlite3-%FPCARCH%.o echo. echo --------------------------------------------------- echo Compiling for FPC on %FPCARCH% using %GCC% -%GCC% -static -w -O2 -fno-pic -fno-stack-protector -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-%FPCARCH%.o +%GCC% -static -w -O2 -fno-pic -fno-stack-protector -fomit-frame-pointer -fno-exceptions -fno-asynchronous-unwind-tables -fno-unwind-tables -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-%FPCARCH%.o + +%FPCARCH%-strip -x sqlite3-%FPCARCH%.o + copy sqlite3-%FPCARCH%.o %DST% +copy sqlite3-%FPCARCH%.o %DST2% rem pause \ No newline at end of file diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.sh index 4fcbbe6..c0e954d 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-linux.sh @@ -3,13 +3,18 @@ FPCARCH=x86_64-linux GCC=gcc-7 DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -fno-pic -fno-stack-protector -O2 -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST +strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-openbsd.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-openbsd.sh index b36b56d..f271a65 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-openbsd.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-openbsd.sh @@ -5,13 +5,19 @@ FPCARCHVERSION= CROSS=/home/ab/fpcup/cross/bin/$FPCARCH GCC=$CROSS/$FPCARCH$FPCARCHVERSION-gcc DST=../../static/$FPCARCH/sqlite3.o +DST2=../../../lib2/static/$FPCARCH/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$FPCARCH.o echo echo --------------------------------------------------- echo Compiling for FPC on $FPCARCH using $GCC $GCC -static -O2 -m64 -DNDEBUG -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -c sqlite3mc.c -o sqlite3-$FPCARCH.o -cp sqlite3-$FPCARCH.o $DST + +$CROSS/$FPCARCH$FPCARCHVERSION-strip -d -x sqlite3-$FPCARCH.o + +cp sqlite3-$FPCARCH.o $DST +cp sqlite3-$FPCARCH.o $DST2 diff --git a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-win64.sh b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-win64.sh index 65325da..1f5d6af 100644 --- a/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-win64.sh +++ b/contrib/mORMot/SQLite3/amalgamation/compile-fpc-x86_64-win64.sh @@ -3,25 +3,40 @@ ARCH=x86_64-win64 GCC=x86_64-w64-mingw32-gcc STATIC=../../static/$ARCH +LIB2=../../../lib2/static +STATIC2=$LIB2/$ARCH +STATIC2DELPHI=$LIB2/delphi DST=$STATIC/sqlite3.o +DST2=$STATIC2/sqlite3.o rm $DST +rm $DST2 rm sqlite3-$ARCH.o echo echo --------------------------------------------------- echo Compiling static for FPC on $ARCH using $GCC $GCC -O2 -static -DWIN64 -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -m64 -DNDEBUG -D_WINDOWS -c sqlite3mc.c -o sqlite3-$ARCH.o + +x86_64-w64-mingw32-strip -d -x sqlite3-$ARCH.o + cp sqlite3-$ARCH.o $DST +cp sqlite3-$ARCH.o $DST2 DLL=sqlite3-64.dll rm $DLL rm $STATIC/$DLL +rm $STATIC2DELPHI/$DLL +A=libsqlite3-64.a +rm $STATIC/$A +rm $STATIC2/$A echo echo --------------------------------------------------- echo Compiling $DLL using $GCC -$GCC -O2 -shared -DSQLITE_MMAP_READWRITE -DSQLITE_ENABLE_RTREE=1 -DSQLITE_ENABLE_FTS3 -DSQLITE_ENABLE_FTS4 -DDSQLITE_ENABLE_FTS5 -DSQLITE_ENABLE_FTS3_PARENTHESIS -DSQLITE_ENABLE_JSON1 -DSQLITE_ENABLE_DESERIALIZE -DWIN64 -DNDEBUG -D_WINDOWS -D_USRDLL -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -DSQLITE_MAX_EXPR_DEPTH=0 -DSQLITE_THREADSAFE=1 -DTEMP_STORE=1 -m64 sqlite3.c -o $DLL -Wl,--out-implib,libsqlite3-64.a +$GCC -O2 -shared -DSQLITE_MMAP_READWRITE -DSQLITE_ENABLE_RTREE=1 -DSQLITE_ENABLE_FTS3 -DSQLITE_ENABLE_FTS4 -DSQLITE_ENABLE_FTS5 -DSQLITE_ENABLE_FTS3_PARENTHESIS -DSQLITE_ENABLE_RBU -DSQLITE_ENABLE_JSON1 -DSQLITE_ENABLE_DESERIALIZE -DWIN64 -DNDEBUG -D_WINDOWS -D_USRDLL -DNO_TCL -D_CRT_SECURE_NO_DEPRECATE -DSQLITE_MAX_EXPR_DEPTH=0 -DSQLITE_THREADSAFE=1 -DTEMP_STORE=1 -m64 sqlite3.c -o $DLL -Wl,--out-implib,libsqlite3-64.a cp $DLL $STATIC -cp libsqlite3-64.a $STATIC +cp $DLL $STATIC2DELPHI +cp $A $STATIC +cp $A $STATIC2 diff --git a/contrib/mORMot/SQLite3/amalgamation/patch-and-compile.sh b/contrib/mORMot/SQLite3/amalgamation/patch-and-compile.sh index ab1f063..8690996 100644 --- a/contrib/mORMot/SQLite3/amalgamation/patch-and-compile.sh +++ b/contrib/mORMot/SQLite3/amalgamation/patch-and-compile.sh @@ -49,3 +49,11 @@ echo Use Native fpcupdeluxe cross-compilers for FPC OpenBSD i386/x64 ./compile-fpc-i386-openbsd.sh ./compile-fpc-x86_64-openbsd.sh + +echo +echo Use Native fpcupdeluxe cross-compilers for FPC Android arm/aarch64/i386/x64-android + +./compile-fpc-arm-android.sh +./compile-fpc-aarch64-android.sh +./compile-fpc-i386-android.sh +./compile-fpc-x86_64-android.sh diff --git a/contrib/mORMot/SQLite3/amalgamation/regexp.c b/contrib/mORMot/SQLite3/amalgamation/regexp.c new file mode 100644 index 0000000..03bbeb9 --- /dev/null +++ b/contrib/mORMot/SQLite3/amalgamation/regexp.c @@ -0,0 +1,760 @@ +/* +** 2012-11-13 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +****************************************************************************** +** +** The code in this file implements a compact but reasonably +** efficient regular-expression matcher for posix extended regular +** expressions against UTF8 text. +** +** This file is an SQLite extension. It registers a single function +** named "regexp(A,B)" where A is the regular expression and B is the +** string to be matched. By registering this function, SQLite will also +** then implement the "B regexp A" operator. Note that with the function +** the regular expression comes first, but with the operator it comes +** second. +** +** The following regular expression syntax is supported: +** +** X* zero or more occurrences of X +** X+ one or more occurrences of X +** X? zero or one occurrences of X +** X{p,q} between p and q occurrences of X +** (X) match X +** X|Y X or Y +** ^X X occurring at the beginning of the string +** X$ X occurring at the end of the string +** . Match any single character +** \c Character c where c is one of \{}()[]|*+?. +** \c C-language escapes for c in afnrtv. ex: \t or \n +** \uXXXX Where XXXX is exactly 4 hex digits, unicode value XXXX +** \xXX Where XX is exactly 2 hex digits, unicode value XX +** [abc] Any single character from the set abc +** [^abc] Any single character not in the set abc +** [a-z] Any single character in the range a-z +** [^a-z] Any single character not in the range a-z +** \b Word boundary +** \w Word character. [A-Za-z0-9_] +** \W Non-word character +** \d Digit +** \D Non-digit +** \s Whitespace character +** \S Non-whitespace character +** +** A nondeterministic finite automaton (NFA) is used for matching, so the +** performance is bounded by O(N*M) where N is the size of the regular +** expression and M is the size of the input string. The matcher never +** exhibits exponential behavior. Note that the X{p,q} operator expands +** to p copies of X following by q-p copies of X? and that the size of the +** regular expression in the O(N*M) performance bound is computed after +** this expansion. +*/ +#include +#include +#include "sqlite3ext.h" +SQLITE_EXTENSION_INIT1 + +/* +** The following #defines change the names of some functions implemented in +** this file to prevent name collisions with C-library functions of the +** same name. +*/ +#define re_match sqlite3re_match +#define re_compile sqlite3re_compile +#define re_free sqlite3re_free + +/* The end-of-input character */ +#define RE_EOF 0 /* End of input */ + +/* The NFA is implemented as sequence of opcodes taken from the following +** set. Each opcode has a single integer argument. +*/ +#define RE_OP_MATCH 1 /* Match the one character in the argument */ +#define RE_OP_ANY 2 /* Match any one character. (Implements ".") */ +#define RE_OP_ANYSTAR 3 /* Special optimized version of .* */ +#define RE_OP_FORK 4 /* Continue to both next and opcode at iArg */ +#define RE_OP_GOTO 5 /* Jump to opcode at iArg */ +#define RE_OP_ACCEPT 6 /* Halt and indicate a successful match */ +#define RE_OP_CC_INC 7 /* Beginning of a [...] character class */ +#define RE_OP_CC_EXC 8 /* Beginning of a [^...] character class */ +#define RE_OP_CC_VALUE 9 /* Single value in a character class */ +#define RE_OP_CC_RANGE 10 /* Range of values in a character class */ +#define RE_OP_WORD 11 /* Perl word character [A-Za-z0-9_] */ +#define RE_OP_NOTWORD 12 /* Not a perl word character */ +#define RE_OP_DIGIT 13 /* digit: [0-9] */ +#define RE_OP_NOTDIGIT 14 /* Not a digit */ +#define RE_OP_SPACE 15 /* space: [ \t\n\r\v\f] */ +#define RE_OP_NOTSPACE 16 /* Not a digit */ +#define RE_OP_BOUNDARY 17 /* Boundary between word and non-word */ + +/* Each opcode is a "state" in the NFA */ +typedef unsigned short ReStateNumber; + +/* Because this is an NFA and not a DFA, multiple states can be active at +** once. An instance of the following object records all active states in +** the NFA. The implementation is optimized for the common case where the +** number of actives states is small. +*/ +typedef struct ReStateSet { + unsigned nState; /* Number of current states */ + ReStateNumber *aState; /* Current states */ +} ReStateSet; + +/* An input string read one character at a time. +*/ +typedef struct ReInput ReInput; +struct ReInput { + const unsigned char *z; /* All text */ + int i; /* Next byte to read */ + int mx; /* EOF when i>=mx */ +}; + +/* A compiled NFA (or an NFA that is in the process of being compiled) is +** an instance of the following object. +*/ +typedef struct ReCompiled ReCompiled; +struct ReCompiled { + ReInput sIn; /* Regular expression text */ + const char *zErr; /* Error message to return */ + char *aOp; /* Operators for the virtual machine */ + int *aArg; /* Arguments to each operator */ + unsigned (*xNextChar)(ReInput*); /* Next character function */ + unsigned char zInit[12]; /* Initial text to match */ + int nInit; /* Number of characters in zInit */ + unsigned nState; /* Number of entries in aOp[] and aArg[] */ + unsigned nAlloc; /* Slots allocated for aOp[] and aArg[] */ +}; + +/* Add a state to the given state set if it is not already there */ +static void re_add_state(ReStateSet *pSet, int newState){ + unsigned i; + for(i=0; inState; i++) if( pSet->aState[i]==newState ) return; + pSet->aState[pSet->nState++] = (ReStateNumber)newState; +} + +/* Extract the next unicode character from *pzIn and return it. Advance +** *pzIn to the first byte past the end of the character returned. To +** be clear: this routine converts utf8 to unicode. This routine is +** optimized for the common case where the next character is a single byte. +*/ +static unsigned re_next_char(ReInput *p){ + unsigned c; + if( p->i>=p->mx ) return 0; + c = p->z[p->i++]; + if( c>=0x80 ){ + if( (c&0xe0)==0xc0 && p->imx && (p->z[p->i]&0xc0)==0x80 ){ + c = (c&0x1f)<<6 | (p->z[p->i++]&0x3f); + if( c<0x80 ) c = 0xfffd; + }else if( (c&0xf0)==0xe0 && p->i+1mx && (p->z[p->i]&0xc0)==0x80 + && (p->z[p->i+1]&0xc0)==0x80 ){ + c = (c&0x0f)<<12 | ((p->z[p->i]&0x3f)<<6) | (p->z[p->i+1]&0x3f); + p->i += 2; + if( c<=0x7ff || (c>=0xd800 && c<=0xdfff) ) c = 0xfffd; + }else if( (c&0xf8)==0xf0 && p->i+3mx && (p->z[p->i]&0xc0)==0x80 + && (p->z[p->i+1]&0xc0)==0x80 && (p->z[p->i+2]&0xc0)==0x80 ){ + c = (c&0x07)<<18 | ((p->z[p->i]&0x3f)<<12) | ((p->z[p->i+1]&0x3f)<<6) + | (p->z[p->i+2]&0x3f); + p->i += 3; + if( c<=0xffff || c>0x10ffff ) c = 0xfffd; + }else{ + c = 0xfffd; + } + } + return c; +} +static unsigned re_next_char_nocase(ReInput *p){ + unsigned c = re_next_char(p); + if( c>='A' && c<='Z' ) c += 'a' - 'A'; + return c; +} + +/* Return true if c is a perl "word" character: [A-Za-z0-9_] */ +static int re_word_char(int c){ + return (c>='0' && c<='9') || (c>='a' && c<='z') + || (c>='A' && c<='Z') || c=='_'; +} + +/* Return true if c is a "digit" character: [0-9] */ +static int re_digit_char(int c){ + return (c>='0' && c<='9'); +} + +/* Return true if c is a perl "space" character: [ \t\r\n\v\f] */ +static int re_space_char(int c){ + return c==' ' || c=='\t' || c=='\n' || c=='\r' || c=='\v' || c=='\f'; +} + +/* Run a compiled regular expression on the zero-terminated input +** string zIn[]. Return true on a match and false if there is no match. +*/ +static int re_match(ReCompiled *pRe, const unsigned char *zIn, int nIn){ + ReStateSet aStateSet[2], *pThis, *pNext; + ReStateNumber aSpace[100]; + ReStateNumber *pToFree; + unsigned int i = 0; + unsigned int iSwap = 0; + int c = RE_EOF+1; + int cPrev = 0; + int rc = 0; + ReInput in; + + in.z = zIn; + in.i = 0; + in.mx = nIn>=0 ? nIn : (int)strlen((char const*)zIn); + + /* Look for the initial prefix match, if there is one. */ + if( pRe->nInit ){ + unsigned char x = pRe->zInit[0]; + while( in.i+pRe->nInit<=in.mx + && (zIn[in.i]!=x || + strncmp((const char*)zIn+in.i, (const char*)pRe->zInit, pRe->nInit)!=0) + ){ + in.i++; + } + if( in.i+pRe->nInit>in.mx ) return 0; + } + + if( pRe->nState<=(sizeof(aSpace)/(sizeof(aSpace[0])*2)) ){ + pToFree = 0; + aStateSet[0].aState = aSpace; + }else{ + pToFree = sqlite3_malloc64( sizeof(ReStateNumber)*2*pRe->nState ); + if( pToFree==0 ) return -1; + aStateSet[0].aState = pToFree; + } + aStateSet[1].aState = &aStateSet[0].aState[pRe->nState]; + pNext = &aStateSet[1]; + pNext->nState = 0; + re_add_state(pNext, 0); + while( c!=RE_EOF && pNext->nState>0 ){ + cPrev = c; + c = pRe->xNextChar(&in); + pThis = pNext; + pNext = &aStateSet[iSwap]; + iSwap = 1 - iSwap; + pNext->nState = 0; + for(i=0; inState; i++){ + int x = pThis->aState[i]; + switch( pRe->aOp[x] ){ + case RE_OP_MATCH: { + if( pRe->aArg[x]==c ) re_add_state(pNext, x+1); + break; + } + case RE_OP_ANY: { + re_add_state(pNext, x+1); + break; + } + case RE_OP_WORD: { + if( re_word_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_NOTWORD: { + if( !re_word_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_DIGIT: { + if( re_digit_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_NOTDIGIT: { + if( !re_digit_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_SPACE: { + if( re_space_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_NOTSPACE: { + if( !re_space_char(c) ) re_add_state(pNext, x+1); + break; + } + case RE_OP_BOUNDARY: { + if( re_word_char(c)!=re_word_char(cPrev) ) re_add_state(pThis, x+1); + break; + } + case RE_OP_ANYSTAR: { + re_add_state(pNext, x); + re_add_state(pThis, x+1); + break; + } + case RE_OP_FORK: { + re_add_state(pThis, x+pRe->aArg[x]); + re_add_state(pThis, x+1); + break; + } + case RE_OP_GOTO: { + re_add_state(pThis, x+pRe->aArg[x]); + break; + } + case RE_OP_ACCEPT: { + rc = 1; + goto re_match_end; + } + case RE_OP_CC_INC: + case RE_OP_CC_EXC: { + int j = 1; + int n = pRe->aArg[x]; + int hit = 0; + for(j=1; j>0 && jaOp[x+j]==RE_OP_CC_VALUE ){ + if( pRe->aArg[x+j]==c ){ + hit = 1; + j = -1; + } + }else{ + if( pRe->aArg[x+j]<=c && pRe->aArg[x+j+1]>=c ){ + hit = 1; + j = -1; + }else{ + j++; + } + } + } + if( pRe->aOp[x]==RE_OP_CC_EXC ) hit = !hit; + if( hit ) re_add_state(pNext, x+n); + break; + } + } + } + } + for(i=0; inState; i++){ + if( pRe->aOp[pNext->aState[i]]==RE_OP_ACCEPT ){ rc = 1; break; } + } +re_match_end: + sqlite3_free(pToFree); + return rc; +} + +/* Resize the opcode and argument arrays for an RE under construction. +*/ +static int re_resize(ReCompiled *p, int N){ + char *aOp; + int *aArg; + aOp = sqlite3_realloc64(p->aOp, N*sizeof(p->aOp[0])); + if( aOp==0 ) return 1; + p->aOp = aOp; + aArg = sqlite3_realloc64(p->aArg, N*sizeof(p->aArg[0])); + if( aArg==0 ) return 1; + p->aArg = aArg; + p->nAlloc = N; + return 0; +} + +/* Insert a new opcode and argument into an RE under construction. The +** insertion point is just prior to existing opcode iBefore. +*/ +static int re_insert(ReCompiled *p, int iBefore, int op, int arg){ + int i; + if( p->nAlloc<=p->nState && re_resize(p, p->nAlloc*2) ) return 0; + for(i=p->nState; i>iBefore; i--){ + p->aOp[i] = p->aOp[i-1]; + p->aArg[i] = p->aArg[i-1]; + } + p->nState++; + p->aOp[iBefore] = (char)op; + p->aArg[iBefore] = arg; + return iBefore; +} + +/* Append a new opcode and argument to the end of the RE under construction. +*/ +static int re_append(ReCompiled *p, int op, int arg){ + return re_insert(p, p->nState, op, arg); +} + +/* Make a copy of N opcodes starting at iStart onto the end of the RE +** under construction. +*/ +static void re_copy(ReCompiled *p, int iStart, int N){ + if( p->nState+N>=p->nAlloc && re_resize(p, p->nAlloc*2+N) ) return; + memcpy(&p->aOp[p->nState], &p->aOp[iStart], N*sizeof(p->aOp[0])); + memcpy(&p->aArg[p->nState], &p->aArg[iStart], N*sizeof(p->aArg[0])); + p->nState += N; +} + +/* Return true if c is a hexadecimal digit character: [0-9a-fA-F] +** If c is a hex digit, also set *pV = (*pV)*16 + valueof(c). If +** c is not a hex digit *pV is unchanged. +*/ +static int re_hex(int c, int *pV){ + if( c>='0' && c<='9' ){ + c -= '0'; + }else if( c>='a' && c<='f' ){ + c -= 'a' - 10; + }else if( c>='A' && c<='F' ){ + c -= 'A' - 10; + }else{ + return 0; + } + *pV = (*pV)*16 + (c & 0xff); + return 1; +} + +/* A backslash character has been seen, read the next character and +** return its interpretation. +*/ +static unsigned re_esc_char(ReCompiled *p){ + static const char zEsc[] = "afnrtv\\()*.+?[$^{|}]"; + static const char zTrans[] = "\a\f\n\r\t\v"; + int i, v = 0; + char c; + if( p->sIn.i>=p->sIn.mx ) return 0; + c = p->sIn.z[p->sIn.i]; + if( c=='u' && p->sIn.i+4sIn.mx ){ + const unsigned char *zIn = p->sIn.z + p->sIn.i; + if( re_hex(zIn[1],&v) + && re_hex(zIn[2],&v) + && re_hex(zIn[3],&v) + && re_hex(zIn[4],&v) + ){ + p->sIn.i += 5; + return v; + } + } + if( c=='x' && p->sIn.i+2sIn.mx ){ + const unsigned char *zIn = p->sIn.z + p->sIn.i; + if( re_hex(zIn[1],&v) + && re_hex(zIn[2],&v) + ){ + p->sIn.i += 3; + return v; + } + } + for(i=0; zEsc[i] && zEsc[i]!=c; i++){} + if( zEsc[i] ){ + if( i<6 ) c = zTrans[i]; + p->sIn.i++; + }else{ + p->zErr = "unknown \\ escape"; + } + return c; +} + +/* Forward declaration */ +static const char *re_subcompile_string(ReCompiled*); + +/* Peek at the next byte of input */ +static unsigned char rePeek(ReCompiled *p){ + return p->sIn.isIn.mx ? p->sIn.z[p->sIn.i] : 0; +} + +/* Compile RE text into a sequence of opcodes. Continue up to the +** first unmatched ")" character, then return. If an error is found, +** return a pointer to the error message string. +*/ +static const char *re_subcompile_re(ReCompiled *p){ + const char *zErr; + int iStart, iEnd, iGoto; + iStart = p->nState; + zErr = re_subcompile_string(p); + if( zErr ) return zErr; + while( rePeek(p)=='|' ){ + iEnd = p->nState; + re_insert(p, iStart, RE_OP_FORK, iEnd + 2 - iStart); + iGoto = re_append(p, RE_OP_GOTO, 0); + p->sIn.i++; + zErr = re_subcompile_string(p); + if( zErr ) return zErr; + p->aArg[iGoto] = p->nState - iGoto; + } + return 0; +} + +/* Compile an element of regular expression text (anything that can be +** an operand to the "|" operator). Return NULL on success or a pointer +** to the error message if there is a problem. +*/ +static const char *re_subcompile_string(ReCompiled *p){ + int iPrev = -1; + int iStart; + unsigned c; + const char *zErr; + while( (c = p->xNextChar(&p->sIn))!=0 ){ + iStart = p->nState; + switch( c ){ + case '|': + case '$': + case ')': { + p->sIn.i--; + return 0; + } + case '(': { + zErr = re_subcompile_re(p); + if( zErr ) return zErr; + if( rePeek(p)!=')' ) return "unmatched '('"; + p->sIn.i++; + break; + } + case '.': { + if( rePeek(p)=='*' ){ + re_append(p, RE_OP_ANYSTAR, 0); + p->sIn.i++; + }else{ + re_append(p, RE_OP_ANY, 0); + } + break; + } + case '*': { + if( iPrev<0 ) return "'*' without operand"; + re_insert(p, iPrev, RE_OP_GOTO, p->nState - iPrev + 1); + re_append(p, RE_OP_FORK, iPrev - p->nState + 1); + break; + } + case '+': { + if( iPrev<0 ) return "'+' without operand"; + re_append(p, RE_OP_FORK, iPrev - p->nState); + break; + } + case '?': { + if( iPrev<0 ) return "'?' without operand"; + re_insert(p, iPrev, RE_OP_FORK, p->nState - iPrev+1); + break; + } + case '{': { + int m = 0, n = 0; + int sz, j; + if( iPrev<0 ) return "'{m,n}' without operand"; + while( (c=rePeek(p))>='0' && c<='9' ){ m = m*10 + c - '0'; p->sIn.i++; } + n = m; + if( c==',' ){ + p->sIn.i++; + n = 0; + while( (c=rePeek(p))>='0' && c<='9' ){ n = n*10 + c-'0'; p->sIn.i++; } + } + if( c!='}' ) return "unmatched '{'"; + if( n>0 && nsIn.i++; + sz = p->nState - iPrev; + if( m==0 ){ + if( n==0 ) return "both m and n are zero in '{m,n}'"; + re_insert(p, iPrev, RE_OP_FORK, sz+1); + n--; + }else{ + for(j=1; j0 ){ + re_append(p, RE_OP_FORK, -sz); + } + break; + } + case '[': { + int iFirst = p->nState; + if( rePeek(p)=='^' ){ + re_append(p, RE_OP_CC_EXC, 0); + p->sIn.i++; + }else{ + re_append(p, RE_OP_CC_INC, 0); + } + while( (c = p->xNextChar(&p->sIn))!=0 ){ + if( c=='[' && rePeek(p)==':' ){ + return "POSIX character classes not supported"; + } + if( c=='\\' ) c = re_esc_char(p); + if( rePeek(p)=='-' ){ + re_append(p, RE_OP_CC_RANGE, c); + p->sIn.i++; + c = p->xNextChar(&p->sIn); + if( c=='\\' ) c = re_esc_char(p); + re_append(p, RE_OP_CC_RANGE, c); + }else{ + re_append(p, RE_OP_CC_VALUE, c); + } + if( rePeek(p)==']' ){ p->sIn.i++; break; } + } + if( c==0 ) return "unclosed '['"; + p->aArg[iFirst] = p->nState - iFirst; + break; + } + case '\\': { + int specialOp = 0; + switch( rePeek(p) ){ + case 'b': specialOp = RE_OP_BOUNDARY; break; + case 'd': specialOp = RE_OP_DIGIT; break; + case 'D': specialOp = RE_OP_NOTDIGIT; break; + case 's': specialOp = RE_OP_SPACE; break; + case 'S': specialOp = RE_OP_NOTSPACE; break; + case 'w': specialOp = RE_OP_WORD; break; + case 'W': specialOp = RE_OP_NOTWORD; break; + } + if( specialOp ){ + p->sIn.i++; + re_append(p, specialOp, 0); + }else{ + c = re_esc_char(p); + re_append(p, RE_OP_MATCH, c); + } + break; + } + default: { + re_append(p, RE_OP_MATCH, c); + break; + } + } + iPrev = iStart; + } + return 0; +} + +/* Free and reclaim all the memory used by a previously compiled +** regular expression. Applications should invoke this routine once +** for every call to re_compile() to avoid memory leaks. +*/ +static void re_free(ReCompiled *pRe){ + if( pRe ){ + sqlite3_free(pRe->aOp); + sqlite3_free(pRe->aArg); + sqlite3_free(pRe); + } +} + +/* +** Compile a textual regular expression in zIn[] into a compiled regular +** expression suitable for us by re_match() and return a pointer to the +** compiled regular expression in *ppRe. Return NULL on success or an +** error message if something goes wrong. +*/ +static const char *re_compile(ReCompiled **ppRe, const char *zIn, int noCase){ + ReCompiled *pRe; + const char *zErr; + int i, j; + + *ppRe = 0; + pRe = sqlite3_malloc( sizeof(*pRe) ); + if( pRe==0 ){ + return "out of memory"; + } + memset(pRe, 0, sizeof(*pRe)); + pRe->xNextChar = noCase ? re_next_char_nocase : re_next_char; + if( re_resize(pRe, 30) ){ + re_free(pRe); + return "out of memory"; + } + if( zIn[0]=='^' ){ + zIn++; + }else{ + re_append(pRe, RE_OP_ANYSTAR, 0); + } + pRe->sIn.z = (unsigned char*)zIn; + pRe->sIn.i = 0; + pRe->sIn.mx = (int)strlen(zIn); + zErr = re_subcompile_re(pRe); + if( zErr ){ + re_free(pRe); + return zErr; + } + if( rePeek(pRe)=='$' && pRe->sIn.i+1>=pRe->sIn.mx ){ + re_append(pRe, RE_OP_MATCH, RE_EOF); + re_append(pRe, RE_OP_ACCEPT, 0); + *ppRe = pRe; + }else if( pRe->sIn.i>=pRe->sIn.mx ){ + re_append(pRe, RE_OP_ACCEPT, 0); + *ppRe = pRe; + }else{ + re_free(pRe); + return "unrecognized character"; + } + + /* The following is a performance optimization. If the regex begins with + ** ".*" (if the input regex lacks an initial "^") and afterwards there are + ** one or more matching characters, enter those matching characters into + ** zInit[]. The re_match() routine can then search ahead in the input + ** string looking for the initial match without having to run the whole + ** regex engine over the string. Do not worry able trying to match + ** unicode characters beyond plane 0 - those are very rare and this is + ** just an optimization. */ + if( pRe->aOp[0]==RE_OP_ANYSTAR ){ + for(j=0, i=1; jzInit)-2 && pRe->aOp[i]==RE_OP_MATCH; i++){ + unsigned x = pRe->aArg[i]; + if( x<=127 ){ + pRe->zInit[j++] = (unsigned char)x; + }else if( x<=0xfff ){ + pRe->zInit[j++] = (unsigned char)(0xc0 | (x>>6)); + pRe->zInit[j++] = 0x80 | (x&0x3f); + }else if( x<=0xffff ){ + pRe->zInit[j++] = (unsigned char)(0xd0 | (x>>12)); + pRe->zInit[j++] = 0x80 | ((x>>6)&0x3f); + pRe->zInit[j++] = 0x80 | (x&0x3f); + }else{ + break; + } + } + if( j>0 && pRe->zInit[j-1]==0 ) j--; + pRe->nInit = j; + } + return pRe->zErr; +} + +/* +** Implementation of the regexp() SQL function. This function implements +** the build-in REGEXP operator. The first argument to the function is the +** pattern and the second argument is the string. So, the SQL statements: +** +** A REGEXP B +** +** is implemented as regexp(B,A). +*/ +static void re_sql_func( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + ReCompiled *pRe; /* Compiled regular expression */ + const char *zPattern; /* The regular expression */ + const unsigned char *zStr;/* String being searched */ + const char *zErr; /* Compile error message */ + int setAux = 0; /* True to invoke sqlite3_set_auxdata() */ + + pRe = sqlite3_get_auxdata(context, 0); + if( pRe==0 ){ + zPattern = (const char*)sqlite3_value_text(argv[0]); + if( zPattern==0 ) return; + zErr = re_compile(&pRe, zPattern, 0); + if( zErr ){ + re_free(pRe); + sqlite3_result_error(context, zErr, -1); + return; + } + if( pRe==0 ){ + sqlite3_result_error_nomem(context); + return; + } + setAux = 1; + } + zStr = (const unsigned char*)sqlite3_value_text(argv[1]); + if( zStr!=0 ){ + sqlite3_result_int(context, re_match(pRe, zStr, -1)); + } + if( setAux ){ + sqlite3_set_auxdata(context, 0, pRe, (void(*)(void*))re_free); + } +} + +/* +** Invoke this routine to register the regexp() function with the +** SQLite database connection. +*/ +#ifdef _WIN32 +__declspec(dllexport) +#endif +int sqlite3_regexp_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + SQLITE_EXTENSION_INIT2(pApi); + rc = sqlite3_create_function(db, "regexp", 2, SQLITE_UTF8|SQLITE_INNOCUOUS, + 0, re_sql_func, 0, 0); + return rc; +} diff --git a/contrib/mORMot/SQLite3/amalgamation/sqlite3mc.c b/contrib/mORMot/SQLite3/amalgamation/sqlite3mc.c index 2a797db..0b1cb46 100644 --- a/contrib/mORMot/SQLite3/amalgamation/sqlite3mc.c +++ b/contrib/mORMot/SQLite3/amalgamation/sqlite3mc.c @@ -1,53 +1,109 @@ /* -** Wrapper around SQlite3 amalgamation file with proper options and code +** Wrapper around SQlite3 amalgamation file for mORMot use ** ** Please download and put sqlite3.c in amalgamation/ sub-folder ** from https://sqlite.org/download.html -** then run ./patch.sh +** then follow the amalgamation/ReadMe.md instructions */ /* -** Define all symbols expected by SynSQLite3Static.pas +** Define conditionals / extensions specially tuned for mORMot ** ** See also https://www.sqlite.org/compile.html#recommended_compile_time_options */ #define SQLITE_DEFAULT_MEMSTATUS 0 // don't need any debug here, and don't even define sqlite3_status() -#define SQLITE_THREADSAFE 1 + // assuming multi-thread safety is made by caller - in our framework, there is // only one thread using the database connection at the same time, but there could -// be multiple database connection at the same time (previous was 0 could be unsafe) -// - this option is also needed by codecext.c +// be multiple database connection at the same time +// * 0 = single-thread = all mutexes disabled - seems unsafe +// * 1 = serialized = all calls serialized - seems overkill +// * 2 = multi-thread = thread-safe by connection - fine for our purpose +// - note that we keep 1=serialized at compile time (to allow all modes) +// but SQLITE_CONFIG_MULTITHREAD is set in TSqlite3Library.BeforeInitialization +// and rely on TSqlDataBase to do explicit Lock/LockJson/UnLock calls +#if SQLITE_NO_THREAD +# define SQLITE_THREADSAFE 0 +#else +# define SQLITE_THREADSAFE 1 +#endif + #define SQLITE_OMIT_SHARED_CACHE 1 // no need of shared cache in a threadsafe calling model + #define SQLITE_OMIT_AUTOINIT 1 -// sqlite3_initialize() is done in unit initialization -> no AUTOINIT +// sqlite3_initialize() is done in unit initialization -> no AUTOINIT + #define SQLITE_OMIT_DEPRECATED 1 -// spare some code size +// spare some code size + + #define SQLITE_LIKE_DOESNT_MATCH_BLOBS 1 // historical function, never used + #define SQLITE_ENABLE_FTS3 1 #define SQLITE_ENABLE_FTS3_PARENTHESIS 1 #define SQLITE_ENABLE_FTS4 1 #define SQLITE_ENABLE_FTS5 1 -// enable all FTS engines -#define SQLITE_ENABLE_RBU 1 -// "Resumable Bulk Update" (or OTA) is not used/published yet +// enable all FTS engines https://www.sqlite.org/fts3.html https://www.sqlite.org/fts5.html + #define SQLITE_ENABLE_JSON1 1 -// add JSON extension +// enable JSON https://www.sqlite.org/json1.html + #define SQLITE_MAX_EXPR_DEPTH 0 // no SQL depth limit, since we trust the input and expect the best performance -#define SQLITE_OMIT_LOAD_EXTENSION 1 -// we don't need/allow extension in an embedded engine -#define SQLITE_OMIT_COMPILEOPTION_DIAGS 1 -// we don't need Compilation Options Diagnostics in our embedded engine -#define SQLITE_OMIT_PROGRESS_CALLBACK 1 -// we don't need sqlite3_progress_handler() API function -#define SQLITE_ENABLE_RTREE 1 -// the RTREE extension is now (from v.1.8/3.7) compiled into the engine + #define SQLITE_ENABLE_DESERIALIZE -// enables sqlite3_serialize() and sqlite3_deserialize() +// enable sqlite3_serialize() and sqlite3_deserialize() + +#define SQLITE_ENABLE_RTREE 1 +// enable RTREE https://sqlite.org/rtree.html + +#define SQLITE_ENABLE_GEOPOLY 1 +// enable GeoJSON over RTREE https://sqlite.org/geopoly.html + +#define SQLITE_ENABLE_REGEXP 1 +// enable the compact https://www.sqlite.org/src/file?name=ext/misc/regexp.c +// - can be overloaded with any other implementation + +#define SQLITE_ENABLE_RBU 1 +// enable "Resumable Bulk Update" (or OTA) https://www.sqlite.org/rbu.html + +#define SQLITE_ENABLE_SESSION 1 +#define SQLITE_ENABLE_PREUPDATE_HOOK 1 +// enable Sessions https://sqlite.org/sessionintro.html + +#define SQLITE_ENABLE_NORMALIZE 1 +// enable all https://sqlite.org/c3ref/expanded_sql.html functions + +#define YYTRACKMAXSTACKDEPTH 1 +// enable SQLITE_STATUS_PARSER_STACK support + +#define SQLITE_ENABLE_COLUMN_METADATA 1 +//enable column_database_name, column_table_name and column_origin_name support + +#define SQLITE_ENABLE_STMT_SCANSTATUS 1 +// enable stmt_scanstatus and stmt_scanstatus_reset support + +#define SQLITE_ENABLE_SNAPSHOT 1 +// support the sqlite3_snapshot object + +#define SQLITE_ENABLE_UNLOCK_NOTIFY 1 +// enable sqlite3_unlock_notify + +/* +** Disabled conditionals / extensions +*/ + +// #define SQLITE_ENABLE_ICU +// disabled because induces a huge dependency - use WIN32NOCASE (which calls +// ICU on POSIX) or even better the UNICODENOCASE as available in mORMot 2 + +// #define SQLITE_ENABLE_STAT4 +// adds additional logic to the ANALYZE command and to the Query Planner + /* ** Define function for extra initilization @@ -229,6 +285,18 @@ static unsigned char* CodecGetPageBuffer(Codec* codec) #include "codecext.c" +/* +** REGEXP +*/ +#ifdef SQLITE_ENABLE_REGEXP +/* Prototype for initialization function of REGEXP extension */ +#ifdef _WIN32 +__declspec(dllexport) +#endif +int sqlite3_regexp_init(sqlite3 *db, char **pzErrMsg, const sqlite3_api_routines *pApi); +#include "regexp.c" +#endif + /* ** Multi cipher VFS */ @@ -259,6 +327,17 @@ sqlite3mc_initialize(const char* arg) } rc = sqlite3mc_vfs_initialize(vfsDefault, 1); } + + /* + ** Can be overloaded later with any other REGEXP engine + */ + #ifdef SQLITE_ENABLE_REGEXP + if (rc == SQLITE_OK) + { + rc = sqlite3_auto_extension((void(*)(void)) sqlite3_regexp_init); + } + #endif + return rc; } diff --git a/contrib/mORMot/SQLite3/mORMot.pas b/contrib/mORMot/SQLite3/mORMot.pas index 35d2e20..a99c962 100644 --- a/contrib/mORMot/SQLite3/mORMot.pas +++ b/contrib/mORMot/SQLite3/mORMot.pas @@ -6,7 +6,7 @@ unit mORMot; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMot; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -68,7 +68,7 @@ unit mORMot; *) -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 +{$I ..\Synopse.inc} // define HASINLINE CPU32 CPU64 {.$define PUREPASCAL} // define for debugg, not on production @@ -112,7 +112,7 @@ unit mORMot; // - Setting NOGSSAPIAUTH conditional will disable this feature // Limitations: // - no NTLM support - this is a deprecated and vulnerable protocol -{$endif} +{$endif MSWINDOWS} {$ifdef KYLIX3} @@ -1929,7 +1929,7 @@ type /// =$ff for a ptField address, or =$fe for a ptVirtual method Kind: byte; end; - {$A+} // back to normal alignment + {$A+} // back to normal alignment {$endif FPC} const @@ -3441,7 +3441,7 @@ type end; var - /// acccess to Zip Deflate compression in level 6 as a TSynCompress class + /// acccess to Zip Deflate compression in level 6 as a TAlgoCompress class AlgoDeflate: TAlgoCompress; /// acccess to Zip Deflate compression in level 1 as a TAlgoCompress class AlgoDeflateFast: TAlgoCompress; @@ -4504,6 +4504,7 @@ type end; TServiceFactoryServer = class; + PSQLAccessRights = ^TSQLAccessRights; /// flags which may be set by the caller to notify low-level context @@ -4758,9 +4759,6 @@ type /// a set of potential actions to be executed from the server // - reSQL will indicate the right to execute any POST SQL statement (not only // SELECT statements) - // - reSQLSelectWithoutTable will allow executing a SELECT statement with - // arbitrary content via GET/LOCK (simple SELECT .. FROM aTable will be checked - // against TSQLAccessRights.GET[] per-table right // - reService will indicate the right to execute the interface-based JSON-RPC // service implementation // - reUrlEncodedSQL will indicate the right to execute a SQL query encoded @@ -4772,6 +4770,9 @@ type // for one user, even if connection comes from the same IP: in this case, // you may have to set the SessionTimeOut to a small value, in case the // session is not closed gracefully + // - reSQLSelectWithoutTable will allow executing a SELECT statement with + // arbitrary content via GET/LOCK (simple SELECT .. FROM aTable will be checked + // against TSQLAccessRights.GET[] per-table right // - by default, read/write access to the TSQLAuthUser table is disallowed, // for obvious security reasons: but you can define reUserCanChangeOwnPassword // so that the current logged user will be able to change its own password @@ -4970,6 +4971,9 @@ type /// the optional Blob field name as specified in URI // - e.g. retrieved from "ModelRoot/TableName/TableID/BlobFieldName" URIBlobFieldName: RawUTF8; + /// decoded URI for rsoMethodUnderscoreAsSlashURI in Server.Options + // - e.g. 'Method_Name' from 'ModelRoot/Method/Name' URI + URIUnderscoreAsSlash: RawUTF8; /// position of the &session_signature=... text in Call^.url string URISessionSignaturePos: integer; /// the Table as specified at the URI level (if any) @@ -5907,6 +5911,7 @@ type // - consider inherit from TSQLRecordNoCase and TSQLRecordNoCaseExtended if // you expect regular NOCASE collation and smaller (but not standard JSON) // variant fields persistence + // - is called TOrm in mORMot 2 TSQLRecord = class(TObject) { note that every TSQLRecord has an Instance size of 20 bytes for private and protected fields (such as fID or fProps e.g.) } @@ -6905,6 +6910,9 @@ type // EORMException: in this case, you should use a TID / T*ID kind of // published property, and not a TSQLRecord, which is limited to the // pointer size + // - on FPC, if you get an Error: Incompatible types: got "Pointer" expected + // "T...", then you are missing a {$mode Delphi} conditional in your unit: + // the easiest is to include {$I Synopse.inc} at the top of your unit property AsTSQLRecord: pointer read GetIDAsPointer; /// this property is set to true, if any published property is a BLOB (TSQLRawBlob) property HasBlob: boolean read GetHasBlob; @@ -7034,7 +7042,7 @@ type protected fRowCount: integer; fFieldCount: integer; - /// contains the data, as returned by sqlite3_get_table() + /// contains the data, e.g. as returned by sqlite3_get_table() fResults: PPUTF8CharArray; fFieldType: array of TSQLTableFieldType; fFieldTypeAllRows: boolean; @@ -7620,7 +7628,7 @@ type // of the first associated record class (from internal QueryTables[]) // - always returns an instance, even if the TSQLTable is nil or void function ToObjectList: TObjectList; overload; - {$endif} + {$endif ISDELPHI2010} /// fill an existing T*ObjArray variable with TSQLRecord instances // corresponding to this TSQLTable result set // - use the specified TSQLRecord class or create instances @@ -7836,9 +7844,10 @@ type // (no additional memory buffer is allocated) function ParseAndConvert(Buffer: PUTF8Char; BufferLen: integer): boolean; /// will check then set (if needed) internal fPrivateCopy[Hash] values - // - returns TRUE if content changed (then fPrivateCopy+fPrivateCopyHash - // will be updated using crc32c hash) - function PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer): boolean; + // - returns TRUE if fPrivateCopy content changed (then fPrivateCopyHash + // will be updated using crc32c hash if aUpdateHash is set) + function PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer; + aUpdateHash: boolean): boolean; public /// create the result table from a JSON-formated Data message // - the JSON data is parsed and formatted in-place @@ -9051,7 +9060,7 @@ type /// this base class will create a FTS3 table using the Unicode61 Stemming algorithm // - see http://sqlite.org/fts3.html#tokenizer - // - will generate tokenize=unicode64 by convention from the class name + // - will generate tokenize=unicode61 by convention from the class name TSQLRecordFTS3Unicode61 = class(TSQLRecordFTS3); /// a base record, corresponding to a FTS4 table, which is an enhancement to FTS3 @@ -9082,7 +9091,7 @@ type /// this base class will create a FTS4 table using the Unicode61 Stemming algorithm // - see http://sqlite.org/fts3.html#tokenizer - // - will generate tokenize=unicode64 by convention from the class name + // - will generate tokenize=unicode61 by convention from the class name TSQLRecordFTS4Unicode61 = class(TSQLRecordFTS4); /// a base record, corresponding to a FTS5 table, which is an enhancement to FTS4 @@ -9104,7 +9113,7 @@ type /// this base class will create a FTS5 table using the Unicode61 Stemming algorithm // - see https://sqlite.org/fts5.html#tokenizers - // - will generate tokenize=unicode64 by convention from the class name + // - will generate tokenize=unicode61 by convention from the class name TSQLRecordFTS5Unicode61 = class(TSQLRecordFTS5); /// class-reference type (metaclass) of a FTS3/FTS4/FTS5 virtual table @@ -9138,7 +9147,9 @@ type // pointing in opposite directions // - by default, only two TSQLRecord (i.e. INTEGER) fields must be created, // named "Source" and "Dest", the first pointing to the source record (the one - // with a TSQLRecordMany published property) and the second to the destination record + // with a TSQLRecordMany published property) and the second to the destination + // record - note that by design, those source/dest tables are stored as + // pointers, so are limited to 32-bit ID values on 32-bit systems // - you should first create a type inheriting from TSQLRecordMany, which // will define the pivot table, providing optional "through" parameters if needed // ! TSQLDest = class(TSQLRecord); @@ -10559,8 +10570,8 @@ type {$M-} /// class handling interface implementation generated from source - // - this class targets FPC, which does not generate the expected RTTI - see - // http://bugs.freepascal.org/view.php?id=26774 + // - this class targets oldest FPC, which did not generate the expected RTTI - + // see http://bugs.freepascal.org/view.php?id=26774 // - mORMotWrapper.pas will generate a new inherited class, overriding abstract // AddMethodsFromTypeInfo() to define the interface methods TInterfaceFactoryGenerated = class(TInterfaceFactory) @@ -12623,7 +12634,7 @@ type /// a dynamic array of TSQLRest instances TSQLRestDynArray = array of TSQLRest; - /// a dynamic array of TSQLRest instances, owniing the instances + /// a dynamic array of TSQLRest instances, owning the instances TSQLRestObjArray = array of TSQLRest; /// used to store the execution parameters for a TSQLRest instance @@ -12783,8 +12794,7 @@ type fServerTimestampCacheTix: cardinal; fServerTimestampCacheValue: TTimeLogBits; fServices: TServiceContainer; - fPrivateGarbageCollector: TSynObjectList; - fRoutingClass: TSQLRestServerURIContextClass; + fServicesRouting: TSQLRestServerURIContextClass; fBackgroundTimer: TSQLRestBackgroundTimer; fOnDecryptBody, fOnEncryptBody: TNotifyRestBody; fCustomEncryptAES: TAESAbstract; @@ -12792,6 +12802,7 @@ type fCustomEncryptCompress: TAlgoCompress; fCustomEncryptContentPrefix, fCustomEncryptContentPrefixUpper, fCustomEncryptUrlIgnore: RawUTF8; fAcquireExecution: array[TSQLRestServerURIContextCommand] of TSQLRestAcquireExecution; + fPrivateGarbageCollector: TSynObjectList; {$ifdef WITHLOG} fLogClass: TSynLogClass; // =SQLite3Log by default fLogFamily: TSynLogFamily; // =SQLite3Log.Family by default @@ -12870,7 +12881,7 @@ type /// used by all overloaded Add() methods function InternalAdd(Value: TSQLRecord; SendData: boolean; CustomFields: PSQLFieldBits; ForceID, DoNotAutoComputeFields: boolean): TID; virtual; - protected // these abstract methods must be overriden by real database engine + protected // these abstract methods must be overriden by real database engine /// retrieve a list of members as JSON encoded data // - implements REST GET collection // - returns '' on error, or JSON data, even with no result rows @@ -13900,7 +13911,7 @@ type function RetrieveList(const FormatSQLWhere: RawUTF8; const BoundsSQLWhere: array of const; const aCustomFieldsCSV: RawUTF8=''): TObjectList; overload; - {$endif ISDELPHIXE} + {$endif ISDELPHI2010} /// you can call this method in TThread.Execute to ensure that // the thread will be taken into account during process @@ -14160,7 +14171,8 @@ type /// access or initialize the internal IoC resolver, used for interface-based // remote services, and more generaly any Services.Resolve() call // - create and initialize the internal TServiceContainer if no service - // interface has been registered yet // - may be used to inject some dependencies, which are not interface-based + // interface has been registered yet + // - may be used to inject some dependencies, which are not interface-based // remote services, but internal IoC, without the ServiceRegister() // or ServiceDefine() methods - e.g. // ! aRest.ServiceContainer.InjectResolver([TInfraRepoUserFactory.Create(aRest)],true); @@ -14175,7 +14187,7 @@ type // server sides), if the client will rather use JSON/RPC alternative pattern // - NEVER set the abstract TSQLRestServerURIContext class on this property property ServicesRouting: TSQLRestServerURIContextClass - read fRoutingClass write SetRoutingClass; + read fServicesRouting write SetRoutingClass; /// low-level background timer thread associated with this TSQLRest // - contains nil if TimerEnable/AsynchInvoke was never executed // - you may instantiate your own TSQLRestBackgroundTimer instances, if @@ -15835,6 +15847,9 @@ type // unless rsoGetUserRetrieveNoBlobData is defined // - rsoNoInternalState could be state to avoid transmitting the // 'Server-InternalState' header, e.g. if the clients wouldn't need it + // - rsoNoTableURI will disable any /root/tablename URI for safety + // - rsoMethodUnderscoreAsSlashURI will try to decode /root/method/name + // as 'method_name' method TSQLRestServerOption = ( rsoNoAJAXJSON, rsoGetAsJsonNotAsString, @@ -15850,7 +15865,9 @@ type rsoTimestampInfoURIDisable, rsoHttpHeaderCheckDisable, rsoGetUserRetrieveNoBlobData, - rsoNoInternalState); + rsoNoInternalState, + rsoNoTableURI, + rsoMethodUnderscoreAsSlashURI); /// allow to customize the TSQLRestServer process via its Options property TSQLRestServerOptions = set of TSQLRestServerOption; @@ -16010,6 +16027,13 @@ type // - will perform any needed clean-up, and log the event // - this method is not thread-safe: caller should use Sessions.Lock/Unlock procedure SessionDelete(aSessionIndex: integer; Ctxt: TSQLRestServerURIContext); + /// SessionAccess will detect and delete outdated sessions, but you can call + // this method to force checking for deprecated session now + // - may be used e.g. from OnSessionCreate to limit the number of active sessions + // - this method is not thread-safe: caller should use Sessions.Lock/Unlock + // - you can call it often: it will seek for outdated sessions once per second + // - returns the current system Ticks number (at second resolution) + function SessionDeleteDeprecated: cardinal; /// returns TRUE if this table is worth caching (e.g. already in memory) // - this overridden implementation returns FALSE for TSQLRestStorageInMemory function CacheWorthItForTable(aTableIndex: cardinal): boolean; override; @@ -16453,7 +16477,7 @@ type // - return nil on any error, or an EModelException if the class is not in // the database model function StaticDataCreate(aClass: TSQLRecordClass; - const aFileName: TFileName = ''; aBinaryFile: boolean=false; + const aFileName: TFileName=''; aBinaryFile: boolean=false; aServerClass: TSQLRestStorageInMemoryClass=nil): TSQLRestStorage; /// register an external static storage for a given table // - will be added to StaticDataServer[] internal list @@ -16647,11 +16671,12 @@ type // can be used if you need an overridden constructor // - instance implementation pattern will be set by the appropriate parameter // - will return the first of the registered TServiceFactoryServer created - // on success (i.e. the one corresponding to the first item of the aInterfaces - // array), or nil if registration failed (e.g. if any of the supplied interfaces + // on success (i.e. corresponding to aInterfaces[0] - not to the others), + // or nil if registration failed (e.g. if any of the supplied interfaces // is not implemented by the given class) - // - you can use the returned TServiceFactoryServer instance to set the - // expected security parameters associated with this interface + // - you can use the returned TServiceFactoryServer instance to set + // the expected security parameters for aInterfaces[0] - warning: only the + // the first interface options are returned // - the same implementation class can be used to handle several interfaces // (just as Delphi allows to do natively) function ServiceRegister(aImplementationClass: TInterfacedClass; @@ -16667,8 +16692,10 @@ type // on success (i.e. the one corresponding to the first item of the aInterfaces // array), or nil if registration failed (e.g. if any of the supplied interfaces // is not implemented by the given class) - // - you can use the returned TServiceFactoryServer instance to set the - // expected security parameters associated with this interface + // - will return the first of the registered TServiceFactoryServer created + // on success (i.e. corresponding to aInterfaces[0] - not to the others), + // or nil if registration failed (e.g. if any of the supplied interfaces + // is not implemented by the given class) // - the same implementation class can be used to handle several interfaces // (just as Delphi allows to do natively) function ServiceRegister(aSharedImplementation: TInterfacedObject; @@ -16693,6 +16720,10 @@ type /// register a Service class on the server side // - this method expects the interface(s) to have been registered previously: // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]); + // - will return the first of the registered TServiceFactoryServer created + // on success (i.e. corresponding to aInterfaces[0] - not to the others), + // or nil if registration failed (e.g. if any of the supplied interfaces + // is not implemented by the given class) function ServiceDefine(aImplementationClass: TInterfacedClass; const aInterfaces: array of TGUID; aInstanceCreation: TServiceInstanceImplementation=sicSingle; @@ -16701,6 +16732,10 @@ type // - this method expects the interface(s) to have been registered previously: // ! TInterfaceFactory.RegisterInterfaces([TypeInfo(IMyInterface),...]); // - the supplied aSharedImplementation will be owned by this Server instance + // - will return the first of the registered TServiceFactoryServer created + // on success (i.e. corresponding to aInterfaces[0] - not to the others), + // or nil if registration failed (e.g. if any of the supplied interfaces + // is not implemented by the given class) function ServiceDefine(aSharedImplementation: TInterfacedObject; const aInterfaces: array of TGUID; const aContractExpected: RawUTF8=''): TServiceFactoryServer; overload; /// register a remote Service via its interface @@ -17884,7 +17919,7 @@ type // same time, you should better use BATCH process, specifying a positive // AutomaticTransactionPerRow parameter to BatchStart() function TransactionBegin(aTable: TSQLRecordClass; - SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED): boolean; override; + SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED): boolean; override; /// end a transaction (calls REST END Member) // - by default, Client transaction will use here a pseudo session procedure Commit(SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED; @@ -18161,7 +18196,7 @@ type /// method calling the remote Server via a RESTful command // - calls the InternalURI abstract method, which should be overridden with a // local, piped or HTTP/1.1 provider - // - this method will add sign the url with the appropriate digital signature + // - this method will sign the url with the appropriate digital signature // according to the current SessionUser property // - this method will retry the connection in case of authentication failure // (i.e. if the session was closed by the remote server, for any reason - @@ -18229,7 +18264,7 @@ type /// internal method able to emulate a call to TSynLog.Add.Log() // - will compute timestamp and event text, than call the overloaded // ServerRemoteLog() method - function ServerRemoteLog(Level: TSynLogInfo; FormatMsg: PUTF8Char; + function ServerRemoteLog(Level: TSynLogInfo; const FormatMsg: RawUTF8; const Args: array of const): boolean; overload; /// start to send all logs to the server 'RemoteLog' method-based service // - will associate the EchoCustom callback of the running log class to the @@ -18269,7 +18304,8 @@ type // !end; // - you may use the dedicated TransactionBeginRetry() method in case of // potential Client concurrent access - function TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean; override; + function TransactionBegin(aTable: TSQLRecordClass; + SessionID: cardinal=CONST_AUTHENTICATION_NOT_USED): boolean; override; /// begin a transaction // - implements REST BEGIN collection // - in aClient-Server environment with multiple Clients connected at the @@ -18500,7 +18536,7 @@ type // - is defines as a class procedure, since the underlying TSQLRestClientURI // instance has no impact here: a single WM_* handler is enough for // several TSQLRestClientURI instances - class procedure ServiceNotificationMethodExecute(var Msg : TMessage); + class procedure ServiceNotificationMethodExecute(var Msg: TMessage); {$endif MSWINDOWS} published /// low-level error code, as returned by server @@ -19577,7 +19613,7 @@ procedure SetWeakZero(aObject: TObject; aObjectInterfaceField: PIInterface; {$ifdef ISDELPHIXE} // class helper requires Delphi 2006 or newer but are buggy before XE :( type /// TWeakZeroInterfaceHelper is a class helper that allows you to use - // SetWeakZero() in any class without specifying the Self parameter + // SetWeakZero() in any class without specifying the self parameter TWeakZeroInterfaceHelper = class helper for TObject protected /// Use SetWeak0 to assign an interface to a weak interface field @@ -19861,7 +19897,7 @@ begin {$else} if @self=TypeInfo(QWord) then result := true else - {$ifdef UINICODE}if Kind=tkInt64 then // check MinInt64Value>MaxInt64Value + {$ifdef UNICODE}if Kind=tkInt64 then // check MinInt64Value>MaxInt64Value with PHash128Rec(PAnsiChar(@Name[1])+ord(Name[0]))^ do result := Lo>Hi else {$endif} result := false; @@ -20653,7 +20689,7 @@ constructor TSQLPropInfo.Create(const aName: RawUTF8; aSQLFieldType: TSQLFieldTy aAttributes: TSQLPropInfoAttributes; aFieldWidth, aPropertyIndex: integer); begin if aName='' then - EORMException.CreateUTF8('Void name for %.Create',[self]); + raise EORMException.CreateUTF8('Void name for %.Create',[self]); if aAuxiliaryRTreeField in aAttributes then fName := copy(aName,2,MaxInt) else fName := aName; @@ -23527,7 +23563,7 @@ end; function TSQLPropInfoList.GetItem(aIndex: integer): TSQLPropInfo; begin if cardinal(aIndex)>=Cardinal(fCount) then - EORMException.Create('Invalid TSQLPropInfoList index'); + raise EORMException.Create('Invalid TSQLPropInfoList index'); result := fList[aIndex]; end; @@ -27822,15 +27858,20 @@ end; { TSQLTableJSON } -function TSQLTableJSON.PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer): boolean; +function TSQLTableJSON.PrivateCopyChanged(aJSON: PUTF8Char; aLen: integer; + aUpdateHash: boolean): boolean; var Hash: cardinal; begin - Hash := crc32c(0,pointer(aJSON),aLen); - result := (fPrivateCopyHash=0) or (Hash=0) or (Hash<>fPrivateCopyHash); - if not result then - exit; - FastSetString(fPrivateCopy,aJSON,aLen+16); // +16 for SSE4.2 read-ahead - fPrivateCopyHash := Hash; + if aUpdateHash then begin + Hash := crc32c(0,pointer(aJSON),aLen); + result := (fPrivateCopyHash=0) or (Hash=0) or (Hash<>fPrivateCopyHash); + if not result then + exit; + fPrivateCopyHash := Hash; + end else + result := true; // from Create() for better performance on single use + FastSetString(fPrivateCopy,nil,aLen+16); // +16 for SSE4.2 read-ahead + MoveFast(pointer(aJSON)^,pointer(fPrivateCopy)^,aLen+1); // +1 for trailing #0 end; function TSQLTableJSON.ParseAndConvert(Buffer: PUTF8Char; BufferLen: integer): boolean; @@ -27971,7 +28012,7 @@ function TSQLTableJSON.UpdateFrom(const aJSON: RawUTF8; var Refreshed: boolean; var len: Integer; begin len := length(aJSON); - if PrivateCopyChanged(pointer(aJSON),len) then + if PrivateCopyChanged(pointer(aJSON),len,{updatehash=}true) then if ParseAndConvert(pointer(fPrivateCopy),len) then begin // parse success from new aJSON data -> need some other update? if Assigned(fIDColumn) then begin @@ -28002,7 +28043,7 @@ constructor TSQLTableJSON.Create(const aSQL, aJSON: RawUTF8); var len: integer; begin len := length(aJSON); - FastSetString(fPrivateCopy,pointer(aJSON),len+16); // +16 for SSE4.2 read-ahead + PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false); Create(aSQL,pointer(fPrivateCopy),len); end; @@ -28018,7 +28059,7 @@ constructor TSQLTableJSON.CreateFromTables(const Tables: array of TSQLRecordClas var len: integer; begin len := length(aJSON); - FastSetString(fPrivateCopy,pointer(aJSON),len+16); + PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false); CreateFromTables(Tables,aSQL,pointer(fPrivateCopy),len); end; @@ -28034,7 +28075,7 @@ constructor TSQLTableJSON.CreateWithColumnTypes(const ColumnTypes: array of TSQL var len: integer; begin len := length(aJSON); - FastSetString(fPrivateCopy,pointer(aJSON),len+16); + PrivateCopyChanged(pointer(aJSON),len,{updatehash=}false); CreateWithColumnTypes(ColumnTypes,aSQL,pointer(fPrivateCopy),len); end; @@ -28890,7 +28931,7 @@ begin kD := DestInfo^.PropType^.Kind; case kS of {$ifdef FPC}tkBool,{$endif} tkEnumeration, tkInteger, tkSet, tkChar, tkWChar: -int: if DestInfo=@Self then +int: if DestInfo=@self then SetOrdProp(Dest,GetOrdProp(Source)) else dst: if kD in tkOrdinalTypes then // use Int64 to handle e.g. cardinal DestInfo^.SetInt64Value(Dest,GetInt64Value(Source)); @@ -29726,7 +29767,7 @@ begin {$endif} end; -function TEnumType.GetCaptionStrings(UsedValuesBits: Pointer=nil): string; +function TEnumType.GetCaptionStrings(UsedValuesBits: Pointer): string; var List: TStringList; begin List := TStringList.Create; @@ -30236,7 +30277,7 @@ end; function SQLWhereIsEndClause(const Where: RawUTF8): boolean; begin - result := IdemPCharArray(pointer(Where),['ORDER BY ','GROUP BY ', + result := IdemPCharArray(GotoNextNotSpace(pointer(Where)),['ORDER BY ','GROUP BY ', 'LIMIT ','OFFSET ','LEFT ','RIGHT ','INNER ','OUTER ','JOIN '])>=0; end; @@ -30252,10 +30293,10 @@ end; function SQLFromSelect(const TableName, Select, Where, SimpleFields: RawUTF8): RawUTF8; begin if Select='*' then - // don't send BLOB values to query: retrieve all other fields - result := 'SELECT '+SimpleFields else - result := 'SELECT '+Select; - result := result+' FROM '+TableName+SQLFromWhere(Where); + // don't send BLOB values to query: retrieve simple = all non-blob fields + result := SimpleFields else + result := Select; + result := 'SELECT '+result+' FROM '+TableName+SQLFromWhere(Where); end; function SelectInClause(const PropName: RawUTF8; const Values: array of RawUTF8; @@ -30676,7 +30717,7 @@ begin f := D.Fields.IndexByName(SP.Name); if f>=0 then begin SP.GetValueVar(aRecord,False,tmp,@wasString); - D.Fields.List[f].SetValueVar(Self,tmp,wasString); + D.Fields.List[f].SetValueVar(self,tmp,wasString); end; end; end; @@ -31028,7 +31069,7 @@ begin W.AddString(W.ColNames[n]); // '"'+ColNames[]+'":' inc(n); end; - Props.List[W.Fields[i]].GetJSONValues(Self,W); + Props.List[W.Fields[i]].GetJSONValues(self,W); W.Add(','); end; end; @@ -31041,7 +31082,7 @@ procedure TSQLRecord.AppendAsJsonObject(W: TJSONSerializer; Fields: TSQLFieldBit var i: integer; Props: TSQLPropInfoList; begin - if Self=nil then begin + if self=nil then begin W.AddShort('null'); exit; end; @@ -31055,7 +31096,7 @@ begin W.Add(',','"'); W.AddNoJSONEscape(pointer(Props.List[i].Name),length(Props.List[i].Name)); W.Add('"',':'); - Props.List[i].GetJSONValues(Self,W); + Props.List[i].GetJSONValues(self,W); end; W.Add('}'); end; @@ -31159,9 +31200,9 @@ begin // no simple field to write -> quick return result := '' else if UsingStream<>nil then begin - UsingStream.Seek(0,soFromBeginning); + UsingStream.Seek(0,soBeginning); GetJSONValues(UsingStream,Expand,withID,Occasion,SQLRecordOptions); - FastSetString(result,UsingStream.Memory,UsingStream.Seek(0,soFromCurrent)); + FastSetString(result,UsingStream.Memory,UsingStream.Seek(0,soCurrent)); end else begin J := TRawByteStringStream.Create; try @@ -31232,15 +31273,17 @@ begin end; for i := 0 to fields.Count-1 do result := result+fields.List[i].Name+','; - tokenizer := 'simple'; + if Props.Kind=rFTS5 then // FTS5 knows ascii/porter/unicode61 + tokenizer := 'ascii' else + tokenizer := 'simple'; // FTS3-4 know simple/porter/unicode61 c := self; repeat ToText(c,cname); // TSQLFTSTest = class(TSQLRecordFTS3Porter) if IdemPChar(pointer(cname),'TSQLRECORDFTS') and (cname[14] in ['3','4','5']) then begin if length(cname)>14 then - tokenizer := copy(cname,15,100); // e.g. TSQLRecordFTS3Porter -> 'Porter' - break; + tokenizer := copy(cname,15,100); + break; // e.g. TSQLRecordFTS3Porter -> 'Porter' end; c := GetClassParent(c); until c=TSQLRecord; @@ -31344,7 +31387,7 @@ var i: integer; begin result := false; if (self=nil) or (Reference=nil) or - (PSQLRecordClass(Reference)^<>PSQLRecordClass(Self)^) or (Reference.fID<>fID) then + (PSQLRecordClass(Reference)^<>PSQLRecordClass(self)^) or (Reference.fID<>fID) then exit; with RecordProps do for i := 0 to length(SimpleFields)-1 do @@ -31402,7 +31445,7 @@ begin for i := 0 to length(CopiableFields)-1 do if CopiableFields[i].SQLFieldType<>sftID then CopiableFields[i].SetValue(self,nil,false) else - TSQLRecord(TSQLPropInfoRTTIInstance(CopiableFields[i]).GetInstance(Self)). + TSQLRecord(TSQLPropInfoRTTIInstance(CopiableFields[i]).GetInstance(self)). ClearProperties; // clear nested allocated TSQLRecord end else for i := 0 to length(CopiableFields)-1 do @@ -31431,7 +31474,7 @@ function TSQLRecord.RecordClass: TSQLRecordClass; begin if self=nil then Result := nil else - Result := PSQLRecordClass(Self)^; + Result := PSQLRecordClass(self)^; end; {$else} function TSQLRecord.RecordClass: TSQLRecordClass; @@ -31473,7 +31516,7 @@ function TSQLRecord.RecordReference(Model: TSQLModel): TRecordReference; begin if (self=nil) or (fID<=0) then result := 0 else begin - result := Model.GetTableIndexExisting(PSQLRecordClass(Self)^); + result := Model.GetTableIndexExisting(PSQLRecordClass(self)^); if result>63 then // TRecordReference handle up to 64=1 shl 6 tables result := 0 else inc(result,fID shl 6); @@ -31586,7 +31629,7 @@ var i,n: integer; SQL: RawUTF8; begin Create; - props := aClient.Model.Props[PSQLRecordClass(Self)^]; + props := aClient.Model.Props[PSQLRecordClass(self)^]; if props.props.JoinedFields=nil then raise EORMException.CreateUTF8('No nested TSQLRecord to JOIN in %',[self]); SQL := props.SQL.SelectAllJoined; @@ -31601,7 +31644,7 @@ begin fFill.fTable.OwnerMustFree := true; n := 0; with props.props do begin // follow SQL.SelectAllJoined columns - fFill.AddMapSimpleFields(Self,SimpleFields,n); + fFill.AddMapSimpleFields(self,SimpleFields,n); for i := 1 to length(JoinedFieldsTable)-1 do begin instance := JoinedFieldsTable[i].Create; JoinedFields[i-1].SetInstance(self,instance); @@ -31913,14 +31956,14 @@ end; function TSQLRecord.GetHasBlob: boolean; begin - if Self=nil then + if self=nil then result := false else result := RecordProps.BlobFields<>nil; end; function TSQLRecord.GetSimpleFieldCount: integer; begin - if Self=nil then + if self=nil then result := 0 else result := length(RecordProps.SimpleFields); end; @@ -32076,8 +32119,8 @@ end; {$ifdef FPC_OR_PUREPASCAL} class function TSQLRecord.RecordProps: TSQLRecordProperties; begin - if Self<>nil then begin - result := PPointer(PtrInt(PtrUInt(Self))+vmtAutoTable)^; + if self<>nil then begin + result := PPointer(PtrInt(PtrUInt(self))+vmtAutoTable)^; if result=nil then result := PropsCreate(self); end else @@ -32311,7 +32354,7 @@ begin end; procedure TSQLRecord.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent); -var F: integer; +var F: PtrInt; types: TSQLFieldTypes; i64: Int64; p: TSQLPropInfo; @@ -32326,18 +32369,18 @@ begin if integer(types)<>0 then begin i64 := aRest.ServerTimestamp; for F := 0 to Fields.Count-1 do begin - p := Fields.List[f]; + p := Fields.List[F]; if p.SQLFieldType in types then - TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(Self,i64); + TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(self,i64); end; end; if sftSessionUserID in HasTypeFields then begin i64 := aRest.GetCurrentSessionUserID; if i64<>0 then for F := 0 to Fields.Count-1 do begin - p := Fields.List[f]; + p := Fields.List[F]; if p.SQLFieldType=sftSessionUserID then - TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(Self,i64); + TSQLPropInfoRTTIInt64(p).fPropInfo.SetInt64Prop(self,i64); end; end; end; @@ -32818,7 +32861,7 @@ begin Kind := rCustomAutoID else Kind := rSQLite3; Props := TSQLModelRecordProperties.Create(self,Table,Kind); - Props.Props.InternalRegisterModel(Self,aIndex,Props); + Props.Props.InternalRegisterModel(self,aIndex,Props); for t := low(t) to high(t) do if fCustomCollationForAll[t]<>'' then Props.Props.SetCustomCollationForAll(t,fCustomCollationForAll[t]); @@ -33489,14 +33532,14 @@ end; function TSQLModel.ActionName(const Action): string; begin - if (Self=nil) or (fActions=nil) then + if (self=nil) or (fActions=nil) then result := '' else result := TSQLRecord.CaptionNameFromRTTI(fActions^.GetEnumName(byte(Action))); end; function TSQLModel.EventName(const Event): string; begin - if (Self=nil) or (fEvents=nil) then + if (self=nil) or (fEvents=nil) then result := '' else result := TSQLRecord.CaptionNameFromRTTI(fEvents^.GetEnumName(byte(Event))); end; @@ -33832,7 +33875,7 @@ begin if fBatchCount>0 then begin // if something to send for i := 0 to fDeletedCount-1 do if fDeletedRecordRef[i]<>0 then - fRest.Cache.NotifyDeletion(fDeletedRecordRef[i] and 63,fDeletedRecordRef[i] shr 6); + fRest.fCache.NotifyDeletion(fDeletedRecordRef[i] and 63,fDeletedRecordRef[i] shr 6); fBatch.CancelLastComma; fBatch.Add(']'); if fTable<>nil then @@ -33884,7 +33927,7 @@ begin if fCalledWithinRest and (FieldBits-Props.SimpleFieldsBits[soUpdate]=[]) then ForceCacheUpdate := true; // safe to update the cache with supplied values if ForceCacheUpdate then - fRest.Cache.Notify(Value,soUpdate) else + fRest.fCache.Notify(Value,soUpdate) else // may not contain all cached fields -> delete from cache AddID(fDeletedRecordRef,fDeletedCount,RecordReference(tableIndex,ID)); result := fBatchCount; @@ -33940,7 +33983,7 @@ begin fAcquireExecution[cmd] := TSQLRestAcquireExecution.Create; AcquireWriteMode := amLocked; AcquireWriteTimeOut := 5000; // default 5 seconds - fRoutingClass := TSQLRestRoutingREST; + fServicesRouting := TSQLRestRoutingREST; {$ifdef WITHLOG} SetLogClass(SQLite3Log); // by default {$endif} @@ -34411,11 +34454,11 @@ end; procedure TSQLRest.SetRoutingClass(aServicesRouting: TSQLRestServerURIContextClass); begin if self<>nil then - if aServicesRouting<>fRoutingClass then + if aServicesRouting<>fServicesRouting then if (aServicesRouting=nil) or (aServicesRouting=TSQLRestServerURIContext) then raise EServiceException.CreateUTF8('Unexpected %.SetRoutingClass(%)', [self,aServicesRouting]) else - fRoutingClass := aServicesRouting; + fServicesRouting := aServicesRouting; end; function TSQLRest.MultiFieldValue(Table: TSQLRecordClass; @@ -34506,7 +34549,7 @@ begin end; function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName, - WhereClause: RawUTF8; Strings: TStrings; IDToIndex: PID=nil): Boolean; + WhereClause: RawUTF8; Strings: TStrings; IDToIndex: PID): Boolean; var Row: integer; aID: TID; T: TSQLTableJSON; @@ -34547,7 +34590,7 @@ end; function TSQLRest.OneFieldValues(Table: TSQLRecordClass; const FieldName, WhereClause, Separator: RawUTF8): RawUTF8; -var i, Len, SepLen, L: integer; +var i, Len, SepLen, L: PtrInt; Lens: TIntegerDynArray; T: TSQLTableJSON; P: PUTF8Char; @@ -34561,13 +34604,12 @@ begin // calculate row values CSV needed memory SetLength(Lens,T.fRowCount); SepLen := length(Separator); - Len := 0; + Len := SepLen*(T.fRowCount-1); for i := 1 to T.fRowCount do begin L := StrLen(T.fResults[i]); // ignore fResults[0] i.e. field name - inc(Len,L+SepLen); + inc(Len,L); Lens[i-1] := L; end; - dec(Len,SepLen); SetLength(result,Len); // add row values as CSV P := pointer(result); @@ -34730,11 +34772,15 @@ end; function TSQLRest.Retrieve(const SQLWhere: RawUTF8; Value: TSQLRecord; const aCustomFieldsCSV: RawUTF8): boolean; var T: TSQLTable; + sql: RawUTF8; begin result := false; if (self=nil) or (Value=nil) then exit; - T := MultiFieldValues(PSQLRecordClass(Value)^,aCustomFieldsCSV,SQLWhere); + sql := Trim(SQLWhere); + if not EndWith(sql,' LIMIT 1') then + sql := sql+' LIMIT 1'; // we keep a single record below + T := MultiFieldValues(PSQLRecordClass(Value)^,aCustomFieldsCSV,sql); if T<>nil then try if T.fRowCount>=1 then begin @@ -34807,7 +34853,7 @@ var Rec: TSQLRecord; begin if (self=nil) or (Table=nil) or (W=nil) then exit; - Rec := Table.CreateAndFillPrepare(Self,FormatSQLWhere,BoundsSQLWhere,CustomFieldsCSV); + Rec := Table.CreateAndFillPrepare(self,FormatSQLWhere,BoundsSQLWhere,CustomFieldsCSV); try Rec.AppendFillAsJsonArray(OutputFieldName,W,Rec.fFill.TableMapFields); finally @@ -34938,7 +34984,7 @@ begin SetVariantNull(result); if (self<>nil) and (Table<>nil) then begin with Table.RecordProps do // optimized primary key direct access - if Cache.IsCached(Table) and (length(BoundsSQLWhere)=1) and + if fCache.IsCached(Table) and (length(BoundsSQLWhere)=1) and VarRecToInt64(BoundsSQLWhere[0],Int64(ID)) and FieldBitsFromCSV(CustomFieldsCSV,bits) and (IdemPropNameU('RowID=?',FormatSQLWhere) or @@ -35540,7 +35586,7 @@ begin exit; if BlobStream.Write(pointer(BlobData)^,length(BlobData))<>length(BlobData) then result := false; - BlobStream.Seek(0,soFromBeginning); // rewind + BlobStream.Seek(0,soBeginning); // rewind end; function TSQLRest.UpdateBlob(Table: TSQLRecordClass; aID: TID; @@ -35551,9 +35597,9 @@ begin result := false; if (self=nil) or (BlobData=nil) then exit; - L := BlobData.Seek(0,soFromEnd); + L := BlobData.Seek(0,soEnd); SetLength(Blob,L); - BlobData.Seek(0,soFromBeginning); + BlobData.Seek(0,soBeginning); if BlobData.Read(pointer(Blob)^,L)<>L then exit; result := UpdateBlob(Table,aID,BlobFieldName,Blob); @@ -35622,7 +35668,7 @@ var BlobData: TSQLRawBlob; TableIndex, i: integer; begin result := false; - if (Self=nil) or (Value=nil) or (Value.fID<=0) then + if (self=nil) or (Value=nil) or (Value.fID<=0) then exit; with Value.RecordProps do if BlobFields<>nil then begin @@ -35717,7 +35763,7 @@ begin end; function TSQLRest.MainFieldValue(Table: TSQLRecordClass; ID: TID; - ReturnFirstIfNoUnique: boolean=false): RawUTF8; + ReturnFirstIfNoUnique: boolean): RawUTF8; begin if (self=nil) or (Table=nil) or (ID<=0) then result := '' else begin @@ -35836,7 +35882,7 @@ procedure TSQLRest.EndCurrentThread(Sender: TThread); begin // most will be done e.g. in TSQLRestServer.EndCurrentThread {$ifdef WITHLOG} fLogFamily.OnThreadEnded(Sender); - {$endif} + {$endif WITHLOG} end; procedure TSQLRest.WriteLock; @@ -35917,7 +35963,7 @@ begin end; end; -{$endif} +{$endif ISDELPHI2010} { TSQLRestCacheEntry } @@ -36723,7 +36769,7 @@ end; function TSQLRestClientURI.ServerInternalState: cardinal; begin - if (Self=nil) or (Model=nil) then // avoid GPF + if (self=nil) or (Model=nil) then // avoid GPF result := cardinal(-1) else result := URI(Model.Root,'STATE').Hi; end; @@ -36731,7 +36777,7 @@ end; function TSQLRestClientURI.ServerCacheFlush(aTable: TSQLRecordClass; aID: TID): boolean; var aResp: RawUTF8; begin - if (Self=nil) or (Model=nil) then // avoid GPF + if (self=nil) or (Model=nil) then // avoid GPF result := false else result := CallBackGet('CacheFlush',[],aResp,aTable,aID) in [HTTP_SUCCESS,HTTP_NOCONTENT]; end; @@ -36778,7 +36824,7 @@ begin fServiceNotificationMethodViaMessages.Msg := Msg; end; -class procedure TSQLRestClientURI.ServiceNotificationMethodExecute(var Msg : TMessage); +class procedure TSQLRestClientURI.ServiceNotificationMethodExecute(var Msg: TMessage); var exec: TSQLRestClientURIServiceNotification; begin exec := pointer(Msg.LParam); @@ -36995,7 +37041,7 @@ end; {$endif LVCL} function TSQLRestClientURI.ServerRemoteLog(Level: TSynLogInfo; - FormatMsg: PUTF8Char; const Args: array of const): boolean; + const FormatMsg: RawUTF8; const Args: array of const): boolean; begin result := ServerRemoteLog(nil,Level, FormatUTF8('%00% %',[NowToString(false),LOG_LEVEL_TEXT[Level], @@ -37035,8 +37081,8 @@ begin fRemoteLogClass := nil; end; -function TSQLRestClientURI.UpdateFromServer(const Data: array of TObject; out Refreshed: boolean; - PCurrentRow: PInteger): boolean; +function TSQLRestClientURI.UpdateFromServer(const Data: array of TObject; + out Refreshed: boolean; PCurrentRow: PInteger): boolean; // notes about refresh mechanism: // - if server doesn't implement InternalState, its value is 0 -> always refresh // - if any TSQLTableJSON or TSQLRecord belongs to a TSQLRestStorage, @@ -37216,7 +37262,7 @@ begin fSafe := TAutoLockerDebug.Create(fLogClass,aModel.Root); // more verbose {$else} fSafe := TAutoLocker.Create; - {$endif} + {$endif USELOCKERDEBUG} end; destructor TSQLRestClientURI.Destroy; @@ -37421,17 +37467,16 @@ begin exit; InternalURI(Call^); if ((Sender=nil) or OnIdleBackgroundThreadActive) and - not(isDestroying in fInternalState) then + not(isDestroying in fInternalState) then begin if (Call^.OutStatus=HTTP_NOTIMPLEMENTED) and (isOpened in fInternalState) then begin InternalClose; // force recreate connection Exclude(fInternalState,isOpened); - if ((Sender=nil) or OnIdleBackgroundThreadActive) then begin + if ((Sender=nil) or OnIdleBackgroundThreadActive) then InternalURI(Call^); // try request again - if Call^.OutStatus<>HTTP_NOTIMPLEMENTED then - Include(fInternalState,isOpened); - end; - end else + end; + if Call^.OutStatus<>HTTP_NOTIMPLEMENTED then Include(fInternalState,isOpened); + end; end; function TSQLRestClientURI.GetOnIdleBackgroundThreadActive: boolean; @@ -37472,7 +37517,7 @@ var retry: Integer; begin Call.Url := url; // reset to allow proper re-sign if fSessionAuthentication<>nil then - fSessionAuthentication.ClientSessionSign(Self,Call); + fSessionAuthentication.ClientSessionSign(self,Call); Call.Method := method; if SendData<>nil then Call.InBody := SendData^; @@ -37482,7 +37527,7 @@ var retry: Integer; if Assigned(fOnIdle) then begin if fBackgroundThread=nil then fBackgroundThread := TSynBackgroundThreadEvent.Create(OnBackgroundProcess, - OnIdle,FormatUTF8('% % background',[Self,Model.Root])); + OnIdle,FormatUTF8('% % background',[self,Model.Root])); if not fBackgroundThread.RunAndWait(@Call) then Call.OutStatus := HTTP_UNAVAILABLE; end else @@ -37500,7 +37545,7 @@ var retry: Integer; end; begin - if Self=nil then begin + if self=nil then begin Int64(result) := HTTP_UNAVAILABLE; SetLastException(nil,HTTP_UNAVAILABLE); exit; @@ -37549,7 +37594,7 @@ begin InternalLog('% % returned % (%) with message %', [method,url,Call.OutStatus,StatusMsg,fLastErrorMessage],sllError); if Assigned(fOnFailed) then - fOnFailed(Self,nil,@Call); + fOnFailed(self,nil,@Call); end; except on E: Exception do begin @@ -38186,7 +38231,7 @@ begin aMethodName := trim(aMethodName); if aMethodName='' then raise EServiceException.CreateUTF8('%.ServiceMethodRegister('''')',[self]); - if Model.GetTableIndex(aMethodName)>=0 then + if not(rsoNoTableURI in fOptions) and (Model.GetTableIndex(aMethodName)>=0) then raise EServiceException.CreateUTF8('Published method name %.% '+ 'conflicts with a Table in the Model!',[self,aMethodName]); with PSQLRestServerMethod(fPublishedMethods.AddUniqueName(aMethodName, @@ -38295,16 +38340,16 @@ begin end; end; -procedure TSQLRestServer.CreateMissingTables(user_version: cardinal=0; - Options: TSQLInitializeTableOptions=[]); +procedure TSQLRestServer.CreateMissingTables(user_version: cardinal; + Options: TSQLInitializeTableOptions); begin fCreateMissingTablesOptions := Options; end; procedure TSQLRestServer.InitializeTables(Options: TSQLInitializeTableOptions); -var t: integer; +var t: PtrInt; begin - if (Self<>nil) and (Model<>nil) then + if (self<>nil) and (Model<>nil) then for t := 0 to Model.TablesMax do if not TableHasRows(Model.Tables[t]) then Model.Tables[t].InitializeTable(self,'',Options); @@ -38317,7 +38362,7 @@ begin end; destructor TSQLRestServer.Destroy; -var i: integer; +var i: PtrInt; begin Shutdown; if GlobalURIRequestServer=self then begin @@ -38330,7 +38375,7 @@ begin CloseServerMessage; {$endif} AsynchBatchStop(nil); // may use fStaticData[] - FreeAndNil(fBackgroundTimer); + FreeAndNil(fBackgroundTimer); // do it ASAP fRecordVersionSlaveCallbacks := nil; // should be done before fServices.Free for i := 0 to high(fStaticVirtualTable) do if fStaticVirtualTable[i]<>nil then begin @@ -39176,7 +39221,7 @@ end; function TSQLRestServer.CreateSQLIndex(Table: TSQLRecordClass; const FieldNames: array of RawUTF8; Unique: boolean): boolean; -var i: integer; +var i: PtrInt; begin result := true; for i := 0 to high(FieldNames) do @@ -39199,7 +39244,7 @@ end; function TSQLRestServer.AuthenticationRegister( aMethod: TSQLRestServerAuthenticationClass): TSQLRestServerAuthentication; -var i: integer; +var i: PtrInt; begin result := nil; if self=nil then @@ -39229,14 +39274,14 @@ end; procedure TSQLRestServer.AuthenticationRegister( const aMethods: array of TSQLRestServerAuthenticationClass); -var i: integer; +var i: PtrInt; begin for i := 0 to high(aMethods) do AuthenticationRegister(aMethods[i]); end; procedure TSQLRestServer.AuthenticationUnregister(aMethod: TSQLRestServerAuthenticationClass); -var i: integer; +var i: PtrInt; begin if (self=nil) or (fSessionAuthentication=nil) then exit; @@ -39255,7 +39300,7 @@ end; procedure TSQLRestServer.AuthenticationUnregister( const aMethods: array of TSQLRestServerAuthenticationClass); -var i: integer; +var i: PtrInt; begin for i := 0 to high(aMethods) do AuthenticationUnregister(aMethods[i]); @@ -39275,7 +39320,7 @@ begin end; function TSQLRestServer.ServiceMethodByPassAuthentication(const aMethodName: RawUTF8): integer; -var i: integer; +var i: PtrInt; begin result := -1; if self=nil then @@ -39479,7 +39524,9 @@ end; procedure TSQLRestServerURIContext.InternalSetTableFromTableName(TableName: PUTF8Char); begin TableEngine := Server; - InternalSetTableFromTableIndex(Server.Model.GetTableIndexPtr(TableName)); + if rsoNoTableURI in Server.Options then + TableIndex := -1 else + InternalSetTableFromTableIndex(Server.Model.GetTableIndexPtr(TableName)); if TableIndex<0 then exit; Static := Server.GetStaticTableIndex(TableIndex,StaticKind); @@ -39544,6 +39591,13 @@ begin // expects 'ModelRoot[/TableName[/TableID][/URIBlobFieldName]][?param=...] TableID := GetCardinalDef(pointer(PtrInt(URIBlobFieldName)+j),cardinal(-1)); SetLength(URIBlobFieldName,j-1); end; + end else if rsoMethodUnderscoreAsSlashURI in Server.Options then begin + URIUnderscoreAsSlash := URI; + i := slash; // set e.g. 'Method_Name' from 'ModelRoot/Method/Name' URI + repeat + URIUnderscoreAsSlash[i] := '_'; + i := PosEx('/',URI,i+1); + until i=0; end; SetLength(URI,slash-1); end else @@ -39562,8 +39616,12 @@ end; procedure TSQLRestServerURIContext.URIDecodeSOAByMethod; begin if Table=nil then + begin // check URI as 'ModelRoot/MethodName' - MethodIndex := Server.fPublishedMethods.FindHashed(URI) else + MethodIndex := Server.fPublishedMethods.FindHashed(URI); + if (MethodIndex<0) and (URIUnderscoreAsSlash<>'') then + MethodIndex := Server.fPublishedMethods.FindHashed(URIUnderscoreAsSlash); + end else if URIBlobFieldName<>'' then // check URI as 'ModelRoot/TableName[/TableID]/MethodName' MethodIndex := Server.fPublishedMethods.FindHashed(URIBlobFieldName) else @@ -39777,6 +39835,7 @@ procedure TSQLRestServerURIContext.ExecuteSOAByMethod; var timeStart,timeEnd: Int64; sessionstat: TSynMonitorInputOutput; begin + if MethodIndex >= 0 then with Server.fPublishedMethod[MethodIndex] do begin if mlMethods in Server.StatLevels then begin {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(timeStart); @@ -40285,7 +40344,7 @@ var OK: boolean; Blob: PPropInfo; SQLSelect, SQLWhere, SQLSort, SQLDir: RawUTF8; begin - if MethodIndex=Server.fPublishedMethodBatchIndex then begin + if (MethodIndex>=0) and (MethodIndex=Server.fPublishedMethodBatchIndex) then begin ExecuteSOAByMethod; // run the BATCH process in execORMWrite context exit; end; @@ -40881,7 +40940,7 @@ begin (Length(Result)>64) then begin FindNameValue(Call.InHead,'IF-NONE-MATCH: ',clientHash); if ServerHash='' then - ServerHash := '"'+crc32cUTF8ToHex(Result)+'"'; + ServerHash := crc32cUTF8ToHex(Result); ServerHash := '"'+ServerHash+'"'; if clientHash<>ServerHash then Call.OutHead := Call.OutHead+#13#10'ETag: '+ServerHash else begin @@ -41845,10 +41904,10 @@ begin case Ctxt.Method of mGET: begin if Ctxt.Table=nil then - Cache.Flush else + fCache.Flush else if Ctxt.TableID=0 then - Cache.Flush(Ctxt.Table) else - Cache.SetCache(Ctxt.Table,Ctxt.TableID); + fCache.Flush(Ctxt.Table) else + fCache.SetCache(Ctxt.Table,Ctxt.TableID); Ctxt.Success; end; mPOST: @@ -41966,7 +42025,7 @@ begin end; procedure TSQLRestServer.Auth(Ctxt: TSQLRestServerURIContext); -var i: integer; +var i: PtrInt; begin if fSessionAuthentication=nil then exit; @@ -42016,7 +42075,7 @@ end; procedure TSQLRestServer.SessionDelete(aSessionIndex: integer; Ctxt: TSQLRestServerURIContext); var sess: TAuthSession; -begin +begin // caller made fSessions.Safe.Lock if (self<>nil) and (cardinal(aSessionIndex)nil then @@ -42033,38 +42092,48 @@ begin end; end; +function TSQLRestServer.SessionDeleteDeprecated: cardinal; +var i: PtrInt; +begin // caller made fSessions.Safe.Lock + result := GetTickCount64 shr 10; + if (self<>nil) and (fSessions<>nil) then begin + if result<>fSessionsDeprecatedTix then begin + fSessionsDeprecatedTix := result; // check sessions every second + for i := fSessions.Count-1 downto 0 do + if result>TAuthSession(fSessions.List[i]).TimeOutTix then + SessionDelete(i,nil); + end; + end; +end; + function TSQLRestServer.SessionAccess(Ctxt: TSQLRestServerURIContext): TAuthSession; var i: integer; tix, session: cardinal; sessions: ^TAuthSession; -begin // caller of RetrieveSession() made fSessions.Safe.Lock +begin // caller made fSessions.Safe.Lock if (self<>nil) and (fSessions<>nil) then begin - tix := GetTickCount64 shr 10; - if tix<>fSessionsDeprecatedTix then begin - fSessionsDeprecatedTix := tix; // check deprecated sessions every second - for i := fSessions.Count-1 downto 0 do - if tix>TAuthSession(fSessions.List[i]).TimeOutTix then - SessionDelete(i,nil); - end; + // check deprecated sessions every second + tix := SessionDeleteDeprecated; // retrieve session from its ID sessions := pointer(fSessions.List); session := Ctxt.Session; - for i := 1 to fSessions.Count do - if sessions^.IDCardinal=session then begin - result := sessions^; - result.fTimeOutTix := tix+result.TimeoutShr10; - Ctxt.fSession := result; // for TSQLRestServer internal use - // make local copy of TAuthSession information - Ctxt.SessionUser := result.User.fID; - Ctxt.SessionGroup := result.User.GroupRights.fID; - Ctxt.SessionUserName := result.User.LogonName; - if (result.RemoteIP<>'') and (Ctxt.fRemoteIP='') then - Ctxt.fRemoteIP := result.RemoteIP; - Ctxt.fSessionAccessRights := result.fAccessRights; - Ctxt.Call^.RestAccessRights := @Ctxt.fSessionAccessRights; - exit; - end else - inc(sessions); + if session>CONST_AUTHENTICATION_NOT_USED then + for i := 1 to fSessions.Count do + if sessions^.IDCardinal=session then begin + result := sessions^; + result.fTimeOutTix := tix+result.TimeoutShr10; + Ctxt.fSession := result; // for TSQLRestServer internal use + // make local copy of TAuthSession information + Ctxt.SessionUser := result.User.fID; + Ctxt.SessionGroup := result.User.GroupRights.fID; + Ctxt.SessionUserName := result.User.LogonName; + if (result.RemoteIP<>'') and (Ctxt.fRemoteIP='') then + Ctxt.fRemoteIP := result.RemoteIP; + Ctxt.fSessionAccessRights := result.fAccessRights; + Ctxt.Call^.RestAccessRights := @Ctxt.fSessionAccessRights; + exit; + end else + inc(sessions); end; result := nil; end; @@ -42305,7 +42374,7 @@ class procedure TSQLRecordHistory.InitializeTable(Server: TSQLRestServer; begin inherited InitializeTable(Server,FieldName,Options); if FieldName='' then - Server.CreateSQLMultiIndex(Self,['ModifiedRecord','Event'],false); + Server.CreateSQLMultiIndex(self,['ModifiedRecord','Event'],false); end; destructor TSQLRecordHistory.Destroy; @@ -42857,7 +42926,7 @@ begin if (Model.TableProps[TableModelIndex].Props.RecordVersionField=nil) or not result then exit; - Batch := TSQLRestBatch.Create(Self,Model.Tables[TableModelIndex],1000); + Batch := TSQLRestBatch.Create(self,fSQLRecordVersionDeleteTable,1000); try for i := 0 to high(IDs) do InternalRecordVersionDelete(TableModelIndex,IDs[i],Batch); @@ -42945,7 +43014,7 @@ var EndOfObject: AnsiChar; for i := 0 to high(RunTableTransactions) do if RunTableTransactions[i]<>nil then begin RunTableTransactions[i].Commit(CONST_AUTHENTICATION_NOT_USED,true); - if RunTableTransactions[i]=Self then + if RunTableTransactions[i]=self then RunMainTransaction := false; RunTableTransactions[i] := nil; // to acquire and begin a new transaction end; @@ -44775,7 +44844,7 @@ function TSQLRestStorageInMemory.FindWhereEqual(const WhereFieldName, WhereValue var WhereFieldIndex: integer; begin result := 0; - if (Self=nil) or not Assigned(OnFind) then + if (self=nil) or not Assigned(OnFind) then exit; if IsRowID(pointer(WhereFieldName)) then WhereFieldIndex := 0 else begin @@ -45211,7 +45280,7 @@ begin // now fValue[] contains the just loaded data cf := 'ID' else for f := 0 to high(fUnique) do if f in fIsUnique then begin - c := fUnique[f].Hasher.ReHash({forced=}true,{grow=}false); + c := fUnique[f].Hasher.ReHash({forced=}true); if c>0 then begin cf := fUnique[f].PropInfo.Name; break; @@ -45929,6 +45998,7 @@ begin n := FindWhereEqual(WhereField,FieldValue,DoAddToListEvent,match,0,0); if n=0 then exit; + result := true; SetLength(ResultID,n); for i := 0 to n-1 do ResultID[i] := TSQLRecord(match.List[i]).fID; @@ -46752,7 +46822,7 @@ begin for t := 0 to fStaticDataCount-1 do with TSQLRestStorageInMemory(fStaticData[t]) do if Count=0 then // emulates TSQLRestServerDB.CreateMissingTables - StoredClass.InitializeTable(Self,'',Options); + StoredClass.InitializeTable(self,'',Options); end; destructor TSQLRestServerFullMemory.Destroy; @@ -47303,7 +47373,7 @@ begin FreeAndNil(fLogTableStorage); exit; end; - fLogTableStorage.Seek(0,soFromBeginning); + fLogTableStorage.Seek(0,soBeginning); fLogTableStorage.WriteBuffer(Pointer(aJSON)^,L-2); end; @@ -49379,8 +49449,8 @@ begin inherited Create; with RecordProps do if (fRecordManySourceProp<>nil) and (fRecordManyDestProp<>nil) then begin - fSourceID := fRecordManySourceProp.GetFieldAddr(Self); - fDestID := fRecordManyDestProp.GetFieldAddr(Self); + fSourceID := fRecordManySourceProp.GetFieldAddr(self); + fDestID := fRecordManyDestProp.GetFieldAddr(self); end; end; @@ -49464,7 +49534,7 @@ begin end; begin result := nil; - if (Self=nil) or (fSourceID=nil) or (fDestID=nil) or (aClient=nil) then + if (self=nil) or (fSourceID=nil) or (fDestID=nil) or (aClient=nil) then exit; if aSourceID=0 then if fSourceID<>nil then @@ -49499,7 +49569,7 @@ begin SQL := 'SELECT % FROM %,% WHERE %.Source=:(%): AND %.Dest=%.RowID AND %' else // statement is not globaly inlined -> no caching of prepared statement SQL := 'SELECT % FROM %,% WHERE %.Source=% AND %.Dest=%.RowID AND %'; - result := aClient.ExecuteList([PSQLRecordClass(Self)^, + result := aClient.ExecuteList([PSQLRecordClass(self)^, TSQLRecordClass(SelfProps.Props.fRecordManyDestProp.ObjectClass)], FormatUTF8(SQL, [Select, DestProps.Props.SQLTableName,SelfProps.Props.SQLTableName, @@ -49542,7 +49612,7 @@ begin if (self=nil) or (aClient=nil) or (aSourceID=0) or (aDestID=0) then result := false else // invalid parameters result := aClient.Retrieve(FormatUTF8('Source=:(%): AND Dest=:(%):', - [aSourceID,aDestID]),Self); + [aSourceID,aDestID]),self); end; function TSQLRecordMany.ManySelect(aClient: TSQLRest; aDestID: TID): boolean; @@ -50239,7 +50309,7 @@ end; function TSQLRecordProperties.CreateJSONWriter(JSON: TStream; Expand, withID: boolean; const aFields: TSQLFieldIndexDynArray; KnownRowsCount,aBufSize: integer): TJSONSerializer; begin - if (self=nil) or ((Fields=nil) and not withID) then // no data + if (self=nil) or ((Fields.Count=0) and not withID) then // no data result := nil else begin result := TJSONSerializer.Create(JSON,Expand,withID,aFields,aBufSize); SetJSONWriterColumnNames(result,KnownRowsCount); @@ -50893,7 +50963,7 @@ var Added: boolean; AddDateTime(D64); if woDateTimeWithZSuffix in Options then if frac(D64)=0 then // FireFox can't decode short form "2017-01-01Z" - AddShort('T00:00Z') else + AddShort('T00:00:00Z') else // the same pattern for date and dateTime Add('Z'); Add('"'); end; @@ -50970,11 +51040,12 @@ var Added: boolean; {$endif NOVARIANTS} tkClass: begin Obj := P^.GetObjProp(Value); - if not(woDontStore0 in Options) or not IsObjectDefaultOrVoid(Obj) then + if Obj<>nil then if PropIsIDTypeCastedField(P,IsObj,Value) then begin HR(P); Add(PtrInt(Obj)); // not true instances, but ID - end else if Obj<>nil then begin + end else + if not(woDontStore0 in Options) or not IsObjectDefaultOrVoid(Obj) then begin HR(P); // TPersistent or any class defined with $M+ WriteObject(Obj,Options); end; @@ -51239,7 +51310,7 @@ end; function TSQLVirtualTable.Prepare(var Prepared: TSQLVirtualTablePrepared): boolean; begin - result := Self<>nil; + result := self<>nil; if result then if (vtWhereIDPrepared in fModule.Features) and Prepared.IsWhereIDEquals(true) then @@ -51309,7 +51380,7 @@ end; function TSQLVirtualTable.Structure: RawUTF8; begin result := ''; - if Self<>nil then + if self<>nil then if (Static<>nil) then // e.g. for TSQLVirtualTableJSON or TSQLVirtualTableExternal Result := StructureFromClass(StaticTable,TableName) else @@ -52677,7 +52748,7 @@ const function TSQLRestServerAuthenticationSSPI.Auth( Ctxt: TSQLRestServerURIContext): boolean; -var i: integer; +var i: PtrInt; UserName, InDataEnc: RawUTF8; ticks,ConnectionID: Int64; BrowserAuth: Boolean; @@ -52797,8 +52868,10 @@ begin // 1st call will return data, 2nd call SessionKey result := ClientGetSessionKey(Sender,User,['UserName','','data',BinToBase64(OutData)]); until Sender.fSessionData=''; - if result<>'' then - result := SecDecrypt(SecCtx,Base64ToBin(result)); + if result<>'' then begin + OutData := Base64ToBin(result); + result := SecDecrypt(SecCtx,{$ifdef MSWINDOWS}TSSPIBuffer{$endif}(OutData)); + end; finally FreeSecContext(SecCtx); end; @@ -52813,7 +52886,7 @@ begin end; destructor TSQLRestServerAuthenticationSSPI.Destroy; -var i: integer; +var i: PtrInt; begin for i := 0 to High(fSSPIAuthContexts) do FreeSecContext(fSSPIAuthContexts[i]); @@ -52886,7 +52959,7 @@ begin exit; CheckInterface(aInterfaces); for i := 0 to high(aInterfaces) do begin - F := ServicesFactoryClients.Create( + F := fServicesFactoryClients.Create( Rest,aInterfaces[i],aInstanceCreation,aContractExpected); AddServiceInternal(F); aContractExpected := ''; // supplied contract is only for the 1st interface @@ -52899,7 +52972,7 @@ function TServiceContainer.AddInterface(aInterface: PTypeInfo; const aContractExpected: RawUTF8): TServiceFactoryClient; begin CheckInterface([aInterface]); - result := ServicesFactoryClients.Create(Rest,aInterface,aInstanceCreation,aContractExpected); + result := fServicesFactoryClients.Create(Rest,aInterface,aInstanceCreation,aContractExpected); AddServiceInternal(result); end; @@ -53282,7 +53355,7 @@ const // always aligned to 8 bytes boundaries for 64-bit ARGS_IN_STACK_SIZE: array[TServiceMethodValueType] of Cardinal = ( 0, PTRSIZ,PTRSIZ, PTRSIZ,PTRSIZ,PTRSIZ, PTRSIZ, 8, 8, 8, - // None, Self, Boolean, Enum, Set, Integer, Cardinal, Int64, Double, DateTime, + // None, self, Boolean, Enum, Set, Integer, Cardinal, Int64, Double, DateTime, 8, PTRSIZ, PTRSIZ, PTRSIZ, PTRSIZ, 0, PTRSIZ, // Currency, RawUTF8, String, RawByteString, WideString, Binary, Record, {$ifndef NOVARIANTS}PTRSIZ,{$endif} // Variant @@ -54750,7 +54823,7 @@ begin {$endif KYLIX3} if fStub=MAP_FAILED then {$endif MSWINDOWS} - raise EServiceException.CreateUTF8('%.Create: OS memory allocation failed',[Self]); + raise EServiceException.CreateUTF8('%.Create: OS memory allocation failed',[self]); end; destructor TFakeStubBuffer.Destroy; @@ -55354,6 +55427,7 @@ begin batch := fBackgroundBatch[b]; if batch.Count=0 then continue; + data := ''; batch.Safe.Lock; try table := batch.Table; @@ -55643,8 +55717,7 @@ type end; TInterfacedObjectMultiDestDynArray = array of TInterfacedObjectMultiDest; TInterfacedObjectMulti = class; - TInterfacedObjectMultiList = class(TInterfacedObjectLocked, - IMultiCallbackRedirect) + TInterfacedObjectMultiList = class(TInterfacedObjectLocked, IMultiCallbackRedirect) protected fDest: TInterfacedObjectMultiDestDynArray; fDestCount: integer; @@ -57291,7 +57364,7 @@ end; function TServiceFactory.GetInterfaceTypeInfo: PTypeInfo; begin - if (Self<>nil) and (fInterface<>nil) then + if (self<>nil) and (fInterface<>nil) then result := fInterface.fInterfaceTypeInfo else result := nil; end; @@ -58067,7 +58140,7 @@ begin fImplementationClass.GetInterfaceEntry(fInterface.fInterfaceIID); if fImplementationClassInterfaceEntry=nil then raise EServiceException.CreateUTF8('%.Create: % does not implement I%', - [self,fImplementationClass,fInterfaceURI]) else + [self,fImplementationClass,fInterfaceURI]); end; if (fInterface.MethodIndexCallbackReleased>=0) and (InstanceCreation<>sicShared) then @@ -58371,17 +58444,16 @@ begin raise EInterfaceFactoryException.CreateUTF8( 'ickFromInjectedResolver: TryResolveInternal(%)=false',[fInterface.fInterfaceName]); result := TInterfacedObject(ObjectFromInterface(IInterface(dummyObj))); - if AndIncreaseRefCount then // RefCount=1 after TryResolveInternal() - AndIncreaseRefCount := false else - dec(TInterfacedObjectHooked(result).FRefCount); + dec(TInterfacedObjectHooked(result).FRefCount); // RefCount=1 after TryResolveInternal() end; else result := fImplementationClass.Create; end; + inc(TInterfacedObjectHooked(result).FRefCount); // >0 to call Support() in event if Assigned(TSQLRestServer(Rest).OnServiceCreateInstance) then TSQLRestServer(Rest).OnServiceCreateInstance(self,result); - if AndIncreaseRefCount then - IInterface(result)._AddRef; // allow passing self to sub-methods + if not AndIncreaseRefCount then + dec(TInterfacedObjectHooked(result).FRefCount); end; procedure TServiceFactoryServer.OnLogRestExecuteMethod(Sender: TServiceMethodExecute; @@ -58625,7 +58697,8 @@ begin if not execres then begin if err<>'' then Ctxt.Error('%',[err],HTTP_NOTACCEPTABLE) else - Error('execution failed (probably due to bad input parameters)',HTTP_NOTACCEPTABLE); + Error('execution failed (probably due to bad input parameters: ' + + 'e.g. did you initialize your input record(s)?)',HTTP_NOTACCEPTABLE); exit; // wrong request end; Ctxt.Call.OutHead := exec.ServiceCustomAnswerHead; @@ -60389,7 +60462,7 @@ begin end; end; // prepare the low-level call context for the asm stub - //Pass the Self (also named $this) + //Pass the self (also named $this) call.ParamRegs[PARAMREG_FIRST] := PtrInt(Instances[i]); call.method := PPtrIntArray(PPointer(Instances[i])^)^[ExecutionMethodIndex]; if ArgsResultIndex>=0 then @@ -60572,7 +60645,7 @@ begin inc(Par); '{': begin // retrieve parameters values from JSON object repeat inc(Par) until not(Par^ in [#1..' ']); - if Par<>'}' then begin + if Par^<>'}' then begin ParObjValuesUsed := true; FillCharFast(ParObjValues,(ArgsInLast+1)*SizeOf(pointer),0); // := nil a1 := ArgsInFirst; @@ -60685,7 +60758,7 @@ class procedure TSQLRecordServiceLog.InitializeTable( begin inherited; if FieldName='' then - Server.CreateSQLMultiIndex(Self,['Method','MicroSec'],false); + Server.CreateSQLMultiIndex(self,['Method','MicroSec'],false); end; @@ -60697,7 +60770,7 @@ class procedure TSQLRecordServiceNotifications.InitializeTable( begin inherited; if (FieldName='') or (FieldName='Sent') then - Server.CreateSQLMultiIndex(Self,['Sent'],false); + Server.CreateSQLMultiIndex(self,['Sent'],false); end; class function TSQLRecordServiceNotifications.LastEventsAsObjects(Rest: TSQLRest; @@ -61169,7 +61242,7 @@ var baseuri,uri,sent,resp,clientDrivenID,head,error,ct: RawUTF8; end; begin result := false; - if Self=nil then + if self=nil then exit; if fClient=nil then fClient := fRest as TSQLRestClientURI; @@ -61350,7 +61423,7 @@ function TServiceFactoryClient.Get(out Obj): Boolean; var O: TInterfacedObjectFake; begin result := false; - if Self=nil then + if self=nil then exit; case fInstanceCreation of sicShared, sicPerSession, sicPerUser, sicPerGroup, sicPerThread: diff --git a/contrib/mORMot/SQLite3/mORMotBigTable.pas b/contrib/mORMot/SQLite3/mORMotBigTable.pas index ad9b356..a60b5fb 100644 --- a/contrib/mORMot/SQLite3/mORMotBigTable.pas +++ b/contrib/mORMot/SQLite3/mORMotBigTable.pas @@ -6,7 +6,7 @@ unit mORMotBigTable; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotBigTable; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotDB.pas b/contrib/mORMot/SQLite3/mORMotDB.pas index 55302c5..df24b20 100644 --- a/contrib/mORMot/SQLite3/mORMotDB.pas +++ b/contrib/mORMot/SQLite3/mORMotDB.pas @@ -6,7 +6,7 @@ unit mORMotDB; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -79,7 +79,8 @@ type // - Handled=FALSE would let the default ID computation take place // - note that execution of this method would be protected by a mutex, so // it would be thread-safe - TOnEngineAddComputeID = function(Sender: TSQLRestStorageExternal; var Handled: Boolean): TID of object; + TOnEngineAddComputeID = function(Sender: TSQLRestStorageExternal; + var Handled: Boolean): TID of object; /// REST server with direct access to a SynDB-based external database // - handle all REST commands, using the external SQL database connection, @@ -119,21 +120,25 @@ type fBatchIDs: TIDDynArray; /// get fFieldsExternal[] index using fFieldsExternalToInternal[] mapping // - do handle ID/RowID fields and published methods - function InternalFieldNameToFieldExternalIndex(const InternalFieldName: RawUTF8): integer; + function InternalFieldNameToFieldExternalIndex( + const InternalFieldName: RawUTF8): integer; /// create, prepare and bound inlined parameters to a thread-safe statement // - this implementation will call the ThreadSafeConnection virtual method, // then bound inlined parameters as :(1234): and call its Execute method // - should return nil on error, and not raise an exception function PrepareInlinedForRows(const aSQL: RawUTF8): ISQLDBStatement; /// overloaded method using FormatUTF8() and binding SynDB parameters - function PrepareDirectForRows(SQLFormat: PUTF8Char; const Args, Params: array of const): ISQLDBStatement; + function PrepareDirectForRows(SQLFormat: PUTF8Char; + const Args, Params: array of const): ISQLDBStatement; /// create, prepare, bound inlined parameters and execute a thread-safe statement // - this implementation will call the ThreadSafeConnection virtual method, // then bound inlined parameters as :(1234): and call its Execute method // - should return nil on error, and not raise an exception - function ExecuteInlined(const aSQL: RawUTF8; ExpectResults: Boolean): ISQLDBRows; overload; + function ExecuteInlined(const aSQL: RawUTF8; + ExpectResults: Boolean): ISQLDBRows; overload; /// overloaded method using FormatUTF8() and inlined parameters - function ExecuteInlined(SQLFormat: PUTF8Char; const Args: array of const; ExpectResults: Boolean): ISQLDBRows; overload; + function ExecuteInlined(SQLFormat: PUTF8Char; const Args: array of const; + ExpectResults: Boolean): ISQLDBRows; overload; /// overloaded method using FormatUTF8() and binding SynDB parameters function ExecuteDirect(SQLFormat: PUTF8Char; const Args, Params: array of const; ExpectResults: Boolean): ISQLDBRows; @@ -146,10 +151,12 @@ type function EngineExecute(const aSQL: RawUTF8): boolean; override; function EngineLockedNextID: TID; virtual; function EngineAdd(TableModelIndex: integer; const SentData: RawUTF8): TID; override; - function EngineUpdate(TableModelIndex: integer; ID: TID; const SentData: RawUTF8): boolean; override; + function EngineUpdate(TableModelIndex: integer; ID: TID; const + SentData: RawUTF8): boolean; override; function EngineDeleteWhere(TableModelIndex: integer; const SQLWhere: RawUTF8; const IDs: TIDDynArray): boolean; override; - function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; ReturnedRowCount: PPtrInt=nil): RawUTF8; override; + function EngineList(const SQL: RawUTF8; ForceAJAX: Boolean=false; + ReturnedRowCount: PPtrInt=nil): RawUTF8; override; // BLOBs should be access directly, not through slower JSON Base64 encoding function EngineRetrieveBlob(TableModelIndex: integer; aID: TID; BlobField: PPropInfo; out BlobData: TSQLRawBlob): boolean; override; @@ -224,7 +231,8 @@ type // - must be ended with Commit on success // - must be aborted with Rollback if any SQL statement failed // - return true if no transaction is active, false otherwise - function TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean; override; + function TransactionBegin(aTable: TSQLRecordClass; + SessionID: cardinal=1): boolean; override; /// end a transaction (implements REST END Member) // - write all pending SQL statements to the external database procedure Commit(SessionID: cardinal=1; RaiseException: boolean=false); override; @@ -363,8 +371,8 @@ type // and TSQLRestStorageExternal as the related static class // - no particular class is supplied here, since it will depend on the // associated Static TSQLRestStorageExternal instance - class procedure GetTableModuleProperties(var aProperties: TVirtualTableModuleProperties); - override; + class procedure GetTableModuleProperties( + var aProperties: TVirtualTableModuleProperties); override; /// called to determine the best way to access the virtual table // - will prepare the request for TSQLVirtualTableCursor.Search() // - this overridden method will let the external DB engine perform the search, @@ -391,7 +399,8 @@ type /// called to update a virtual table row content // - column order follows the Structure method, i.e. StoredClassProps.Fields[] order // - returns true on success, false otherwise - function Update(oldRowID, newRowID: Int64; var Values: TSQLVarDynArray): boolean; override; + function Update(oldRowID, newRowID: Int64; + var Values: TSQLVarDynArray): boolean; override; end; @@ -440,7 +449,8 @@ function VirtualTableExternalRegister(aModel: TSQLModel; // definitions, in a fluent interface: function VirtualTableExternalMap(aModel: TSQLModel; aClass: TSQLRecordClass; aExternalDB: TSQLDBConnectionProperties; - const aExternalTableName: RawUTF8=''; aMapping: TSQLRecordPropertiesMappingOptions=[]): PSQLRecordPropertiesMapping; + const aExternalTableName: RawUTF8=''; + aMapping: TSQLRecordPropertiesMappingOptions=[]): PSQLRecordPropertiesMapping; type /// all possible options for VirtualTableExternalRegisterAll/TSQLRestExternalDBCreate @@ -505,6 +515,7 @@ function TSQLRestExternalDBCreate(aModel: TSQLModel; implementation + function VirtualTableExternalRegister(aModel: TSQLModel; aClass: TSQLRecordClass; aExternalDB: TSQLDBConnectionProperties; const aExternalTableName: RawUTF8; aMappingOptions: TSQLRecordPropertiesMappingOptions): boolean; @@ -577,7 +588,8 @@ end; function VirtualTableExternalMap(aModel: TSQLModel; aClass: TSQLRecordClass; aExternalDB: TSQLDBConnectionProperties; - const aExternalTableName: RawUTF8; aMapping: TSQLRecordPropertiesMappingOptions): PSQLRecordPropertiesMapping; + const aExternalTableName: RawUTF8; + aMapping: TSQLRecordPropertiesMappingOptions): PSQLRecordPropertiesMapping; begin if VirtualTableExternalRegister(aModel,aClass,aExternalDB,aExternalTableName,aMapping) then result := @aModel.Props[aClass].ExternalDB else @@ -657,7 +669,7 @@ constructor TSQLRestStorageExternal.Create(aClass: TSQLRecordClass; {$ifndef NOVARIANTS} ftUTF8, // sftVariant ftUTF8, // sftNullable (retrieved from Prop.SQLFieldTypeStored) - {$endif} + {$endif NOVARIANTS} ftBlob, // sftBlob ftBlob, // sftBlobDynArray ftBlob, // sftBlobCustom @@ -987,6 +999,7 @@ function TSQLRestStorageExternal.EngineLockedNextID: TID; if (rows<>nil) and rows.Step then fEngineLockedMaxID := rows.ColumnInt(0) else fEngineLockedMaxID := 0; + rows.ReleaseRows; end; var handled: boolean; @@ -1348,8 +1361,10 @@ begin result := false else begin rows := ExecuteDirect(pointer(fSelectTableHasRowsSQL),[],[],true); if rows=nil then - result := false else + result := false else begin result := rows.Step; + rows.ReleaseRows; + end; end; end; @@ -1359,9 +1374,13 @@ begin if (self=nil) or (Table<>fStoredClass) then result := 0 else begin rows := ExecuteDirect('select count(*) from %',[fTableName],[],true); - if (rows=nil) or not rows.Step then - result := 0 else - result := rows.ColumnInt(0); + if rows=nil then + result := 0 else begin + if not rows.Step then + result := 0 else + result := rows.ColumnInt(0); + rows.ReleaseRows; + end; end; end; diff --git a/contrib/mORMot/SQLite3/mORMotDDD.pas b/contrib/mORMot/SQLite3/mORMotDDD.pas index c34247e..cae0d30 100644 --- a/contrib/mORMot/SQLite3/mORMotDDD.pas +++ b/contrib/mORMot/SQLite3/mORMotDDD.pas @@ -6,7 +6,7 @@ unit mORMotDDD; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotDDD; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -2540,7 +2540,7 @@ begin end; writeln('Press [Enter] to quit'); ioresult; - readln; + ConsoleWaitForEnterKey; // for proper Synchronize() work {$ifdef LINUX} if ioresult<>0 then // e.g. when redirected from "nohup daemon &" command WaitUntilHalted; diff --git a/contrib/mORMot/SQLite3/mORMotFastCgiServer.pas b/contrib/mORMot/SQLite3/mORMotFastCgiServer.pas index dabbbab..72ab3c2 100644 --- a/contrib/mORMot/SQLite3/mORMotFastCgiServer.pas +++ b/contrib/mORMot/SQLite3/mORMotFastCgiServer.pas @@ -6,7 +6,7 @@ unit mORMotFastCgiServer; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotFastCgiServer; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotHttpClient.pas b/contrib/mORMot/SQLite3/mORMotHttpClient.pas index 029f925..2b3938c 100644 --- a/contrib/mORMot/SQLite3/mORMotHttpClient.pas +++ b/contrib/mORMot/SQLite3/mORMotHttpClient.pas @@ -6,7 +6,7 @@ unit mORMotHttpClient; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotHttpClient; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -580,17 +580,17 @@ begin Create(URI.Server,URI.Port,aModel,URI.Https); P := Pointer(aDefinition.DataBaseName); while P<>nil do begin - if UrlDecodeCardinal(P,'CONNECTTIMEOUT',V) then + if UrlDecodeCardinal(P,'CONNECTTIMEOUT=',V) then fConnectTimeout := V else - if UrlDecodeCardinal(P,'SENDTIMEOUT',V) then + if UrlDecodeCardinal(P,'SENDTIMEOUT=',V) then fSendTimeout := V else - if UrlDecodeCardinal(P,'RECEIVETIMEOUT',V) then + if UrlDecodeCardinal(P,'RECEIVETIMEOUT=',V) then fReceiveTimeout := V else - if UrlDecodeValue(P,'PROXYNAME',tmp) then + if UrlDecodeValue(P,'PROXYNAME=',tmp) then fProxyName := CurrentAnsiConvert.UTF8ToAnsi(tmp) else - if UrlDecodeValue(P,'PROXYBYPASS',tmp) then + if UrlDecodeValue(P,'PROXYBYPASS=',tmp) then fProxyByPass := CurrentAnsiConvert.UTF8ToAnsi(tmp); - if UrlDecodeCardinal(P,'IGNORESSLCERTIFICATEERRORS',V,@P) then + if UrlDecodeCardinal(P,'IGNORESSLCERTIFICATEERRORS=',V,@P) then fExtendedOptions.IgnoreSSLCertificateErrors := Boolean(V); end; inherited RegisteredClassCreateFrom(aModel,aDefinition); // call SetUser() diff --git a/contrib/mORMot/SQLite3/mORMotHttpServer.pas b/contrib/mORMot/SQLite3/mORMotHttpServer.pas index b7084c7..66e019d 100644 --- a/contrib/mORMot/SQLite3/mORMotHttpServer.pas +++ b/contrib/mORMot/SQLite3/mORMotHttpServer.pas @@ -6,7 +6,7 @@ unit mORMotHttpServer; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotHttpServer; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -577,7 +577,6 @@ begin if aURI='' then fHosts.Delete(aDomain) else fHosts.Add(aDomain,aURI); // e.g. Add('project1.com','root1') - end; constructor TSQLHttpServer.Create(const aPort: AnsiString; @@ -925,7 +924,7 @@ begin if fRedirectServerRootUriForExactCase and (match=rmMatchWithCaseChange) then begin // force redirection to exact Server.Model.Root case sensitivity call.OutStatus := HTTP_TEMPORARYREDIRECT; - call.OutHead := 'Location: '+serv.Model.Root+ + call.OutHead := 'Location: /'+serv.Model.Root+ copy(call.Url,length(serv.Model.Root)+1,maxInt); end else begin // call matching TSQLRestServer.URI() @@ -950,6 +949,8 @@ begin if hostroot<>'' then begin if ((result=HTTP_MOVEDPERMANENTLY) or (result=HTTP_TEMPORARYREDIRECT)) then begin redirect := FindIniNameValue(P,'LOCATION: '); + if (redirect<>'') and (redirect[1]='/') then + delete(redirect,1,1); // what is needed for real URI doesn't help here hostlen := length(hostroot); if (length(redirect)>hostlen) and (redirect[hostlen+1]='/') and IdemPropNameU(hostroot,pointer(redirect),hostlen) then diff --git a/contrib/mORMot/SQLite3/mORMotMVC.pas b/contrib/mORMot/SQLite3/mORMotMVC.pas index e50a571..95c585b 100644 --- a/contrib/mORMot/SQLite3/mORMotMVC.pas +++ b/contrib/mORMot/SQLite3/mORMotMVC.pas @@ -6,7 +6,7 @@ unit mORMotMVC; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotMVC; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -84,7 +84,7 @@ type TMVCViewFlags = set of (viewHasGenerationTimeTag); /// define a particular rendered View - // - as rendered by TMVCViewsAbtract.Render() method + // - as rendered by TMVCViewsAbstract.Render() method TMVCView = record /// the low-level content of this View Content: RawByteString; @@ -95,7 +95,7 @@ type end; /// an abstract class able to implement Views - TMVCViewsAbtract = class + TMVCViewsAbstract = class protected fFactory: TInterfaceFactory; fLogClass: TSynLogClass; @@ -105,7 +105,8 @@ type fViewGenerationTimeTag: RawUTF8; procedure SetViewTemplateFolder(const aFolder: TFileName); /// overriden implementations should return the rendered content - procedure Render(methodIndex: Integer; const Context: variant; var View: TMVCView); virtual; abstract; + procedure Render(methodIndex: Integer; const Context: variant; + var View: TMVCView); virtual; abstract; /// return the static file contents - from fViewStaticFolder by default // - called if cacheStatic has been defined function GetStaticFile(const aFileName: TFileName): RawByteString; virtual; @@ -148,7 +149,7 @@ type end; /// a class able to implement Views using Mustache templates - TMVCViewsMustache = class(TMVCViewsAbtract) + TMVCViewsMustache = class(TMVCViewsAbstract) protected fViewTemplateFileTimestampMonitor: cardinal; fViewPartials: TSynMustachePartials; @@ -400,7 +401,7 @@ type TMVCApplication = class; - /// abtract MVC rendering execution context + /// abstract MVC rendering execution context // - you shoud not execute this abstract class, but any of the inherited class // - one instance inherited from this class would be allocated for each event // - may return some data (when inheriting from TMVCRendererReturningData), or @@ -511,9 +512,9 @@ type // an optional simple in-memory cache TMVCRunWithViews = class(TMVCRun) protected - fViews: TMVCViewsAbtract; + fViews: TMVCViewsAbstract; fCacheLocker: IAutoLocker; - fCache: array of record + fCache: array of record // fCache[MethodIndex] Policy: TMVCRendererCachePolicy; TimeOutSeconds: cardinal; RootValue: RawUTF8; @@ -523,7 +524,7 @@ type public /// link this runner class to a specified MVC application constructor Create(aApplication: TMVCApplication; - aViews: TMVCViewsAbtract=nil); reintroduce; + aViews: TMVCViewsAbstract=nil); reintroduce; /// method called to flush the caching mechanism for a MVC command procedure NotifyContentChangedForMethod(aMethodIndex: integer); override; /// defines the caching policy for a given MVC command @@ -537,7 +538,7 @@ type /// finalize this instance destructor Destroy; override; /// read-write access to the associated MVC Views instance - property Views: TMVCViewsAbtract read fViews; + property Views: TMVCViewsAbstract read fViews; end; /// the kinds of optional content which may be published @@ -587,7 +588,7 @@ type // - aPublishOptions could be used to specify integration with the server constructor Create(aApplication: TMVCApplication; aRestServer: TSQLRestServer=nil; const aSubURI: RawUTF8=''; - aViews: TMVCViewsAbtract=nil; aPublishOptions: TMVCPublishOptions= + aViews: TMVCViewsAbstract=nil; aPublishOptions: TMVCPublishOptions= [low(TMVCPublishOption)..high(TMVCPublishOption)]); reintroduce; /// define some content for a static file // - only used if cacheStatic has been defined @@ -645,7 +646,7 @@ type // - you should inherit from this class, then implement an interface inheriting // from IMVCApplication to define the various commands of the application // - here the Model would be a TSQLRest instance, Views will be defined by - // TMVCViewsAbtract (e.g. TMVCViewsMustache), and the ViewModel/Controller + // TMVCViewsAbstract (e.g. TMVCViewsMustache), and the ViewModel/Controller // will be implemented with IMVCApplication methods of the inherited class // - inherits from TInjectableObject, so that you could resolve dependencies // via services or stubs, following the IoC pattern @@ -726,9 +727,9 @@ const implementation -{ TMVCViewsAbtract } +{ TMVCViewsAbstract } -constructor TMVCViewsAbtract.Create(aInterface: PTypeInfo; aLogClass: TSynLogClass); +constructor TMVCViewsAbstract.Create(aInterface: PTypeInfo; aLogClass: TSynLogClass); begin inherited Create; fFactory := TInterfaceFactory.Get(aInterface); @@ -739,13 +740,13 @@ begin fViewGenerationTimeTag := '[[GENERATION_TIME_TAG]]'; end; -procedure TMVCViewsAbtract.SetViewTemplateFolder(const aFolder: TFileName); +procedure TMVCViewsAbstract.SetViewTemplateFolder(const aFolder: TFileName); begin fViewTemplateFolder := IncludeTrailingPathDelimiter(aFolder); fViewStaticFolder := IncludeTrailingPathDelimiter(fViewTemplateFolder+STATIC_URI); end; -function TMVCViewsAbtract.GetStaticFile(const aFileName: TFileName): RawByteString; +function TMVCViewsAbstract.GetStaticFile(const aFileName: TFileName): RawByteString; begin result := StringFromFile(fViewStaticFolder + aFileName); end; @@ -1490,6 +1491,7 @@ begin [self,aRestModel,fFactory.InterfaceTypeInfo^.Name,URI]) else // TServiceCustomAnswer maps TMVCAction in TMVCApplication.RunOnRestServer ArgsResultIsServiceCustomAnswer := true; + FlushAnyCache; end; destructor TMVCApplication.Destroy; @@ -1738,7 +1740,7 @@ end; { TMVCRunWithViews } constructor TMVCRunWithViews.Create(aApplication: TMVCApplication; - aViews: TMVCViewsAbtract); + aViews: TMVCViewsAbstract); begin inherited Create(aApplication); fViews := aViews; @@ -1792,7 +1794,7 @@ end; constructor TMVCRunOnRestServer.Create(aApplication: TMVCApplication; aRestServer: TSQLRestServer; const aSubURI: RawUTF8; - aViews: TMVCViewsAbtract; aPublishOptions: TMVCPublishOptions); + aViews: TMVCViewsAbstract; aPublishOptions: TMVCPublishOptions); var m: integer; bypass: boolean; method: RawUTF8; diff --git a/contrib/mORMot/SQLite3/mORMotMidasVCL.pas b/contrib/mORMot/SQLite3/mORMotMidasVCL.pas index 1e01580..a002fc0 100644 --- a/contrib/mORMot/SQLite3/mORMotMidasVCL.pas +++ b/contrib/mORMot/SQLite3/mORMotMidasVCL.pas @@ -6,7 +6,7 @@ unit mORMotMidasVCL; { This file is part of Synopse mORmot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotMidasVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotMongoDB.pas b/contrib/mORMot/SQLite3/mORMotMongoDB.pas index a4fa813..f2d4e9e 100644 --- a/contrib/mORMot/SQLite3/mORMotMongoDB.pas +++ b/contrib/mORMot/SQLite3/mORMotMongoDB.pas @@ -6,7 +6,7 @@ unit mORMotMongoDB; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotMongoDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -84,7 +84,7 @@ uses SynMongoDB; type - /// exeception class raised by this units + /// exception class raised by this units EORMMongoDBException = class(EORMException); /// how TSQLRestStorageMongoDB would compute the next ID to be inserted @@ -190,6 +190,12 @@ type /// create one index for all specific FieldNames at once function CreateSQLMultiIndex(Table: TSQLRecordClass; const FieldNames: array of RawUTF8; Unique: boolean; IndexName: RawUTF8=''): boolean; override; + /// search for a field value, according to its SQL content representation + // - return true on success (i.e. if some values have been added to ResultID) + // - store the results into the ResultID dynamic array + // - faster than OneFieldValues method, which creates a temporary JSON content + function SearchField(const FieldName, FieldValue: RawUTF8; + out ResultID: TIDDynArray): boolean; override; /// drop the whole table content // - in practice, dropping the whole MongoDB database would be faster @@ -992,6 +998,32 @@ begin result := true; // we do not have any Virtual Table yet -> always accept end; +function TSQLRestStorageMongoDB.SearchField(const FieldName, FieldValue: RawUTF8; + out ResultID: TIDDynArray): boolean; +var query: variant; + id: TBSONIterator; + n: integer; // an external count is actually faster +begin + if (fCollection = nil) or (FieldName = '') or (FieldValue = '') then + result := false else + try + // use {%:%} here since FieldValue is already JSON encoded + query := BSONVariant('{%:%}', + [fStoredClassMapping^.InternalToExternal(FieldName), FieldValue], []); + // retrieve the IDs for this query + if id.Init(fCollection.FindBSON(query, BSONVariant(['_id', 1]))) then begin + n := 0; + while id.Next do + AddInt64(TInt64DynArray(ResultID), n, id.Item.DocItemToInteger('_id')); + SetLength(ResultID, n); + result := true; + end else + result := false; + except + result := false; + end; +end; + function TSQLRestStorageMongoDB.GetJSONValues(const Res: TBSONDocument; const extFieldNames: TRawUTF8DynArray; W: TJSONSerializer): integer; function itemFind(item: PBSONElement; itemcount,o1ndx: integer; diff --git a/contrib/mORMot/SQLite3/mORMotReport.pas b/contrib/mORMot/SQLite3/mORMotReport.pas index 7b7961c..51bd969 100644 --- a/contrib/mORMot/SQLite3/mORMotReport.pas +++ b/contrib/mORMot/SQLite3/mORMotReport.pas @@ -6,7 +6,7 @@ unit mORMotReport; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -27,7 +27,7 @@ unit mORMotReport; Portions created by the Initial Developer are Copyright (C) 2003 the Initial Developer. All Rights Reserved. - Portions created by Arnaud Bouchez for Synopse are Copyright (C) 2020 + Portions created by Arnaud Bouchez for Synopse are Copyright (C) 2022 Arnaud Bouchez. All Rights Reserved. Contributor(s): @@ -111,7 +111,7 @@ unit mORMotReport; - full Unicode text process (even before Delphi 2009) - speed up and various bug fixes to work with Delphi 5 up to XE3 - Modifications © 2009-2020 Arnaud Bouchez + Modifications (c) 2009-2022 Arnaud Bouchez Version 1.4 - February 8, 2010 - whole Synopse SQLite3 database framework released under the GNU Lesser @@ -4932,11 +4932,9 @@ begin rc := rcPage; rc.Top := (fCurrentYPos*1440) div LogY; LastChar := 0; - with TextLenEx do begin - flags := GTL_DEFAULT; - codepage := CP_ACP; - end; - MaxLen := SendMessage(RichEditHandle, EM_GETTEXTLENGTHEX, Integer(@TextLenEx), 0); + TextLenEx.flags := GTL_DEFAULT; + TextLenEx.codepage := CP_ACP; + MaxLen := SendMessage(RichEditHandle, EM_GETTEXTLENGTHEX, PtrInt(@TextLenEx), 0); chrg.cpMax := -1; OldMap := SetMapMode(hdc, MM_TEXT); try @@ -4945,7 +4943,7 @@ begin chrg.cpMin := LastChar; hdc := fCanvas.Handle; hdcTarget := hdc; - LastChar := SendMessage(RichEditHandle, EM_FORMATRANGE, 1, Integer(@Range)); + LastChar := SendMessage(RichEditHandle, EM_FORMATRANGE, 1, PtrInt(@Range)); if EndOfPagePositions<>nil then AddInteger(EndOfPagePositions^,LastChar); if cardinal(LastChar)>=cardinal(MaxLen) then diff --git a/contrib/mORMot/SQLite3/mORMotSQLite3.pas b/contrib/mORMot/SQLite3/mORMotSQLite3.pas index 8b77e8f..ddfa3e4 100644 --- a/contrib/mORMot/SQLite3/mORMotSQLite3.pas +++ b/contrib/mORMot/SQLite3/mORMotSQLite3.pas @@ -6,7 +6,7 @@ unit mORMotSQLite3; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotSQLite3; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -118,7 +118,7 @@ type // - SQL statements for record retrieval from ID are prepared for speed TSQLRestServerDB = class(TSQLRestServer) private - /// internal copy of the SQLite3 database engine + /// access to the associated SQLite3 database engine fDB: TSQLDataBase; /// initialized by Create(aModel,aDBFileName) fOwnedDB: TSQLDataBase; @@ -511,7 +511,8 @@ type // - returns the created TSQLVirtualTableModule instance (which will be a // TSQLVirtualTableModuleSQLite3 instance in fact) // - will raise an exception of failure -function RegisterVirtualTableModule(aModule: TSQLVirtualTableClass; aDatabase: TSQLDataBase): TSQLVirtualTableModule; +function RegisterVirtualTableModule(aModule: TSQLVirtualTableClass; + aDatabase: TSQLDataBase): TSQLVirtualTableModule; implementation @@ -519,7 +520,8 @@ implementation {$ifdef SQLVIRTUALLOGS} uses mORMotDB; -{$endif} +{$endif SQLVIRTUALLOGS} + { TSQLTableDB } @@ -2186,7 +2188,7 @@ begin TSQLRestStorageExternal(Table.Static).ComputeSQL(prepared^); SQLite3Log.Add.Log(sllDebug,'vt_BestIndex(%) plan=% -> cost=% rows=%', [sqlite3.VersionNumber,ord(Prepared^.EstimatedCost),pInfo.estimatedCost,pInfo.estimatedRows]); - {$endif} + {$endif SQLVIRTUALLOGS} finally if result<>SQLITE_OK then sqlite3.free_(Prepared); // avoid memory leak on error diff --git a/contrib/mORMot/SQLite3/mORMotSelfTests.pas b/contrib/mORMot/SQLite3/mORMotSelfTests.pas index 3c7456a..0b6dbe4 100644 --- a/contrib/mORMot/SQLite3/mORMotSelfTests.pas +++ b/contrib/mORMot/SQLite3/mORMotSelfTests.pas @@ -6,7 +6,7 @@ unit mORMotSelfTests; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotSelfTests; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -110,7 +110,7 @@ end; procedure TTestSynopsemORMotFramework.SynopseLibraries; begin - //AddCase(TTestLowLevelTypes); + //AddCase(TTestProtocols); //exit; AddCase([TTestLowLevelCommon, TTestLowLevelTypes, @@ -137,7 +137,7 @@ type // mORMot.pas unit doesn't compile with Delphi 5 yet {$else} procedure TTestSynopsemORMotFramework._mORMot; begin - //AddCase(TTestExternalDatabase); + //AddCase(TTestBasicClasses); //exit; // (* AddCase([TTestFileBased,TTestFileBasedMemoryMap,TTestFileBasedWAL]); AddCase(TTestMemoryBased); diff --git a/contrib/mORMot/SQLite3/mORMotService.pas b/contrib/mORMot/SQLite3/mORMotService.pas index 84b3378..29664a6 100644 --- a/contrib/mORMot/SQLite3/mORMotService.pas +++ b/contrib/mORMot/SQLite3/mORMotService.pas @@ -6,7 +6,7 @@ unit mORMotService; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotService; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -1129,29 +1129,35 @@ begin result := FArgsList[Idx]; end; + {$ifdef CPUX86} + {.$define X86JUMPER} // this preliminary version is buggy so disabled + // a single service per excecutable is fine enough for our daemons + // also for proper Delphi 10.4 compilation with no hint +{$endif CPUX86} + +{$ifdef X86JUMPER} procedure JumpToService; asm pop eax - mov eax, [eax] // retrieve self value + mov eax, [eax] // retrieve TService self value mov edx, [esp+4] call TService.CtrlHandle ret 4 end; -{$endif CPUX86} +{$endif X86JUMPER} function TService.GetControlHandler: TServiceControlHandler; -{$ifdef CPUX86} +{$ifdef X86JUMPER} var AfterCallAddr: Pointer; Offset: Integer; -{$endif} +{$endif X86JUMPER} begin Result := fControlHandler; if not Assigned(Result) then ServiceLog.Add.Log(sllError,'%.GetControlHandler with fControlHandler=nil: '+ 'use TServiceSingle or set a custom ControlHandler',[self]); - {$ifdef CPUX86} - exit; + {$ifdef X86JUMPER} if not Assigned(Result) then begin raise EServiceException.Create('Automated jumper generation is not working: '+ @@ -1169,7 +1175,7 @@ begin end; Result := Pointer(fJumper); end; - {$endif CPUX86} + {$endif X86JUMPER} end; function TService.GetInstalled: boolean; @@ -1674,7 +1680,9 @@ begin ExeVersion.Version.DetailedOrVoid], daemon); start; while SynDaemonTerminated = 0 do - {$ifdef FPC}fpPause{$else}pause{$endif}; + if GetCurrentThreadID = MainThreadID then + CheckSynchronize(100) else + Sleep(100); finally if log <> nil then log.Log(sllNewRun, 'Stop /% from Sig=%', [TXT[dofork], SynDaemonTerminated], daemon); @@ -2000,9 +2008,6 @@ begin fLogRotateFileCount := 2; fServiceName := UTF8ToString(ExeVersion.ProgramName); fServiceDisplayName := fServiceName; - {$ifndef MSWINDOWS} - fLogPath := GetSystemPath(spLog); // /var/log or $home - {$endif MSWINDOWS} end; function TSynDaemonSettings.ServiceDescription: string; diff --git a/contrib/mORMot/SQLite3/mORMotToolBar.pas b/contrib/mORMot/SQLite3/mORMotToolBar.pas index 736ceed..de62281 100644 --- a/contrib/mORMot/SQLite3/mORMotToolBar.pas +++ b/contrib/mORMot/SQLite3/mORMotToolBar.pas @@ -9,7 +9,7 @@ interface This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -28,7 +28,7 @@ interface The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotUI.pas b/contrib/mORMot/SQLite3/mORMotUI.pas index 7534e97..d584fda 100644 --- a/contrib/mORMot/SQLite3/mORMotUI.pas +++ b/contrib/mORMot/SQLite3/mORMotUI.pas @@ -6,7 +6,7 @@ unit mORMotUI; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotUI; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -222,7 +222,7 @@ type TSQLTableToGridAlign = (alLeft, alCenter, alRight); /// a hidden component, used for displaying a TSQLTable in a TDrawGrid - // - just call TSQLTableToGrid.Create(Grid,Table) to initiate the association + // - just call TSQLTableToGrid.Create(Grid,Table) to initiate the association // - the Table will be released when no longer necessary // - any former association by TSQLTableToGrid.Create() will be overridden // - handle unicode, column size, field sort, incremental key lookup, hide ID @@ -720,7 +720,7 @@ begin end; end; -function CreateAnIcon (const Name, Description, Path, Parameters, +function CreateAnIcon(const Name, Description, Path, Parameters, WorkingDir, IconFilename: TFileName; const IconIndex: Integer; const RunMinimized: Boolean = false): TFileName; var Dir: TFileName; @@ -2347,7 +2347,7 @@ end; procedure TUIComponentsPersist.TrackControls(const ctrls: array of TComponent); var - i: integer; + i: PtrInt; begin for i := 0 to high(ctrls) do ObjArrayAddOnce(fTracked, ctrls[i]); @@ -2359,5 +2359,12 @@ begin RegisterComponents('Synopse',[TSynLabeledEdit]); end; + +initialization + {$ifdef FPC} + // LCL/Lazarus components expect UTF-8 encoding for strings + CurrentAnsiConvert := UTF8AnsiConvert; + {$endif FPC} + end. diff --git a/contrib/mORMot/SQLite3/mORMotUIEdit.pas b/contrib/mORMot/SQLite3/mORMotUIEdit.pas index 3a1626a..598c69a 100644 --- a/contrib/mORMot/SQLite3/mORMotUIEdit.pas +++ b/contrib/mORMot/SQLite3/mORMotUIEdit.pas @@ -6,7 +6,7 @@ unit mORMotUIEdit; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotUIEdit; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotUILogin.pas b/contrib/mORMot/SQLite3/mORMotUILogin.pas index 251c508..143fe12 100644 --- a/contrib/mORMot/SQLite3/mORMotUILogin.pas +++ b/contrib/mORMot/SQLite3/mORMotUILogin.pas @@ -6,7 +6,7 @@ unit mORMotUILogin; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotUILogin; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotUIOptions.pas b/contrib/mORMot/SQLite3/mORMotUIOptions.pas index 03fb588..8347b75 100644 --- a/contrib/mORMot/SQLite3/mORMotUIOptions.pas +++ b/contrib/mORMot/SQLite3/mORMotUIOptions.pas @@ -6,7 +6,7 @@ unit mORMotUIOptions; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotUIOptions; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotUIQuery.pas b/contrib/mORMot/SQLite3/mORMotUIQuery.pas index 72cd061..adad045 100644 --- a/contrib/mORMot/SQLite3/mORMotUIQuery.pas +++ b/contrib/mORMot/SQLite3/mORMotUIQuery.pas @@ -6,7 +6,7 @@ unit mORMotUIQuery; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotUIQuery; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotVCL.pas b/contrib/mORMot/SQLite3/mORMotVCL.pas index 703dea5..e525d2a 100644 --- a/contrib/mORMot/SQLite3/mORMotVCL.pas +++ b/contrib/mORMot/SQLite3/mORMotVCL.pas @@ -6,7 +6,7 @@ unit mORMotVCL; { This file is part of Synopse mORmot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/mORMotWrappers.pas b/contrib/mORMot/SQLite3/mORMotWrappers.pas index 3d6b4a7..0b56911 100644 --- a/contrib/mORMot/SQLite3/mORMotWrappers.pas +++ b/contrib/mORMot/SQLite3/mORMotWrappers.pas @@ -6,7 +6,7 @@ unit mORMotWrappers; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMotWrappers; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s) (for this unit and the .mustache templates): diff --git a/contrib/mORMot/SQLite3/mORMoti18n.pas b/contrib/mORMot/SQLite3/mORMoti18n.pas index a92e050..3d3ec60 100644 --- a/contrib/mORMot/SQLite3/mORMoti18n.pas +++ b/contrib/mORMot/SQLite3/mORMoti18n.pas @@ -6,7 +6,7 @@ unit mORMoti18n; (* This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit mORMoti18n; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SQLite3/sqlite3.obj b/contrib/mORMot/SQLite3/sqlite3.obj index f931be0..2d2b43d 100644 Binary files a/contrib/mORMot/SQLite3/sqlite3.obj and b/contrib/mORMot/SQLite3/sqlite3.obj differ diff --git a/contrib/mORMot/SyNode/SpiderMonkey.pas b/contrib/mORMot/SyNode/SpiderMonkey.pas index 0889d93..73353ec 100644 --- a/contrib/mORMot/SyNode/SpiderMonkey.pas +++ b/contrib/mORMot/SyNode/SpiderMonkey.pas @@ -6,10 +6,10 @@ unit SpiderMonkey; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com *** BEGIN LICENSE BLOCK ***** @@ -26,7 +26,7 @@ unit SpiderMonkey; The Initial Developer of the Original Code is Pavel Mashlyakovsky & Vadim Orel. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SyNode/SyNode.inc b/contrib/mORMot/SyNode/SyNode.inc index b9f5893..f0bca4a 100644 --- a/contrib/mORMot/SyNode/SyNode.inc +++ b/contrib/mORMot/SyNode/SyNode.inc @@ -1,10 +1,10 @@ { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - Scripting support for mORMot Copyright (C) 2020 Pavel Mashlyakovsky + Scripting support for mORMot Copyright (C) 2022 Pavel Mashlyakovsky pavel.mash at gmail.com *** BEGIN LICENSE BLOCK ***** @@ -21,7 +21,7 @@ The Initial Developer of the Original Code is Pavel Mashlyakovsky. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SyNode/SyNode.pas b/contrib/mORMot/SyNode/SyNode.pas index 40f578a..e008709 100644 --- a/contrib/mORMot/SyNode/SyNode.pas +++ b/contrib/mORMot/SyNode/SyNode.pas @@ -6,10 +6,10 @@ unit SyNode; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com Some ideas taken from @@ -30,7 +30,7 @@ unit SyNode; The Initial Developer of the Original Code is Pavel Mashlyakovsky. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -383,7 +383,7 @@ type FEngineClass: TSMEngineClass; /// List of loaded dll modules - FDllModules: TRawUTF8ListHashedLocked; + FDllModules: TRawUTF8List; /// Path to core modules FCoreModulesPath: RawUTF8; FEngineExpireTimeOutTicks: Int64; @@ -559,7 +559,7 @@ const ); var - GlobalSyNodeBindingHandlers: TRawUTF8ListHashedLocked; + GlobalSyNodeBindingHandlers: TRawUTF8List; /// handle errors from JavaScript. Just call DoProcessJSError of corresponding TSMEngine // to set TSMEngine error properties @@ -1116,7 +1116,7 @@ class procedure TSMEngineManager.RegisterBinding(const Name: RawUTF8; const handler: TSMProcessBindingHandler); begin if GlobalSyNodeBindingHandlers = nil then - GlobalSyNodeBindingHandlers := TRawUTF8ListHashedLocked.Create(false); + GlobalSyNodeBindingHandlers := TRawUTF8List.Create(false); GlobalSyNodeBindingHandlers.AddObject(Name, TObject(@handler)); end; @@ -1125,7 +1125,7 @@ var obj: TObject; handler: TSMProcessBindingHandler absolute obj; begin - obj := GlobalSyNodeBindingHandlers.GetObjectByName(Name); + obj := GlobalSyNodeBindingHandlers.GetObjectFrom(Name); result := handler; end; @@ -1153,7 +1153,7 @@ begin {$ifdef ISDELPHIXE2} FRttiCx := TRttiContext.Create(); {$endif} - FDllModules := TRawUTF8ListHashedLocked.Create(); + FDllModules := TRawUTF8List.Create(); FCoreModulesPath := aCoreModulesPath; FWorkersManager := TJSWorkersManager.Create; end; @@ -1261,7 +1261,7 @@ begin cx.BeginRequest; try dirname := ExtractFilePath(UTF8ToString(filename)) ; - ModuleRec := PDllModuleRec(FDllModules.GetObjectByName(filename)); + ModuleRec := PDllModuleRec(FDllModules.GetObjectFrom(filename)); if ModuleRec = nil then begin fHandle := {$IFDEF FPC}dynlibs.{$ENDIF}SafeLoadLibrary(UTF8ToString(filename)); if fHandle=0 then @@ -1422,7 +1422,7 @@ begin try i := ThreadEngineIndex(aThreadID); if i>=0 then begin - (FEnginePool[i] as TSMEngine).GarbageCollect; + (TObject(FEnginePool[i]) as TSMEngine).GarbageCollect; FEnginePool.Delete(i); end; finally diff --git a/contrib/mORMot/SyNode/SyNodeBinding_fs.pas b/contrib/mORMot/SyNode/SyNodeBinding_fs.pas index 63e3a54..e38818c 100644 --- a/contrib/mORMot/SyNode/SyNodeBinding_fs.pas +++ b/contrib/mORMot/SyNode/SyNodeBinding_fs.pas @@ -670,7 +670,7 @@ begin end; stream := TFileStream.Create(filePath, fmOpenReadWrite); - stream.Seek(0, soFromEnd); + stream.Seek(0, soEnd); writer := SynCommons.TTextWriter.Create(stream, 65536); try vp.rval := SyNodeReadWrite.SMWrite_impl(cx, argc - 1, @in_argv[1], writer); diff --git a/contrib/mORMot/SyNode/SyNodeNewProto.pas b/contrib/mORMot/SyNode/SyNodeNewProto.pas index f5c57b3..8755d27 100644 --- a/contrib/mORMot/SyNode/SyNodeNewProto.pas +++ b/contrib/mORMot/SyNode/SyNodeNewProto.pas @@ -5,10 +5,10 @@ unit SyNodeNewProto; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com Some ideas taken from @@ -29,7 +29,7 @@ unit SyNodeNewProto; The Initial Developer of the Original Code is Pavel Mashlyakovsky. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SyNode/SyNodeProto.pas b/contrib/mORMot/SyNode/SyNodeProto.pas index 7288979..6b08103 100644 --- a/contrib/mORMot/SyNode/SyNodeProto.pas +++ b/contrib/mORMot/SyNode/SyNodeProto.pas @@ -5,10 +5,10 @@ unit SyNodeProto; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com Some ideas taken from diff --git a/contrib/mORMot/SyNode/SyNodeRemoteDebugger.pas b/contrib/mORMot/SyNode/SyNodeRemoteDebugger.pas index 154891a..886b4d8 100644 --- a/contrib/mORMot/SyNode/SyNodeRemoteDebugger.pas +++ b/contrib/mORMot/SyNode/SyNodeRemoteDebugger.pas @@ -5,10 +5,10 @@ unit SyNodeRemoteDebugger; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com Some ideas taken from @@ -141,8 +141,8 @@ type private fIndex: Integer; fIsPaused: boolean; - fMessagesQueue: TRawUTF8ListLocked; - fLogQueue: TRawUTF8ListLocked; + fMessagesQueue: TRawUTF8List; + fLogQueue: TRawUTF8List; {$IFNDEF SM52} fOldInterruptCallback: JSInterruptCallback; {$ENDIF} @@ -221,7 +221,7 @@ begin eng := fManager.EngineForThread(curThreadID); if eng<>nil then begin Debugger := eng.PrivateDataForDebugger; - Debugger.fLogQueue.SafePush(Text); + Debugger.fLogQueue.Add(Text); if eng.cx.IsRunning then {$IFDEF SM52} @@ -522,7 +522,7 @@ begin engine := fParent.fManager.EngineForThread(fDebugger.fSmThreadID); if (engine <> nil) then begin - fDebugger.fMessagesQueue.SafePush(VariantToUTF8(request)); + fDebugger.fMessagesQueue.Add(VariantToUTF8(request)); if not fDebugger.fIsPaused then begin if (not engine.cx.IsRunning) then begin if not Assigned(engine.doInteruptInOwnThread) then @@ -599,8 +599,8 @@ end; procedure TSMDebugger.attach(aThread: TSMRemoteDebuggerCommunicationThread); begin fCommunicationThread := aThread; - fMessagesQueue.SafeClear; - fLogQueue.SafeClear; + fMessagesQueue.Clear; + fLogQueue.Clear; end; constructor TSMDebugger.Create(aParent: TSMRemoteDebuggerThread; aEng: TSMEngine); @@ -617,8 +617,8 @@ begin fSmThreadID := GetCurrentThreadId; - fMessagesQueue := TRawUTF8ListLocked.Create(); - fLogQueue := TRawUTF8ListLocked.Create(); + fMessagesQueue := TRawUTF8List.Create(); + fLogQueue := TRawUTF8List.Create(); fNameForDebug := aEng.nameForDebug; fDebuggerName := 'synode_debPort_' + aParent.fPort; fWebAppRootPath := aEng.webAppRootDir; @@ -680,8 +680,8 @@ var dbgObject: PJSRootedObject; res: Boolean; begin - fMessagesQueue.SafeClear; - fLogQueue.SafeClear; + fMessagesQueue.Clear; + fLogQueue.Clear; cx := aEng.cx; cmpDbg := cx.EnterCompartment(aEng.GlobalObjectDbg.ptr); @@ -765,7 +765,7 @@ function debugger_read(cx: PJSContext; argc: uintN; var vp: JSArgRec): Boolean; var debugger: TSMDebugger; msg: RawUTF8; - Queue: TRawUTF8ListLocked; + Queue: TRawUTF8List; begin debugger := TSMEngine(cx.PrivateData).PrivateDataForDebugger; if (argc = 0) or vp.argv[0].asBoolean then @@ -774,7 +774,7 @@ begin Queue := debugger.fLogQueue; msg := ''; while ((Queue <> nil) and (debugger.fCommunicationThread <> nil) and - (not Queue.SafePop(msg))) and (argc = 0) do + (not Queue.PopFirst(msg))) and (argc = 0) do SleepHiRes(10); result := true; if (Queue <> nil) and (debugger.fCommunicationThread <> nil) then diff --git a/contrib/mORMot/SyNode/SyNodeSimpleProto.pas b/contrib/mORMot/SyNode/SyNodeSimpleProto.pas index e0a27e4..b9ba70f 100644 --- a/contrib/mORMot/SyNode/SyNodeSimpleProto.pas +++ b/contrib/mORMot/SyNode/SyNodeSimpleProto.pas @@ -5,10 +5,10 @@ unit SyNodeSimpleProto; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - http://synopse.info - SyNode for mORMot Copyright (C) 2020 Pavel Mashlyakovsky & Vadim Orel + SyNode for mORMot Copyright (C) 2022 Pavel Mashlyakovsky & Vadim Orel pavel.mash at gmail.com Some ideas taken from @@ -180,7 +180,7 @@ begin PI.SetInt64Prop(Instance^.instance, val.asInt64); tkFloat: PI.SetFloatProp(Instance^.instance, val.asDouble); - tkLString,{$IFDEF FPC}tkLStringOld{$ENDIF},tkWString{$ifdef HASVARUSTRING},tkUString{$endif}: + tkLString{$IFDEF FPC},tkLStringOld{$ENDIF},tkWString{$ifdef HASVARUSTRING},tkUString{$endif}: PI.SetLongStrValue(Instance^.instance, val.asJsString.ToUTF8(cx)); else raise ESMException.Create('NotImplemented'); diff --git a/contrib/mORMot/SynBidirSock.pas b/contrib/mORMot/SynBidirSock.pas index 38cba6c..2392200 100644 --- a/contrib/mORMot/SynBidirSock.pas +++ b/contrib/mORMot/SynBidirSock.pas @@ -6,7 +6,7 @@ unit SynBidirSock; { This file is part of the Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynBidirSock; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -1291,7 +1291,6 @@ implementation { -------------- high-level SynCrtSock classes depending on SynCommons } - { THttpRequestCached } constructor THttpRequestCached.Create(const aURI: RawUTF8; @@ -1343,6 +1342,11 @@ begin headin := headin+fTokenHeader; end; if fSocket<>nil then begin + if connectionClose in fSocket.HeaderFlags then begin + // server may close after a few requests (e.g. nginx keepalive_requests) + FreeAndNil(fSocket); + fSocket := THttpClientSocket.Open(fURI.Server,fURI.Port) + end; status := fSocket.Get(aAddress,fKeepAlive,headin); result := fSocket.Content; end else diff --git a/contrib/mORMot/SynBigTable.pas b/contrib/mORMot/SynBigTable.pas index e2d6a73..a03630b 100644 --- a/contrib/mORMot/SynBigTable.pas +++ b/contrib/mORMot/SynBigTable.pas @@ -3,7 +3,7 @@ unit SynBigTable; (* - Synopse Big Table. Copyright (C) 2020 Arnaud Bouchez + Synopse Big Table. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -22,7 +22,7 @@ unit SynBigTable; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -2162,7 +2162,7 @@ begin try with TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone) do try // same exact layout as in TSynBigTable.LoadFromFile - result := (Seek(-4,soFromEnd)>0) and (Read(magic,4)=4) and + result := (Seek(-4,soEnd)>0) and (Read(magic,4)=4) and (magic=InternalMagic); finally Free; diff --git a/contrib/mORMot/SynBz.pas b/contrib/mORMot/SynBz.pas index 90707e4..f744680 100644 --- a/contrib/mORMot/SynBz.pas +++ b/contrib/mORMot/SynBz.pas @@ -5,7 +5,7 @@ unit SynBz; { This file is part of Synopse BZ2 Compression. - Synopse Synopse BZ2 Compression. Copyright (C) 2020 Arnaud Bouchez + Synopse Synopse BZ2 Compression. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynBz; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynBzPas.pas b/contrib/mORMot/SynBzPas.pas index 5f9581e..a117752 100644 --- a/contrib/mORMot/SynBzPas.pas +++ b/contrib/mORMot/SynBzPas.pas @@ -5,7 +5,7 @@ unit SynBzPas; { This file is part of Synopse BZ2 Compression. - Synopse Synopse BZ2 Compression. Copyright (C) 2020 Arnaud Bouchez + Synopse Synopse BZ2 Compression. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynBzPas; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynCommons.pas b/contrib/mORMot/SynCommons.pas index 84758c7..6c16dc2 100644 --- a/contrib/mORMot/SynCommons.pas +++ b/contrib/mORMot/SynCommons.pas @@ -6,7 +6,7 @@ unit SynCommons; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCommons; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -522,6 +522,30 @@ type { ************ 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); @@ -1140,18 +1164,6 @@ function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; // - faster than System.UTF8ToUnicode with dest=nil function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will stop when the buffer contains #0 -function IsValidUTF8(source: PUTF8Char): Boolean; overload; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; overload; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -function IsValidUTF8(const source: RawUTF8): Boolean; overload; - /// 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 @@ -1626,6 +1638,8 @@ function StringToWinAnsi(const Text: string): WinAnsiString; // 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 @@ -1816,8 +1830,15 @@ procedure ResourceSynLZToRawByteString(const ResName: string; // - 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} @@ -3103,9 +3124,9 @@ function TrimLeft(const S: RawUTF8): RawUTF8; // newline, space, and tab characters function TrimRight(const S: RawUTF8): RawUTF8; -// single-allocation (therefore faster) alternative to Trim(copy()) +/// single-allocation (therefore faster) alternative to Trim(copy()) procedure TrimCopy(const S: RawUTF8; start,count: PtrInt; - out result: RawUTF8); + var result: RawUTF8); /// fast WinAnsi comparison using the NormToUpper[] array for all 8 bits values function AnsiIComp(Str1, Str2: pointer): PtrInt; @@ -3920,8 +3941,9 @@ procedure RaiseLastOSError; procedure VarCastError; {$endif} -/// extract file name, without its extension -// - may optionally return the associated extension, as '.ext' +/// 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; @@ -5049,10 +5071,17 @@ type /// internal set to specify some standard Delphi arrays TDynArrayKinds = set of TDynArrayKind; - /// internal integer type used for string/dynarray header reference counters - TRefCnt = {$ifdef FPC}SizeInt{$else}longint{$endif}; - /// internal pointer integer type used for string/dynarray header reference counters - PRefCnt = ^TRefCnt; + /// 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}; @@ -5068,7 +5097,7 @@ type // - match tdynarray type definition in dynarr.inc TDynArrayRec = {packed} record /// dynamic array reference count (basic memory management mechanism) - refCnt: TRefCnt; + refCnt: TDACnt; /// equals length-1 high: tdynarrayindex; function GetLength: sizeint; inline; @@ -5083,15 +5112,15 @@ const // - 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 PRefCnt(p-_STRREFCNT)^ - _STRREFCNT = Sizeof(TRefCnt)+_STRLEN; + // - 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 PRefCnt(PtrUInt(Values)-_DAREFCNT)^ - _DAREFCNT = Sizeof(TRefCnt)+_DALEN; + // - to be used inlined e.g. as PDACnt(PtrUInt(Values)-_DAREFCNT)^ + _DAREFCNT = Sizeof(TDACnt)+_DALEN; function ToText(k: TDynArrayKind): PShortString; overload; @@ -5163,14 +5192,22 @@ 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 = @@ -5950,7 +5987,7 @@ type procedure Clear; /// full computation of the internal hash table // - returns the number of duplicated values found - function ReHash(forced, forceGrow: boolean): integer; + 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 } @@ -6051,7 +6088,7 @@ type // 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; forceGrow: boolean=false): integer; + 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 @@ -6430,8 +6467,8 @@ type TSynLocker = object protected fSection: TRTLCriticalSection; - fSectionPadding: PtrInt; // paranoid to avoid FUTEX_WAKE_PRIVATE=EAGAIN - fLocked, fInitialized: boolean; + fLockCount: integer; + fInitialized: boolean; {$ifndef NOVARIANTS} function GetVariant(Index: integer): Variant; procedure SetVariant(Index: integer; const Value: Variant); @@ -6445,8 +6482,14 @@ type 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[], @@ -6455,11 +6498,6 @@ type // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure, // and maintain the PaddingUsedCount field accurately Padding: array[0..6] of TVarData; - /// 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; /// initialize the mutex // - calling this method is mandatory (e.g. in the class constructor owning // the TSynLocker instance), otherwise you may encounter unexpected @@ -6531,7 +6569,7 @@ type // !end; function ProtectMethod: IUnknown; /// returns true if the mutex is currently locked by another thread - property IsLocked: boolean read fLocked; + 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 @@ -8357,6 +8395,9 @@ type 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 @@ -8462,6 +8503,7 @@ type // - 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, @@ -8473,7 +8515,8 @@ type twoForceJSONStandard, twoEndOfLineCRLF, twoBufferIsExternal, - twoIgnoreDefaultInRecord); + 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 @@ -8500,10 +8543,12 @@ type // 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); @@ -8610,17 +8655,20 @@ type 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; @@ -9230,6 +9278,8 @@ type // - 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 @@ -9251,6 +9301,8 @@ type // - 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 @@ -9805,7 +9857,7 @@ type /// abstract low-level parent class for generic compression/decompression algorithms // - will encapsulate the compression algorithm with crc32c hashing - // - all Algo* abtract methods should be overriden by inherited classes + // - all Algo* abstract methods should be overriden by inherited classes TAlgoCompress = class(TSynPersistent) public /// should return a genuine byte identifier @@ -10615,9 +10667,10 @@ function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; /// 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 when end is reached +// - 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 @@ -10830,9 +10883,11 @@ function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; // - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; -/// remove comments from a text buffer before passing it to JSON parser +/// 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: @@ -10993,7 +11048,8 @@ type // - 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); + 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() @@ -12038,12 +12094,16 @@ procedure FillZero(var secret: RawUTF8); overload; {$ifdef FPC}inline;{$endif} /// fill all bytes of a memory buffer with zero -// - is expected to be used with a constant count from SizeOf() so that -// inlining make it more efficient than FillCharFast(..,...,0): -// ! FillZero(variable,SizeOf(variable)); +// - 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} @@ -12052,27 +12112,30 @@ 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, + 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, DL } - cfFSGS, cf_b01, cfSGX, cfBMI1, cfHLE, cfAVX2, cf_b06, cfSMEP, - cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, + 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, cf_c07, + 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, - cf_cc16, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23, - cf_c24, cf_c25, cf_c26, cf_c27, cf_c28, cf_c29, cfSGXLC, cf_c31, - cf_d0, cf_d1, cfAVX512NNIW, cfAVX512MAS, cf_d4, cf_d5, cf_d6, cf_d7); + 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; @@ -12365,6 +12428,7 @@ type 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 @@ -12372,7 +12436,10 @@ type // 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 - TSynDate = object + // - 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} @@ -12414,9 +12481,12 @@ type // - 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, but could be - // filled on demand via ComputeDayOfWeek - TSynSystemTime = object + // - 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; @@ -12488,6 +12558,7 @@ type 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 @@ -12531,11 +12602,20 @@ type Value: Int64; /// extract the date and time content in Value into individual values procedure Expand(out Date: TSynSystemTime); - /// convert to Iso-8601 encoded text + /// 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 + /// 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; @@ -12725,9 +12805,20 @@ procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); // - 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): RawUTF8; + 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 @@ -12755,14 +12846,14 @@ function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar=' /// 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 -procedure DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt); overload; +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 -procedure DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean); overload; +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 '' @@ -12809,16 +12900,16 @@ procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var res // - 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 -procedure TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false); overload; +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 -procedure TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false); overload; +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 @@ -13244,7 +13335,8 @@ type 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, wServer2019_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 @@ -13262,11 +13354,12 @@ const '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', 'Server 2019 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]; + 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 @@ -13541,12 +13634,16 @@ function InterlockedDecrement(var I: Integer): Integer; {$endif FPC} -/// low-level string/dynarray reference counter unprocess +/// 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) -// - on Delphi, RefCnt field is a 32-bit longint, whereas on FPC it is a SizeInt/PtrInt -function RefCntDecFree(var refcnt: TRefCnt): boolean; - {$ifndef CPUINTEL}inline;{$endif} +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 @@ -13651,7 +13748,7 @@ type {$ifdef FPC} // FPC already use heap instead of GlobalAlloc() THeapMemoryStream = TMemoryStream; {$else} - {$ifdef MSWINDOWS} + {$ifndef UNICODE} // old Delphi used GlobalAlloc() THeapMemoryStream = class(TMemoryStream) protected function Realloc(var NewCapacity: longint): Pointer; override; @@ -13746,6 +13843,7 @@ function IsRowIDShort(const FieldName: shortstring): boolean; /// 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; @@ -14370,6 +14468,7 @@ type // 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; @@ -15438,6 +15537,7 @@ function _Arr(const Items: array of const; // 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 @@ -15472,6 +15572,7 @@ function _Json(const JSON: RawUTF8; // - 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']); @@ -15501,6 +15602,7 @@ procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; // 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 @@ -15532,8 +15634,9 @@ 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]); +// ! _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 @@ -15542,6 +15645,12 @@ function _ArrFast(const Items: array of const): variant; overload; 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); @@ -15550,6 +15659,7 @@ function _JsonFastExt(const JSON: RawUTF8): variant; /// 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 @@ -16279,6 +16389,9 @@ type 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 @@ -16312,6 +16425,8 @@ type // !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 @@ -16325,6 +16440,8 @@ type // !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: @@ -16549,6 +16666,8 @@ type 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 @@ -16613,6 +16732,8 @@ type /// 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 @@ -16821,20 +16942,6 @@ function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; -resourcestring - sInvalidIPAddress = '"%s" is an invalid IP v4 address'; - sInvalidEmailAddress = '"%s" is an invalid email address'; - sInvalidPattern = '"%s" does not match the expected pattern'; - sCharacter01n = 'character,character,characters'; - sInvalidTextLengthMin = 'Expect at least %d %s'; - sInvalidTextLengthMax = 'Expect up to %d %s'; - sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+ - 'alphabetical,digital,punctuation,lowercase,uppercase,space,'+ - 'Too much spaces on the left,Too much spaces on the right'; - sValidationFailed = '"%s" rule failed'; - sValidationFieldVoid = 'An unique key field must not be void'; - sValidationFieldDuplicate = 'Value already used for this unique key field'; - implementation @@ -16878,30 +16985,6 @@ var // internal list of TSynAnsiConvert instances SynAnsiConvertList: TSynObjectList = nil; -// 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); - {$ifdef HASINLINE} {$ifdef USE_VTYPE_STATIC} // circumvent weird bug on BSD + ARM (Alfred) procedure VarClear(var v: variant); // defined here for proper inlining @@ -17038,9 +17121,6 @@ function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; var c: cardinal; {$ifndef MSWINDOWS} -{$ifdef FPC} - tmp: UnicodeString; -{$endif} {$ifdef KYLIX3} ic: iconv_t; DestBegin: PAnsiChar; @@ -17084,10 +17164,8 @@ begin fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); {$else} {$ifdef FPC} - widestringmanager.Ansi2UnicodeMoveProc(Source, - {$ifdef ISFPC27}fCodePage,{$endif}tmp,SourceChars); - MoveFast(Pointer(tmp)^,Dest^,length(tmp)*2); - result := Dest+length(tmp); + // uses our SynFPCLinux ICU API helper + result := Dest+AnsiToWideICU(fCodePage,Source,Dest,SourceChars); {$else} {$ifdef KYLIX3} result := Dest; // makes compiler happy @@ -17139,7 +17217,8 @@ begin 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]); + result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,tmp.buf, + (PtrUInt(U)-PtrUInt(tmp.buf))shr 1,[ccfNoTrailingZero]); tmp.Done; end; if not NoTrailingZero then @@ -17209,10 +17288,13 @@ 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 - tmp.Done(AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars),result); + result := '' else begin + endchar := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars,true); + tmp.Done(endchar,result); + end; end; constructor TSynAnsiConvert.Create(aCodePage: cardinal); @@ -17263,9 +17345,6 @@ function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; var c: cardinal; {$ifndef MSWINDOWS} -{$ifdef FPC} - tmp: RawByteString; -{$endif} {$ifdef KYLIX3} ic: iconv_t; DestBegin: PAnsiChar; @@ -17308,10 +17387,8 @@ begin fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); {$else} {$ifdef FPC} - widestringmanager.Unicode2AnsiMoveProc(Source,tmp, - {$ifdef ISFPC27}fCodePage,{$endif}SourceChars); - MoveFast(Pointer(tmp)^,Dest^,length(tmp)); - result := Dest+length(tmp); + // uses our SynFPCLinux ICU API helper + result := Dest+WideToAnsiICU(fCodePage,Source,Dest,SourceChars); {$else} {$ifdef KYLIX3} result := Dest; // makes compiler happy @@ -17520,7 +17597,11 @@ By1: c := byte(Source^); inc(Source); end; if not NoTrailingZero then Dest^ := #0; + {$ifdef ISDELPHI104} + exit(Dest); // circumvent Delphi 10.4 optimizer bug + {$else} Result := Dest; + {$endif} end; procedure TSynAnsiFixedWidth.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; @@ -18376,56 +18457,6 @@ NoSource: dest^ := #0; // always append a WideChar(0) to the end of the buffer end; -function IsValidUTF8(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 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 - exit else - inc(source); // check valid UTF-8 content - end; - until false; - result := true; -end; - -function IsValidUTF8(const source: RawUTF8): Boolean; -begin - result := IsValidUTF8(pointer(Source),length(Source)); -end; - -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - inc(sourcelen,PtrInt(source)); - if source<>nil then - while PtrInt(PtrUInt(source))0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if (PtrInt(PtrUInt(source))>=sourcelen) or (byte(source^) and $c0<>$80) then - exit else - inc(source); // check valid UTF-8 content - end; - end; - result := true; -end; - function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; var extra, i: integer; c: cardinal; @@ -19481,7 +19512,7 @@ smlu32: Res.Text := pointer(SmallUInt32UTF8[result]); vtPointer,vtInterface: begin Res.Text := @Res.Temp; Res.Len := SizeOf(pointer)*2; - BinToHexDisplayLower(V.VPointer,@Res.Temp,SizeOf(Pointer)); + BinToHexDisplayLower(@V.VPointer,@Res.Temp,SizeOf(Pointer)); result := SizeOf(pointer)*2; exit; end; @@ -19842,7 +19873,7 @@ begin s := pointer(Value); d := s; for i := 1 to Safe.Padding[0].VInteger do begin - if PRefCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin + if PStrCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin {$ifdef FPC} Finalize(PRawUTF8(s)^); {$else} @@ -19966,8 +19997,6 @@ begin UniqueText(aResult); end; -{$ifndef NOVARIANTS} - procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline; {$endif} var v: TVarData absolute Value; begin @@ -19981,6 +20010,8 @@ begin end; end; +{$ifndef NOVARIANTS} + procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8); begin ClearVariantForString(aResult); @@ -20440,11 +20471,11 @@ type {$ifdef ISFPC27} codePage: TSystemCodePage; // =Word elemSize: Word; + {$ifndef STRCNT32} {$ifdef CPU64} _PaddingToQWord: DWord; - {$endif} - {$endif} - refCnt: TRefCnt; // =SizeInt + {$endif} {$endif} {$endif} + refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4 length: SizeInt; end; {$else FPC} @@ -20455,7 +20486,7 @@ type _Padding: LongInt; {$endif} /// dynamic array reference count (basic garbage memory mechanism) - refCnt: TRefCnt; + refCnt: TDACnt; /// length in element count // - size in bytes = length*ElemSize length: PtrInt; @@ -20481,7 +20512,7 @@ type elemSize: Word; {$endif UNICODE} /// COW string reference count (basic garbage memory mechanism) - refCnt: TRefCnt; + refCnt: TStrCnt; /// length in characters // - size in bytes = length*elemSize length: Longint; @@ -20702,7 +20733,8 @@ 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)); - PCardinal(@PStrRec(result)^.codePage)^ := cp or (1 shl 16); // also set elemSize:=1 + 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 @@ -20758,9 +20790,15 @@ asm 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 @@ -20771,9 +20809,15 @@ 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; @@ -20784,6 +20828,19 @@ asm 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] @@ -20795,6 +20852,7 @@ lock inc qword ptr[s - _STRREFCNT] cmp qword ptr[rax - _STRREFCNT], 0 jl @n lock dec qword ptr[rax - _STRREFCNT] + {$endif STRCNT32} ja @n @free: sub d, STRRECSIZE jmp _Freemem @@ -20919,9 +20977,15 @@ asm 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 @@ -20959,7 +21023,11 @@ asm 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 @@ -21193,7 +21261,7 @@ begin if sr = nil then exit; dec(sr); - if (sr^.refcnt >= 0) and RefCntDecFree(sr^.refcnt) then + if (sr^.refcnt >= 0) and StrCntDecFree(sr^.refcnt) then FreeMem(sr); end; {$endif FPC_X64} @@ -22961,6 +23029,17 @@ asm 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; @@ -23485,7 +23564,7 @@ var from: PUTF8Char; begin if P<>nil then begin P := SQLBegin(P); - case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH']) of + case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH','EXECUTE']) of 0: if P[6]<=' ' then begin if SelectClause<>nil then begin inc(P,7); @@ -23501,6 +23580,10 @@ begin 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 @@ -23611,11 +23694,11 @@ begin L := Length(S); I := 1; while (I<=L) and (S[I]<=' ') do inc(I); - if I>L then + if I>L then // void string result := '' else - if (I=1) and (S[L]>' ') then + if (I=1) and (S[L]>' ') then // nothing to trim result := S else begin - while S[L]<=' ' do dec(L); + while S[L]<=' ' do dec(L); // allocated trimmed result := Copy(S,I,L-I+1); end; end; @@ -23915,7 +23998,7 @@ end; {$ifdef DOUBLETOSHORT_USEGRISU} // includes Fabian Loitsch's Grisu algorithm especially compiled for double -{$I .\SynDoubleToText.inc} // implements DoubleToAscii() +{$I SynDoubleToText.inc} // implements DoubleToAscii() function DoubleToShort(var S: ShortString; const Value: double): integer; var valueabs: double; @@ -23973,6 +24056,11 @@ begin FastSetString(result,@tmp[1],DoubleToShort(tmp,Value)); end; +function TrimU(const S: RawUTF8): RawUTF8; +begin + result := Trim(s); +end; + function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; begin FormatUTF8(Format,Args,result); @@ -27318,9 +27406,10 @@ begin inc(Vers,2); // e.g. wEight -> wServer2012 if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then Vers := wServer2019_64; // https://stackoverflow.com/q/53393150 - end; + 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 < wServer2019_64) then + (Vers wEight64 end; OSVersion := Vers; @@ -27589,23 +27678,43 @@ begin end; end; -function RefCntDecFree(var refcnt: TRefCnt): boolean; +function StrCntDecFree(var refcnt: TStrCnt): boolean; {$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} asm {$ifdef CPU64DELPHI} .noframe {$endif} - {$ifdef FPC_64} - lock dec qword ptr[refcnt] // TRefCnt=SizeInt=PtrInt=Int64 for FPC_64 + {$ifdef STRCNT32} + lock dec dword ptr[refcnt] {$else} - lock dec dword ptr[refcnt] // TRefCnt=longint on Delphi and FPC_32 - {$endif} + 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 FPC_64} - result := InterLockedDecrement64(refcnt)<=0; - {$else} + {$ifdef STRCNT32} result := InterLockedDecrement(refcnt)<=0; - {$endif FPC_64} + {$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} @@ -29125,37 +29234,45 @@ begin Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]); end; +{$ifdef KYLIX3} function UpperCaseUnicode(const S: RawUTF8): RawUTF8; -{$ifdef MSWINDOWS} -var tmp: RawUnicode; - TmpLen: integer; -{$endif} begin -{$ifdef MSWINDOWS} // no temporary WideString involved - tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen); - TmpLen := TmpLen shr 1; - CharUpperBuffW(pointer(tmp),TmpLen); - RawUnicodeToUtf8(pointer(tmp),TmpLen,result); -{$else} result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S))); -{$endif} end; function LowerCaseUnicode(const S: RawUTF8): RawUTF8; -{$ifdef MSWINDOWS} -var tmp: RawUnicode; - TmpLen: integer; -{$endif} begin -{$ifdef MSWINDOWS} // no temporary WideString involved - tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen); - TmpLen := TmpLen shr 1; - CharLowerBuffW(pointer(tmp),TmpLen); - RawUnicodeToUtf8(pointer(tmp),TmpLen,result); -{$else} result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S))); -{$endif} 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 @@ -29262,27 +29379,30 @@ begin FastSetString(result,pointer(S),i); end; -procedure TrimCopy(const S: RawUTF8; start,count: PtrInt; - out result: RawUTF8); +procedure TrimCopy(const S: RawUTF8; start, count: PtrInt; + var result: RawUTF8); 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 - FastSetString(result,@PByteArray(S)[start],L); + 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 @@ -30878,7 +30998,7 @@ end; function SearchRecValidFolder(const F: TSearchRec): boolean; begin - result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}and faHidden{$endif})=faDirectory) and + result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faHidden{$endif})=faDirectory) and (F.Name<>'') and (F.Name<>'.') and (F.Name<>'..'); end; @@ -31403,7 +31523,7 @@ begin exit; // wrong Index dec(n); if n>Index then begin - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TWordDynArray)); MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word)); end; @@ -31418,7 +31538,7 @@ begin exit; // wrong Index dec(n); if n>Index then begin - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer)); end; @@ -31433,7 +31553,7 @@ begin exit; // wrong Index dec(n,Index+1); if n>0 then begin - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); MoveFast(Values[Index+1],Values[Index],n*SizeOf(Integer)); end; @@ -31448,7 +31568,7 @@ begin exit; // wrong Index dec(n); if n>Index then begin - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64)); end; @@ -31463,7 +31583,7 @@ begin exit; // wrong Index dec(n,Index+1); if n>0 then begin - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); MoveFast(Values[Index+1],Values[Index],n*SizeOf(Int64)); end; @@ -31475,9 +31595,9 @@ var i,v,x,n: PtrInt; begin if (Values=nil) or (Excluded=nil) then exit; // nothing to exclude - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PRefCnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Excluded,TypeInfo(TIntegerDynArray)); v := length(Values); n := 0; @@ -31510,9 +31630,9 @@ begin Values := nil; exit; end; - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PRefCnt(PtrUInt(Included)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Included)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Included,TypeInfo(TIntegerDynArray)); v := length(Values); n := 0; @@ -33724,14 +33844,14 @@ begin _80 := PtrUInt($8080808080808080); // use registers for constants _61 := $6161616161616161; _7b := $7b7b7b7b7b7b7b7b; - for i := 0 to sourceLen shr 3 do begin + 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 shr 2 do begin + 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 @@ -33965,7 +34085,6 @@ begin result := FindIniNameValueW(P,UpperName); end; end; - {$endif UNICODE} function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; @@ -34680,7 +34799,7 @@ procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUT var offs,i: integer; begin offs := 1; - while offs#0 then begin @@ -37802,18 +37928,20 @@ begin // use Thhmmss[.sss] format inc(P); end; PWord(P)^ := tab[S]; + inc(P,2); if WithMS then begin - inc(P,2); {$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P); - P^ := '.'; // override first digit + P^ := '.'; // override first '0' digit + inc(P,4); end; + result := P; end; -procedure DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean); +function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; var T: TSynSystemTime; begin // use YYYYMMDD / YYYY-MM-DD date format T.FromDate(Date); - DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); + result := DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); end; function DateToIso8601Text(Date: TDateTime): RawUTF8; @@ -37825,24 +37953,37 @@ begin // into 'YYYY-MM-DD' date format end; end; -procedure TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean); +function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; + FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; var T: TSynSystemTime; begin T.FromTime(Time); - TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS); + 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): RawUTF8; -const ISO8601_LEN: array[boolean,boolean] of integer = ((15,14),(19,18)); + FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUTF8; var tmp: array[0..31] of AnsiChar; begin // D=0 is handled in DateTimeToIso8601Text() - DateToIso8601PChar(D,tmp,Expanded); - if Expanded then - TimeToIso8601PChar(D,@tmp[10],true,FirstChar,WithMS) else - TimeToIso8601PChar(D,@tmp[8],false,FirstChar,WithMS); - FastSetString(result,@tmp,ISO8601_LEN[Expanded,FirstChar=#0]+4*integer(WithMS)); + FastSetString(result,@tmp,DateTimeToIso8601(@tmp,D,Expanded,FirstChar,WithMS,QuotedChar)); end; function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; @@ -37897,14 +38038,10 @@ function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; begin if Value<>0 then begin - if trunc(Value)<>0 then begin - DateToIso8601PChar(Value,Dest,true); - inc(Dest,10); - end; - if frac(Value)<>0 then begin - TimeToIso8601PChar(Value,Dest,true,FirstChar,WithMS); - inc(Dest,9+4*integer(WithMS)); - end; + 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; @@ -38202,7 +38339,8 @@ begin // faster version by AB else exit; // Month <= 0 Div100(Year,d100); Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+ - (153*Month+2) div 5+Day-693900; + (153*Month+2) div 5+Day; + Date := Date-693900; // should be separated to avoid sign issues result := true; end; end; @@ -38281,49 +38419,33 @@ 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 begin + if lo and (1 shl (6+6+5)-1)=0 then // no Time: just convert date - DateToIso8601PChar(Dest, Expanded, + 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); - if Expanded then - result := 10 else - result := 8; - end else - if {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5)=0 then begin + 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 - TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar); - if Expanded then - result := 9 else - result := 7; - if FirstTimeChar=#0 then - dec(result); - end else begin + 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 - DateToIso8601PChar(Dest, Expanded, + 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); - if Expanded then - inc(Dest,10) else - inc(Dest,8); - TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar); - if Expanded then - result := 15+4 else - result := 15; - if FirstTimeChar=#0 then - dec(result); + 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 = 'T'): RawUTF8; +function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; var tmp: array[0..31] of AnsiChar; begin if Value=0 then @@ -38331,6 +38453,33 @@ begin 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 @@ -39851,6 +40000,7 @@ begin // see http://www.garykessler.net/library/file_sigs.html $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 @@ -39862,6 +40012,7 @@ begin // see http://www.garykessler.net/library/file_sigs.html $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 @@ -40257,7 +40408,7 @@ function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; ValueLen: PtrInt): PtrInt; var tmp: array[byte] of AnsiChar; begin - UpperCopy255Buf(@tmp,Value,ValueLen); + UpperCopy255Buf(@tmp,Value,ValueLen)^ := #0; result := FastFindPUTF8CharSorted(P,R,@tmp); end; @@ -40394,7 +40545,7 @@ begin if cardinal(Index)>=cardinal(n) then result := false else begin dec(n); - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); Values[Index] := ''; // avoid GPF if n>Index then begin @@ -40415,7 +40566,7 @@ begin result := false else begin dec(n); ValuesCount := n; - if PRefCnt(PtrUInt(Values)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); Values[Index] := ''; // avoid GPF dec(n,Index); @@ -40995,7 +41146,7 @@ end; {$ifndef LVCL} {$ifndef FPC} -{$ifdef MSWINDOWS} +{$ifndef UNICODE} const MemoryDelta = $8000; // 32 KB granularity (must be a power of 2) @@ -41032,7 +41183,7 @@ begin end; end; -{$endif MSWINDOWS} +{$endif UNICODE} {$endif FPC} {$endif LVCL} @@ -44203,7 +44354,7 @@ begin UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName^); up := pointer(ItemTypeName^); end else begin - UpperCopy255Buf(@tmp,TypeName,TypeNameLen); + UpperCopy255Buf(@tmp,TypeName,TypeNameLen)^ := #0; up := @tmp; end; //for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]); @@ -44451,7 +44602,7 @@ begin p := pointer(Data); dec(p); Data := 0; - if (p^.refCnt>=0) and RefCntDecFree(p^.refCnt) then begin + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin for i := 1 to p^.length do FinalizeNestedRecord(ItemData); FreeMem(p); @@ -47677,11 +47828,11 @@ begin result := false else begin dec(VCount); if VName<>nil then begin - if PRefCnt(PtrUInt(VName)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(VName)-_DAREFCNT)^>1 then DynArrayMakeUnique(@VName,TypeInfo(TRawUTF8DynArray)); VName[Index] := ''; end; - if PRefCnt(PtrUInt(VValue)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(VValue)-_DAREFCNT)^>1 then DynArrayMakeUnique(@VValue,TypeInfo(TVariantDynArray)); VarClear(VValue[Index]); if Index0) then + 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 @@ -48989,6 +49140,11 @@ 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); @@ -49217,7 +49373,7 @@ begin if p<>nil then begin v^ := nil; dec(p); - if (p^.refCnt>=0) and RefCntDecFree(p^.refCnt) then + if (p^.refCnt>=0) and StrCntDecFree(p^.refCnt) then freemem(p); end; inc(v); @@ -49282,7 +49438,7 @@ begin p := Value^; if p<>nil then begin dec(p); - if (p^.refCnt>=0) and RefCntDecFree(p^.refCnt) then begin + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin if ElemTypeInfo<>nil then FastFinalizeArray(Value^,ElemTypeInfo,p^.length); Freemem(p); @@ -49640,7 +49796,7 @@ begin n := GetCount; if PtrUInt(aIndex)>=PtrUInt(n) then exit; // out of range - if PRefCnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then + if PDACnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then InternalSetLength(n,n); // unique dec(n); P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize); @@ -49822,7 +49978,7 @@ end; procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream); var P: PAnsiChar; begin - P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soFromCurrent); + P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soCurrent); Stream.Seek(LoadFrom(P,nil,false,PAnsiChar(Stream.Memory)+Stream.Size)-P,soCurrent); end; @@ -50168,7 +50324,7 @@ begin // code below must match TTextWriter.AddDynArrayJSON() end; exit; end; - inc(P); + repeat inc(P) until not(P^ in [#1..' ']); n := JSONArrayCount(P); if n<0 then exit; // invalid array content @@ -51189,7 +51345,7 @@ begin // this method is faster than default System.DynArraySetLength() function if NewLength=0 then begin if p<>nil then begin // FastDynArrayClear() with ObjArray support dec(p); - if (p^.refCnt>=0) and RefCntDecFree(p^.refCnt) then begin + if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin if OldLength<>0 then if ElemType<>nil then FastFinalizeArray(fValue^,ElemType,OldLength) else @@ -51214,7 +51370,7 @@ begin // this method is faster than default System.DynArraySetLength() function OldLength := NewLength; // no FillcharFast() below end else begin dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object - if (p^.refCnt>=0) and RefCntDecFree(p^.refCnt) then begin + 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 @@ -51877,7 +52033,7 @@ begin // on input: HashTable[result] slot is already computed if HashTableSize=0 then RaiseFatalCollision('HashAdd',aHashCode); @@ -52124,7 +52280,7 @@ begin end; end; if not(canHash in State) then - ReHash({forced=}true,{grow=}false); // hash previous CountTrigger items + ReHash({forced=}true); // hash previous CountTrigger items result := FindOrNew(aHashCode,Elem,nil); if result<0 then begin // found no matching item wasAdded := true; @@ -52198,7 +52354,7 @@ begin inc(ScanCounter); if ScanCounter>=CountTrigger*2 then begin CountTrigger := 2; // rather use hashing from now on - ReHash(false,false); // set HashTable[] and canHash + ReHash(false); // set HashTable[] and canHash end; end; end; @@ -52215,34 +52371,30 @@ begin result := -1; // for coherency with most search methods end; -function TDynArrayHasher.ReHash(forced, forceGrow: boolean): integer; +function TDynArrayHasher.ReHash(forced: boolean): integer; var i, n, cap, siz, ndx: integer; P: PAnsiChar; hc: cardinal; begin result := 0; - // initialize a new void HashTable[]=0 - siz := HashTableSize; - Clear; - if not(hasHasher in State) then - exit; n := DynArray^.Count; - if not forced and ((n=0) or (n0) then // next power of two or next prime - {$ifdef CPU32DELPHI} - if siz 0; +end; + procedure TSynLocker.Lock; begin EnterCriticalSection(fSection); - fLocked := true; + inc(fLockCount); end; procedure TSynLocker.UnLock; begin - fLocked := false; + dec(fLockCount); LeaveCriticalSection(fSection); end; function TSynLocker.TryLock: boolean; begin - result := not fLocked and - (TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}); + result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}; + if result then + inc(fLockCount); end; function TSynLocker.TryLockMS(retryms: integer): boolean; @@ -53144,12 +53301,10 @@ function TSynLocker.GetVariant(Index: integer): Variant; begin if cardinal(Index)=PaddingUsedCount then PaddingUsedCount := Index+1; variant(Padding[Index]) := Value; finally - fLocked := false; - LeaveCriticalSection(fSection); + UnLock; end; end; @@ -53173,13 +53326,11 @@ function TSynLocker.GetInt64(Index: integer): Int64; begin if cardinal(Index)=PaddingUsedCount then PaddingUsedCount := Index+1; with Padding[index] do begin @@ -53257,8 +53403,7 @@ begin VUnknown := Value; end; finally - fLocked := false; - LeaveCriticalSection(fSection); + UnLock; end; end; @@ -53267,14 +53412,12 @@ var wasString: Boolean; begin if cardinal(Index)=PaddingUsedCount then PaddingUsedCount := Index+1; RawUTF8ToVariant(Value,Padding[Index],varString); finally - fLocked := false; - LeaveCriticalSection(fSection); + UnLock; end; end; @@ -53298,16 +53439,14 @@ function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64) begin if cardinal(Index)<=high(Padding) then try - EnterCriticalSection(fSection); - fLocked := true; + Lock; result := 0; if Index#0 then @@ -53799,18 +53934,16 @@ begin dec(B); if Value^<>0 then begin inc(B); - if trunc(Value^)<>0 then begin - DateToIso8601PChar(Value^,B,true); - inc(B,10); - end; - if frac(Value^)<>0 then begin - TimeToIso8601PChar(Value^,B,true,FirstChar,WithMS); - if WithMS then - inc(B,13) else - inc(B,9); - end; + 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; @@ -53821,20 +53954,16 @@ procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean); begin if Value=0 then exit; - if BEnd-B<=23 then + if BEnd-B<=24 then FlushToStream; inc(B); - if trunc(Value)<>0 then begin - DateToIso8601PChar(Value,B,true); - inc(B,10); - end; - if frac(Value)<>0 then begin - TimeToIso8601PChar(Value,B,true,'T',WithMS); - if WithMS then - inc(B,13) else - inc(B,9); - end; - dec(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; @@ -53911,8 +54040,12 @@ begin end; procedure TTextWriter.Add(Value: boolean); +var PS: PShortString; begin - AddShort(BOOL_STR[Value]); + 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); @@ -54701,7 +54834,7 @@ begin '{': begin repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); if JSON^='}' then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); + repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else begin repeat Name := GetJSONPropName(JSON); if Name=nil then @@ -54718,6 +54851,7 @@ begin Add('>'); end; until objEnd='}'; + end; end; else begin Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil @@ -55019,9 +55153,7 @@ begin dec(BinBytes,ChunkBytes); if BinBytes=0 then break; // Flush writes B-buf+1 -> special one below: - ChunkBytes := B-fTempBuf; - fStream.WriteBuffer(fTempBuf^,ChunkBytes); - inc(fTotalFileSize,ChunkBytes); + WriteToStream(fTempBuf,B-fTempBuf); B := fTempBuf; until false; dec(B); // allow CancelLastChar @@ -55260,9 +55392,7 @@ begin inc(PByte(P),i); dec(Len,i); // FlushInc writes B-buf+1 -> special one below: - i := B-fTempBuf; - fStream.WriteBuffer(fTempBuf^,i); - inc(fTotalFileSize,i); + WriteToStream(fTempBuf,B-fTempBuf); B := fTempBuf; until false; dec(B); // allow CancelLastChar @@ -56165,7 +56295,7 @@ begin end; if aStream<>nil then begin fStream := aStream; - fInitialStreamPosition := fStream.Seek(0,soFromCurrent); + fInitialStreamPosition := fStream.Seek(0,soCurrent); fTotalFileSize := fInitialStreamPosition; end; end; @@ -56177,8 +56307,7 @@ begin i := B-fTempBuf+1; if i<=0 then exit; - fStream.WriteBuffer(fTempBuf^,i); - inc(fTotalFileSize,i); + WriteToStream(fTempBuf,i); if not (twoFlushToStreamNoAutoResize in fCustomOptions) then begin s := fTotalFileSize-fInitialStreamPosition; if (fTempBufSize<49152) and (s>PtrUInt(fTempBufSize)*4) then @@ -56192,12 +56321,20 @@ begin exclude(fCustomOptions,twoBufferIsExternal) else FreeMem(fTempBuf); // with big content comes bigger buffer GetMem(fTempBuf,fTempBufSize); - BEnd := fTempBuf+(fTempBufSize-2); + 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 @@ -56295,10 +56432,8 @@ begin main := Base64EncodeMain(PAnsiChar(fTempBuf),P,n); n := main*4; if nnil then wasString^ := false; // not a string by default - PDest := nil; // PDest=nil indicates error or unexpected end (#0) + 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^>' '; @@ -57765,7 +57902,36 @@ begin 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 @@ -57773,35 +57939,22 @@ begin // replace comments by ' ' characters which will be ignored by parser '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then - exit; + exit else + Inc(P); end; - '/': begin - inc(P); - case P^ of - '/': begin // this is // comment - replace by ' ' - dec(P); - repeat - P^ := ' '; - inc(P) - until P^ in [#0, #10, #13]; - end; - '*': begin // this is /* comment - replace by ' ' but keep CRLF - P[-1] := ' '; - repeat - if not(P^ in [#10, #13]) then - P^ := ' '; // keep CRLF for correct line numbering (e.g. for error) - inc(P); - if PWord(P)^=ord('*')+ord('/')shl 8 then begin - PWord(P)^ := $2020; - inc(P,2); - break; - end; - until P^=#0; - end; - 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; - inc(P); end; end; @@ -58905,12 +59058,12 @@ end; procedure TAutoLocker.Enter; begin - EnterCriticalSection(fSafe.fSection); + fSafe.Lock; end; procedure TAutoLocker.Leave; begin - LeaveCriticalSection(fSafe.fSection); + fSafe.UnLock; end; function TAutoLocker.Safe: PSynLocker; @@ -58945,6 +59098,11 @@ begin 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 @@ -59157,7 +59315,8 @@ begin {$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 10.5 Next' + {$elseif defined(VER350)}'Delphi 11 Alexandria' + {$elseif defined(VER360)}'Delphi 11.1 Next' {$ifend} {$endif CONDITIONALEXPRESSIONS} {$endif FPC} @@ -60958,16 +61117,33 @@ begin 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; - while tcCtrlNot0Comma in tab[P^] do inc(P); + 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); - while tcCtrlNot0Comma in tab[P^] do inc(P); + P := GotoNextSqlIdentifier(P, tab); result := Prop<>''; end; @@ -61284,7 +61460,7 @@ begin exit; if Source.InheritsFrom(TCustomMemoryStream) then begin S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition); - Source.Seek(Head.CompressedSize,soFromCurrent); + Source.Seek(Head.CompressedSize,soCurrent); end else begin if Head.CompressedSize>length(Buf) then SetString(Buf,nil,Head.CompressedSize); @@ -61847,13 +62023,14 @@ begin inherited Create(msg); end; -constructor ESynException.CreateLastOSError(const Format: RawUTF8; const Args: array of const); +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('OSError % [%] %',[error,SysErrorMessage(error),tmp]); + CreateUTF8('% % [%] %',[Trailer,error,SysErrorMessage(error),tmp]); end; {$ifndef NOEXCEPTIONINTERCEPT} @@ -62541,8 +62718,9 @@ var name: RawUTF8; begin FormatUTF8(Format,Args,name); name := StringReplaceAll(name,['TSQLRest','', 'TSQL','', 'TWebSocket','WS', - 'TSyn','', 'Thread','', 'Process','', 'Background','Bgd', 'Server','Svr', - 'Client','Clt', 'WebSocket','WS', 'Timer','Tmr', 'Thread','Thd']); + 'TServiceFactory','SF', 'TSyn','', 'Thread','', 'Process','', + 'Background','Bgd', 'Server','Svr', 'Client','Clt', 'WebSocket','WS', + 'Timer','Tmr', 'Thread','Thd']); SetThreadNameInternal(ThreadID,name); end; @@ -62728,7 +62906,7 @@ begin GetCPUID(7,regs); PIntegerArray(@CpuFeatures)^[2] := regs.ebx; PIntegerArray(@CpuFeatures)^[3] := regs.ecx; - PByte(@PIntegerArray(@CpuFeatures)^[4])^ := regs.edx; + PIntegerArray(@CpuFeatures)^[4] := regs.edx; {$ifdef DISABLE_SSE42} // paranoid execution on Darwin x64 (as reported by alf) CpuFeatures := CpuFeatures-[cfSSE42,cfAESNI]; {$endif DISABLE_SSE42} @@ -63063,7 +63241,9 @@ begin 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 + 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); diff --git a/contrib/mORMot/SynCrtSock.pas b/contrib/mORMot/SynCrtSock.pas index a0a12f2..0f3d72f 100644 --- a/contrib/mORMot/SynCrtSock.pas +++ b/contrib/mORMot/SynCrtSock.pas @@ -6,7 +6,7 @@ unit SynCrtSock; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCrtSock; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -292,7 +292,8 @@ type // - 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); + 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 @@ -570,8 +571,8 @@ type /// 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); + 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); @@ -619,6 +620,7 @@ type /// 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; @@ -805,7 +807,7 @@ type {$endif MSWINDOWS} /// defines the sub-threads used by TSynThreadPool - TSynThreadPoolSubThread = class(TSynThread) + TSynThreadPoolWorkThread = class(TSynThread) protected fOwner: TSynThreadPool; fNotifyThreadStartName: AnsiString; @@ -825,14 +827,16 @@ type 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 - fSubThread: array of TSynThreadPoolSubThread; - fSubThreadCount: integer; + fWorkThread: TSynThreadPoolWorkThreads; + fWorkThreadCount: integer; fRunningThreads: integer; fExceptionsCount: integer; fOnThreadTerminate: TNotifyThreadEvent; @@ -887,7 +891,11 @@ type /// 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 @@ -1018,7 +1026,7 @@ type /// 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. SynCrtSock's TWebSocketProcess.NotifyCallback method would use + // - 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 @@ -1352,7 +1360,6 @@ type fRegisteredUnicodeUrl: array of SockUnicode; fServerSessionID: HTTP_SERVER_SESSION_ID; fUrlGroupID: HTTP_URL_GROUP_ID; - fExecuting: boolean; fLogData: pointer; fLogDataStorage: array of byte; fLoggingServiceName: SockString; @@ -2346,6 +2353,8 @@ type // 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; @@ -2491,9 +2500,9 @@ type 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 returnsd by a previous call to Request() + /// returns the HTTP body as returned by a previous call to Request() property Body: SockString read fBody; - /// returns the HTTP headers as returnsd by a previous call to Request() + /// 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; @@ -2531,7 +2540,8 @@ function OpenHttp(const aURI: SockString; aAddress: PSockString=nil): THttpClien /// 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() +// 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): SockString; overload; @@ -2560,6 +2570,10 @@ function HttpGetAuth(const aURI, aAuthToken: SockString; 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; @@ -2616,7 +2630,8 @@ function SendEmail(const Server, From, CSVDest, Subject, Text: SockString; // - 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 +// - 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; @@ -3895,7 +3910,6 @@ const ERROR_WINHTTP_TIMEOUT = 12002; ERROR_WINHTTP_INVALID_SERVER_RESPONSE = 12152; - function SysErrorMessagePerModule(Code: DWORD; ModuleName: PChar): string; {$ifdef MSWINDOWS} var tmpLen: DWORD; @@ -3909,6 +3923,11 @@ begin 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); @@ -4823,7 +4842,7 @@ function WSAIsFatalError(anothernonfatal: integer=NO_ERROR): boolean; var err: integer; begin err := WSAGetLastError; - result := (err<>NO_ERROR) and (err<>WSATRY_AGAIN) and (err<>WSAEINTR) and + 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; @@ -4928,14 +4947,15 @@ begin result := false; end; -constructor TCrtSocket.Bind(const aAddr: SockString; aLayer: TCrtSocketLayer); +constructor TCrtSocket.Bind(const aAddr: SockString; aLayer: TCrtSocketLayer; + aTimeOut: integer); var s,p: SockString; aSock: integer; {$ifdef LINUXNOTBSD} n: integer; {$endif} begin - Create(10000); + Create(aTimeOut); if aAddr='' then begin {$ifdef LINUXNOTBSD} // try systemd if not SystemdIsAvailable then @@ -4980,16 +5000,15 @@ begin if self=nil then exit; fSndBufLen := 0; // always reset (e.g. in case of further Open) - if (SockIn<>nil) or (SockOut<>nil) then begin - 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; + 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 @@ -5226,7 +5245,7 @@ begin exit; if ResultClass=nil then ResultClass := TCrtSocket; - result := ResultClass.Create; + result := ResultClass.Create(Timeout); result.AcceptRequest(client,@sin); result.CreateSockIn; // use SockIn with 1KB input buffer: 2x faster end; @@ -5435,8 +5454,8 @@ begin TSynLog.Add.Log(sllCustom2, 'TrySockRecv: sock=% AsynchRecv=% %', [Sock,read,SocketErrorMessage],self); {$endif} - if WSAIsFatalError then begin - Close; // connection broken or socket closed gracefully + if (read=0) or WSAIsFatalError then begin + Close; // connection broken or socket closed gracefully (read=0) exit; end; if StopBeforeLength then @@ -5725,7 +5744,7 @@ 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); + 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); @@ -5734,7 +5753,8 @@ procedure DoRetry(Error: integer; const msg: SockString); result := Error else begin Close; // close this connection try - OpenBind(Server,Port,false); // retry this request with a new socket + 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 @@ -5748,8 +5768,9 @@ begin if SockIn=nil then // done once CreateSockIn; // use SockIn by default if not already initialized: 2x faster Content := ''; - if SockReceivePending(0)=cspSocketError then begin - DoRetry(STATUS_NOTFOUND,'connection broken (keepalive timeout?)'); + if (connectionClose in HeaderFlags) or + (SockReceivePending(0)=cspSocketError) then begin + DoRetry(STATUS_NOTFOUND,'connection broken (kepepalive timeout or too many requests)'); exit; end; try @@ -5801,8 +5822,10 @@ begin exit; end; GetHeader(false); // read all other headers - if (result<>STATUS_NOCONTENT) and not IdemPChar(pointer(method),'HEAD') then - GetBody; // get content if necessary (not HEAD method) + 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'); @@ -5921,6 +5944,23 @@ begin 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 @@ -6002,9 +6042,12 @@ begin head := trim(Headers); if head<>'' then head := head+#13#10; - writeln(TCP.SockOut^,'Subject: ',Subject,#13#10'From: ',From, - ToList,#13#10'Content-Type: text/plain; charset=',TextCharSet, - #13#10'Content-Transfer-Encoding: 8bit'#13#10,head,#13#10,Text); + 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; @@ -6390,7 +6433,7 @@ begin exit; Sleep(1); if GetTick64 > tix then - raise ECrtSocket.CreateFmt('%s.WaitStarted failed after % seconds with %s', + raise ECrtSocket.CreateFmt('%s.WaitStarted failed after %d seconds [%s]', [ClassName,Seconds,fExecuteMessage]); until false; end; @@ -6653,17 +6696,20 @@ begin exit; until GetTick64>endtix; end; - result := false; // normal delay expiration + result := false; // abnormal delay expiration end; {$ifndef LVCL} procedure TSynThread.DoTerminate; begin - if Assigned(fStartNotified) and Assigned(fOnThreadTerminate) then begin - fOnThreadTerminate(self); - fStartNotified := nil; + 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; - inherited DoTerminate; end; {$endif} @@ -6798,7 +6844,8 @@ begin HandleRequestsProcess; end else begin // call from TSynThreadPoolTHttpServer -> handle first request - if not fServerSock.fBodyRetrieved then + 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 @@ -6864,9 +6911,9 @@ begin SetLength(Content,ContentLength); // not chuncked: direct read SockInRead(pointer(Content),ContentLength); // works with SockIn=nil or not end else - if ContentLength<0 then begin // ContentLength=-1 if no Content-Length - // no Content-Length nor Chunked header -> read until eof() - if SockIn<>nil then + 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 @@ -6996,7 +7043,7 @@ begin PWord(@line[len])^ := 13+10 shl 8; // CR + LF SockSend(@line,len+2); end else - SockSend(s); + SockSend(s); // SockSend() internal buffer is used as temporary buffer until false; Headers := copy(fSndBuf, 1, fSndBufLen); fSndBufLen := 0; @@ -7150,7 +7197,8 @@ begin end; end; if withBody and not (connectionUpgrade in HeaderFlags) then begin - GetBody; + if IdemPCharArray(pointer(fMethod),['HEAD','OPTIONS'])<0 then + GetBody; result := grBodyReceived; end else result := grHeaderReceived; @@ -7262,8 +7310,8 @@ end; { TSynThreadPool } const - // up to 256 * 2MB = 512MB of RAM for the TSynThreadPoolSubThread stack - THREADPOOL_MAXSUBTHREADS = 256; + // 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 @@ -7279,8 +7327,8 @@ var i: integer; begin if NumberOfThreads=0 then NumberOfThreads := 1 else - if cardinal(NumberOfThreads)>THREADPOOL_MAXSUBTHREADS then - NumberOfThreads := THREADPOOL_MAXSUBTHREADS; + 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); @@ -7293,24 +7341,24 @@ begin fQueuePendingContext := aQueuePendingContext; {$endif} // now create the worker threads - fSubThreadCount := NumberOfThreads; - SetLength(fSubThread,fSubThreadCount); - for i := 0 to fSubThreadCount-1 do - fSubThread[i] := TSynThreadPoolSubThread.Create(Self); + 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; // fSubThread[].Execute will check this flag + fTerminated := true; // fWorkThread[].Execute will check this flag try // notify the threads we are shutting down - for i := 0 to fSubThreadCount-1 do + for i := 0 to fWorkThreadCount-1 do {$ifdef USE_WINIOCP} PostQueuedCompletionStatus(fRequestQueue,0,0,nil); {$else} - fSubThread[i].fEvent.SetEvent; + fWorkThread[i].fEvent.SetEvent; {$endif} {$ifndef USE_WINIOCP} // cleanup now any pending task (e.g. THttpServerSocket instance) @@ -7321,8 +7369,8 @@ begin endtix := GetTick64+30000; while (fRunningThreads>0) and (GetTick64QueueLength then + if n+fWorkThreadCount>QueueLength then exit; // too many connection limit reached (see QueueIsFull) if n=length(fPendingContext) then SetLength(fPendingContext,n+n shr 3+64); @@ -7423,7 +7471,7 @@ end; function TSynThreadPool.QueueIsFull: boolean; begin result := fQueuePendingContext and - (GetPendingContextCount+fSubThreadCount>QueueLength); + (GetPendingContextCount+fWorkThreadCount>QueueLength); end; function TSynThreadPool.PopPendingContext: pointer; @@ -7461,9 +7509,9 @@ begin end; -{ TSynThreadPoolSubThread } +{ TSynThreadPoolWorkThread } -constructor TSynThreadPoolSubThread.Create(Owner: TSynThreadPool); +constructor TSynThreadPoolWorkThread.Create(Owner: TSynThreadPool); begin fOwner := Owner; // ensure it is set ASAP: on Linux, Execute raises immediately fOnThreadTerminate := Owner.fOnThreadTerminate; @@ -7473,7 +7521,7 @@ begin inherited Create(false); end; -destructor TSynThreadPoolSubThread.Destroy; +destructor TSynThreadPoolWorkThread.Destroy; begin inherited Destroy; {$ifndef USE_WINIOCP} @@ -7488,7 +7536,7 @@ function GetQueuedCompletionStatus(CompletionPort: THandle; external kernel32; // redefine with an unique signature for all Delphi/FPC {$endif} -procedure TSynThreadPoolSubThread.DoTask(Context: pointer); +procedure TSynThreadPoolWorkThread.DoTask(Context: pointer); begin try fOwner.Task(Self,Context); @@ -7498,7 +7546,7 @@ begin end; end; -procedure TSynThreadPoolSubThread.Execute; +procedure TSynThreadPoolWorkThread.Execute; var ctxt: pointer; {$ifdef USE_WINIOCP} dum1: DWORD; @@ -7539,7 +7587,7 @@ begin end; end; -procedure TSynThreadPoolSubThread.NotifyThreadStart(Sender: TSynThread); +procedure TSynThreadPoolWorkThread.NotifyThreadStart(Sender: TSynThread); begin if Sender=nil then raise ECrtSocket.Create('NotifyThreadStart(nil)'); @@ -7606,7 +7654,8 @@ begin 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) then begin + 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; @@ -8960,7 +9009,7 @@ begin Http.CloseUrlGroup(fUrlGroupID); fUrlGroupID := 0; end; - CloseHandle(FReqQueue); + CloseHandle(fReqQueue); if fServerSessionID<>0 then begin Http.CloseServerSession(fServerSessionID); fServerSessionID := 0; @@ -8971,6 +9020,10 @@ begin 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; @@ -8979,18 +9032,14 @@ begin end; destructor THttpApiServer.Destroy; -var endtix: Int64; 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; - if fExecuting then begin - endtix := GetTick64+5000; // never wait forever - repeat - sleep(1); - until not fExecuting or (GetTick64>endtix); // ensure Execute has ended - end; + {$ifdef FPC} + WaitForSingleObject(Handle,30000); // wait the main Execute method on FPC + {$endif FPC} finally inherited Destroy; end; @@ -9205,7 +9254,6 @@ var Req: PHTTP_REQUEST; begin if Terminated then exit; - fExecuting := true; Context := nil; try // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event @@ -9391,7 +9439,6 @@ begin until Terminated; finally Context.Free; - fExecuting := false; end; end; @@ -9863,7 +9910,8 @@ type hReceive, hSend ); -const sProtocolHeader: SockString = 'SEC-WEBSOCKET-PROTOCOL'; +const + sProtocolHeader: SockString = 'SEC-WEBSOCKET-PROTOCOL'; function HttpSys2ToWebSocketHeaders(const aHttpHeaders: HTTP_REQUEST_HEADERS): WEB_SOCKET_HTTP_HEADER_ARR; var headerCnt: Integer; @@ -10164,7 +10212,8 @@ begin fFirstEmptyConnectionIndex := index; end; -function THttpApiWebSocketServerProtocol.Send(index: Integer; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG): boolean; +function THttpApiWebSocketServerProtocol.Send(index: Integer; + aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG): boolean; var conn: PHttpApiWebSocketConnection; begin result := false; @@ -11539,11 +11588,22 @@ 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', - [dwInternetStatus, pdword(lpvStatusInformation)^]); + raise EWinHTTP.CreateFmt('WinHTTP security error. Status %d, StatusInfo: %d ($%x%s)', + [dwInternetStatus, code, code, err]); end; {$ifndef UNICODE} @@ -11569,12 +11629,22 @@ function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall 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 - // MPV - don't know why, but if I pass WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 - // flag also, TLS1.2 do not work protocols: DWORD; begin if OSVersionInfo.dwOSVersionInfoSize=0 then begin // API call once @@ -11596,13 +11666,7 @@ begin ConnectionTimeOut,SendTimeout,ReceiveTimeout) then RaiseLastModuleError(winhttpdll,EWinHTTP); if fHTTPS then begin - protocols := WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 - or 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 - protocols := protocols or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 - or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2; + protocols := InternalGetProtocols; if not WinHttpAPI.SetOption(fSession, WINHTTP_OPTION_SECURE_PROTOCOLS, @protocols, SizeOf(protocols)) then RaiseLastModuleError(winhttpdll,EWinHTTP); @@ -11750,10 +11814,8 @@ begin RaiseLastModuleError(winhttpdll,EWinHTTP); L := length(aData); if not _SendRequest(L) or - not WinHttpAPI.ReceiveResponse(fRequest,nil) then begin - if not fHTTPS then - RaiseLastModuleError(winhttpdll,EWinHTTP); - if (GetLastError=ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED) and + 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 @@ -11764,8 +11826,8 @@ begin if not _SendRequest(L) or not WinHttpAPI.ReceiveResponse(fRequest,nil) then RaiseLastModuleError(winhttpdll,EWinHTTP); - end; - end; + end + else RaiseLastModuleError(winhttpdll,EWinHTTP); end; @@ -11879,11 +11941,13 @@ begin if not IsAvailable then raise ECrtSocket.CreateFmt('No available %s',[LIBCURL_DLL]); fHandle := curl.easy_init; - ConnectionTimeOut := ConnectionTimeOut div 1000; // curl expects seconds - if ConnectionTimeOut=0 then - ConnectionTimeOut := 1; - curl.easy_setopt(fHandle,coConnectTimeout,ConnectionTimeOut); // default=300 ! - // coTimeout=CURLOPT_TIMEOUT is global for the transfer, so shouldn't be used + 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])); @@ -11906,7 +11970,6 @@ begin fSSL.CACertFile := aCertFile; end; - procedure TCurlHTTP.UseClientCertificate( const aCertFile, aCACertFile, aKeyName, aPassPhrase: SockString); begin @@ -12077,7 +12140,7 @@ begin else try if (fHttp = nil) or (fHttp.Server <> Uri.Server) or - (fHttp.Port <> Uri.Port) then begin + (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); diff --git a/contrib/mORMot/SynCrypto.pas b/contrib/mORMot/SynCrypto.pas index 4981492..1f315a7 100644 --- a/contrib/mORMot/SynCrypto.pas +++ b/contrib/mORMot/SynCrypto.pas @@ -8,7 +8,7 @@ unit SynCrypto; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -27,7 +27,7 @@ unit SynCrypto; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -328,6 +328,76 @@ type function KeyBits: integer; {$ifdef FPC}inline;{$endif} end; +type + /// low-level AES-GCM processing + // - implements standard AEAD (authenticated-encryption with associated-data) + // algorithm, as defined by NIST and + TAESGCMEngine = object + private + /// standard AES encryption context + // - will use AES-NI if available + actx: TAES; + /// ghash value of the Authentication Data + aad_ghv: TAESBlock; + /// ghash value of the Ciphertext + txt_ghv: TAESBlock; + /// ghash H current value + ghash_h: TAESBlock; + /// number of Authentication Data bytes processed + aad_cnt: TQWordRec; + /// number of bytes of the Ciphertext + atx_cnt: TQWordRec; + /// initial 32-bit ctr val - to be reused in Final() + y0_val: integer; + /// current 0..15 position in encryption block + blen: byte; + /// the state of this context + flags: set of (flagInitialized, flagFinalComputed, flagFlushed); + /// lookup table for fast Galois Finite Field multiplication + // - is defined as last field of the object for better code generation + gf_t4k: array[byte] of TAESBlock; + /// build the gf_t4k[] internal table - assuming set to zero by caller + procedure Make4K_Table; + /// compute a * ghash_h in Galois Finite Field 2^128 + procedure gf_mul_h(var a: TAESBlock); {$ifdef FPC} inline; {$endif} + /// low-level AES-CTR encryption + procedure internal_crypt(ptp, ctp: PByte; ILen: PtrUInt); + /// low-level GCM authentication + procedure internal_auth(ctp: PByte; ILen: PtrUInt; + var ghv: TAESBlock; var gcnt: TQWordRec); + public + /// initialize the AES-GCM structure for the supplied Key + function Init(const Key; KeyBits: PtrInt): boolean; + /// start AES-GCM encryption with a given Initialization Vector + // - IV_len is in bytes use 12 for exact IV setting, otherwise the + // supplied buffer will be hashed using gf_mul_h() + function Reset(pIV: pointer; IV_len: PtrInt): boolean; + /// encrypt a buffer with AES-GCM, updating the associated authentication data + function Encrypt(ptp, ctp: Pointer; ILen: PtrInt): boolean; + /// decrypt a buffer with AES-GCM, updating the associated authentication data + // - also validate the GMAC with the supplied ptag/tlen if ptag<>nil, + // and skip the AES-CTR phase if the authentication doesn't match + function Decrypt(ctp, ptp: Pointer; ILen: PtrInt; + ptag: pointer=nil; tlen: PtrInt=0): boolean; + /// append some data to be authenticated, but not encrypted + function Add_AAD(pAAD: pointer; aLen: PtrInt): boolean; + /// finalize the AES-GCM encryption, returning the authentication tag + // - will also flush the AES context to avoid forensic issues, unless + // andDone is forced to false + function Final(out tag: TAESBlock; andDone: boolean=true): boolean; + /// flush the AES context to avoid forensic issues + // - do nothing if Final() has been already called + procedure Done; + /// single call AES-GCM encryption and authentication process + function FullEncryptAndAuthenticate(const Key; KeyBits: PtrInt; + pIV: pointer; IV_len: PtrInt; pAAD: pointer; aLen: PtrInt; + ptp, ctp: Pointer; pLen: PtrInt; out tag: TAESBlock): boolean; + /// single call AES-GCM decryption and verification process + function FullDecryptAndVerify(const Key; KeyBits: PtrInt; + pIV: pointer; IV_len: PtrInt; pAAD: pointer; aLen: PtrInt; + ctp, ptp: Pointer; pLen: PtrInt; ptag: pointer; tLen: PtrInt): boolean; + end; + /// class-reference type (metaclass) of an AES cypher/uncypher TAESAbstractClass = class of TAESAbstract; @@ -639,7 +709,7 @@ type /// release the used instance memory and resources // - also fill the TAES instance with zeros, for safety destructor Destroy; override; - /// perform the AES cypher in the corresponding mode + /// perform the AES cypher in the corresponding mode, over Count bytes // - this abstract method will set CV from fIV property, and fIn/fOut // from BufIn/BufOut procedure Encrypt(BufIn, BufOut: pointer; Count: cardinal); override; @@ -818,6 +888,46 @@ type procedure Decrypt(BufIn, BufOut: pointer; Count: cardinal); override; end; + /// handle AES-GCM cypher/uncypher with built-in authentication + // - implements AEAD (authenticated-encryption with associated-data) methods + // like MACEncrypt/MACCheckError + // - this class will use AES-NI hardware instructions, if available + TAESGCM = class(TAESAbstract) + protected + fAES: TAESGCMEngine; + fContext: (ctxNone,ctxEncrypt,ctxDecrypt); // used to call AES.Reset() + public + /// Initialize the AES-GCM context for cypher + // - first method to call before using this class + // - KeySize is in bits, i.e. 128,192,256 + constructor Create(const aKey; aKeySize: cardinal); override; + /// creates a new instance with the very same values + // - by design, our classes will use TAESGCMEngine stateless context, so + // this method will just copy the current fields to a new instance, + // by-passing the key creation step + function Clone: TAESAbstract; override; + /// release the used instance memory and resources + // - also fill the internal TAES instance with zeros, for safety + destructor Destroy; override; + /// perform the AES-GCM cypher and authentication + procedure Encrypt(BufIn, BufOut: pointer; Count: cardinal); override; + /// perform the AES un-cypher and authentication + procedure Decrypt(BufIn, BufOut: pointer; Count: cardinal); override; + /// prepare the AES-GCM process before Encrypt/Decrypt is called + // - aKey is not used: AES-GCM has its own nonce setting algorithm, and + // the IV will be set from random value by EncryptPKCS7() + // - will just include any supplied associated data to the GMAC tag + function MACSetNonce(const aKey: THash256; aAssociated: pointer=nil; + aAssociatedLen: integer=0): boolean; override; + /// returns AEAD (authenticated-encryption with associated-data) MAC + /// - only the lower 128-bit (THash256.Lo) of aCRC is filled with the GMAC + function MACGetLast(out aCRC: THash256): boolean; override; + /// validate if an encrypted buffer matches the stored AEAD MAC + // - since AES-GCM is a one pass process, always assume the content is fine + // and returns true - we don't know the IV at this time + function MACCheckError(aEncrypted: pointer; Count: cardinal): boolean; override; + end; + {$ifdef USE_PROV_RSA_AES} type /// handle AES cypher/uncypher using Windows CryptoAPI and the @@ -2403,7 +2513,7 @@ type /// finalize the encryption destructor Destroy; override; /// initialize the communication by exchanging some client/server information - // - this method will return sprUnsupported + // - this method will return sprUnsupported, since no key negociation is involved function ProcessHandshake(const MsgIn: RawUTF8; out MsgOut: RawUTF8): TProtocolResult; /// encrypt a message on one side, ready to be transmitted to the other side // - this method uses AES encryption and PKCS7 padding @@ -6221,6 +6331,433 @@ end; {$endif USETHREADSFORBIGAESBLOCKS} +{ AES-GCM Support } + +const + // lookup table as used by mul_x/gf_mul/gf_mul_h + gft_le: array[byte] of word = ( + $0000, $c201, $8403, $4602, $0807, $ca06, $8c04, $4e05, + $100e, $d20f, $940d, $560c, $1809, $da08, $9c0a, $5e0b, + $201c, $e21d, $a41f, $661e, $281b, $ea1a, $ac18, $6e19, + $3012, $f213, $b411, $7610, $3815, $fa14, $bc16, $7e17, + $4038, $8239, $c43b, $063a, $483f, $8a3e, $cc3c, $0e3d, + $5036, $9237, $d435, $1634, $5831, $9a30, $dc32, $1e33, + $6024, $a225, $e427, $2626, $6823, $aa22, $ec20, $2e21, + $702a, $b22b, $f429, $3628, $782d, $ba2c, $fc2e, $3e2f, + $8070, $4271, $0473, $c672, $8877, $4a76, $0c74, $ce75, + $907e, $527f, $147d, $d67c, $9879, $5a78, $1c7a, $de7b, + $a06c, $626d, $246f, $e66e, $a86b, $6a6a, $2c68, $ee69, + $b062, $7263, $3461, $f660, $b865, $7a64, $3c66, $fe67, + $c048, $0249, $444b, $864a, $c84f, $0a4e, $4c4c, $8e4d, + $d046, $1247, $5445, $9644, $d841, $1a40, $5c42, $9e43, + $e054, $2255, $6457, $a656, $e853, $2a52, $6c50, $ae51, + $f05a, $325b, $7459, $b658, $f85d, $3a5c, $7c5e, $be5f, + $00e1, $c2e0, $84e2, $46e3, $08e6, $cae7, $8ce5, $4ee4, + $10ef, $d2ee, $94ec, $56ed, $18e8, $dae9, $9ceb, $5eea, + $20fd, $e2fc, $a4fe, $66ff, $28fa, $eafb, $acf9, $6ef8, + $30f3, $f2f2, $b4f0, $76f1, $38f4, $faf5, $bcf7, $7ef6, + $40d9, $82d8, $c4da, $06db, $48de, $8adf, $ccdd, $0edc, + $50d7, $92d6, $d4d4, $16d5, $58d0, $9ad1, $dcd3, $1ed2, + $60c5, $a2c4, $e4c6, $26c7, $68c2, $aac3, $ecc1, $2ec0, + $70cb, $b2ca, $f4c8, $36c9, $78cc, $bacd, $fccf, $3ece, + $8091, $4290, $0492, $c693, $8896, $4a97, $0c95, $ce94, + $909f, $529e, $149c, $d69d, $9898, $5a99, $1c9b, $de9a, + $a08d, $628c, $248e, $e68f, $a88a, $6a8b, $2c89, $ee88, + $b083, $7282, $3480, $f681, $b884, $7a85, $3c87, $fe86, + $c0a9, $02a8, $44aa, $86ab, $c8ae, $0aaf, $4cad, $8eac, + $d0a7, $12a6, $54a4, $96a5, $d8a0, $1aa1, $5ca3, $9ea2, + $e0b5, $22b4, $64b6, $a6b7, $e8b2, $2ab3, $6cb1, $aeb0, + $f0bb, $32ba, $74b8, $b6b9, $f8bc, $3abd, $7cbf, $bebe); + +procedure mul_x(var a: TAESBlock; const b: TAESBlock); +// {$ifdef HASINLINE}inline;{$endif} // inlining has no benefit here +var t: cardinal; + y: TWA4 absolute b; +const + MASK_80 = cardinal($80808080); + MASK_7F = cardinal($7f7f7f7f); +begin + t := gft_le[(y[3] shr 17) and MASK_80]; + TWA4(a)[3] := ((y[3] shr 1) and MASK_7F) or (((y[3] shl 15) or (y[2] shr 17)) and MASK_80); + TWA4(a)[2] := ((y[2] shr 1) and MASK_7F) or (((y[2] shl 15) or (y[1] shr 17)) and MASK_80); + TWA4(a)[1] := ((y[1] shr 1) and MASK_7F) or (((y[1] shl 15) or (y[0] shr 17)) and MASK_80); + TWA4(a)[0] := (((y[0] shr 1) and MASK_7F) or ( (y[0] shl 15) and MASK_80)) xor t; +end; + +procedure gf_mul(var a: TAESBlock; const b: TAESBlock); +var p: array[0..7] of TAESBlock; + x: TWA4; + t: cardinal; + i: PtrInt; + j: integer; + c: byte; +begin + p[0] := b; + for i := 1 to 7 do + mul_x(p[i], p[i-1]); + FillZero(TAESBlock(x)); + for i:=0 to 15 do begin + c := a[15-i]; + if i>0 then begin + // inlined mul_x8() + t := gft_le[x[3] shr 24]; + x[3] := ((x[3] shl 8) or (x[2] shr 24)); + x[2] := ((x[2] shl 8) or (x[1] shr 24)); + x[1] := ((x[1] shl 8) or (x[0] shr 24)); + x[0] := ((x[0] shl 8) xor t); + end; + for j:=0 to 7 do begin + if c and ($80 shr j) <> 0 then begin + x[3] := x[3] xor TWA4(p[j])[3]; + x[2] := x[2] xor TWA4(p[j])[2]; + x[1] := x[1] xor TWA4(p[j])[1]; + x[0] := x[0] xor TWA4(p[j])[0]; + end; + end; + end; + a := TAESBlock(x); +end; + + +{ TAESGCMEngine } + +procedure TAESGCMEngine.Make4K_Table; +var j, k: PtrInt; +begin + gf_t4k[128] := ghash_h; + j := 64; + while j>0 do begin + mul_x(gf_t4k[j],gf_t4k[j+j]); + j := j shr 1; + end; + j := 2; + while j<256 do begin + for k := 1 to j-1 do + XorBlock16(@gf_t4k[k],@gf_t4k[j+k],@gf_t4k[j]); + inc(j,j); + end; +end; + +procedure TAESGCMEngine.gf_mul_h(var a: TAESBlock); +var + x: TWA4; + i: PtrUInt; + t: cardinal; + p: PWA4; + {$ifdef CPUX86NOTPIC} + tab: TWordArray absolute gft_le; + {$else} + tab: PWordArray; + {$endif CPUX86NOTPIC} +begin + {$ifndef CPUX86NOTPIC} + tab := @gft_le; + {$endif CPUX86NOTPIC} + x := TWA4(gf_t4k[a[15]]); + for i := 14 downto 0 do begin + p := @gf_t4k[a[i]]; + t := tab[x[3] shr 24]; + // efficient mul_x8 and xor using pre-computed table entries + x[3] := ((x[3] shl 8) or (x[2] shr 24)) xor p^[3]; + x[2] := ((x[2] shl 8) or (x[1] shr 24)) xor p^[2]; + x[1] := ((x[1] shl 8) or (x[0] shr 24)) xor p^[1]; + x[0] := ((x[0] shl 8) xor t) xor p^[0]; + end; + a := TAESBlock(x); +end; + +procedure GCM_IncCtr(var x: TAESBlock); {$ifdef HASINLINE} inline; {$endif} +begin + // in AES-GCM, CTR covers only 32 LSB Big-Endian bits, i.e. x[15]..x[12] + inc(x[15]); + if x[15]<>0 then + exit; + inc(x[14]); + if x[14]<>0 then + exit; + inc(x[13]); + if x[13]=0 then + inc(x[12]); +end; + +procedure TAESGCMEngine.internal_crypt(ptp, ctp: PByte; ILen: PtrUInt); +var b_pos: PtrUInt; +begin + b_pos := blen; + inc(blen,ILen); + blen := blen and AESBlockMod; + if b_pos=0 then + b_pos := SizeOf(TAESBlock) else + while (ILen>0) and (b_pos=SizeOf(TAESBlock) do begin + GCM_IncCtr(TAESContext(actx).IV); + actx.Encrypt(TAESContext(actx).IV,TAESContext(actx).buf); // maybe AES-NI + XorBlock16(pointer(ptp),pointer(ctp),@TAESContext(actx).buf); + inc(PAESBlock(ptp)); + inc(PAESBlock(ctp)); + dec(ILen,SizeOf(TAESBlock)); + end; + while ILen>0 do begin + if b_pos=SizeOf(TAESBlock) then begin + GCM_IncCtr(TAESContext(actx).IV); + actx.Encrypt(TAESContext(actx).IV,TAESContext(actx).buf); + b_pos := 0; + end; + ctp^ := TAESContext(actx).buf[b_pos] xor ptp^; + inc(b_pos); + inc(ptp); + inc(ctp); + dec(ILen); + end; +end; + +procedure TAESGCMEngine.internal_auth(ctp: PByte; ILen: PtrUInt; + var ghv: TAESBlock; var gcnt: TQWordRec); +var b_pos: PtrUInt; +begin + b_pos := gcnt.L and AESBlockMod; + inc(gcnt.V,ILen); + if (b_pos=0) and (gcnt.V<>0) then + gf_mul_h(ghv); + while (ILen>0) and (b_pos=SizeOf(TAESBlock) do begin + gf_mul_h(ghv); + XorBlock16(@ghv,pointer(ctp)); + inc(PAESBlock(ctp)); + dec(ILen,SizeOf(TAESBlock)); + end; + while ILen>0 do begin + if b_pos=SizeOf(TAESBlock) then begin + gf_mul_h(ghv); + b_pos := 0; + end; + ghv[b_pos] := ghv[b_pos] xor ctp^; + inc(b_pos); + inc(ctp); + dec(ILen); + end; +end; + +function TAESGCMEngine.Init(const Key; KeyBits: PtrInt): boolean; +begin + FillcharFast(self,SizeOf(self),0); + result := actx.EncryptInit(Key,KeyBits); + if not result then + exit; + actx.Encrypt(ghash_h, ghash_h); + Make4K_Table; +end; + +const + CTR_POS = 12; + +function TAESGCMEngine.Reset(pIV: pointer; IV_len: PtrInt): boolean; +var i, n_pos: PtrInt; +begin + if (pIV=nil) or (IV_len=0) then begin + result := false; + exit; + end; + if IV_len=CTR_POS then begin + // Initialization Vector size matches perfect size of 12 bytes + MoveFast(pIV^,TAESContext(actx).IV,CTR_POS); + TWA4(TAESContext(actx).IV)[3] := $01000000; + end else begin + // Initialization Vector is otherwise computed from GHASH(IV,H) + n_pos := IV_len; + FillZero(TAESContext(actx).IV); + while n_pos>=SizeOf(TAESBlock) do begin + XorBlock16(@TAESContext(actx).IV,pIV); + inc(PAesBlock(pIV)); + dec(n_pos,SizeOf(TAESBlock)); + gf_mul_h(TAESContext(actx).IV); + end; + if n_pos>0 then begin + for i := 0 to n_pos-1 do + TAESContext(actx).IV[i] := TAESContext(actx).IV[i] xor PAESBlock(pIV)^[i]; + gf_mul_h(TAESContext(actx).IV); + end; + n_pos := IV_len shl 3; + i := 15; + while n_pos>0 do begin + TAESContext(actx).IV[i] := TAESContext(actx).IV[i] xor byte(n_pos); + n_pos := n_pos shr 8; + dec(i); + end; + gf_mul_h(TAESContext(actx).IV); + end; + // reset internal state and counters + y0_val := TWA4(TAESContext(actx).IV)[3]; + FillZero(aad_ghv); + FillZero(txt_ghv); + aad_cnt.V := 0; + atx_cnt.V := 0; + flags := []; + result := true; +end; + +function TAESGCMEngine.Encrypt(ptp, ctp: Pointer; ILen: PtrInt): boolean; +begin + if ILen>0 then begin + if (ptp=nil) or (ctp=nil) or (flagFinalComputed in flags) then begin + result := false; + exit; + end; + if (ILen and AESBlockMod=0) and (blen=0) then begin + inc(atx_cnt.V,ILen); + ILen := ILen shr AESBlockShift; + repeat // loop optimized e.g. for PKCS7 padding + GCM_IncCtr(TAESContext(actx).IV); + actx.Encrypt(TAESContext(actx).IV,TAESContext(actx).buf); // maybe AES-NI + XorBlock16(ptp,ctp,@TAESContext(actx).buf); + gf_mul_h(txt_ghv); + XorBlock16(@txt_ghv,ctp); + inc(PAESBlock(ptp)); + inc(PAESBlock(ctp)); + dec(ILen); + until ILen=0; + end else begin // generic process in dual steps + internal_crypt(ptp,ctp,iLen); + internal_auth(ctp,ILen,txt_ghv,atx_cnt); + end; + end; + result := true; +end; + +function TAESGCMEngine.Decrypt(ctp, ptp: Pointer; ILen: PtrInt; + ptag: pointer; tlen: PtrInt): boolean; +var tag: TAESBlock; +begin + result := false; + if ILen>0 then begin + if (ptp=nil) or (ctp=nil) or (flagFinalComputed in flags) then + exit; + if (ILen and AESBlockMod=0) and (blen=0) then begin + inc(atx_cnt.V,ILen); + ILen := ILen shr AESBlockShift; + repeat // loop optimized e.g. for PKCS7 padding + gf_mul_h(txt_ghv); + XorBlock16(@txt_ghv,ctp); + GCM_IncCtr(TAESContext(actx).IV); + actx.Encrypt(TAESContext(actx).IV,TAESContext(actx).buf); // maybe AES-NI + XorBlock16(ctp,ptp,@TAESContext(actx).buf); + inc(PAESBlock(ptp)); + inc(PAESBlock(ctp)); + dec(ILen); + until ILen=0; + if (ptag<>nil) and (tlen>0) then begin + Final(tag,{anddone=}false); + if not IsEqual(tag,ptag^,tlen) then + exit; // check authentication after single pass encryption + auth + end; + end else begin // generic process in dual steps + internal_auth(ctp,ILen,txt_ghv,atx_cnt); + if (ptag<>nil) and (tlen>0) then begin + Final(tag,{anddone=}false); + if not IsEqual(tag,ptag^,tlen) then + exit; // check authentication before encryption + end; + internal_crypt(ctp,ptp,iLen); + end; + end; + result := true; +end; + +function TAESGCMEngine.Add_AAD(pAAD: pointer; aLen: PtrInt): boolean; +begin + if aLen>0 then begin + if (pAAD=nil) or (flagFinalComputed in flags) then begin + result := false; + exit; + end; + internal_auth(pAAD,aLen,aad_ghv,aad_cnt); + end; + result := true; +end; + +function TAESGCMEngine.Final(out tag: TAESBlock; andDone: boolean): boolean; +var + tbuf: TAESBlock; + ln: cardinal; +begin + if not (flagFinalComputed in flags) then begin + include(flags,flagFinalComputed); + // compute GHASH(H, AAD, ctp) + gf_mul_h(aad_ghv); + gf_mul_h(txt_ghv); + // compute len(AAD) || len(ctp) with each len as 64-bit big-endian + ln := (atx_cnt.V+AESBlockMod) shr AESBlockShift; + if (aad_cnt.V>0) and (ln<>0) then begin + tbuf := ghash_h; + while ln<>0 do begin + if odd(ln) then + gf_mul(aad_ghv,tbuf); + ln := ln shr 1; + if ln<>0 then + gf_mul(tbuf,tbuf); + end; + end; + TWA4(tbuf)[0] := bswap32((aad_cnt.L shr 29) or (aad_cnt.H shl 3)); + TWA4(tbuf)[1] := bswap32((aad_cnt.L shl 3)); + TWA4(tbuf)[2] := bswap32((atx_cnt.L shr 29) or (atx_cnt.H shl 3)); + TWA4(tbuf)[3] := bswap32((atx_cnt.L shl 3)); + XorBlock16(@tbuf,@txt_ghv); + XorBlock16(@aad_ghv,@tbuf); + gf_mul_h(aad_ghv); + // compute E(K,Y0) + tbuf := TAESContext(actx).IV; + TWA4(tbuf)[3] := y0_val; + actx.Encrypt(tbuf); + // GMAC = GHASH(H, AAD, ctp) xor E(K,Y0) + XorBlock16(@aad_ghv,@tag,@tbuf); + if andDone then + Done; + result := true; + end else begin + Done; + result := false; + end; +end; + +procedure TAESGCMEngine.Done; +begin + if flagFlushed in flags then + exit; + actx.Done; + include(flags,flagFlushed); +end; + +function TAESGCMEngine.FullEncryptAndAuthenticate(const Key; KeyBits: PtrInt; + pIV: pointer; IV_len: PtrInt; pAAD: pointer; aLen: PtrInt; ptp, ctp: Pointer; + pLen: PtrInt; out tag: TAESBlock): boolean; +begin + result := Init(Key,KeyBits) and Reset(pIV,IV_len) and Add_AAD(pAAD,aLen) and + Encrypt(ptp,ctp,pLen) and Final(tag); + Done; +end; + +function TAESGCMEngine.FullDecryptAndVerify(const Key; KeyBits: PtrInt; + pIV: pointer; IV_len: PtrInt; pAAD: pointer; aLen: PtrInt; ctp, ptp: Pointer; + pLen: PtrInt; ptag: pointer; tLen: PtrInt): boolean; +begin + result := Init(Key,KeyBits) and Reset(pIV,IV_len) and Add_AAD(pAAD,aLen) and + Decrypt(ctp,ptp,pLen,ptag,tlen); + Done; +end; + + + { TSHA256 } // under Win32, with a Core i7 CPU: pure pascal: 152ms - x86: 112ms @@ -7598,6 +8135,15 @@ var Data: TSHAContext absolute Context; begin if Buffer=nil then exit; // avoid GPF inc(Data.MLen,QWord(cardinal(Len)) shl 3); + {$ifdef CPUX64} + if (K256AlignedStore<>'') and (Data.Index=0) and (Len>=64) then begin + // use optimized Intel's sha256_sse4.asm for whole blocks + sha256_sse4(Buffer^,Data.Hash,Len shr 6); + inc(PByte(Buffer),Len); + Len := Len and 63; + dec(PByte(Buffer),Len); + end; + {$endif CPUX64} while Len>0 do begin aLen := 64-Data.Index; if aLen<=Len then begin @@ -7608,7 +8154,7 @@ begin end else RawSha256Compress(Data.Hash,Buffer); // avoid temporary copy dec(Len,aLen); - inc(PtrInt(Buffer),aLen); + inc(PByte(Buffer),aLen); end else begin MoveFast(Buffer^,Data.Buffer[Data.Index],Len); inc(Data.Index,Len); @@ -9576,7 +10122,7 @@ begin if OutStream<>nil then begin if OutStream.InheritsFrom(TMemoryStream) then with TMemoryStream(OutStream) do begin - P := Seek(0,soFromCurrent); + P := Seek(0,soCurrent); Size := P+Len; // auto-reserve space (no Realloc:) Seek(P+Len,soBeginning); bOut := PAnsiChar(Memory)+P; @@ -11695,6 +12241,8 @@ var p: ^TMD5In; t: cardinal; i: integer; begin + if len=0 then + exit; p := @buffer; // Update byte count t := bytes[0]; @@ -12253,7 +12801,7 @@ begin TAESPRNG.Main.FillRandom(rec.nonce); if not MACSetNonce(rec.nonce) then exit; - rec.Data := EncryptPKCS7(Data,true); + rec.Data := EncryptPKCS7(Data,{IVAtBeginning=}true); if not MACGetLast(rec.mac) then exit; rec.crc := crc32c(VERSION,@rec.nonce,CRCSIZ); @@ -12376,6 +12924,7 @@ begin inherited Destroy; AES.Done; // mandatory for Padlock - also fill buffer with 0 for safety FillZero(fCV); // may contain sensitive data on some modes + FillZero(fIV); end; function TAESAbstractSyn.Clone: TAESAbstract; @@ -13139,6 +13688,86 @@ begin end; +{ TAESGCM } + +constructor TAESGCM.Create(const aKey; aKeySize: cardinal); +begin + inherited Create(aKey,aKeySize); // set fKey/fKeySize + if not fAES.Init(aKey,aKeySize) then + raise ESynCrypto.CreateUTF8('%.Create(keysize=%) failed',[self,aKeySize]); +end; + +function TAESGCM.Clone: TAESAbstract; +begin + result := NewInstance as TAESGCM; + result.fKey := fKey; + result.fKeySize := fKeySize; + result.fKeySizeBytes := fKeySizeBytes; + TAESGCM(result).fAES := fAES; // reuse the very same TAESGCMEngine memory +end; + +destructor TAESGCM.Destroy; +begin + inherited Destroy; + fAES.Done; + FillZero(fIV); +end; + +procedure TAESGCM.Encrypt(BufIn, BufOut: pointer; Count: cardinal); +begin + if fContext<>ctxEncrypt then + if fContext=ctxNone then begin + fAES.Reset(@fIV,CTR_POS); // caller should have set the IV + fContext := ctxEncrypt; + end else + raise ESynCrypto.CreateUTF8('%.Encrypt after Decrypt',[self]); + if not fAES.Encrypt(BufIn,BufOut,Count) then + raise ESynCrypto.CreateUTF8('%.Encrypt called after GCM final state',[self]); +end; + +procedure TAESGCM.Decrypt(BufIn, BufOut: pointer; Count: cardinal); +begin + if fContext<>ctxDecrypt then + if fContext=ctxNone then begin + fAES.Reset(@fIV,CTR_POS); + fContext := ctxDecrypt; + end else + raise ESynCrypto.CreateUTF8('%.Decrypt after Encrypt',[self]); + if not fAES.Decrypt(BufIn,BufOut,Count) then + raise ESynCrypto.CreateUTF8('%.Decrypt called after GCM final state',[self]); +end; + +function TAESGCM.MACSetNonce(const aKey: THash256; aAssociated: pointer; + aAssociatedLen: integer): boolean; +begin + if fContext<>ctxNone then begin + result := false; // should be called before Encrypt/Decrypt + exit; + end; + // aKey is ignored since not used during GMAC computation + if (aAssociated<>nil) and (aAssociatedLen>0) then + fAES.Add_AAD(aAssociated,aAssociatedLen); + result := true; +end; + +function TAESGCM.MACGetLast(out aCRC: THash256): boolean; +begin + if fContext=ctxNone then begin + result := false; // should be called after Encrypt/Decrypt + exit; + end; + fAES.Final(THash256Rec(aCRC).Lo,{forreuse:anddone=}false); + FillZero(THash256Rec(aCRC).Hi); // upper 128-bit are not used + fContext := ctxNone; // allow reuse of this fAES instance + result := true; +end; + +function TAESGCM.MACCheckError(aEncrypted: pointer; Count: cardinal): boolean; +begin + result := true; // AES-GCM requires the IV to be set -> will be checked later +end; + + {$ifdef MSWINDOWS} type @@ -13580,42 +14209,42 @@ function TAESPRNG.Random32: cardinal; var block: THash128Rec; begin FillRandom(block.b); - result := block.c0 xor block.c1 xor block.c2 xor block.c3; + result := block.c0; // no need to XOR with c1, c2, c3 with a permutation algo end; function TAESPRNG.Random32(max: cardinal): cardinal; var block: THash128Rec; begin FillRandom(block.b); - result := (Qword(block.c0 xor block.c1 xor block.c2 xor block.c3)*max) shr 32; + result := (Qword(block.c0)*max) shr 32; // no need to XOR with c1, c2, c3 end; function TAESPRNG.Random64: QWord; var block: THash128Rec; begin FillRandom(block.b); - result := block.L xor block.H; + result := block.L; // no need to XOR with H end; function Hash128ToExt({$ifdef FPC}constref{$else}const{$endif} r: THash128): TSynExtended; const COEFF64: TSynExtended = (1.0/$80000000)/$100000000; // 2^-63 begin - result := ((THash128Rec(r).Lo xor THash128Rec(r).Hi) and $7fffffffffffffff)*COEFF64; + result := (THash128Rec(r).Lo and $7fffffffffffffff)*COEFF64; end; function Hash128ToDouble({$ifdef FPC}constref{$else}const{$endif} r: THash128): double; const COEFF64: double = (1.0/$80000000)/$100000000; // 2^-63 begin - result := ((THash128Rec(r).Lo xor THash128Rec(r).Hi) and $7fffffffffffffff)*COEFF64; + result := (THash128Rec(r).Lo and $7fffffffffffffff)*COEFF64; end; function Hash128ToSingle({$ifdef FPC}constref{$else}const{$endif} r: THash128): double; const COEFF64: single = (1.0/$80000000)/$100000000; // 2^-63 begin - result := ((THash128Rec(r).Lo xor THash128Rec(r).Hi) and $7fffffffffffffff)*COEFF64; + result := (THash128Rec(r).Lo and $7fffffffffffffff)*COEFF64; end; function TAESPRNG.RandomExt: TSynExtended; @@ -13968,9 +14597,9 @@ begin try if Compress then begin CompressSynLZ(Data,true); - Data := EncryptPKCS7(Data,true); + Data := EncryptPKCS7(Data,{IVAtBeginning=}true); end else begin - Data := DecryptPKCS7(Data,true); + Data := DecryptPKCS7(Data,{IVAtBeginning=}true); if CompressSynLZ(Data,false)='' then begin result := ''; exit; // invalid content @@ -14240,7 +14869,7 @@ procedure TProtocolAES.Encrypt(const aPlain: RawByteString; begin fSafe.Lock; try - aEncrypted := fAES[true].EncryptPKCS7(aPlain,{iv=}true); + aEncrypted := fAES[true].EncryptPKCS7(aPlain,{IVAtBeginning=}true); finally fSafe.UnLock; end; @@ -14500,10 +15129,8 @@ begin if N=nil then exit; V := GetJSONFieldOrObjectOrArray(P,@wasstring,@EndOfObject,true); - if V=nil then - exit; len := StrLen(N); - if len=3 then begin + if (len=3) and (V<>nil) then begin c := PInteger(N)^; for claim := low(claim) to high(claim) do if PInteger(JWT_CLAIMS_TEXT[claim])^=c then begin @@ -14560,7 +15187,7 @@ begin if JWT.data.Count=0 then JWT.data.Capacity := cap; JWT.data.AddValue(N,len,value) - until EndOfObject='}'; + until (EndOfObject='}') or (P=nil); if JWT.data.Count>0 then JWT.data.Capacity := JWT.data.Count; if requiredclaims-JWT.claims<>[] then diff --git a/contrib/mORMot/SynCurl.pas b/contrib/mORMot/SynCurl.pas index f850291..1aa931d 100644 --- a/contrib/mORMot/SynCurl.pas +++ b/contrib/mORMot/SynCurl.pas @@ -6,7 +6,7 @@ unit SynCurl; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynCurl; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -147,6 +147,8 @@ type coFTPSSLAuth = 129, coIgnoreContentLength = 136, coFTPSkipPasvIp = 137, + coTimeoutMs = 155, // since libcurl 7.16.2 - April 11 2007 + coConnectTimeoutMs = 156, coFile = 10001, coWriteData = coFile, coURL = 10002, @@ -243,6 +245,22 @@ type crTFTPDiskFull, crTFTPIllegal, crTFTPUnknownID, crTFTPExists, crTFTPNoSuchUser ); + CURLSHcode = (CURLSHE_OK, // all is fine + CURLSHE_BAD_OPTION, // 1 + CURLSHE_IN_USE, // 2 + CURLSHE_INVALID, // 3 + CURLSHE_NOMEM, // 4 out of memory + CURLSHE_NOT_BUILT_IN, // 5 feature not present in lib + CURLSHE_LAST); // never use + + CURLSHoption = (CURLSHOPT_NONE, + CURLSHOPT_SHARE, + CURLSHOPT_UNSHARE, + CURLSHOPT_LOCKFUNC, + CURLSHOPT_UNLOCKFUNC, + CURLSHOPT_USERDATA, + CURLSHOPT_LAST); + /// low-level information enumeration for libcurl library API calls TCurlInfo = ( ciNone, @@ -357,6 +375,7 @@ type /// low-level string list type for libcurl library API TCurlSList = type pointer; PCurlSList = ^TCurlSList; + TCurlShare = type pointer; PPCurlSListArray = ^PCurlSListArray; PCurlSListArray = array[0..(MaxInt div SizeOf(PCurlSList))-1] of PCurlSList; /// low-level access to the libcurl library instance in "multi" mode @@ -400,6 +419,26 @@ type curl_read_callback = function (buffer: PAnsiChar; size,nitems: integer; instream: pointer): integer; cdecl; + curl_lock_data = (CURL_LOCK_DATA_NONE = 0, + CURL_LOCK_DATA_SHARE, + CURL_LOCK_DATA_COOKIE, + CURL_LOCK_DATA_DNS, + CURL_LOCK_DATA_SSL_SESSION, + CURL_LOCK_DATA_CONNECT, + CURL_LOCK_DATA_PSL, + CURL_LOCK_DATA_LAST); + + curl_lock_access = (CURL_LOCK_ACCESS_NONE = 0, + CURL_LOCK_ACCESS_SHARED = 1, + CURL_LOCK_ACCESS_SINGLE = 2, + CURL_LOCK_ACCESS_LAST); + + /// lock function signature for CURLSHOPT_LOCKFUNC + curl_lock_function = procedure (handle: TCurl; data: curl_lock_data; + locktype: curl_lock_access; userptr: pointer); cdecl; + /// unlock function signature for CURLSHOPT_UNLOCKFUNC + curl_unlock_function = procedure (handle: TCurl; data: curl_lock_data; + userptr: pointer); cdecl; {$Z1} @@ -417,6 +456,11 @@ var {$else} Module: THandle; {$endif FPC} + /// in case CurlEnableShare is called this array holds a + // critical section per curl_lock_data + share_cs: array[curl_lock_data] of TRTLCriticalSection; + /// global TCurlShare object, created by CurlEnableGlobalShare + globalShare: TCurlShare; /// initialize the library global_init: function(flags: TCurlGlobalInit): TCurlResult; cdecl; /// finalize the library @@ -443,7 +487,15 @@ var slist_append: function(list: TCurlSList; s: PAnsiChar): TCurlSList; cdecl; /// free an entire slist slist_free_all: procedure(list: TCurlSList); cdecl; - {$ifdef LIBCURLMULTI} + /// create a shared object + share_init: function: pointer; cdecl; + /// clean up a shared object + share_cleanup: function(share_handle: TCurlShare): CURLSHcode; cdecl; + /// set options for a shared object + share_setopt: function(share: TCurlShare; option: CURLSHoption): CURLSHcode; cdecl varargs; + /// return the text description of an error code + share_strerror: function(code: CURLSHcode): PAnsiChar; cdecl; + {$ifdef LIBCURLMULTI} 12 /// add an easy handle to a multi session multi_add_handle: function(mcurl: TCurlMulti; curl: TCurl): TCurlMultiCode; cdecl; /// set data to associate with an internal socket @@ -498,6 +550,22 @@ function CurlIsAvailable: boolean; function CurlWriteRawByteString(buffer: PAnsiChar; size,nitems: integer; opaque: pointer): integer; cdecl; +/// enable libcurl multiple easy handles to share data +// - is called automatically during libcurl initialization +// - shared objects are: DNS cache, TLS session cache and connection cache +// - this way, each single transfer can take advantage of the context of the +// other transfer(s) +// - do nothing if the global share has already been enabled +// - see https://curl.se/libcurl/c/libcurl-share.html for details +function CurlEnableGlobalShare: boolean; + +/// disable a global share for libcurl +// - is called automatically in finalization section +// - can be called on purpose, to ensure there is no active HTTP requests +// and prevent CURLSHE_IN_USE error +// - you can re-enable the libcurl global share by CurlEnableGlobalShare +function CurlDisableGlobalShare: CURLSHcode; + implementation {$ifdef LIBCURLSTATIC} @@ -538,6 +606,14 @@ implementation function curl_slist_append(list: TCurlSList; s: PAnsiChar): TCurlSList; cdecl; external; /// free an entire slist procedure curl_slist_free_all(list: TCurlSList); cdecl; external; + /// create a shared object + function curl_share_init: pointer; cdecl; external; + /// clean up a shared object + function curl_share_cleanup(share_handle: TCurlShare): CURLSHcode; cdecl; external; + /// set options for a shared object + function curl_share_setopt(share: TCurlShare; option: CURLSHoption): CURLSHcode; cdecl varargs; external; + /// return string describing error code + function curl_share_strerror(code: CURLSHcode): PAnsiChar; cdecl; external; {$ifdef LIBCURLMULTI} /// add an easy handle to a multi session function curl_multi_add_handle(mcurl: TCurlMulti; curl: TCurl): TCurlMultiCode; cdecl; external; @@ -615,10 +691,11 @@ procedure LibCurlInitialize(engines: TCurlGlobalInit; const dllname: TFileName); var P: PPointer; api: integer; h: {$ifdef FPC}TLibHandle{$else}THandle{$endif FPC}; -const NAMES: array[0..{$ifdef LIBCURLMULTI}26{$else}12{$endif}] of string = ( +const NAMES: array[0..{$ifdef LIBCURLMULTI}30{$else}16{$endif}] of string = ( 'global_init','global_cleanup','version_info', 'easy_init','easy_setopt','easy_perform','easy_cleanup','easy_getinfo', - 'easy_duphandle','easy_reset','easy_strerror','slist_append','slist_free_all' + 'easy_duphandle','easy_reset','easy_strerror','slist_append','slist_free_all', + 'share_init', 'share_cleanup','share_setopt', 'share_strerror' {$ifdef LIBCURLMULTI}, 'multi_add_handle','multi_assign','multi_cleanup','multi_fdset', 'multi_info_read','multi_init','multi_perform','multi_remove_handle', @@ -644,6 +721,10 @@ begin curl.easy_strerror := @curl_easy_strerror; curl.slist_append := @curl_slist_append; curl.slist_free_all := @curl_slist_free_all; + curl.share_init := @curl_share_init; + curl.share_cleanup := @curl_share_cleanup; + curl.share_setopt := @curl_share_setopt; + curl.share_strerror := @curl_share_strerror; {$ifdef LIBCURLMULTI} curl.multi_add_handle := @curl_multi_add_handle; curl.multi_assign := @curl_multi_assign; @@ -714,6 +795,8 @@ begin curl.infoText := format('%s version %s',[LIBCURL_DLL,curl.info.version]); if curl.info.ssl_version<>nil then curl.infoText := format('%s using %s',[curl.infoText,curl.info.ssl_version]); + curl.globalShare := nil; + CurlEnableGlobalShare; // won't hurt, and may benefit even for the OS // api := 0; with curl.info do while protocols[api]<>nil do begin // write(protocols[api], ' '); inc(api); end; writeln(#13#10,curl.infoText); finally @@ -721,6 +804,55 @@ begin end; end; +procedure curlShareLock(handle: TCurl; data: curl_lock_data; + locktype: curl_lock_access; userptr: pointer); cdecl; +begin + EnterCriticalSection(curl.share_cs[data]); +end; + +procedure curlShareUnLock(handle: TCurl; data: curl_lock_data; + userptr: pointer); cdecl; +begin + LeaveCriticalSection(curl.share_cs[data]); +end; + +function CurlEnableGlobalShare: boolean; +var + d: curl_lock_data; +begin + result := false; + if not CurlIsAvailable or (curl.globalShare<>nil) then + exit; // not available, or already shared + curl.globalShare := curl.share_init; + if curl.globalShare = nil then + exit; // something went wrong (out of memory, etc.) and therefore the share object was not created + for d := low(d) to high(d) do + InitializeCriticalSection(curl.share_cs[d]); + curl.share_setopt(curl.globalShare,CURLSHOPT_LOCKFUNC,@curlShareLock); + curl.share_setopt(curl.globalShare,CURLSHOPT_UNLOCKFUNC,@curlShareUnLock); + curl.share_setopt(curl.globalShare,CURLSHOPT_SHARE,CURL_LOCK_DATA_DNS); + curl.share_setopt(curl.globalShare,CURLSHOPT_SHARE,CURL_LOCK_DATA_SSL_SESSION); + // CURL_LOCK_DATA_CONNECT triggers GPF e.g. on Debian Burster 10 + if curl.info.version_num>=$00074400 then // seems to be fixed in 7.68 + // see https://github.com/curl/curl/issues/4544 + curl.share_setopt(curl.globalShare,CURLSHOPT_SHARE,CURL_LOCK_DATA_CONNECT); + // CURL_LOCK_DATA_CONNECT triggers GPF on Debian Burster 10 + result := true; +end; + +function CurlDisableGlobalShare: CURLSHcode; +var + d: curl_lock_data; +begin + result := CURLSHE_OK; + if curl.globalShare = nil then + exit; // already disabled + result := curl.share_cleanup(curl.globalShare); + if result = CURLSHE_OK then + curl.globalShare := nil; + for d := low(d) to high(d) do + DeleteCriticalSection(curl.share_cs[d]); +end; initialization {$ifdef LIBCURLSTATIC} @@ -729,10 +861,13 @@ initialization finalization {$ifdef LIBCURLSTATIC} - if curl_static_initialized then + if curl_static_initialized then begin + CurlDisableGlobalShare; curl.global_cleanup; + end; {$else} if PtrInt(curl.Module)>0 then begin + CurlDisableGlobalShare; curl.global_cleanup; FreeLibrary(curl.Module); end; diff --git a/contrib/mORMot/SynDB.pas b/contrib/mORMot/SynDB.pas index 5f20ad7..e5cbc41 100644 --- a/contrib/mORMot/SynDB.pas +++ b/contrib/mORMot/SynDB.pas @@ -6,7 +6,7 @@ unit SynDB; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -903,6 +903,7 @@ type {$ifndef UNICODE} fVariantWideString: boolean; {$endif} + fStatementMaxMemory: Int64; fForeignKeys: TSynNameValue; fSQLCreateField: TSQLDBFieldTypeDefinition; fSQLCreateFieldMax: cardinal; @@ -1433,6 +1434,12 @@ type // - will cache only statements containing ? parameters or a SELECT with no // WHERE clause within property UseCache: boolean read fUseCache write fUseCache; + /// maximum bytes allowed for FetchAllToJSON/FetchAllToBinary methods + // - if a result set exceeds this limit, an ESQLDBException is raised + // - default is 512 shl 20, i.e. 512MB which is very high + // - avoid unexpected OutOfMemory errors when incorrect statement is run + property StatementMaxMemory: Int64 + read fStatementMaxMemory write fStatementMaxMemory; /// if UseCache is true, how many statement replicates can be generated // if the cached ISQLDBStatement is already used // - such replication is normally not needed in a per-thread connection, @@ -1632,7 +1639,7 @@ type // corresponding TSQLDBProxyConnectionCommand on the current connection procedure RemoteProcessMessage(const Input: RawByteString; out Output: RawByteString; Protocol: TSQLDBProxyConnectionProtocol); virtual; - {$endif} + {$endif WITH_PROXY} /// the current Date and Time, as retrieved from the server // - note that this value is the DB_SERVERTIME[] constant SQL value, so @@ -1708,6 +1715,7 @@ type fSQLLogTimer: TPrecisionTimer; fCacheIndex: integer; fSQLPrepared: RawUTF8; + function GetSQLCurrent: RawUTF8; function GetSQLWithInlinedParams: RawUTF8; procedure ComputeSQLWithInlinedParams; function GetForceBlobAsNull: boolean; @@ -2189,10 +2197,15 @@ type /// low-level access to the Timer used for last DB operation property SQLLogTimer: TPrecisionTimer read fSQLLogTimer; /// after a call to Prepare(), contains the query text to be passed to the DB - // - Depends on DB parameters placeholder are replaced to ?, :AA, $1 etc + // - depending on the DB, parameters placeholders are replaced by ?, :1, $1 etc // - this SQL is ready to be used in any DB tool, e.g. to check the real // execution plan/timing property SQLPrepared: RawUTF8 read fSQLPrepared; + /// the prepared SQL statement, in its current state + // - if statement is prepared, then equals SQLPrepared, otherwise, contains + // the raw SQL property content + // - used internally by the implementation units, e.g. for errors logging + property SQLCurrent: RawUTF8 read GetSQLCurrent; /// low-level access to the statement cache index, after a call to Prepare() // - contains >= 0 if the database supports prepared statement cache //(Oracle, Postgres) and query plan is cached; contains -1 in other cases @@ -2237,7 +2250,9 @@ type // when multiple connections may break stability, consume too much resources // and/or decrease performance TSQLDBConnectionPropertiesThreadSafeThreadingMode = ( - tmThreadPool, tmMainConnection, tmBackgroundThread); + tmThreadPool, + tmMainConnection, + tmBackgroundThread); /// connection properties which will implement an internal Thread-Safe // connection pool @@ -2843,7 +2858,9 @@ function TrimLeftSchema(const TableName: RawUTF8): RawUTF8; // - returns the number of ? parameters found within aSQL // - won't generate any SQL keyword parameters (e.g. :AS :OF :BY), to be // compliant with Oracle OCI expectations -function ReplaceParamsByNames(const aSQL: RawUTF8; var aNewSQL: RawUTF8): integer; +// - any ending ';' character is deleted, unless aStripSemicolon is unset +function ReplaceParamsByNames(const aSQL: RawUTF8; var aNewSQL: RawUTF8; + aStripSemicolon: boolean=true): integer; /// replace all '?' in the SQL statement with indexed parameters like $1 $2 ... // - returns the number of ? parameters found within aSQL @@ -3292,7 +3309,7 @@ const (Position: posAfter; InsertFmt:' first % ')); { dInformix } /// the known database engines handling CREATE INDEX IF NOT EXISTS statement - DB_HANDLECREATEINDEXIFNOTEXISTS = [dSQLite]; + DB_HANDLECREATEINDEXIFNOTEXISTS = [dSQLite, dPostgreSQL]; /// the known database engines handling CREATE INDEX on BLOB columns // - SQLite3 does not have any issue about indexing any column @@ -3328,7 +3345,7 @@ function TSQLDBFieldTypeToString(aType: TSQLDBFieldType): TShort16; /// retrieve the ready-to-be displayed text of proxy commands implemented by // TSQLDBProxyConnectionProperties.Process() function ToText(cmd: TSQLDBProxyConnectionCommand): PShortString; overload; -{$endif} +{$endif WITH_PROXY} implementation @@ -3357,13 +3374,6 @@ begin FormatShort16('#%',[ord(aType)],result); end; -function OracleSQLIso8601ToDate(Iso8601: RawUTF8): RawUTF8; -begin - if (length(Iso8601)>10) and (Iso8601[11]='T') then - Iso8601[11] := ' '; // 'T' -> ' ' - result := 'to_date('''+Iso8601+''',''YYYY-MM-DD HH24:MI:SS'')'; // from Iso8601 -end; - {$ifdef EMULATES_TQUERY} @@ -3425,12 +3435,12 @@ begin with TVarData(fValue) do case VType of varNull: result := ''; - varInt64: result := UTF8ToSynUnicode(Int64ToUtf8(VInt64)); - varString: result := UTF8ToSynUnicode(RawUTF8(VAny)); + varInt64: UTF8ToSynUnicode(Int64ToUtf8(VInt64),result); + varString: UTF8ToSynUnicode(RawUTF8(VAny),result); {$ifdef HASVARUSTRING} varUString: result := UnicodeString(VAny); {$endif} - else Result := SynUnicode(fValue); + else result := SynUnicode(fValue); end; end; @@ -3647,7 +3657,10 @@ end; procedure TQuery.Close; begin try - fPrepared := nil; + if Assigned(fPrepared) then begin + fPrepared.ReleaseRows; + fPrepared := nil; + end; finally //fSQL.Clear; // original TQuery expect SQL content to be preserved fParam.Clear; @@ -3878,7 +3891,7 @@ begin req := Trim(StringToUTF8(SQL.Text)); P := pointer(req); if P=nil then - ESQLQueryException.Create('No SQL statement'); + raise ESQLQueryException.Create('No SQL statement'); col := 0; repeat B := P; @@ -4520,7 +4533,7 @@ begin // follow TSQLDBRemoteConnectionPropertiesAbstract.Process binary layout if ExecuteWithResults then begin Data := TRawByteStringStream.Create(msgOutput); try - Data.Seek(0,soFromEnd); // include header + Data.Seek(0,soEnd); // include header case header.Command of cExecuteToBinary: Stmt.FetchAllToBinary(Data); @@ -4571,6 +4584,7 @@ begin fRollbackOnDisconnect := true; // enabled by default fUseCache := true; fLoggedSQLMaxSize := 2048; // log up to 2KB of inlined SQL by default + fStatementMaxMemory := 512 shl 20; // fetch to JSON/Binary up to 512MB SetInternalProperties; // virtual method used to override default parameters aDBMS := GetDBMS; if aDBMS in [dSQLite, dDB2, dPostgreSQL] then // for SQLDateToIso8601Quoted() @@ -4615,8 +4629,8 @@ end; function TSQLDBConnectionProperties.Execute(const aSQL: RawUTF8; const Params: array of const - {$ifndef LVCL}{$ifndef DELPHI5OROLDER}; RowsVariant: PVariant=nil{$endif}{$endif}; - ForceBlobAsNull: boolean=false): ISQLDBRows; + {$ifndef LVCL}{$ifndef DELPHI5OROLDER}; RowsVariant: PVariant{$endif}{$endif}; + ForceBlobAsNull: boolean): ISQLDBRows; var Stmt: ISQLDBStatement; begin Stmt := NewThreadSafeStatementPrepared(aSQL,true,true); @@ -5723,21 +5737,17 @@ function TSQLDBConnectionProperties.SQLIso8601ToDate(const Iso8601: RawUTF8): Ra begin case DBMS of dSQLite: result := TrimTInIso; - dOracle: result := OracleSQLIso8601ToDate(Iso8601); + dOracle: result := 'to_date('''+TrimTInIso+''',''YYYY-MM-DD HH24:MI:SS'')'; dNexusDB: result := 'DATE '+Iso8601; dDB2: result := 'TIMESTAMP '''+TrimTInIso+''''; + dPostgreSQL: result := ''''+TrimTInIso+''''; else result := ''''+Iso8601+''''; end; end; function TSQLDBConnectionProperties.SQLDateToIso8601Quoted(DateTime: TDateTime): RawUTF8; -var tmp: array[0..23] of AnsiChar; - P: PUTF8Char; begin - tmp[0] := ''''; - P := DateTimeToIso8601ExpandedPChar(DateTime,@tmp[1],DateTimeFirstChar); - P^ := ''''; - FastSetString(result,@tmp,PtrUInt(P)-PtrUInt(@tmp)+1); + result := DateTimeToIso8601(DateTime,true,DateTimeFirstChar,false,''''); end; function TSQLDBConnectionProperties.SQLCreate(const aTableName: RawUTF8; @@ -6974,12 +6984,14 @@ end; function TSQLDBStatement.FetchAllToJSON(JSON: TStream; Expanded: boolean): PtrInt; var W: TJSONWriter; col: integer; + maxmem: PtrUInt; tmp: TTextWriterStackBuffer; begin result := 0; W := TJSONWriter.Create(JSON,Expanded,false,nil,0,@tmp); try Connection.InternalProcess(speActive); + maxmem := Connection.Properties.StatementMaxMemory; // get col names and types SetLength(W.ColNames,ColumnCount); for col := 0 to ColumnCount-1 do @@ -6995,6 +7007,9 @@ begin ColumnsToJSON(W); W.Add(','); inc(result); + if (maxmem>0) and (W.WrittenBytes>maxmem) then // TextLength is slower + raise ESQLDBException.CreateUTF8('%.FetchAllToJSON: overflow %', + [self, KB(maxmem)]); end; {$ifdef SYNDB_SILENCE} fSQLLogTimer.Pause; @@ -7020,6 +7035,7 @@ function TSQLDBStatement.FetchAllToCSVValues(Dest: TStream; Tab: boolean; const NULL: array[boolean] of string[7] = ('"null"','null'); BLOB: array[boolean] of string[7] = ('"blob"','blob'); var F, FMax: integer; + maxmem: PtrUInt; W: TTextWriter; tmp: RawByteString; V: TSQLVar; @@ -7031,6 +7047,7 @@ begin if Tab then CommaSep := #9; FMax := ColumnCount-1; + maxmem := Connection.Properties.StatementMaxMemory; W := TTextWriter.Create(Dest,65536); try if AddBOM then @@ -7083,6 +7100,9 @@ begin W.Add(CommaSep); end; inc(result); + if (maxmem>0) and (W.WrittenBytes>maxmem) then // TextLength is slower + raise ESQLDBException.CreateUTF8('%.FetchAllToCSVValues: overflow %', + [self, KB(maxmem)]); end; {$ifdef SYNDB_SILENCE} fSQLLogTimer.Pause; @@ -7157,13 +7177,14 @@ const function TSQLDBStatement.FetchAllToBinary(Dest: TStream; MaxRowCount: cardinal; DataRowPosition: PCardinalDynArray): cardinal; var F, FMax, FieldSize, NullRowSize: integer; - StartPos: Int64; + StartPos, MaxMem: Int64; W: TFileBufferWriter; ft: TSQLDBFieldType; ColTypes: TSQLDBFieldTypeDynArray; Null: TByteDynArray; begin result := 0; + MaxMem := Connection.Properties.StatementMaxMemory; W := TFileBufferWriter.Create(Dest); try W.WriteVarUInt32(FETCHALLTOBINARY_MAGIC); @@ -7213,6 +7234,9 @@ begin // then write data values ColumnsToBinary(W,pointer(Null),ColTypes); inc(result); + if (MaxMem>0) and (W.TotalWritten>MaxMem) then // Stream.Position is slower + raise ESQLDBException.CreateUTF8('%.FetchAllToBinary: overflow %', + [self, KB(MaxMem)]); if (MaxRowCount>0) and (result>=MaxRowCount) then break; until not Step; @@ -7405,6 +7429,13 @@ begin result := SQLLogEnd(@tmp); end; +function TSQLDBStatement.GetSQLCurrent: RawUTF8; +begin + if fSQLPrepared <> '' then + Result := fSQLPrepared else + Result := fSQL; +end; + function TSQLDBStatement.GetSQLWithInlinedParams: RawUTF8; begin if fSQL='' then @@ -7829,7 +7860,7 @@ end; procedure TSQLDBStatementWithParams.BindArray(Param: Integer; const Values: array of double); -var i: integer; +var i: PtrInt; begin with CheckParam(Param,ftDouble,paramIn,length(Values))^ do for i := 0 to high(Values) do @@ -7838,7 +7869,7 @@ end; procedure TSQLDBStatementWithParams.BindArray(Param: Integer; const Values: array of Int64); -var i: integer; +var i: PtrInt; begin with CheckParam(Param,ftInt64,paramIn,length(Values))^ do for i := 0 to high(Values) do @@ -7847,27 +7878,29 @@ end; procedure TSQLDBStatementWithParams.BindArray(Param: Integer; ParamType: TSQLDBFieldType; const Values: TRawUTF8DynArray; ValuesCount: integer); -var i: integer; +var i: PtrInt; ChangeFirstChar: AnsiChar; + p: PSQLDBParam; begin inherited; // raise an exception in case of invalid parameter if fConnection=nil then ChangeFirstChar := 'T' else ChangeFirstChar := Connection.Properties.DateTimeFirstChar; - with CheckParam(Param,ParamType,paramIn)^ do begin - VArray := Values; // immediate COW reference-counted assignment - if (ParamType=ftDate) and (ChangeFirstChar<>'T') then - for i := 0 to ValuesCount-1 do // fix e.g. for PostgreSQL - if (length(Values[i])>11) and (Values[i][12]='T') then - Values[i][12] := ChangeFirstChar; // [12] since quoted 'dateTtime' - VInt64 := ValuesCount; - end; + p := CheckParam(Param,ParamType,paramIn); + p^.VInt64 := ValuesCount; + p^.VArray := Values; // immediate COW reference-counted assignment + if (ParamType=ftDate) and (ChangeFirstChar<>'T') then + for i := 0 to ValuesCount-1 do // fix e.g. for PostgreSQL + if (p^.VArray[i]<>'') and (p^.VArray[i][1]='''') then + // not only replace 'T'->ChangeFirstChar, but force expanded format + DateTimeToIso8601(Iso8601ToDateTime(p^.VArray[i]), + {expanded=}true, ChangeFirstChar, {ms=}fForceDateWithMS, ''''); fParamsArrayCount := ValuesCount; end; procedure TSQLDBStatementWithParams.BindArray(Param: Integer; const Values: array of RawUTF8); -var i: integer; +var i: PtrInt; StoreVoidStringAsNull: boolean; begin StoreVoidStringAsNull := (fConnection<>nil) and @@ -7881,7 +7914,7 @@ end; procedure TSQLDBStatementWithParams.BindArrayCurrency(Param: Integer; const Values: array of currency); -var i: integer; +var i: PtrInt; begin with CheckParam(Param,ftCurrency,paramIn,length(Values))^ do for i := 0 to high(Values) do @@ -7890,7 +7923,7 @@ end; procedure TSQLDBStatementWithParams.BindArrayDateTime(Param: Integer; const Values: array of TDateTime); -var i: integer; +var i: PtrInt; begin with CheckParam(Param,ftDate,paramIn,length(Values))^ do for i := 0 to high(Values) do @@ -7899,7 +7932,7 @@ end; procedure TSQLDBStatementWithParams.BindArrayRowPrepare( const aParamTypes: array of TSQLDBFieldType; aExpectedMinimalRowCount: integer); -var i: integer; +var i: PtrInt; begin fParam.Count := 0; for i := 0 to high(aParamTypes) do @@ -7908,7 +7941,7 @@ begin end; procedure TSQLDBStatementWithParams.BindArrayRow(const aValues: array of const); -var i: integer; +var i: PtrInt; begin if length(aValues)<>fParamCount then raise ESQLDBException.CreateFmt('Invalid %.BindArrayRow call',[self]); @@ -7936,7 +7969,7 @@ begin end; procedure TSQLDBStatementWithParams.BindFromRows(Rows: TSQLDBStatement); -var F: integer; +var F: PtrInt; U: RawUTF8; begin if Rows<>nil then @@ -8047,7 +8080,8 @@ begin result := copy(TableName,j,maxInt); end; -function ReplaceParamsByNames(const aSQL: RawUTF8; var aNewSQL: RawUTF8): integer; +function ReplaceParamsByNames(const aSQL: RawUTF8; var aNewSQL: RawUTF8; + aStripSemicolon: boolean): integer; var i,j,B,L: PtrInt; P: PAnsiChar; c: array[0..3] of AnsiChar; @@ -8056,10 +8090,11 @@ const SQL_KEYWORDS: array[0..19] of AnsiChar = 'ASATBYIFINISOFONORTO'; begin result := 0; L := Length(aSQL); - while (L>0) and (aSQL[L] in [#1..' ',';']) do - if (aSQL[L]=';') and (L>5) and IdemPChar(@aSQL[L-3],'END') then - break else // allows 'END;' at the end of a statement - dec(L); // trim ' ' or ';' right (last ';' could be found incorrect) + if aStripSemicolon then + while (L>0) and (aSQL[L] in [#1..' ',';']) do + if (aSQL[L]=';') and (L>5) and IdemPChar(@aSQL[L-3],'END') then + break else // allows 'END;' at the end of a statement + dec(L); // trim ' ' or ';' right (last ';' could be found incorrect) if PosExChar('?',aSQL)>0 then begin aNewSQL:= ''; // change ? into :AA :BA .. diff --git a/contrib/mORMot/SynDBDataset.pas b/contrib/mORMot/SynDBDataset.pas index d448a30..4ddb509 100644 --- a/contrib/mORMot/SynDBDataset.pas +++ b/contrib/mORMot/SynDBDataset.pas @@ -1,12 +1,12 @@ /// DB.pas TDataset-based direct access classes (abstract TQuery-like) // - this unit is a part of the freeware Synopse framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynDBDataset; +unit SynDBDataset; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBDataset; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBDataset/SynDBBDE.pas b/contrib/mORMot/SynDBDataset/SynDBBDE.pas index 565377c..6162da5 100644 --- a/contrib/mORMot/SynDBDataset/SynDBBDE.pas +++ b/contrib/mORMot/SynDBDataset/SynDBBDE.pas @@ -6,7 +6,7 @@ unit SynDBBDE; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBBDE; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBDataset/SynDBFireDAC.pas b/contrib/mORMot/SynDBDataset/SynDBFireDAC.pas index 83d552b..8786597 100644 --- a/contrib/mORMot/SynDBDataset/SynDBFireDAC.pas +++ b/contrib/mORMot/SynDBDataset/SynDBFireDAC.pas @@ -6,7 +6,7 @@ unit SynDBFireDAC; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBFireDAC; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -209,6 +209,8 @@ const FIREDAC_PROVIDER: array[dOracle..high(TSQLDBDefinition)] of RawUTF8 = ( 'Ora','MSSQL','MSAcc','MySQL','SQLite','IB','','PG','DB2','Infx'); {$endif} + + implementation uses @@ -425,6 +427,7 @@ begin inherited Create(aProperties); fDatabase := TADConnection.Create(nil); fDatabase.ResourceOptions.SilentMode := True; // no need for wait cursor + fDatabase.LoginPrompt := false; fDatabase.Params.Text := (fProperties as TSQLDBFireDACConnectionProperties).fFireDACOptions.Text; end; diff --git a/contrib/mORMot/SynDBDataset/SynDBNexusDB.pas b/contrib/mORMot/SynDBDataset/SynDBNexusDB.pas index 4bd6ebe..d627442 100644 --- a/contrib/mORMot/SynDBDataset/SynDBNexusDB.pas +++ b/contrib/mORMot/SynDBDataset/SynDBNexusDB.pas @@ -6,7 +6,7 @@ unit SynDBNexusDB; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBNexusDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -227,7 +227,6 @@ function DropNexusEmbeddedEngine: TnxServerEngine; implementation uses - {$ifdef SYNDB_FULLNEXUSDB} nxreRemoteServerEngine, uMiscellaneous, diff --git a/contrib/mORMot/SynDBDataset/SynDBUniDAC.pas b/contrib/mORMot/SynDBDataset/SynDBUniDAC.pas index e1d7c83..bbb7908 100644 --- a/contrib/mORMot/SynDBDataset/SynDBUniDAC.pas +++ b/contrib/mORMot/SynDBDataset/SynDBUniDAC.pas @@ -6,7 +6,7 @@ unit SynDBUniDAC; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBUniDAC; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -63,9 +63,11 @@ uses Classes, Contnrs, SynCommons, + SynTable, SynLog, SynDB, SynDBDataset, + SynOleDB, // for CoInit/CoUnInit Uni, UniProvider, UniScript; @@ -173,6 +175,7 @@ type /// implements a statement via a UniDAC connection TSQLDBUniDACStatement = class(TSQLDBDatasetStatement) protected + fBatchExecute: Boolean; /// initialize and set fQuery: TUniQuery internal field as expected procedure DatasetCreate; override; /// set fQueryParams internal field as expected @@ -211,6 +214,7 @@ begin break; end; inherited Create(provider,aDatabaseName,aUserID,aPassWord); + fOnBatchInsert := nil; // MultipleValuesInsert is slower fSpecificOptions := TStringList.Create; opt := pointer(options); while opt<>nil do begin @@ -220,37 +224,71 @@ begin end; case fDBMS of dSQLite: begin // UniDAC support of SQLite3 is just buggy + {$ifdef FPC} + fSpecificOptions.Values['UseUnicode'] := 'true'; // FPC strings do like UTF8 + {$else} + {$ifndef UNICODE} + fForceUseWideString := true; // for non-unicode Delphi + {$endif} + {$endif} fSpecificOptions.Values['ForceCreateDatabase'] := 'true'; fSQLCreateField[ftInt64] := ' BIGINT'; // SQLite3 INTEGER = 32bit for UniDAC end; dFirebird: begin + {$ifdef FPC} + fSpecificOptions.Values['UseUnicode'] := 'true'; // FPC strings do like UTF8 + {$else} {$ifndef UNICODE} - fForceUseWideString := true; + fForceUseWideString := true; // for non-unicode Delphi + {$endif} {$endif} fSpecificOptions.Values['CharSet'] := 'UTF8'; - fSpecificOptions.Values['UseUnicode'] := 'true'; fSpecificOptions.Values['CharLength'] := '2'; fSpecificOptions.Values['DescribeParams'] := 'true'; end; // http://www.devart.com/unidac/docs/index.html?ibprov_article.htm - dOracle: begin - fSpecificOptions.Values['UseUnicode'] := 'true'; - fSpecificOptions.Values['Direct'] := 'true'; - fSpecificOptions.Values['HOMENAME'] := ''; - end; - dMySQL: begin - // s.d. 30.11.19 Damit der Connect schneller geht ! CRVioTCP.pas WaitForConnect - fSpecificOptions.Values['MySQL.ConnectionTimeout'] := '0'; - end; + dOracle: begin + {$ifdef FPC} + fSpecificOptions.Values['UseUnicode'] := 'true'; // FPC strings do like UTF8 + {$else} + {$ifndef UNICODE} + fForceUseWideString := true; // for non-unicode Delphi + {$endif} + {$endif} + fSpecificOptions.Values['Direct'] := 'true'; + fSpecificOptions.Values['HOMENAME'] := ''; + end; + dMySQL: begin + {$ifdef FPC} + fSpecificOptions.Values['UseUnicode'] := 'true'; // FPC strings do like UTF8 + {$else} + {$ifndef UNICODE} + fForceUseWideString := true; // for non-unicode Delphi + {$endif} + {$endif} + // s.d. 30.11.19 Damit der Connect schneller geht ! CRVioTCP.pas WaitForConnect + fSpecificOptions.Values['MySQL.ConnectionTimeout'] := '0'; + end; dMSSQL: begin + {$ifndef UNICODE} + {$ifndef FPC} + fForceUseWideString := true; // for non-unicode Delphi + {$endif} + {$endif} if aUserID='' then fSpecificOptions.Values['Authentication'] := 'auWindows'; - fSpecificOptions.Values['SQL Server.Provider'] := cMSSQLProvider; - // s.d. 30.11.19 Damit der Connect im Direct Mode so Schnell ist wie mit prAuto/OleDB - fSpecificOptions.Values['SQL Server.ConnectionTimeout'] := '0'; + fSpecificOptions.Values['SQL Server.Provider'] := cMSSQLProvider; + // s.d. 30.11.19 Damit der Connect im Direct Mode so Schnell ist wie mit prAuto/OleDB + fSpecificOptions.Values['SQL Server.ConnectionTimeout'] := '0'; end; // http://www.devart.com/unidac/docs/index.html?sqlprov_article.htm dPostgreSQL: begin // thanks delphinium for the trick! + {$ifdef FPC} + fSpecificOptions.Values['UseUnicode'] := 'true'; // FPC strings do like UTF8 + {$else} + {$ifndef UNICODE} + fForceUseWideString := true; // for non-unicode Delphi + {$endif} + {$endif} fSpecificOptions.Values['CharSet'] := 'UTF8'; - fSpecificOptions.Values['UseUnicode'] := 'true'; end; end; end; @@ -281,10 +319,10 @@ begin Table := Owner; Owner := ''; end; - if Owner = '' then + if (Owner='') and (fDBMS<>dOracle) then Owner := MainConnection.Properties.DatabaseName; // itSDS if Owner<>'' then - meta.Restrictions.Values['TABLE_SCHEMA'] := UTF8ToString(UpperCase(Owner)) + meta.Restrictions.Values['TABLE_SCHEMA'] := UTF8ToString(UpperCase(Owner)) else meta.Restrictions.Values['SCOPE'] := 'LOCAL'; meta.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(Table)); meta.Open; @@ -300,6 +338,7 @@ begin F.ColumnPrecision := meta.FieldByName('DATA_PRECISION').AsInteger; F.ColumnType := ColumnTypeNativeToDB(F.ColumnTypeNative,F.ColumnScale); if F.ColumnType=ftUnknown then begin // UniDAC metadata failed -> use SQL + Fields := nil; inherited GetFields(aTableName,Fields); exit; end; @@ -321,6 +360,7 @@ var meta, indexs: TDAMetaData; n: integer; ColName: RawUTF8; ndxName: string; + Owner,Table: RawUTF8; begin SetLength(Indexes,0); FA.Init(TypeInfo(TSQLDBIndexDefineDynArray),Indexes,@n); @@ -329,14 +369,27 @@ begin indexs := (MainConnection as TSQLDBUniDACConnection).fDatabase.CreateMetaData; try meta.MetaDataKind := 'Indexes'; - meta.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(aTableName)); + Split(aTableName,'.',Owner,Table); + if Table='' then begin + Table := Owner; + Owner := ''; + end; + if (Owner='') and (fDBMS<>dOracle) then + Owner := MainConnection.Properties.DatabaseName; // itSDS + if Owner<>'' then + meta.Restrictions.Values['TABLE_SCHEMA'] := UTF8ToString(UpperCase(Owner)) else + meta.Restrictions.Values['SCOPE'] := 'LOCAL'; + meta.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(Table)); meta.Open; while not meta.Eof do begin ndxName := meta.FieldByName('INDEX_NAME').AsString; F.IndexName := StringToUTF8(ndxName); F.KeyColumns := ''; indexs.MetaDataKind := 'indexcolumns'; - indexs.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(aTableName)); + if Owner<>'' then + indexs.Restrictions.Values['TABLE_SCHEMA'] := UTF8ToString(UpperCase(Owner)) else + indexs.Restrictions.Values['SCOPE'] := 'LOCAL'; + indexs.Restrictions.Values['TABLE_NAME'] := UTF8ToString(UpperCase(Table)); indexs.Restrictions.Values['INDEX_NAME'] := ndxName; indexs.Open; while not indexs.Eof do begin @@ -398,7 +451,7 @@ begin if aLibraryLocation<>'' then begin result := result+'?ClientLibrary='; if aLibraryLocationAppendExePath then - result := result+StringToUTF8(ExtractFilePath(ParamStr(0))); + result := result+StringToUTF8(ExeVersion.ProgramFilePath); result := result+StringToUTF8(aLibraryLocation); end; if aServerName<>'' then begin @@ -552,39 +605,170 @@ end; procedure TSQLDBUniDACStatement.DataSetBindSQLParam(const aArrayIndex, aParamIndex: integer; const aParam: TSQLDBParam); var P: TDAParam; + i: Integer; + tmp: RawUTF8; + StoreVoidStringAsNull: boolean; begin P := TDAParam(fQueryParams[aParamIndex]); - if P.InheritsFrom(TDAParam) then - with aParam do - if (VinOut<>paramInOut) and (VType=SynTable.ftBlob) then begin - P.ParamType := SQLParamTypeToDBParamType(VInOut); - if aArrayIndex>=0 then -{$ifdef UNICODE} - P.SetBlobData(Pointer(VArray[aArrayIndex]),Length(VArray[aArrayIndex])) else - P.SetBlobData(Pointer(VData),Length(VData)); -{$else} P.AsString := VArray[aArrayIndex] else - P.AsString := VData; -{$endif}exit; + if not P.InheritsFrom(TDAParam) then begin + inherited DataSetBindSQLParam(aArrayIndex, aParamIndex, aParam); + Exit; + end; + if fDatasetSupportBatchBinding then + fBatchExecute := (aArrayIndex<0) and (fParamsArrayCount>0) else + fBatchExecute := false; + if fBatchExecute then + P.ValueCount := fParamsArrayCount else + P.ValueCount := 1; + with aParam do begin + P.ParamType := SQLParamTypeToDBParamType(VInOut); + if VinOut <> paramInOut then + case VType of + SynTable.ftNull: + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + P.Values[i].Clear else + P.Clear; + SynTable.ftInt64: begin + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + if VArray[i]='null' then + P.Values[i].Clear else + P.Values[i].AsLargeInt := GetInt64(pointer(VArray[i])) else + if aArrayIndex>=0 then + if VArray[aArrayIndex]='null' then + P.Clear else + P.AsLargeInt := GetInt64(pointer(VArray[aArrayIndex])) else + P.AsLargeInt := VInt64; + end; + SynTable.ftDouble: + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + if VArray[i]='null' then + P.Values[i].Clear else + P.Values[i].AsFloat := GetExtended(pointer(VArray[i])) else + if aArrayIndex>=0 then + if VArray[aArrayIndex]='null' then + P.Clear else + P.AsFloat := GetExtended(pointer(VArray[aArrayIndex])) else + P.AsFloat := PDouble(@VInt64)^; + SynTable.ftCurrency: + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + if VArray[i]='null' then + P.Values[i].Clear else + P.Values[i].AsCurrency := StrToCurrency(pointer(VArray[i])) else + if aArrayIndex>=0 then + if VArray[aArrayIndex]='null' then + P.Clear else + P.AsCurrency := StrToCurrency(pointer(VArray[aArrayIndex])) else + P.AsCurrency := PCurrency(@VInt64)^; + SynTable.ftDate: + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + if VArray[i]='null' then + P.Values[i].Clear else begin + UnQuoteSQLStringVar(pointer(VArray[i]),tmp); + P.Values[i].AsDateTime := Iso8601ToDateTime(tmp); + end else + if aArrayIndex>=0 then + if VArray[aArrayIndex]='null' then + P.Clear else begin + UnQuoteSQLStringVar(pointer(VArray[aArrayIndex]),tmp); + P.AsDateTime := Iso8601ToDateTime(tmp); + end else + P.AsDateTime := PDateTime(@VInt64)^; + SynTable.ftUTF8: + if fBatchExecute then begin + StoreVoidStringAsNull := fConnection.Properties.StoreVoidStringAsNull; + for i := 0 to fParamsArrayCount-1 do + if (VArray[i]='null') or + (StoreVoidStringAsNull and (VArray[i]=#39#39)) then + P.Values[i].Clear else begin + UnQuoteSQLStringVar(pointer(VArray[i]),tmp); + {$ifdef UNICODE} + P.Values[i].AsWideString := UTF8ToString(tmp); + {$else} + if fForceUseWideString then + P.Values[i].AsWideString := UTF8ToWideString(tmp) else + P.Values[i].AsString := UTF8ToString(tmp); + {$endif} + end + end else + if aArrayIndex>=0 then + if (VArray[aArrayIndex]='null') or + (fConnection.Properties.StoreVoidStringAsNull and + (VArray[aArrayIndex]=#39#39)) then + P.Clear else begin + UnQuoteSQLStringVar(pointer(VArray[aArrayIndex]),tmp); + {$ifdef UNICODE} + P.AsWideString := UTF8ToString(tmp); + {$else} + if fForceUseWideString then + P.AsWideString := UTF8ToWideString(tmp) else + P.AsString := UTF8ToString(tmp); + {$endif} + end else + if (VData='') and fConnection.Properties.StoreVoidStringAsNull then + P.Clear else + {$ifdef UNICODE} + P.AsWideString := UTF8ToString(VData); + {$else} + if not fForceUseWideString then + P.AsString := UTF8ToString(VData) else + P.AsWideString := UTF8ToWideString(VData); + {$endif} + SynTable.ftBlob: + if fBatchExecute then + for i := 0 to fParamsArrayCount-1 do + if VArray[i]='null' then + P.Values[i].Clear else begin + {$ifdef UNICODE} + P.Values[i].AsBlobRef.Clear; + P.Values[i].AsBlobRef.Write(0, Length(VArray[aArrayIndex]), Pointer(VArray[aArrayIndex])); end else + {$else} + P.Values[i].AsString := VArray[aArrayIndex]; end else + {$endif} + if aArrayIndex>=0 then + if VArray[aArrayIndex]='null' then + P.Clear else begin + {$ifdef UNICODE} + P.AsBlobRef.Clear; + P.AsBlobRef.Write(0, Length(VArray[aArrayIndex]), Pointer(VArray[aArrayIndex])); end else begin + P.AsBlobRef.Clear; + P.AsBlobRef.Write(0, Length(VData), Pointer(VData)); end; + {$else} + P.AsString := VArray[aArrayIndex] end else + P.AsString := VData; + {$endif} + else + raise ESQLDBUniDAC.CreateUTF8( + '%.DataSetBindSQLParam: invalid type % on bound parameter #%', + [Self,ord(VType),aParamIndex+1]); end; - inherited DataSetBindSQLParam(aArrayIndex, aParamIndex, aParam); + end; end; procedure TSQLDBUniDACStatement.DatasetCreate; begin fQuery := TUniQuery.Create(nil); TUniQuery(fQuery).Connection := (fConnection as TSQLDBUniDACConnection).Database; + fDatasetSupportBatchBinding := true; end; function TSQLDBUniDACStatement.DatasetPrepare(const aSQL: string): boolean; begin (fQuery as TUniQuery).SQL.Text := aSQL; + TUniQuery(fQuery).Prepare; fQueryParams := TUniQuery(fQuery).Params; result := fQueryParams<>nil; end; procedure TSQLDBUniDACStatement.DatasetExecSQL; begin - (fQuery as TUniQuery).Execute; + if fBatchExecute then + (fQuery as TUniQuery).Execute(fParamsArrayCount) else + (fQuery as TUniQuery).Execute; end; diff --git a/contrib/mORMot/SynDBFirebird.pas b/contrib/mORMot/SynDBFirebird.pas index 9175924..51d11b3 100644 --- a/contrib/mORMot/SynDBFirebird.pas +++ b/contrib/mORMot/SynDBFirebird.pas @@ -7,7 +7,7 @@ unit SynDBFirebird; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -26,7 +26,7 @@ unit SynDBFirebird; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBMidasVCL.pas b/contrib/mORMot/SynDBMidasVCL.pas index fe030a4..3c37050 100644 --- a/contrib/mORMot/SynDBMidasVCL.pas +++ b/contrib/mORMot/SynDBMidasVCL.pas @@ -6,7 +6,7 @@ unit SynDBMidasVCL; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBMidasVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBODBC.pas b/contrib/mORMot/SynDBODBC.pas index 1622404..0859b90 100644 --- a/contrib/mORMot/SynDBODBC.pas +++ b/contrib/mORMot/SynDBODBC.pas @@ -6,7 +6,7 @@ unit SynDBODBC; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBODBC; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -87,6 +87,7 @@ type protected fDriverDoesNotHandleUnicode: Boolean; fSQLDriverConnectPrompt: Boolean; + fSQLStatementTimeout: integer; /// this overridden method will hide de DATABASE/PWD fields in ODBC connection string function GetDatabaseNameSafe: RawUTF8; override; /// this overridden method will retrieve the kind of DBMS from the main connection @@ -159,6 +160,10 @@ type // - set to TRUE to allow UI prompt if needed property SQLDriverConnectPrompt: boolean read fSQLDriverConnectPrompt write fSQLDriverConnectPrompt; + /// The number of seconds to wait for a SQL statement to execute before canceling the query. + // When set to 0 (the default) there is no timeout. See ODBC SQL_QUERY_TIMEOUT documentation + property SQLStatementTimeoutSec: integer read fSQLStatementTimeout + write fSQLStatementTimeout; end; /// implements a direct connection to the ODBC library @@ -292,7 +297,7 @@ type end; {$ifdef MSWINDOWS} -/// List all ODBC drivers installed +/// List all ODBC drivers installed, by reading the Windows Registry // - aDrivers is the output driver list container, which should be either nil (to // create a new TStringList), or any existing TStrings instance (may be from VCL // - aIncludeVersion: include the DLL driver version as = @@ -300,6 +305,7 @@ type function ODBCInstalledDriversList(const aIncludeVersion: Boolean; var aDrivers: TStrings): boolean; {$endif MSWINDOWS} + implementation {$ifdef MSWINDOWS} @@ -384,10 +390,12 @@ const SQL_ATTR_METADATA_ID = 10014; // statement attributes + SQL_QUERY_TIMEOUT = 0; SQL_ATTR_APP_ROW_DESC = 10010; SQL_ATTR_APP_PARAM_DESC = 10011; SQL_ATTR_IMP_ROW_DESC = 10012; SQL_ATTR_IMP_PARAM_DESC = 10013; + SQL_ATTR_QUERY_TIMEOUT = SQL_QUERY_TIMEOUT; // ODBC 3.0 SQL_ATTR_CURSOR_SCROLLABLE = (-1); SQL_ATTR_CURSOR_SENSITIVITY = (-2); @@ -1704,7 +1712,15 @@ begin end; ftDouble: begin CValueType := SQL_C_DOUBLE; - // in case of "Invalid character value for cast specification" error + if (fDBMS = dMSSQL) and (VInOut=paramIn) and + (PDouble(@VInt64)^ > -1) and (PDouble(@VInt64)^ < 1) then begin + // prevent "Invalid character value for cast specification" error for numbers (-1; 1) + // for doubles outside this range SQL_C_DOUBLE must be used + ParameterType := SQL_NUMERIC; + ColumnSize := 9; + DecimalDigits := 6; + end; + // in case of "Invalid character value for cast specification" error // for small digits like 0.01, -0.0001 under Linux msodbcsql17 should // be updated to >= 17.5.2 ParameterValue := pointer(@VInt64); @@ -1728,8 +1744,14 @@ begin if ansitext then begin retry: VData := CurrentAnsiConvert.UTF8ToAnsi(VData); CValueType := SQL_C_CHAR; - end else + end else begin VData := Utf8DecodeToRawUnicode(VData); + if (fDBMS=dMSSQL) then begin // statements like CONTAINS(field, ?) do not accept NVARCHAR(max) + ColumnSize := length(VData) shr 1; // length in characters + if (ColumnSize > 4000) then // > 8000 bytes - use varchar(max) + ColumnSize := 0; + end; + end; ftBlob: StrLen_or_Ind[p] := length(VData); else @@ -1867,6 +1889,10 @@ begin try ODBC.Check(nil,self,ODBC.PrepareW(fStatement,pointer(fSQLW),length(fSQLW) shr 1), SQL_HANDLE_STMT,fStatement); + if TODBCConnectionProperties(Connection.Properties).SQLStatementTimeoutSec > 0 then + ODBC.Check(nil,self,ODBC.SetStmtAttrA(fStatement,SQL_ATTR_QUERY_TIMEOUT, + SQLPOINTER(TODBCConnectionProperties(Connection.Properties).SQLStatementTimeoutSec), SQL_IS_INTEGER), + SQL_HANDLE_STMT,fStatement); SQLLogEnd; except on E: Exception do begin @@ -2054,7 +2080,7 @@ begin end; FA.Init(TypeInfo(TSQLDBColumnDefineDynArray),Fields,@n); FA.Compare := SortDynArrayAnsiStringI; // FA.Find() case insensitive - fillchar(F,SizeOf(F),0); + FillcharFast(F,SizeOf(F),0); if fCurrentRow>0 then // Step done above repeat F.ColumnName := Trim(ColumnUTF8(3)); // Column*() should be done in order @@ -2256,7 +2282,7 @@ begin Stmt.Step; end; PA.Init(TypeInfo(TSQLDBColumnDefineDynArray),Parameters,@n); - fillchar(P,SizeOf(P),0); + FillcharFast(P,SizeOf(P),0); if Stmt.fCurrentRow>0 then // Step done above repeat P.ColumnName := Trim(Stmt.ColumnUTF8(3)); // Column*() should be in order diff --git a/contrib/mORMot/SynDBOracle.pas b/contrib/mORMot/SynDBOracle.pas index 13aed30..5fce620 100644 --- a/contrib/mORMot/SynDBOracle.pas +++ b/contrib/mORMot/SynDBOracle.pas @@ -6,7 +6,7 @@ unit SynDBOracle; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBOracle; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -73,7 +73,7 @@ uses { -------------- Oracle Client Interface native connection } type - /// execption type associated to the native Oracle Client Interface (OCI) + /// exception type associated to the native Oracle Client Interface (OCI) ESQLDBOracle = class(ESQLDBException); POracleDate = ^TOracleDate; @@ -312,6 +312,11 @@ type // - if ExpectResults is TRUE, then Step() and Column*() methods are available // to retrieve the data rows // - raise an ESQLDBOracle on any error + // - if aSQL requires a trailing ';', you should end it with ';;' e.g. for + // $ DB.ExecuteNoResult( + // $ 'CREATE OR REPLACE FUNCTION ORA_POC(MAIN_TABLE IN VARCHAR2, REC_COUNT IN NUMBER, BATCH_SIZE IN NUMBER) RETURN VARCHAR2' + + // $ ' AS LANGUAGE JAVA' + + // $ ' NAME ''OraMain.selectTable(java.lang.String, int, int) return java.lang.String'';;', []); procedure Prepare(const aSQL: RawUTF8; ExpectResults: Boolean=false); overload; override; /// Execute a prepared SQL statement // - parameters marked as ? should have been already bound with Bind*() functions @@ -439,6 +444,7 @@ var /// how many blob chunks should be handled at once SynDBOracleBlobChunksCount: integer = 250; + implementation { TOracleDate } @@ -2611,7 +2617,9 @@ begin end; type + /// Oracle VARNUM memory structure TSQLT_VNU = array[0..21] of byte; + /// points to a Oracle VARNUM memory structure PSQLT_VNU = ^TSQLT_VNU; procedure Int64ToSQLT_VNU(Value: Int64; OutData: PSQLT_VNU); @@ -2657,7 +2665,7 @@ begin end; procedure UnQuoteSQLString(S,D: PUTF8Char; SLen: integer); -begin +begin // internal method, tuned for our OCI process if S=nil then D^ := #0 else if S^<>'''' then @@ -2970,7 +2978,14 @@ begin VDBType,@oIndicator[i],nil,nil,0,nil,OCI_DEFAULT),fError); end; end; - // 2. execute prepared statement + // 2. retrieve column information (if not already done) + if fExpectResults and (fColumn.Count = 0) then + // We move this after params binding to prevent "ORA-00932: inconsistent + // datatypes" during call to StmtExecute with OCI_DESCRIBE_ONLY. + // Because if called here sometimes it breaks the Oracle shared pool and + // only `ALTER system flush shared_pool` seems to fix the DB state + SetColumnsForPreparedStatement; + // 3. execute prepared statement and dispatch data in row buffers if (fColumnCount=0) and (Connection.TransactionCount=0) then // for INSERT/UPDATE/DELETE without a transaction: AutoCommit after execution mode := OCI_COMMIT_ON_SUCCESS else @@ -2978,6 +2993,7 @@ begin mode := OCI_DEFAULT; Status := OCI.StmtExecute(TSQLDBOracleConnection(Connection).fContext, fStatement,fError,fRowCount,0,nil,nil,mode); + // 4. check execution error, and retrieve data result range FetchTest(Status); // error + set fRowCount+fCurrentRow+fRowFetchedCurrent Status := OCI_SUCCESS; // mark OK for fBoundCursor[] below finally @@ -3412,14 +3428,16 @@ begin raise ESQLDBOracle.CreateUTF8('%.Prepare should be called only once',[self]); // 1. process SQL inherited Prepare(aSQL,ExpectResults); // set fSQL + Connect if necessary - fPreparedParamsCount := ReplaceParamsByNumbers(aSQL,fSQLPrepared,':', true); + fPreparedParamsCount := ReplaceParamsByNumbers(aSQL,fSQLPrepared,':',true); L := Length(fSQLPrepared); - while (L>0) and (fSQLPrepared[L] in [#1..' ',';']) do - if (fSQLPrepared[L]=';') and (L>5) and IdemPChar(@fSQLPrepared[L-3],'END') then - break else // allows 'END;' at the end of a statement - dec(L); // trim ' ' or ';' right (last ';' could be found incorrect) - if L <> Length(fSQLPrepared) then - fSQLPrepared := copy(fSQLPrepared,1,L); // trim right ';' if any + while (L>0) and (fSQLPrepared[L]<=' ') do // trim right + dec(L); + // allow one trailing ';' by writing ';;' or allows 'END;' at the end of a statement + if (L>5) and (fSQLPrepared[L]=';') and not + (IdemPChar(@fSQLPrepared[L-3],'END') and (fSQLPrepared[L-4]<='A')) then + dec(L); + if L<>Length(fSQLPrepared) then + SetLength(fSQLPrepared,L); // trim trailing spaces or ';' if needed // 2. prepare statement env := (Connection as TSQLDBOracleConnection).fEnv; with OCI do begin @@ -3437,8 +3455,8 @@ begin OCI_NTV_SYNTAX,OCI_DEFAULT),fError); end; end; - // 3. retrieve column information and dispatch data in row buffer - SetColumnsForPreparedStatement; + // note: if SetColumnsForPreparedStatement is called here, we randomly got + // "ORA-00932 : inconsistent datatypes" error -> moved to ExecutePrepared except on E: Exception do begin FreeHandles(True); diff --git a/contrib/mORMot/SynDBPostgres.pas b/contrib/mORMot/SynDBPostgres.pas index 3cde862..9d71fe6 100644 --- a/contrib/mORMot/SynDBPostgres.pas +++ b/contrib/mORMot/SynDBPostgres.pas @@ -322,12 +322,6 @@ type /// direct access to the libpq native Postgres protocol 3 library // - only the endpoints needed by this unit are imported TSQLDBPostgresLib = class(TSQLDBLib) - protected - /// raise an exception on error and clean result - // - will set pRes to nil if passed - // - if andClear is true - will call always PQ.Clear(res) - procedure Check(conn: PPGconn; res: PPGresult; - pRes: PPPGresult = nil; andClear: boolean = true); public LibVersion: function: integer; cdecl; IsThreadSafe: function: integer; cdecl; @@ -365,6 +359,11 @@ type /// just a wrapper around FastSetString + GetValue/GetLength procedure GetRawUTF8(res: PPGresult; tup_num, field_num: integer; var result: RawUTF8); + /// raise an exception on error and clean result + // - will set pRes to nil if passed + // - if andClear is true - will call always PQ.Clear(res) + procedure Check(conn: PPGconn; res: PPGresult; + pRes: PPPGresult = nil; andClear: boolean = true); end; const @@ -519,11 +518,13 @@ end; procedure TSQLDBPostgresConnection.Connect; var log: ISynLog; + host, port: RawUtf8; begin log := SynDBLog.Enter(self, 'Connect'); Disconnect; // force fTrans=fError=fServer=fContext=nil try - fPGConn := PQ.SetDBLogin(pointer(Properties.ServerName), nil, nil, nil, + Split(Properties.ServerName, ':', host, port); + fPGConn := PQ.SetDBLogin(pointer(host), pointer(port), nil, nil, pointer(Properties.DatabaseName), pointer(Properties.UserID), pointer(Properties.PassWord)); if PQ.Status(fPGConn) = CONNECTION_BAD then @@ -537,7 +538,8 @@ begin log.Log(sllDB, 'Connected to % % using % v%', [fProperties.ServerName, fProperties.DatabaseNameSafe, PQ.fLibraryPath, PQ.LibVersion], self); end - else // to ensure no performance drop due to notice to console + else + // to ensure no performance drop due to notice to console PQ.SetNoticeProcessor(fPGConn, DummyNoticeProcessor, nil); inherited Connect; // notify any re-connection except @@ -816,7 +818,8 @@ begin DoubleToStr(PDouble(@p^.VInt64)^, RawUTF8(p^.VData)); ftDate: // Postgres expects space instead of T in ISO8601 expanded format - p^.VData := DateTimeToIso8601(PDateTime(@p^.VInt64)^, true, ' '); + p^.VData := DateTimeToIso8601( + PDateTime(@p^.VInt64)^, true, ' ', fForceDateWithMS); ftUTF8: ; // text already in p^.VData ftBlob: diff --git a/contrib/mORMot/SynDBRemote.pas b/contrib/mORMot/SynDBRemote.pas index fbcbe66..a2773f4 100644 --- a/contrib/mORMot/SynDBRemote.pas +++ b/contrib/mORMot/SynDBRemote.pas @@ -6,7 +6,7 @@ unit SynDBRemote; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBRemote; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBSQLite3.pas b/contrib/mORMot/SynDBSQLite3.pas index 4aad5d7..016591e 100644 --- a/contrib/mORMot/SynDBSQLite3.pas +++ b/contrib/mORMot/SynDBSQLite3.pas @@ -6,7 +6,7 @@ unit SynDBSQLite3; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBSQLite3; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynDBVCL.pas b/contrib/mORMot/SynDBVCL.pas index 3c19d41..09a647e 100644 --- a/contrib/mORMot/SynDBVCL.pas +++ b/contrib/mORMot/SynDBVCL.pas @@ -6,7 +6,7 @@ unit SynDBVCL; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBVCL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -80,7 +80,8 @@ type // - by default, ColumnDataSize would be computed from the supplied data, // unless you set IgnoreColumnDataSize=true to set the value to 0 (and // force e.g. SynDBVCL TSynBinaryDataSet.InternalInitFieldDefs define the - // field as ftDefaultMemo) + // field as ftDefaultMemo) or you define some FieldDefs.Items[].Size values + // for ftUTF8 column sizes before calling this From() method procedure From(const BinaryData: RawByteString; DataRowPosition: PCardinalDynArray=nil; IgnoreColumnDataSize: boolean=false); overload; virtual; /// initialize the virtual TDataSet from a SynDB TSQLDBStatement result set @@ -89,7 +90,8 @@ type // - by default, ColumnDataSize would be computed from the supplied data, // unless you set IgnoreColumnDataSize=true to set the value to 0 (and // force e.g. SynDBVCL TSynBinaryDataSet.InternalInitFieldDefs define the - // field as ftDefaultMemo) + // field as ftDefaultMemo) or you define some FieldDefs.Items[].Size values + // for ftUTF8 column sizes before calling this From() method procedure From(Statement: TSQLDBStatement; MaxRowCount: cardinal=0; IgnoreColumnDataSize: boolean=false); overload; virtual; /// finalize the class instance @@ -139,7 +141,8 @@ type // - by default, ColumnDataSize would be computed from the supplied data, // unless you set IgnoreColumnDataSize=true to set the value to 0 (and // force e.g. SynDBVCL TSynBinaryDataSet.InternalInitFieldDefs define the - // field as ftDefaultMemo) + // field as ftDefaultMemo) or you define some FieldDefs.Items[].Size values + // for ftUTF8 column sizes before calling this From() method procedure From(Statement: TSQLDBStatement; MaxRowCount: cardinal=0; IgnoreColumnDataSize: boolean=false); override; /// the associated connection properties @@ -260,33 +263,49 @@ begin end; procedure TSynBinaryDataSet.InternalInitFieldDefs; -var F: integer; +var F,custom: integer; DBType: TFieldType; + ExistingName: TRawUTF8DynArray; // FieldDefs.Items[].Name + ExistingSize: TIntegerDynArray; // FieldDefs.Items[].Size begin + if FieldDefs.Count>0 then begin // custom column sizes + SetLength(ExistingName,FieldDefs.Count); + SetLength(ExistingSize,FieldDefs.Count); + for F := 0 to FieldDefs.Count-1 do + with FieldDefs.Items[F] do begin + ExistingName[F] := StringToUtf8(Name); + ExistingSize[F] := Size; + end; + end; FieldDefs.Clear; if fDataAccess=nil then exit; for F := 0 to fDataAccess.ColumnCount-1 do with fDataAccess.Columns[F] do begin - case ColumnType of - SynTable.ftInt64: - DBType := ftLargeint; - SynTable.ftDate: - DBType := ftDateTime; - SynTable.ftUTF8: - if ColumnDataSize=0 then - DBType := ftDefaultMemo else - DBType := ftWideString; // means UnicodeString for Delphi 2009+ - SynTable.ftBlob: - DBType := ftBlob; - SynTable.ftDouble, SynTable.ftCurrency: - DBType := ftFloat; - else - raise EDatabaseError.CreateFmt( - 'GetFieldData ColumnType=%s',[TSQLDBFieldTypeToString(ColumnType)]); + if ExistingName<>nil then begin + custom := FindRawUTF8(ExistingName,ColumnName); + if custom>=0 then // retrieve custom max column length from FieldDefs + ColumnDataSize := ExistingSize[custom]; + end; + case ColumnType of + SynTable.ftInt64: + DBType := ftLargeint; + SynTable.ftDate: + DBType := ftDateTime; + SynTable.ftUTF8: + if ColumnDataSize=0 then + DBType := ftDefaultMemo else // no size + DBType := ftWideString; // means UnicodeString for Delphi 2009+ + SynTable.ftBlob: + DBType := ftBlob; + SynTable.ftDouble, SynTable.ftCurrency: + DBType := ftFloat; + else + raise EDatabaseError.CreateFmt( + 'GetFieldData ColumnType=%s',[TSQLDBFieldTypeToString(ColumnType)]); + end; + FieldDefs.Add(UTF8ToString(ColumnName),DBType,ColumnDataSize); end; - FieldDefs.Add(UTF8ToString(ColumnName),DBType,ColumnDataSize); - end; end; function TSynBinaryDataSet.GetRowFieldData(Field: TField; diff --git a/contrib/mORMot/SynDBZeos.pas b/contrib/mORMot/SynDBZeos.pas index ed9aae9..78d875c 100644 --- a/contrib/mORMot/SynDBZeos.pas +++ b/contrib/mORMot/SynDBZeos.pas @@ -6,7 +6,7 @@ unit SynDBZeos; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynDBZeos; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -158,6 +158,9 @@ uses {$if defined(ENABLE_INTERBASE) and not defined(ZEOS_DISABLE_INTERBASE)} ZDbcInterbase6, {$ifend} + {$if defined(ENABLE_FIREBIRD) and not defined(ZEOS_DISABLE_FIREBIRD)} + ZDbcFirebird, + {$ifend} {$if defined(ENABLE_SQLITE) and not defined(ZEOS_DISABLE_SQLITE)} ZDbcSqLite, {$ifend} @@ -167,6 +170,9 @@ uses {$if defined(ENABLE_ASA) and not defined(ZEOS_DISABLE_ASA)} ZDbcASA, {$ifend} + {$if defined(ENABLE_SQLANY) and not defined(ZEOS_DISABLE_SQLANY)} + ZDbcSQLAnywhere, + {$ifend} {$if defined(ENABLE_POOLED) and not defined(ZEOS_DISABLE_POOLED)} ZDbcPooled, {$ifend} @@ -176,10 +182,13 @@ uses {$if defined(ENABLE_ODBC) and not defined(ZEOS_DISABLE_ODBC)} ZDbcODBCCon, {$ifend} + // main ZDBC units ZCompatibility, ZVariant, + {$ifndef ZEOS80UP} ZURL, + {$endif ZEOS80UP} ZDbcIntfs, ZDbcResultSet, // mORMot units after ZDBC due to some name conflicts (e.g. UTF8ToString) @@ -728,9 +737,10 @@ begin sSchema := UTF8ToString(Schema); { mormot does not create the Tables casesensitive but gives mixed cased strings as tablename so we normalize the identifiers to database defaults : } - sTableName := meta.GetIdentifierConvertor.ExtractQuote(UTF8ToString(TableName)); - sTableName := meta.AddEscapeCharToWildcards(sTableName); //do not use "like" search patterns ['_','%'] so they need to be escaped - res := meta.GetColumns('',sSchema,sTableName,''); + sTableName := meta.{$ifdef ZEOS80UP}GetIdentifierConverter{$else}GetIdentifierConvertor{$endif}. + ExtractQuote(Utf8ToString(TableName)); + // do not escape sTableName - https://synopse.info/forum/viewtopic.php?pid=34896#p34896 + res := meta.GetColumns('',sSchema,meta.AddEscapeCharToWildcards(sTableName),''); FA.InitSpecific(TypeInfo(TSQLDBColumnDefineDynArray),Fields,djRawUTF8,@n,true); FillChar(F,sizeof(F),0); while res.Next do begin diff --git a/contrib/mORMot/SynDprUses.inc b/contrib/mORMot/SynDprUses.inc index 39b7ed2..5654f82 100644 --- a/contrib/mORMot/SynDprUses.inc +++ b/contrib/mORMot/SynDprUses.inc @@ -37,15 +37,14 @@ {$endif FPC_X64MM_WIN} {$ifdef Unix} // we may also be on Darwin / OSX {$ifdef Darwin} - iosxwstr, // optional WideString manager for Mac, but won't hurt + // iosxwstr, // optional WideString manager for Mac {$else} - cwstring, // optional WideString manager, but won't hurt + // cwstring, // optional WideString manager {$endif Darwin} {$else} {$ifopt D-} // at the moment, debug mode with cmem causes trouble //cmem, // default FPC's heap manager is very RAM hungry (one heap per thread) {$endif} - //FastMM4, // need the latest version, e.g. from lib\kylix sub folder {$endif Unix} {$else} // enable FastMM4 on older versions of Delphi {$IFDEF CONDITIONALEXPRESSIONS} diff --git a/contrib/mORMot/SynEcc.pas b/contrib/mORMot/SynEcc.pas index d949580..4110771 100644 --- a/contrib/mORMot/SynEcc.pas +++ b/contrib/mORMot/SynEcc.pas @@ -6,7 +6,7 @@ unit SynEcc; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,11 +25,11 @@ unit SynEcc; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): - - Kenneth MacKay (easy-ecc source code) + - Kenneth MacKay (micro-ecc source code) 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 @@ -48,7 +48,7 @@ unit SynEcc; Using secp256r1 curve from "simple and secure ECDH and ECDSA library" Copyright (c) 2013, Kenneth MacKay - BSD 2-clause license - https://github.com/esxgx/easy-ecc + https://github.com/kmackay/micro-ecc *** BEGIN LICENSE BLOCK ***** Copyright (c) 2013, Kenneth MacKay @@ -164,6 +164,10 @@ type // - each ECC signature consumes 64 bytes of memory TECCSignature = array[0..(ECC_BYTES*2)-1] of byte; + /// store a signature, in the DER format + // - static allocated buffer as returned by EccSignToDer() + TEccSignatureDer = array[0..(ECC_BYTES * 2) + 7] of byte; + /// store an encryption key, as generated by ECC secp256r1 cryptography // - use ecdh_shared_secret() to compute such a key from public/private keys // - 256-bit / 32 bytes derivation from secp256r1 ECDH is expected to have at @@ -212,7 +216,7 @@ var /// create a public/private key pair // - using secp256r1 curve, i.e. NIST P-256, or OpenSSL prime256v1 -// - directly low-level access to the statically linked easy-ecc library function +// - directly low-level access to the statically linked micro-ecc library function // - returns true if the key pair was generated successfully in pub/priv // - returns false if an error occurred // - this function is thread-safe and does not perform any memory allocation @@ -221,7 +225,7 @@ function ecc_make_key(out pub: TECCPublicKey; out priv: TECCPrivateKey): boolean /// compute a shared secret given your secret key and someone else's public key // - using secp256r1 curve, i.e. NIST P-256, or OpenSSL prime256v1 -// - directly low-level access to the statically linked easy-ecc library function +// - directly low-level access to the statically linked micro-ecc library function // - note: it is recommended that you hash the result of ecdh_shared_secret // before using it for symmetric encryption or HMAC (via an intermediate KDF) // - returns true if the shared secret was generated successfully in secret @@ -233,7 +237,7 @@ function ecdh_shared_secret(const pub: TECCPublicKey; const priv: TECCPrivateKey /// generate an ECDSA signature for a given hash value // - using secp256r1 curve, i.e. NIST P-256, or OpenSSL prime256v1 -// - directly low-level access to the statically linked easy-ecc library function +// - directly low-level access to the statically linked micro-ecc library function // - returns true if the signature generated successfully in sign // - returns false if an error occurred // - this function is thread-safe and does not perform any memory allocation @@ -243,7 +247,7 @@ function ecdsa_sign(const priv: TECCPrivateKey; const hash: TECCHash; /// verify an ECDSA signature // - using secp256r1 curve, i.e. NIST P-256, or OpenSSL prime256v1 -// - directly low-level access to the statically linked easy-ecc library function +// - directly low-level access to the statically linked micro-ecc library function // - returns true if the signature is valid // - returns false if an error occurred // - this function is thread-safe and does not perform any memory allocation @@ -664,6 +668,10 @@ function ECCCheck(const content: TECCSignatureCertifiedContent): boolean; overlo /// convert a supplied base-64 text into a TECCSignatureCertifiedContent binary buffer function ECCSign(const base64: RawUTF8; out content: TECCSignatureCertifiedContent): boolean; +/// convert a raw signature into a DER compatible content +// - returns the number of bytes encoded into der[] buffer +function EccSignToDer(const sign: TEccSignature; out der: TEccSignatureDer): integer; + /// convert a supplied TECCSignatureCertifiedContent binary buffer into proper text // - returns base-64 encoded text, or '' if the signature was filled with zeros function ECCText(const sign: TECCSignatureCertifiedContent): RawUTF8; overload; @@ -1958,9 +1966,7 @@ end; {$endif ECC_STATICLIB_AVAILABLE} -{$ifdef HASUINT64} - -{ Pure Pascal Version of low-level ECC process (adapted from easy-ecc.c code) +{ Pure Pascal Version of low-level ECC process (adapted from micro-ecc.c code) Some numbers (on another slower computer than the previous values above), which is quite acceptable, since it is faster than gcc -O1 mode :) @@ -2055,6 +2061,13 @@ type // we use UInt64 instead of QWord end; PEccPoint = ^TEccPoint; +function _isZero(const VLI: TVLI): boolean; {$ifdef HASINLINE}inline;{$endif} +begin + result := (VLI[0]=0) and (VLI[1]=0) and (VLI[2]=0) and (VLI[3]=0); +end; + +{$ifdef HASUINT64} + const Curve_P_32: TVLI = ( UInt64($FFFFFFFFFFFFFFFF), UInt64($00000000FFFFFFFF), @@ -2084,11 +2097,6 @@ begin VLI[3] := 0; end; -function _isZero(const VLI: TVLI): boolean; {$ifdef HASINLINE}inline;{$endif} -begin - result := (VLI[0]=0) and (VLI[1]=0) and (VLI[2]=0) and (VLI[3]=0); -end; - function _equals(const Left, Right: TVLI): boolean; {$ifdef HASINLINE}inline;{$endif} begin result := (Left[0]=Right[0]) and (Left[1]=Right[1]) and (Left[2]=Right[2]) and @@ -3242,6 +3250,35 @@ begin result := Base64ToBin(pointer(base64),@content,length(base64),sizeof(content),false); end; +const + DER_SEQUENCE = $30; + DER_INTEGER = #$02; + +function DerAppend(P: PAnsiChar; vli: PByteArray): PAnsiChar; +var pos, prefix: PtrUInt; +begin + pos := 0; + while vli[pos] = 0 do inc(pos); // ignore trailing zeros + prefix := vli[pos] shr 7; // two's complement? + P[0] := DER_INTEGER; + P[1] := AnsiChar(ECC_BYTES - pos + prefix); + P[2] := #$00; // prepend 0 for negative number (if prefix=1) + inc(P, 2 + prefix); + MoveSmall(@vli[pos], P, ECC_BYTES - pos); + result := P + ECC_BYTES - pos; +end; + +function EccSignToDer(const sign: TEccSignature; out der: TEccSignatureDer): integer; +begin + if _isZero(PVLI(@sign[0])^) or _isZero(PVLI(@sign[ECC_BYTES])^) then + result := 0 + else begin + result := DerAppend(DerAppend(@der[2],@sign[0]),@sign[ECC_BYTES])-PAnsiChar(@der); + der[0] := DER_SEQUENCE; + der[1] := result - 2; + end; +end; + function ECCText(const sign: TECCSignatureCertifiedContent): RawUTF8; overload; begin if ECCCheck(sign) then @@ -4410,31 +4447,11 @@ begin end; function TECCSignatureCertified.SaveToDERBinary: RawByteString; -const DER_SEQUENCE = $30; - DER_INTEGER = $02; -var RPrefix,SPrefix: integer; - P: PByteArray; +var der: TEccSignatureDer; begin - if not Check then begin - result := ''; - exit; - end; - RPrefix := fContent.Signature[0] shr 7; // DER_INTEGER are two's complement - SPrefix := fContent.Signature[ECC_BYTES] shr 7; - SetLength(result,RPrefix+SPrefix+(ECC_BYTES*2+6)); - P := pointer(result); - P[0] := DER_SEQUENCE; - P[1] := RPrefix+SPrefix+(ECC_BYTES*2+4); - P[2] := DER_INTEGER; - P[3] := ECC_BYTES+RPrefix; - P[4] := $00; // prepend 0 for negative number (if RPrefix=1) - inc(PByte(P),4+RPrefix); - MoveFast(fContent.Signature[0],P[0],ECC_BYTES); - inc(PByte(P),ECC_BYTES); - P[0] := DER_INTEGER; - P[1] := ECC_BYTES+SPrefix; - P[2] := $00; - MoveFast(fContent.Signature[ECC_BYTES],P[2+SPrefix],ECC_BYTES); + if not Check then + result := '' else + SetString(result,PAnsiChar(@der),EccSignToDer(fContent.Signature,der)); end; function TECCSignatureCertified.SaveToDERFile( @@ -5060,7 +5077,7 @@ begin exit; // mandatory parameter sw.ValueEnum('k',TypeInfo(TECDHEKDF),algo.kdf); sw.ValueEnum('e',TypeInfo(TECDHEEF),algo.ef); - sw.ValueEnum('m',TypeInfo(TECDHEEF),algo.mac); + sw.ValueEnum('m',TypeInfo(TECDHEMAC),algo.mac); // compute ca: TECCCertificateChain ca := nil; c := sw.Str['ca']; diff --git a/contrib/mORMot/SynEcc32asm.inc b/contrib/mORMot/SynEcc32asm.inc index a00fd27..7734710 100644 --- a/contrib/mORMot/SynEcc32asm.inc +++ b/contrib/mORMot/SynEcc32asm.inc @@ -6,7 +6,7 @@ This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info Using secp256r1 curve from "simple and secure ECDH and ECDSA library" diff --git a/contrib/mORMot/SynFPCCMemAligned.pas b/contrib/mORMot/SynFPCCMemAligned.pas index 50fd88d..dd684c4 100644 --- a/contrib/mORMot/SynFPCCMemAligned.pas +++ b/contrib/mORMot/SynFPCCMemAligned.pas @@ -10,7 +10,7 @@ unit SynFPCCMemAligned; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -29,7 +29,7 @@ unit SynFPCCMemAligned; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynFPCLinux.pas b/contrib/mORMot/SynFPCLinux.pas index ef1263b..b6b8671 100644 --- a/contrib/mORMot/SynFPCLinux.pas +++ b/contrib/mORMot/SynFPCLinux.pas @@ -6,7 +6,7 @@ unit SynFPCLinux; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynFPCLinux; The Initial Developer of the Original Code is Alfred Glaenzer. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -61,6 +61,7 @@ interface uses {$ifdef LINUX} + BaseUnix, UnixType, {$endif LINUX} SysUtils; @@ -119,10 +120,26 @@ function GetLastError: longint; inline; procedure SetLastError(error: longint); inline; /// compatibility function, wrapping Win32 API text comparison -// - somewhat slow by using two temporary UnicodeString - but seldom called, -// unless our proprietary WIN32CASE collation is used in SynSQLite3 -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar; - cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint; +// - 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 @@ -222,7 +239,8 @@ function UnixKeyPending: boolean; type /// the libraries supported by TExternalLibrariesAPI - TExternalLibrary = (elPThread {$ifdef LINUXNOTBSD} , elSystemD {$endif}); + TExternalLibrary = ( + elPThread, elICU {$ifdef LINUXNOTBSD} , elSystemD {$endif}); /// set of libraries supported by TExternalLibrariesAPI TExternalLibraries = set of TExternalLibrary; @@ -240,6 +258,8 @@ type systemd: pointer; {$endif LINUXNOTBSD} {$endif LINUX} + icu, icudata, icui18n: pointer; + procedure LoadIcuWithVersion; procedure Done; public {$ifdef LINUXNOTBSD} @@ -254,18 +274,63 @@ type 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: PUTF8Char): longint; cdecl; + 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); @@ -315,7 +380,6 @@ implementation uses Classes, Unix, - BaseUnix, {$ifdef BSD} sysctl, {$else} @@ -624,18 +688,140 @@ begin fpseterrno(error); end; -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar; - cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint; -var U1,U2: UnicodeString; // (may be?) faster than WideString -begin // not inlined to avoid try..finally UnicodeString protection - if cchCount1<0 then +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); - SetString(U1,lpString1,cchCount1); - if cchCount2<0 then + if cchCount2 < 0 then cchCount2 := StrLen(lpString2); - SetString(U2,lpString2,cchCount2); - result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(dwCmpFlags))+2; -end; // caller would make -2 to get regular -1/0/1 comparison values + 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; @@ -732,13 +918,108 @@ 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..4] of PAnsiChar = ( - 'sd_listen_fds', 'sd_is_socket_unix', 'sd_journal_print', + 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 @@ -759,6 +1040,34 @@ begin {$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 @@ -802,6 +1111,16 @@ begin 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); @@ -814,6 +1133,7 @@ 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 @@ -839,7 +1159,6 @@ begin if L = 0 then exit; trunc[L] := #0; - {$ifdef LINUXNOTBSD} ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]); {$endif LINUXNOTBSD} end; diff --git a/contrib/mORMot/SynFPCSock.pas b/contrib/mORMot/SynFPCSock.pas index 73a7596..6a3695f 100644 --- a/contrib/mORMot/SynFPCSock.pas +++ b/contrib/mORMot/SynFPCSock.pas @@ -6,7 +6,7 @@ unit SynFPCSock; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -27,7 +27,7 @@ unit SynFPCSock; Portions created by Lukas Gebauer are Copyright (C) 2003. All Rights Reserved. - Portions created by Arnaud Bouchez are Copyright (C) 2020 Arnaud Bouchez. + Portions created by Arnaud Bouchez are Copyright (C) 2022 Arnaud Bouchez. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynFPCTypInfo.pas b/contrib/mORMot/SynFPCTypInfo.pas index 1d3475c..42ab29a 100644 --- a/contrib/mORMot/SynFPCTypInfo.pas +++ b/contrib/mORMot/SynFPCTypInfo.pas @@ -6,7 +6,7 @@ unit SynFPCTypInfo; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynFPCTypInfo; The Initial Developer of the Original Code is Alfred Glaenzer. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynFPCx64MM.pas b/contrib/mORMot/SynFPCx64MM.pas index b0b1f82..c2afc55 100644 --- a/contrib/mORMot/SynFPCx64MM.pas +++ b/contrib/mORMot/SynFPCx64MM.pas @@ -9,14 +9,8 @@ unit SynFPCx64MM; A Multi-thread Friendly Memory Manager for FPC written in x86_64 assembly - targetting Linux (and Windows) multi-threaded Services - only for FPC on the x86_64 target - use the RTL MM on Delphi or ARM - - based on FastMM4 proven algorithms by Pierre le Riche - - code has been reduced to the only necessary featureset for production - - deep asm refactoring for cross-platform, compactness and efficiency + - based on proven FastMM4 by Pierre le Riche - with tuning and enhancements - can report detailed statistics (with threads contention and memory leaks) - - mremap() makes large block ReallocMem a breeze on Linux :) - - inlined SSE2 movaps loop is more efficient that subfunction(s) - - lockless round-robin of tiny blocks (<=128/256 bytes) for better scaling - - optional lockless bin list to avoid freemem() thread contention - three app modes: default mono-thread friendly, FPCMM_SERVER or FPCMM_BOOST Usage: include this unit as the very first in your FPC project uses clause @@ -28,17 +22,18 @@ unit SynFPCx64MM; - C memory managers (glibc, Intel TBB, jemalloc) have a very high RAM consumption (especially Intel TBB) and do panic/SIGKILL on any GPF - Pascal alternatives (FastMM4,ScaleMM2,BrainMM) are Windows+Delphi specific - - Our lockess round-robin of tiny blocks is a unique algorithm in MM AFAIK + - Our lockess round-robin of tiny blocks and freemem bin list are unique + algorithms among Memory Managers, and match modern CPUs and workloads - It was so fun diving into SSE2 x86_64 assembly and Pierre's insight - Resulting code is still easy to understand and maintain - IMPORTANT NOTICE: seems stable on Linux and Win64 but feedback is welcome! + DISCLAMER: seems stable on Linux and Win64 but feedback is welcome! ***************************************************************************** This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -57,7 +52,7 @@ unit SynFPCx64MM; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -80,21 +75,27 @@ unit SynFPCx64MM; { ---- Ready-To-Use Scenarios for Memory Manager Tuning } -// by default, we target LCL/console mono-threaded apps to replace the RTL MM -// - you may define FPCMM_SERVER or even FPCMM_BOOST for a service/daemon +{ + TL;DR: + 1. default settings target LCL/console mono-threaded apps; + 2. define FPCMM_SERVER for a multi-threaded service/daemon. +} -// if defined, set FPCMM_DEBUG and FPCMM_ASSUMEMULTITHREAD -// - those flags target well a multi-threaded service -// - consider FPCMM_BOOST to try more aggressive settings +// target a multi-threaded service on a modern CPU +// - define FPCMM_DEBUG, FPCMM_ASSUMEMULTITHREAD, FPCMM_ERMS, FPCMM_LOCKLESSFREE +// - currently mormot2tests run with no sleep when FPCMM_SERVER is set :) +// - you may try to define FPCMM_BOOST for even more aggressive settings. {.$define FPCMM_SERVER} -// if defined, tiny blocks <= 256 bytes will have a bigger round-robin cycle +// increase settings for very aggressive multi-threaded process // - try to enable it if unexpected SmallGetmemSleepCount/SmallFreememSleepCount -// and SleepCount/SleepCycles contentions are reported by CurrentHeapStatus -// - will also use 2x (FPCMM_BOOST) or 4x (FPCMM_BOOSTER) more tiny blocks -// arenas to share among the threads - so process will consume slightly more RAM -// - warning: depending on the workload and hardware, it may actually be slower; -// consider FPCMM_SERVER as a fair alternative +// and SleepCount/SleepCycles contentions are reported by CurrentHeapStatus; +// - tiny blocks will be <= 256 bytes (instead of 128 bytes); +// - FPCMM_BOOSTER will use 2x more tiny blocks arenas - likely to be wasteful; +// - will enable FPCMM_SMALLNOTWITHMEDIUM trying to reduce medium sleeps; +// - warning: depending on the workload and hardware, it may actually be slower, +// triggering more Meidum arena contention, and consuming more RAM: consider +// FPCMM_SERVER as a fair alternative. {.$define FPCMM_BOOST} {.$define FPCMM_BOOSTER} @@ -104,6 +105,15 @@ unit SynFPCx64MM; // includes more detailed information to WriteHeapStatus() {.$define FPCMM_DEBUG} +// on thread contention, don't spin executing "pause" but directly call Sleep() +// - may help on a single core CPU, or for very specific workloads +{.$define FPCMM_NOPAUSE} + +// let FPCMM_DEBUG include SleepCycles information from rdtsc +// and FPCMM_PAUSE call rdtsc for its spinnning loop +// - since rdtsc is emulated so unrealiable on VM, it is disabled by default +{.$define FPCMM_SLEEPTSC} + // checks leaks and write them to the console at process shutdown // - only basic information will be included: more debugging information (e.g. // call stack) may be gathered using heaptrc or valgrid @@ -117,34 +127,40 @@ unit SynFPCx64MM; // let Freemem multi-thread contention use a lockless algorithm // - on contention, Freemem won't yield the thread using an OS call, but fill // an internal Bin list which will be released when the lock becomes available -// - from our tests on high thread contention, this may be slower on Linux, but -// sometimes slightly faster on Win64 (in a VM at least) +// - beneficial from our tests on high thread contention (HTTP/REST server) {.$define FPCMM_LOCKLESSFREE} -// won't use mremap but a regular getmem/move/freemem pattern +// won't use mremap but a regular getmem/move/freemem pattern for large blocks // - depending on the actual system (e.g. on a VM), mremap may be slower +// - will disable Linux mremap() or Windows following block VirtualQuery/Alloc {.$define FPCMM_NOMREMAP} -// on contention problem, execute "pause" opcode and spin retrying the lock -// - you may try to define this if you have more than one core, to follow Intel -// recommendation from https://software.intel.com/en-us/comment/1134767 -// - on SkylakeX (Intel 7th gen), "pause" opcode went from 10-20 to 140 cycles, -// so we use rdtsc and a given number of cycles - see http://tiny.cc/toeaqz -// - from our tests on high thread contention, spinning is slower on both -// Linux and Windows, whatever Intel is advising -{.$define FPCMM_PAUSE} +// force the tiny/small blocks to be in their own arena, not with medium blocks +// - would use a little more memory, but medium pool is less likely to sleep +// - not defined for FPCMM_SERVER because no performance difference was found +{.$define FPCMM_SMALLNOTWITHMEDIUM} + +// use "rep movsb/stosd" ERMS for blocks > 256 bytes instead of SSE2 "movaps" +// - ERMS is available since Ivy Bridge, and we use "movaps" for smallest blocks +// (to not slow down older CPUs), so it is safe to enable this on FPCMM_SERVER +{.$define FPCMM_ERMS} + +// try "cmp" before "lock cmpxchg" for old processors with huge lock penalty +{.$define FPCMM_CMPBEFORELOCK} // will export libc-like functions, and not replace the FPC MM // - e.g. to use this unit as a stand-alone C memory allocator {.$define FPCMM_STANDALONE} +// this whole unit will compile as void +// - may be defined e.g. when compiled as Design-Time Lazarus package +{.$define FPCMM_DISABLE} interface {$ifdef FPC} // cut-down version of Synopse.inc to make this unit standalone {$mode Delphi} - {$asmmode Intel} {$inline on} {$R-} // disable Range checking {$S-} // disable Stack checking @@ -152,25 +168,35 @@ interface {$Q-} // disable overflow checking {$B-} // expect short circuit boolean {$ifdef CPUX64} - {$define FPC_CPUX64} // this unit is for FPC + x86_64 only + {$define FPCX64MM} // this unit is for FPC + x86_64 only + {$asmmode Intel} {$endif CPUX64} {$ifdef FPCMM_BOOSTER} {$define FPCMM_BOOST} - {$undef FPCMM_DEBUG} // when performance matters more than stats {$endif FPCMM_BOOSTER} {$ifdef FPCMM_BOOST} - {$undef FPCMM_SERVER} - {$define FPCMM_ASSUMEMULTITHREAD} + {$define FPCMM_SERVER} + {$define FPCMM_SMALLNOTWITHMEDIUM} {$endif FPCMM_BOOST} {$ifdef FPCMM_SERVER} {$define FPCMM_DEBUG} {$define FPCMM_ASSUMEMULTITHREAD} + {$define FPCMM_LOCKLESSFREE} + {$define FPCMM_ERMS} {$endif FPCMM_SERVER} + {$ifdef FPCMM_BOOSTER} + {$undef FPCMM_DEBUG} // when performance matters more than stats + {$endif FPCMM_BOOSTER} {$endif FPC} +{$ifdef FPCMM_DISABLE} + {$undef FPCX64MM} // e.g. when compiled as Design-Time Lazarus package +{$endif FPCMM_DISABLE} -{$ifdef FPC_CPUX64} + +{$ifdef FPCX64MM} // this unit is available only for FPC + X86_64 CPU +// other targets would compile as a void unit type /// Arena (middle/large) heap information as returned by CurrentHeapStatus @@ -193,32 +219,41 @@ type /// heap information as returned by CurrentHeapStatus TMMStatus = record - /// how many tiny/small memory blocks (<=2600) are currently allocated + /// how many tiny/small memory blocks (<=2600 bytes) are currently allocated SmallBlocks: PtrUInt; /// how many bytes of tiny/small memory blocks are currently allocated - // - this size is part of the Medium.CurrentBytes arena + // - this size is included in Medium.CurrentBytes value, even if + // FPCMM_SMALLNOTWITHMEDIUM has been defined SmallBlocksSize: PtrUInt; - /// contain blocks up to 256KB (small and medium blocks) + /// information about blocks up to 256KB (tiny, small and medium) + // - includes also the memory needed for tiny/small blocks Medium: TMMStatusArena; - /// large blocks > 256KB which are directly handled by the Operating System + /// information about large blocks > 256KB + // - those blocks are directly handled by the Operating System Large: TMMStatusArena; {$ifdef FPCMM_DEBUG} + {$ifdef FPCMM_SLEEPTSC} /// how much rdtsc cycles were spent within SwitchToThread/NanoSleep API - // - we rdtsc since it is an indicative but very fast way of timing + // - we rdtsc since it is an indicative but very fast way of timing on + // direct hardware + // - warning: on virtual machines, the rdtsc opcode is usually emulated so + // these SleepCycles number are non indicative anymore SleepCycles: PtrUInt; + {$endif FPCMM_SLEEPTSC} {$ifdef FPCMM_LOCKLESSFREE} - /// how many types Freemem() did spin to acquire its lock-less bin list + /// how many times Freemem() did spin to acquire its lock-less bin list SmallFreememLockLessSpin: PtrUInt; {$endif FPCMM_LOCKLESSFREE} {$endif FPCMM_DEBUG} /// how many times the Operating System Sleep/NanoSleep API was called - // - in a perfect world, should be as small as possible + // - in a perfect world, should be as small as possible: mormot2tests run as + // SleepCount=0 when FPCMM_LOCKLESSFREE is defined (FPCMM_SERVER default) SleepCount: PtrUInt; - /// how many times Getmem() did block and wait for a small block - // - see also GetSmallBlockContention() + /// how many times Getmem() did block and wait for a tiny/small block + // - see also GetSmallBlockContention() for more detailed information SmallGetmemSleepCount: PtrUInt; - /// how many times Freemem() did block and wait for a small block - // - see also GetSmallBlockContention() + /// how many times Freemem() did block and wait for a tiny/small block + // - see also GetSmallBlockContention() for more detailed information SmallFreememSleepCount: PtrUInt; end; PMMStatus = ^TMMStatus; @@ -246,6 +281,14 @@ function _MemSize(P: pointer): PtrUInt; inline; /// retrieve high-level statistics about the current memory manager state // - see also GetSmallBlockContention for detailed small blocks information +// - standard GetHeapStatus and GetFPCHeapStatus gives less accurate information +// (only CurrHeapSize and MaxHeapSize are set), since we don't track "free" heap +// bytes: I can't figure how "free" memory is relevant nowadays - on 21th century +// Operating Systems, memory is virtual, and reserved/mapped by the OS but +// physically hosted in the HW RAM chips only when written the first time - +// GetHeapStatus information made sense on MSDOS with fixed 640KB of RAM +// - note that FPC GetHeapStatus and GetFPCHeapStatus is only about the +// current thread (irrelevant for sure) whereas CurrentHeapStatus is global function CurrentHeapStatus: TMMStatus; @@ -300,12 +343,13 @@ type /// retrieve the use counts of allocated small blocks // - returns maxcount biggest results, sorted by "orderby" field occurence function GetSmallBlockStatus(maxcount: integer = 10; - orderby: TSmallBlockOrderBy = obTotal; count: PPtrUInt = nil; - bytes: PPtrUInt = nil): TSmallBlockStatusDynArray; + orderby: TSmallBlockOrderBy = obTotal; count: PPtrUInt = nil; bytes: PPtrUInt = nil; + small: PCardinal = nil; tiny: PCardinal = nil): TSmallBlockStatusDynArray; /// retrieve all small blocks which suffered from blocking during multi-thread // - returns maxcount biggest results, sorted by SleepCount occurence -function GetSmallBlockContention(maxcount: integer = 10): TSmallBlockContentionDynArray; +function GetSmallBlockContention( + maxcount: integer = 10): TSmallBlockContentionDynArray; /// convenient debugging function into the console @@ -315,68 +359,136 @@ procedure WriteHeapStatus(const context: shortstring = ''; smallblockstatuscount: integer = 8; smallblockcontentioncount: integer = 8; compilationflags: boolean = false); +/// convenient debugging function into a string +// - if smallblockcontentioncount > 0, includes GetSmallBlockContention() info +// up to the smallblockcontentioncount biggest occurences +// - warning: this function is not thread-safe +function GetHeapStatus(const context: shortstring; smallblockstatuscount, + smallblockcontentioncount: integer; compilationflags, onsameline: boolean): string; + + +const + /// human readable information about how our MM was built + // - similar to WriteHeapStatus(compilationflags=true) output + FPCMM_FLAGS = ' ' + {$ifdef FPCMM_BOOSTER} + 'BOOSTER ' {$else} + {$ifdef FPCMM_BOOST} + 'BOOST ' {$else} + {$ifdef FPCMM_SERVER} + 'SERVER ' {$endif} + {$endif} + {$endif} + {$ifdef FPCMM_ASSUMEMULTITHREAD} + ' assumulthrd' {$endif} + {$ifdef FPCMM_LOCKLESSFREE} + ' lockless' {$endif} + {$ifdef FPCMM_PAUSE} + ' pause' {$endif} + {$ifdef FPCMM_SLEEPTSC} + ' rdtsc' {$endif} + {$ifndef BSD} + {$ifdef FPCMM_NOMREMAP} + ' nomremap' {$endif} + {$endif BSD} + {$ifdef FPCMM_SMALLNOTWITHMEDIUM}+ ' smallpool' {$endif} + {$ifdef FPCMM_ERMS} + ' erms' {$endif} + {$ifdef FPCMM_DEBUG} + ' debug' {$endif} + {$ifdef FPCMM_REPORTMEMORYLEAKS} + ' repmemleak' {$endif}; + {$endif FPCMM_STANDALONE} -{$endif FPC_CPUX64} +{$endif FPCX64MM} implementation { - High-level Algorithms Description - ----------------------------------- + High-level Allocation Strategy Description + -------------------------------------------- The allocator handles the following families of memory blocks: - - TINY <= 128 B (or <= 256 B for FPCMM_BOOST) - not existing in FastMM4 - Round-robin distribution into several arenas, fed from medium blocks + - TINY <= 128 B (<= 256 B for FPCMM_BOOST) + Round-robin distribution into several arenas, fed from shared tiny/small pool (fair scaling from multi-threaded calls, with no threadvar nor GC involved) - - SMALL <= 2600 B - Single arena per block size, fed from medium blocks + - SMALL <= 2600 B + One arena per block size, fed from shared tiny/small pool - MEDIUM <= 256 KB - Pool of bitmap-marked chunks, fed from 1MB of OS mmap/virtualalloc + Separated pool of bitmap-marked chunks, fed from 1MB of OS mmap/virtualalloc - LARGE > 256 KB Directly fed from OS mmap/virtualalloc with mremap when growing + The original FastMM4 was enhanced as such, especially in FPCMM_SERVER mode: + - FPC compatibility, even on POSIX/Linux, also for FPC specific API behavior; + - x86_64 code was refactored and tuned in regard to 2020's hardware; + - Inlined SSE2 movaps loop or ERMS are more efficient that subfunction(s); + - New round-robin thread-friendly arenas of tiny blocks; + - Tiny and small blocks can fed from their own pool, not the medium pool; + - Additional bin list to reduce small/tiny Freemem() thread contention; + - Memory leaks and thread sleep tracked with almost no performance loss; + - Large blocks logic has been rewritten, especially realloc; + - On Linux, mremap is used for efficient realloc of large blocks. + About locking: - - Tiny and Small blocks have their own per-size lock, in every arena - - Medium and Large blocks have one giant lock each (seldom used) - - SwitchToThread/FpNanoSleep OS call is done after initial spinning - - FPCMM_LOCKLESSFREE reduces OS calls on Freemem() thread contention - - FPCMM_DEBUG / WriteHeapStatus allows to identify the lock contention + - Tiny and Small blocks have their own per-size lock; + - Tiny and Small blocks have one giant lock when fedding from their pool; + - Medium blocks have one giant lock over their own pool; + - Large blocks have one giant lock over mmap/virtualalloc system calls; + - SwitchToThread/FpNanoSleep OS call is done after initial spinning; + - FPCMM_LOCKLESSFREE reduces Freemem() thread contention; + - FPCMM_DEBUG / WriteHeapStatus helps identifying the lock contention(s). } -{$ifdef FPC_CPUX64} +{$ifdef FPCX64MM} // this unit is available only for FPC + X86_64 CPU +{$ifndef FPCMM_NOPAUSE} + // on contention problem, execute "pause" opcode and spin retrying the lock + // - defined by default to follow Intel recommendatations from + // https://software.intel.com/content/www/us/en/develop/articles/benefitting-power-and-performance-sleep-loops.html + // - spinning loop is either using constants or rdtsc (if FPCMM_SLEEPTSC is set) + // - on SkylakeX (Intel 7th gen), "pause" opcode went from 10-20 to 140 cycles + // so our constants below will favor those latest CPUs with a longer pause + {$define FPCMM_PAUSE} +{$endif FPCMM_NOPAUSE} + { ********* Operating System Specific API Calls } {$ifdef MSWINDOWS} -var - HeapStatus: TMMStatus; +// Win64: any assembler function with sub-calls should have a stack frame +// -> nostackframe is defined only on Linux or for functions with no nested call +{$undef NOSFRAME} const kernel32 = 'kernel32.dll'; - MEM_COMMIT = $1000; + MEM_COMMIT = $1000; MEM_RESERVE = $2000; - MEM_RELEASE = $8000; - MEM_FREE = $10000; + MEM_RELEASE = $8000; + MEM_FREE = $10000; MEM_TOP_DOWN = $100000; PAGE_READWRITE = 4; + PAGE_GUARD = $0100; + PAGE_VALID = $00e6; // PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or + // PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY + +type + // VirtualQuery() API result structure + TMemInfo = record + BaseAddress, AllocationBase: pointer; + AllocationProtect: cardinal; + PartitionId: word; + RegionSize: PtrUInt; + State, Protect, MemType: cardinal; + end; function VirtualAlloc(lpAddress: pointer; - dwSize: PtrUInt; flAllocationType, flProtect: Cardinal): pointer; stdcall; - external kernel32 name 'VirtualAlloc'; + dwSize: PtrUInt; flAllocationType, flProtect: cardinal): pointer; + stdcall; external kernel32 name 'VirtualAlloc'; function VirtualFree(lpAddress: pointer; dwSize: PtrUInt; - dwFreeType: Cardinal): LongBool; stdcall; - external kernel32 name 'VirtualFree'; -procedure SwitchToThread; stdcall; - external kernel32 name 'SwitchToThread'; + dwFreeType: cardinal): LongBool; + stdcall; external kernel32 name 'VirtualFree'; +procedure SwitchToThread; + stdcall; external kernel32 name 'SwitchToThread'; +function VirtualQuery(lpAddress, lpMemInfo: pointer; dwLength: PtrUInt): PtrUInt; + stdcall; external kernel32 name 'VirtualQuery'; function AllocMedium(Size: PtrInt): pointer; inline; begin @@ -386,16 +498,54 @@ end; function AllocLarge(Size: PtrInt): pointer; inline; begin - // top-down allocation to reduce fragmentation + // top-down allocation of large blocks to reduce fragmentation + // (MEM_TOP_DOWN is not available on POSIX, but seems less needed) result := VirtualAlloc(nil, Size, MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE); end; -procedure Free(ptr: pointer; Size: PtrInt); inline; +procedure FreeMediumLarge(ptr: pointer; Size: PtrInt); inline; begin VirtualFree(ptr, 0, MEM_RELEASE); end; -{$define FPCMM_NOMREMAP} +{$ifndef FPCMM_NOMREMAP} + +function RemapLarge(addr: pointer; old_len, new_len: size_t): pointer; +var + meminfo: TMemInfo; + next: pointer; + nextsize: PtrUInt; +begin + // old_len and new_len have 64KB granularity, so match Windows page size + nextsize := new_len - old_len; + if PtrInt(nextsize) > 0 then + begin + // try to allocate the memory just after the existing one + FillChar(meminfo, SizeOf(meminfo), 0); + next := addr + old_len; + if (VirtualQuery(next, @meminfo, SizeOf(meminfo)) = SizeOf(meminfo)) and + (meminfo.State = MEM_FREE) and + (meminfo.RegionSize >= nextsize) and // enough space? + // reserve the address space in two steps for thread safety + (VirtualAlloc(next, nextsize, MEM_RESERVE, PAGE_READWRITE) <> nil) and + (VirtualAlloc(next, nextsize, MEM_COMMIT, PAGE_READWRITE) <> nil) then + begin + result := addr; // in-place realloc: no need to move memory :) + exit; + end; + end; + // we need to use the slower but safe Alloc/Move/Free pattern + result := AllocLarge(new_len); + if new_len > old_len then + new_len := old_len; // handle size up or down + Move(addr^, result^, new_len); // RTL non-volatile asm or our AVX MoveFast() + FreeMediumLarge(addr, old_len); +end; + +{$endif FPCMM_NOMREMAP} + +// experimental VirtualQuery detection of object class - use at your own risk +{$define FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} {$else} @@ -405,10 +555,17 @@ uses {$endif DARWIN} BaseUnix; -var - HeapStatus: TMMStatus; +// in practice, SYSV ABI seems to not require a stack frame, as Win64 does, for +// our use case of nested calls with no local stack storage and direct kernel +// syscalls - but since it is clearly undocumented, we set it on LINUX only +// -> appears to work with no problem from our tests: feedback is welcome! +// -> see FPCMM_NOSFRAME conditional to disable it on LINUX +{$ifdef LINUX} + {$define NOSFRAME} +{$endif LINUX} -// we directly call the Kernel, so this unit doesn't require any libc + +// we directly call the OS Kernel, so this unit doesn't require any libc function AllocMedium(Size: PtrInt): pointer; inline; begin @@ -418,14 +575,12 @@ end; function AllocLarge(Size: PtrInt): pointer; inline; begin - result := fpmmap(nil, Size, PROT_READ or PROT_WRITE, - MAP_PRIVATE or MAP_ANONYMOUS, -1, 0); + result := AllocMedium(size); // same API (no MEM_TOP_DOWN option) end; -procedure Free(ptr: pointer; Size: PtrInt); inline; +procedure FreeMediumLarge(ptr: pointer; Size: PtrInt); inline; begin - Size := fpmunmap(ptr, Size); - // assert(Size = 0); + fpmunmap(ptr, Size); end; {$ifdef LINUX} @@ -436,21 +591,26 @@ const syscall_nr_mremap = 25; // valid on x86_64 Linux and Android MREMAP_MAYMOVE = 1; -function fpmremap(addr: pointer; old_len, new_len: size_t; may_move: longint): pointer; inline; +function RemapLarge(addr: pointer; old_len, new_len: size_t): pointer; inline; begin + // let the Linux Kernel mremap() the memory using its TLB magic result := pointer(do_syscall(syscall_nr_mremap, TSysParam(addr), - TSysParam(old_len), TSysParam(new_len), TSysParam(may_move))); + TSysParam(old_len), TSysParam(new_len), TSysParam(MREMAP_MAYMOVE))); end; {$endif FPCMM_NOMREMAP} -{$else BSD} +// experimental detection of object class - use at your own risk +{$define FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} +// (untested on BSD/DARWIN) + +{$else} {$define FPCMM_NOMREMAP} // mremap is a Linux-specific syscall {$endif LINUX} -procedure SwitchToThread; inline; +procedure SwitchToThread; var t: Ttimespec; begin @@ -462,11 +622,38 @@ end; {$endif MSWINDOWS} +// fallback to safe and simple Alloc/Move/Free pattern +{$ifdef FPCMM_NOMREMAP} + +function RemapLarge(addr: pointer; old_len, new_len: size_t): pointer; +begin + result := AllocLarge(new_len); + if new_len > old_len then + new_len := old_len; // resize down + Move(addr^, result^, new_len); // RTL non-volatile asm or our AVX MoveFast() + FreeMediumLarge(addr, old_len); +end; + +{$endif FPCMM_NOMREMAP} + + +{ ********* Some Assembly Helpers } + +// low-level conditional to disable nostackframe code on Linux +{$ifdef FPCMM_NOSFRAME} + {$undef NOSFRAME} +{$endif FPCMM_NOSFRAME} + +var + HeapStatus: TMMStatus; + {$ifdef FPCMM_DEBUG} -procedure ReleaseCore; nostackframe; assembler; +procedure ReleaseCore; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm - rdtsc + {$ifdef FPCMM_SLEEPTSC} + rdtsc // returns the TSC in EDX:EAX shl rdx, 32 or rax, rdx push rax @@ -477,8 +664,12 @@ asm or rax, rdx lea rdx, [rip + HeapStatus] sub rax, rcx - lock xadd qword ptr [rdx + TMMStatus.SleepCycles], rax - lock inc qword ptr [rdx + TMMStatus.SleepCount] + lock add qword ptr [rdx + TMMStatus.SleepCycles], rax + {$else} + call SwitchToThread + lea rdx, [rip + HeapStatus] + {$endif FPCMM_SLEEPTSC} + lock inc qword ptr [rdx + TMMStatus.SleepCount] end; {$else} @@ -491,79 +682,63 @@ end; {$endif FPCMM_DEBUG} - -{ ********* Some Assembly Helpers } - -procedure NotifyAlloc(var Arena: TMMStatusArena; Size: PtrUInt); +procedure NotifyArenaAlloc(var Arena: TMMStatusArena; Size: PtrUInt); nostackframe; assembler; asm - mov rax, Size - lock xadd qword ptr [Arena].TMMStatusArena.CurrentBytes, rax - lock xadd qword ptr [Arena].TMMStatusArena.CumulativeBytes, Size {$ifdef FPCMM_DEBUG} - lock inc qword ptr [Arena].TMMStatusArena.CumulativeAlloc + lock add qword ptr [Arena].TMMStatusArena.CurrentBytes, Size + lock add qword ptr [Arena].TMMStatusArena.CumulativeBytes, Size + lock inc qword ptr [Arena].TMMStatusArena.CumulativeAlloc mov rax, qword ptr [Arena].TMMStatusArena.CurrentBytes cmp rax, qword ptr [Arena].TMMStatusArena.PeakBytes jbe @s mov qword ptr [Arena].TMMStatusArena.PeakBytes, rax -@s: {$endif FPCMM_DEBUG} +@s: {$else} + add qword ptr [Arena].TMMStatusArena.CurrentBytes, Size + add qword ptr [Arena].TMMStatusArena.CumulativeBytes, Size + {$endif FPCMM_DEBUG} end; -procedure NotifyFree(var Arena: TMMStatusArena; Size: PtrUInt); +procedure NotifyMediumLargeFree(var Arena: TMMStatusArena; Size: PtrUInt); nostackframe; assembler; asm neg Size - lock xadd qword ptr [Arena].TMMStatusArena.CurrentBytes, Size {$ifdef FPCMM_DEBUG} - lock inc qword ptr [Arena].TMMStatusArena.CumulativeFree + lock add qword ptr [Arena].TMMStatusArena.CurrentBytes, Size + lock inc qword ptr [Arena].TMMStatusArena.CumulativeFree + {$else} + add qword ptr [Arena].TMMStatusArena.CurrentBytes, Size {$endif FPCMM_DEBUG} end; -// faster than Move() as called from ReallocateLargeBlock -procedure MoveLarge(src, dst: pointer; cnt: PtrInt); nostackframe; assembler; -asm - sub cnt, 8 - add src, cnt - add dst, cnt - neg cnt - jns @z - align 16 -@s: movaps xmm0, oword ptr [src + cnt] // AVX move is not really faster - movntdq oword ptr [dst + cnt], xmm0 // non-temporal loop - add cnt, 16 - js @s - sfence -@z: mov rax, qword ptr [src + cnt] - mov qword ptr [dst + cnt], rax -end; - - { ********* Constants and Data Structures Definitions } const - {$ifdef FPCMM_BOOST} // someimtes the more arenas, the better multi-threadable + // (sometimes) the more arenas, the better multi-threadable {$ifdef FPCMM_BOOSTER} - NumTinyBlockTypesPO2 = 4; - NumTinyBlockArenasPO2 = 5; // will probably end up with Medium lock contention + NumTinyBlockTypesPO2 = 4; + NumTinyBlockArenasPO2 = 4; // will probably end up with Medium lock contention {$else} - NumTinyBlockTypesPO2 = 4; // tiny are <= 256 bytes - NumTinyBlockArenasPO2 = 4; // 16 + 1 arenas + {$ifdef FPCMM_BOOST} + NumTinyBlockTypesPO2 = 4; // tiny are <= 256 bytes + NumTinyBlockArenasPO2 = 3; // 8 arenas + {$else} + // default (or FPCMM_SERVER) settings + NumTinyBlockTypesPO2 = 3; // multiple arenas for tiny blocks <= 128 bytes + NumTinyBlockArenasPO2 = 3; // 8 round-robin arenas (including main) by default + {$endif FPCMM_BOOST} {$endif FPCMM_BOOSTER} - {$else} - NumTinyBlockTypesPO2 = 3; // multiple arenas for tiny blocks <= 128 bytes - NumTinyBlockArenasPO2 = 3; // 8 round-robin arenas + 1 main by default - {$endif FPCMM_BOOST} NumSmallBlockTypes = 46; MaximumSmallBlockSize = 2608; SmallBlockSizes: array[0..NumSmallBlockTypes - 1] of word = ( - 16, 32, 48, 64, 80, 96, 112, 128, 144, 160, 176, 192, 208, 224, 240, 256, - 272, 288, 304, 320, 352, 384, 416, 448, 480, 528, 576, 624, 672, 736, 800, - 880, 960, 1056, 1152, 1264, 1376, 1504, 1648, 1808, 1984, 2176, 2384, - MaximumSmallBlockSize, MaximumSmallBlockSize, MaximumSmallBlockSize); + 16, 32, 48, 64, 80, 96, 112, 128, 144, 160, 176, 192, 208, 224, 240, 256, + 272, 288, 304, 320, 352, 384, 416, 448, 480, 528, 576, 624, 672, 736, 800, + 880, 960, 1056, 1152, 1264, 1376, 1504, 1648, 1808, 1984, 2176, 2384, + MaximumSmallBlockSize, MaximumSmallBlockSize, MaximumSmallBlockSize); NumTinyBlockTypes = 1 shl NumTinyBlockTypesPO2; - NumTinyBlockArenas = 1 shl NumTinyBlockArenasPO2; + NumTinyBlockArenas = (1 shl NumTinyBlockArenasPO2) - 1; // -1 = main Small[] NumSmallInfoBlock = NumSmallBlockTypes + NumTinyBlockArenas * NumTinyBlockTypes; SmallBlockGranularity = 16; TargetSmallBlocksPerPool = 48; @@ -571,10 +746,10 @@ const SmallBlockDownsizeCheckAdder = 64; SmallBlockUpsizeAdder = 32; {$ifdef FPCMM_LOCKLESSFREE} - SmallBlockTypePO2 = 8; // SizeOf(TSmallBlockType)=256 - SmallBlockBinCount = (((1 shl SmallBlockTypePO2) - 64) div 8) - 1; + SmallBlockTypePO2 = 8; // SizeOf(TSmallBlockType)=256 with Bin list + SmallBlockBinCount = (((1 shl SmallBlockTypePO2) - 64) div 8) - 1; // =23 {$else} - SmallBlockTypePO2 = 6; + SmallBlockTypePO2 = 6; // SizeOf(TSmallBlockType)=64 {$endif FPCMM_LOCKLESSFREE} MediumBlockPoolSizeMem = 20 * 64 * 1024; @@ -593,7 +768,6 @@ const 64 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset; MaximumSmallBlockPoolSize = OptimalSmallBlockPoolSizeUpperLimit + MinimumMediumBlockSize; - LargeBlockGranularity = 65536; MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4; IsFreeBlockFlag = 1; @@ -607,29 +781,45 @@ const DropMediumAndLargeFlagsMask = -16; ExtractMediumAndLargeFlagsMask = 15; - // use pause before ReleaseCore API call when spinning locks - // pause is 140 cycles since SkylakeX - see http://tiny.cc/010ioz -> use rdtsc - // which has 30 cycles latency; ring3 to ring 0 transition is 1000 cycles + {$ifdef FPCMM_SLEEPTSC} + // pause using rdtsc (30 cycles latency on hardware but emulated on VM) + SpinMediumLockTSC = 10000; + SpinLargeLockTSC = 10000; {$ifdef FPCMM_PAUSE} SpinSmallGetmemLockTSC = 1000; SpinSmallFreememLockTSC = 1000; // _freemem has more collisions {$ifdef FPCMM_LOCKLESSFREE} SpinSmallFreememBinTSC = 2000; {$endif FPCMM_LOCKLESSFREE} - SpinMediumLockTSC = 2000; - SpinLargeLockTSC = 2000; - {$else} - SpinMediumLockTSC = 1000; // minimum spinning - SpinLargeLockTSC = 1000; {$endif FPCMM_PAUSE} + {$else} + // pause with constant spinning counts (empirical values from fastmm4-avx) + SpinMediumLockCount = 2500; + SpinLargeLockCount = 5000; + {$ifdef FPCMM_PAUSE} + SpinSmallGetmemLockCount = 500; + SpinSmallFreememLockCount = 500; + {$ifdef FPCMM_LOCKLESSFREE} + SpinFreememBinCount = 500; + {$endif FPCMM_LOCKLESSFREE} + {$endif FPCMM_PAUSE} + {$endif FPCMM_SLEEPTSC} + + {$ifdef FPCMM_ERMS} + // pre-ERMS expects at least 256 bytes, IvyBridge+ with ERMS is good from 64 + // see https://stackoverflow.com/a/43837564/458259 for explanations and timing + // -> "movaps" loop is used up to 256 bytes of data: good on all CPUs + // -> "movnt" Move/MoveFast is used for large blocks: always faster than ERMS + ErmsMinSize = 256; + {$endif FPCMM_ERMS} type PSmallBlockPoolHeader = ^TSmallBlockPoolHeader; // information for each small block size - 64/256 bytes long >= CPU cache line TSmallBlockType = record - BlockTypeLocked: boolean; - AllowedGroupsForBlockPoolBitmap: Byte; + Locked: boolean; + AllowedGroupsForBlockPoolBitmap: byte; BlockSize: Word; MinimumBlockPoolSize: Word; OptimalBlockPoolSize: Word; @@ -642,8 +832,8 @@ type FreememCount: cardinal; GetmemSleepCount: cardinal; FreememSleepCount: cardinal; - {$ifdef FPCMM_LOCKLESSFREE} // 192 optional bytes for FreeMem Bin - BinLocked: boolean; + {$ifdef FPCMM_LOCKLESSFREE} // 192 optional bytes for FreeMem Bin (= 13KB) + BinLocked: boolean; // dedicated lock for less contention BinCount: byte; BinSpinCount: cardinal; BinInstance: array[0.. SmallBlockBinCount - 1] of pointer; @@ -669,12 +859,12 @@ type BlockType: PSmallBlockType; {$ifdef CPU32} Padding32Bits: cardinal; - {$endif} + {$endif CPU32} NextPartiallyFreePool: PSmallBlockPoolHeader; PreviousPartiallyFreePool: PSmallBlockPoolHeader; FirstFreeBlock: pointer; - BlocksInUse: Cardinal; - SmallBlockPoolSignature: Cardinal; + BlocksInUse: cardinal; + SmallBlockPoolSignature: cardinal; FirstBlockPoolPointerAndFlags: PtrUInt; end; @@ -692,24 +882,44 @@ type NextFreeBlock: PMediumFreeBlock; end; + // medium locks occurs at getmem: freemem bin list got MaxCount=0 :( + {.$define FPCMM_LOCKLESSFREEMEDIUM} + +{$ifdef FPCMM_LOCKLESSFREEMEDIUM} +const + MediumBlockLocklessBinCount = 255; + +type + // used by TMediumBlockInfo to reduce thread pressure + TMediumLocklessBin = record + Locked: boolean; // dedicated lock for less contention + Count: byte; + MaxCount: byte; + Instance: array[0 .. MediumBlockLocklessBinCount - 1] of pointer; + end; +{$endif FPCMM_LOCKLESSFREEMEDIUM} + TMediumBlockInfo = record Locked: boolean; PoolsCircularList: TMediumBlockPoolHeader; LastSequentiallyFed: pointer; - SequentialFeedBytesLeft: Cardinal; - BinGroupBitmap: Cardinal; + SequentialFeedBytesLeft: cardinal; + BinGroupBitmap: cardinal; {$ifndef FPCMM_ASSUMEMULTITHREAD} IsMultiThreadPtr: PBoolean; // safe access to IsMultiThread global variable {$endif FPCMM_ASSUMEMULTITHREAD} - BinBitmaps: array[0..MediumBlockBinGroupCount - 1] of Cardinal; + BinBitmaps: array[0..MediumBlockBinGroupCount - 1] of cardinal; Bins: array[0..MediumBlockBinCount - 1] of TMediumFreeBlock; + {$ifdef FPCMM_LOCKLESSFREEMEDIUM} + LocklessBin: TMediumLocklessBin; + {$endif FPCMM_LOCKLESSFREEMEDIUM} end; PLargeBlockHeader = ^TLargeBlockHeader; TLargeBlockHeader = record PreviousLargeBlockHeader: PLargeBlockHeader; NextLargeBlockHeader: PLargeBlockHeader; - Reserved1: PtrUInt; + Reserved: PtrUInt; BlockSizeAndFlags: PtrUInt; end; @@ -718,10 +928,16 @@ const SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader); MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader); LargeBlockHeaderSize = SizeOf(TLargeBlockHeader); + LargeBlockGranularity = 65536; var SmallBlockInfo: TSmallBlockInfo; MediumBlockInfo: TMediumBlockInfo; + SmallMediumBlockInfo: TMediumBlockInfo + {$ifdef FPCMM_SMALLNOTWITHMEDIUM} ; + {$else} absolute MediumBlockInfo; + {$endif FPCMM_SMALLNOTWITHMEDIUM} + LargeBlocksLocked: boolean; LargeBlocksCircularList: TLargeBlockHeader; @@ -729,9 +945,16 @@ var { ********* Shared Routines } -procedure LockMediumBlocks; nostackframe; assembler; +{$define FPCMM_CMPBEFORELOCK_SPIN} +// during spinning, there is clearly thread contention: in this case, plain +// "cmp" before "lock cmpxchg" is mandatory to leverage the CPU cores + + +procedure LockMediumBlocks; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; +// on input/output: r10=TMediumBlockInfo asm - // on input/output: r10=MediumBlockInfo + {$ifdef FPCMM_SLEEPTSC} @s: rdtsc // tsc in edx:eax shl rdx, 32 lea r9, [rax + rdx + SpinMediumLockTSC] // r9 = endtsc @@ -741,14 +964,22 @@ asm or rax, rdx cmp rax, r9 ja @rc // timeout + {$else} +@s: mov edx, SpinMediumLockCount +@sp: pause + dec edx + jz @rc //timeout + {$endif FPCMM_SLEEPTSC} mov rcx, r10 mov eax, $100 + {$ifdef FPCMM_CMPBEFORELOCK_SPIN} cmp byte ptr [r10].TMediumBlockInfo.Locked, true je @sp + {$endif FPCMM_CMPBEFORELOCK_SPIN} lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah je @ok jmp @sp -@rc: push rsi // preserve POSIX ABI registers +@rc: push rsi // preserve POSIX and Win64 ABI registers push rdi push r10 push r11 @@ -758,14 +989,15 @@ asm pop rdi pop rsi lea rax, [rip + HeapStatus] - lock inc qword ptr [rax].TMMStatus.Medium.SleepCount + {$ifdef FPCMM_DEBUG} lock {$endif} + inc qword ptr [rax].TMMStatus.Medium.SleepCount jmp @s @ok: end; procedure InsertMediumBlockIntoBin; nostackframe; assembler; +// rcx=P edx=blocksize r10=TMediumBlockInfo - even on POSIX asm - // rcx=MediumFreeBlock edx=MediumBlockSize r10=MediumBlockInfo - even on POSIX mov rax, rcx // Get the bin number for this block size sub edx, MinimumMediumBlockSize @@ -806,7 +1038,7 @@ end; procedure RemoveMediumFreeBlock; nostackframe; assembler; asm - // rcx=MediumFreeBlock r10=MediumBlockInfo - even on POSIX + // rcx=MediumFreeBlock r10=TMediumBlockInfo - even on POSIX // Get the current previous and next blocks mov rdx, TMediumFreeBlock[rcx].PreviousFreeBlock mov rcx, TMediumFreeBlock[rcx].NextFreeBlock @@ -836,14 +1068,15 @@ asm @Done: end; -procedure BinMediumSequentialFeedRemainder; nostackframe; assembler; +procedure BinMediumSequentialFeedRemainder( + var Info: TMediumBlockInfo); nostackframe; assembler; asm - // r10=MediumBlockInfo - even on POSIX - mov eax, [r10 + TMediumBlockInfo.SequentialFeedBytesLeft] + mov r10, Info + mov eax, [Info + TMediumBlockInfo.SequentialFeedBytesLeft] test eax, eax jz @Done // Is the last fed sequentially block free? - mov rax, [r10 + TMediumBlockInfo.LastSequentiallyFed] + mov rax, [Info + TMediumBlockInfo.LastSequentiallyFed] test byte ptr [rax - BlockHeaderSize], IsFreeBlockFlag jnz @LastBlockFedIsFree // Set the "previous block is free" flag in the last block fed @@ -861,7 +1094,7 @@ asm cmp edx, MinimumMediumBlockSize jb @Done mov rcx, rax - call InsertMediumBlockIntoBin // rcx=APMediumFreeBlock, edx=AMediumBlockSize + jmp InsertMediumBlockIntoBin // rcx=APMediumFreeBlock, edx=AMediumBlockSize @Done: ret @LastBlockFedIsFree: // Drop the flags @@ -888,46 +1121,48 @@ end; procedure FreeMedium(ptr: PMediumBlockPoolHeader); begin - Free(ptr, MediumBlockPoolSizeMem); - NotifyFree(HeapStatus.Medium, MediumBlockPoolSizeMem); + FreeMediumLarge(ptr, MediumBlockPoolSizeMem); + NotifyMediumLargeFree(HeapStatus.Medium, MediumBlockPoolSizeMem); end; -function AllocNewSequentialFeedMediumPool(blocksize: Cardinal): pointer; +function AllocNewSequentialFeedMediumPool(BlockSize: cardinal; + var Info: TMediumBlockInfo): pointer; var old: PMediumBlockPoolHeader; new: pointer; begin - BinMediumSequentialFeedRemainder; + BinMediumSequentialFeedRemainder(Info); new := AllocMedium(MediumBlockPoolSizeMem); - with MediumblockInfo do if new <> nil then begin - old := PoolsCircularList.NextMediumBlockPoolHeader; - PMediumBlockPoolHeader(new).PreviousMediumBlockPoolHeader := @PoolsCircularList; - PoolsCircularList.NextMediumBlockPoolHeader := new; + old := Info.PoolsCircularList.NextMediumBlockPoolHeader; + PMediumBlockPoolHeader(new).PreviousMediumBlockPoolHeader := @Info.PoolsCircularList; + Info.PoolsCircularList.NextMediumBlockPoolHeader := new; PMediumBlockPoolHeader(new).NextMediumBlockPoolHeader := old; old.PreviousMediumBlockPoolHeader := new; PPtrUInt(PByte(new) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag; - SequentialFeedBytesLeft := - (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - blocksize; - result := pointer(PByte(new) + MediumBlockPoolSize - blocksize); - LastSequentiallyFed := result; - PPtrUInt(PByte(result) - BlockHeaderSize)^ := blocksize or IsMediumBlockFlag; - NotifyAlloc(HeapStatus.Medium, MediumBlockPoolSizeMem); + Info.SequentialFeedBytesLeft := + (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - BlockSize; + result := pointer(PByte(new) + MediumBlockPoolSize - BlockSize); + Info.LastSequentiallyFed := result; + PPtrUInt(PByte(result) - BlockHeaderSize)^ := BlockSize or IsMediumBlockFlag; + NotifyArenaAlloc(HeapStatus.Medium, MediumBlockPoolSizeMem); end else begin - SequentialFeedBytesLeft := 0; + Info.SequentialFeedBytesLeft := 0; result := nil; end; end; -procedure LockLargeBlocks; nostackframe; assembler; +procedure LockLargeBlocks; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm @s: mov eax, $100 lea rcx, [rip + LargeBlocksLocked] lock cmpxchg byte ptr [rcx], ah je @ok + {$ifdef FPCMM_SLEEPTSC} rdtsc shl rdx, 32 lea r9, [rax + rdx + SpinLargeLockTSC] // r9 = endtsc @@ -937,21 +1172,30 @@ asm or rax, rdx cmp rax, r9 ja @rc // timeout + {$else} + mov edx, SpinLargeLockCount +@sp: pause + dec edx + jz @rc // timeout + {$endif FPCMM_SLEEPTSC} mov eax, $100 - cmp byte ptr [rcx], ah // don't flush the CPU cache if Locked still true + {$ifdef FPCMM_CMPBEFORELOCK_SPIN} + cmp byte ptr [rcx], true je @sp + {$endif FPCMM_CMPBEFORELOCK_SPIN} lock cmpxchg byte ptr [rcx], ah je @ok jmp @sp @rc: call ReleaseCore lea rax, [rip + HeapStatus] - lock inc qword ptr [rax].TMMStatus.Large.SleepCount + {$ifdef FPCMM_DEBUG} lock {$endif} + inc qword ptr [rax].TMMStatus.Large.SleepCount jmp @s -@ok: +@ok: // reset the stack frame before ret end; function AllocateLargeBlockFrom(size: PtrUInt; - existing: pointer; oldsize: PtrUInt): pointer; + existing: pointer; oldsize: PtrUInt): pointer; var blocksize: PtrUInt; header, old: PLargeBlockHeader; @@ -961,16 +1205,12 @@ begin if existing = nil then header := AllocLarge(blocksize) else - {$ifdef FPCMM_NOMREMAP} - header := nil; // paranoid - {$else} - header := fpmremap(existing, oldsize, blocksize, MREMAP_MAYMOVE); - {$endif FPCMM_NOMREMAP} + header := RemapLarge(existing, oldsize, blocksize); if header <> nil then begin - NotifyAlloc(HeapStatus.Large, blocksize); + NotifyArenaAlloc(HeapStatus.Large, blocksize); if existing <> nil then - NotifyFree(HeapStatus.Large, oldsize); + NotifyMediumLargeFree(HeapStatus.Large, oldsize); header.BlockSizeAndFlags := blocksize or IsLargeBlockFlag; LockLargeBlocks; old := LargeBlocksCircularList.NextLargeBlockHeader; @@ -991,8 +1231,8 @@ end; procedure FreeLarge(ptr: PLargeBlockHeader; size: PtrUInt); begin - NotifyFree(HeapStatus.Large, size); - Free(ptr, size); + NotifyMediumLargeFree(HeapStatus.Large, size); + FreeMediumLarge(ptr, size); end; function FreeLargeBlock(p: pointer): PtrInt; @@ -1001,7 +1241,8 @@ var begin header := pointer(PByte(p) - LargeBlockHeaderSize); if header.BlockSizeAndFlags and IsFreeBlockFlag <> 0 then - begin // try to duplicate the same pointer twice + begin + // try to release the same pointer twice result := 0; exit; end; @@ -1018,11 +1259,11 @@ end; function ReallocateLargeBlock(p: pointer; size: PtrUInt): pointer; var oldavail, minup, new: PtrUInt; - {$ifndef FPCMM_NOMREMAP} prev, next, {$endif} header: PLargeBlockHeader; + prev, next, header: PLargeBlockHeader; begin header := pointer(PByte(p) - LargeBlockHeaderSize); oldavail := (DropMediumAndLargeFlagsMask and header^.BlockSizeAndFlags) - - (LargeBlockHeaderSize + BlockHeaderSize); + (LargeBlockHeaderSize + BlockHeaderSize); new := size; if size > oldavail then begin @@ -1045,111 +1286,36 @@ begin // size-down and move just the trailing data oldavail := size; end; - {$ifdef FPCMM_NOMREMAP} - // no mremap(): reallocate a new block, copy the existing data, free old - result := _GetMem(new); - if result <> nil then - MoveLarge(p, result, oldavail); - _FreeMem(p); - {$else} - // remove from current chain list - LockLargeBlocks; - prev := header^.PreviousLargeBlockHeader; - next := header^.NextLargeBlockHeader; - next.PreviousLargeBlockHeader := prev; - prev.NextLargeBlockHeader := next; - LargeBlocksLocked := False; - // let the Linux Kernel mremap() the memory using its TLB magic - size := DropMediumAndLargeFlagsMask and header^.BlockSizeAndFlags; - result := AllocateLargeBlockFrom(new, header, size); - {$endif FPCMM_NOMREMAP} + if new < MaximumMediumBlockSize then + begin + // size was reduced to a small/medium block: use GetMem/Move/FreeMem + result := _GetMem(new); + if result <> nil then + Move(p^, result^, oldavail); // RTL non-volatile asm or our AVX MoveFast() + _FreeMem(p); + end + else + begin + // remove large block from current chain list + LockLargeBlocks; + prev := header^.PreviousLargeBlockHeader; + next := header^.NextLargeBlockHeader; + next.PreviousLargeBlockHeader := prev; + prev.NextLargeBlockHeader := next; + LargeBlocksLocked := False; + size := DropMediumAndLargeFlagsMask and header^.BlockSizeAndFlags; + // on Linux, call Kernel mremap() and its TLB magic + // on Windows, try to reserve the memory block just after the existing + // otherwise, use Alloc/Move/Free pattern, with asm/AVX move + result := AllocateLargeBlockFrom(new, header, size); + end; end; { ********* Main Memory Manager Functions } -procedure LockGetMem; nostackframe; assembler; -asm - // Can use one of the several arenas reserved for tiny blocks? - cmp ecx, SizeOf(TTinyBlockTypes) - jae @NotTinyBlockType - { ---------- TINY (size<=128B) block lock ---------- } -@LockTinyBlockTypeLoop: - // Round-Robin attempt to lock of SmallBlockInfo.Tiny[] - // -> fair distribution among calls to reduce thread contention - mov edx, NumTinyBlockArenas -@TinyBlockArenaLoop: - mov eax, SizeOf(TTinyBlockTypes) - lock xadd dword ptr [r8 + TSmallBlockInfo.TinyCurrentArena], eax - and eax, (NumTinyBlockArenas * Sizeof(TTinyBlockTypes)) - 1 - add rax, rcx - lea rbx, [r8 + rax].TSmallBlockInfo.Tiny - mov eax, $100 - cmp [rbx].TSmallBlockType.BlockTypeLocked, ah - je @NextTinyBlockArena - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - jne @NextTinyBlockArena -@GotLockOnTinyBlockType: - ret -@NextTinyBlockArena: - dec edx - jnz @TinyBlockArenaLoop - // Also try the default SmallBlockInfo.Small[] - lea rbx, [r8 + rcx] - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - je @GotLockOnTinyBlockType - // Thread Contention (occurs much less than during _Freemem) - lock inc dword ptr [rbx].TSmallBlockType.GetmemSleepCount - push r8 - push rcx - call ReleaseCore - pop rcx - pop r8 - jmp @LockTinyBlockTypeLoop - { ---------- SMALL (size<2600) block lock ---------- } -@NotTinyBlockType: - lea rbx, [r8 + rcx].TSmallBlockInfo.Small -@LockBlockTypeLoopRetry: - {$ifdef FPCMM_PAUSE} - rdtsc - shl rdx, 32 - lea r9, [rax + rdx + SpinSmallGetmemLockTSC] // r9 = endtsc - {$endif FPCMM_PAUSE} -@LockBlockTypeLoop: - // Grab the default block type - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - jne @LockNextSmallBlockType -@GotLockOnSmallBlockType: - ret -@LockNextSmallBlockType: - // Try up to two next sizes - add rbx, SizeOf(TSmallBlockType) - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - je @GotLockOnSmallBlockType - pause - add rbx, SizeOf(TSmallBlockType) - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - je @GotLockOnSmallBlockType - sub rbx, 2 * SizeOf(TSmallBlockType) - {$ifdef FPCMM_PAUSE} - pause - rdtsc - shl rdx, 32 - or rax, rdx - cmp rax, r9 - jb @LockBlockTypeLoop // no timeout yet - {$endif FPCMM_PAUSE} - // Block type and two sizes larger are all locked - give up and sleep - lock inc dword ptr [rbx].TSmallBlockType.GetmemSleepCount - call ReleaseCore - jmp @LockBlockTypeLoopRetry -end; - -function _GetMem(size: PtrUInt): pointer; nostackframe; assembler; +function _GetMem(size: PtrUInt): pointer; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm {$ifndef MSWINDOWS} mov rcx, size @@ -1161,12 +1327,12 @@ asm // Since most allocations are for small blocks, determine small block type lea rbx, [rip + SmallBlockInfo] @VoidSizeToSomething: - lea rdx, [rcx + BlockHeaderSize - 1] + lea rdx, [size + BlockHeaderSize - 1] shr rdx, 4 // div SmallBlockGranularity // Is it a tiny/small block? - cmp rcx, (MaximumSmallBlockSize - BlockHeaderSize) + cmp size, (MaximumSmallBlockSize - BlockHeaderSize) ja @NotTinySmallBlock - test rcx, rcx + test size, size jz @VoidSize {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, qword ptr [rbx].TSmallBlockInfo.IsMultiThreadPtr @@ -1175,25 +1341,133 @@ asm movzx ecx, byte ptr [rbx + rdx].TSmallBlockInfo.GetmemLookup mov r8, rbx shl ecx, SmallBlockTypePO2 - // Acquire block type lock - {$ifdef FPCMM_ASSUMEMULTITHREAD} - call LockGetMem + // ---------- Acquire block type lock ---------- + {$ifndef FPCMM_ASSUMEMULTITHREAD} + cmp byte ptr [rax], false + je @GotLockOnSmallBlock // no lock if IsMultiThread=false + {$endif FPCMM_ASSUMEMULTITHREAD} + // Can use one of the several arenas reserved for tiny blocks? + cmp ecx, SizeOf(TTinyBlockTypes) + jae @NotTinyBlockType + // ---------- TINY (size<=128B) block lock ---------- +@LockTinyBlockTypeLoop: + // Round-Robin attempt to lock next SmallBlockInfo.Tiny[] + // -> fair distribution among calls to reduce thread contention + mov dl, NumTinyBlockArenas + 1 // 8/16 arenas (including Small[]) +@TinyBlockArenaLoop: + mov eax, SizeOf(TTinyBlockTypes) + // note: "lock xadd" decreases the loop iterations but is slower + xadd dword ptr [r8 + TSmallBlockInfo.TinyCurrentArena], eax + lea rbx, [r8 + rcx] + and eax, ((NumTinyBlockArenas + 1) * SizeOf(TTinyBlockTypes)) - 1 + jz @TinySmall // Arena 0 = TSmallBlockInfo.Small[] + lea rbx, [rax + rbx + TSmallBlockInfo.Tiny - SizeOf(TTinyBlockTypes)] +@TinySmall: + mov eax, $100 + {$ifdef FPCMM_CMPBEFORELOCK} + cmp byte ptr [rbx].TSmallBlockType.Locked, false + jnz @NextTinyBlockArena1 + {$endif FPCMM_CMPBEFORELOCK} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType +@NextTinyBlockArena1: + dec dl + jnz @TinyBlockArenaLoop + // Fallback to SmallBlockInfo.Small[] next 2 small sizes - never occurs + lea rbx, [r8 + rcx + TSmallBlockInfo.Small + SizeOf(TSmallBlockType)] + mov eax, $100 + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType + add rbx, SizeOf(TSmallBlockType) // next two small sizes + mov eax, $100 + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType + // Thread Contention (_Freemem is more likely) + {$ifdef FPCMM_DEBUG} lock {$endif} + inc dword ptr [rbx].TSmallBlockType.GetmemSleepCount + push r8 + push rcx + call ReleaseCore + pop rcx + pop r8 + jmp @LockTinyBlockTypeLoop + // ---------- SMALL (size<2600) block lock ---------- +@NotTinyBlockType: + lea rbx, [r8 + rcx].TSmallBlockInfo.Small +@LockBlockTypeLoopRetry: + {$ifdef FPCMM_PAUSE} + {$ifdef FPCMM_SLEEPTSC} + rdtsc + shl rdx, 32 + lea r9, [rax + rdx + SpinSmallGetmemLockTSC] // r9 = endtsc {$else} - cmp byte ptr [rax], 0 - jne @CheckTinySmallLock + mov edx, SpinSmallGetmemLockCount + {$endif FPCMM_SLEEPTSC} + {$endif FPCMM_PAUSE} +@LockBlockTypeLoop: + // Grab the default block type + mov eax, $100 + {$ifdef FPCMM_CMPBEFORELOCK} + cmp byte ptr [rbx].TSmallBlockType.Locked, false + jnz @NextLockBlockType1 + {$endif FPCMM_CMPBEFORELOCK} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType + // Try up to two next sizes + mov eax, $100 +@NextLockBlockType1: + add rbx, SizeOf(TSmallBlockType) + {$ifdef FPCMM_CMPBEFORELOCK} + cmp byte ptr [rbx].TSmallBlockType.Locked, al + jnz @NextLockBlockType2 + {$endif FPCMM_CMPBEFORELOCK} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType + mov eax, $100 +@NextLockBlockType2: + add rbx, SizeOf(TSmallBlockType) + pause + {$ifdef FPCMM_CMPBEFORELOCK} + cmp byte ptr [rbx].TSmallBlockType.Locked, al + jnz @NextLockBlockType3 + {$endif FPCMM_CMPBEFORELOCK} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + je @GotLockOnSmallBlockType +@NextLockBlockType3: + sub rbx, 2 * SizeOf(TSmallBlockType) + {$ifdef FPCMM_PAUSE} + pause + {$ifdef FPCMM_SLEEPTSC} + rdtsc + shl rdx, 32 + or rax, rdx + cmp rax, r9 + jb @LockBlockTypeLoop // continue spinning until timeout + {$else} + dec edx + jnz @LockBlockTypeLoop // continue until spin count reached + {$endif FPCMM_SLEEPTSC} + {$endif FPCMM_PAUSE} + // Block type and two sizes larger are all locked - give up and sleep + {$ifdef FPCMM_DEBUG} lock {$endif} + inc dword ptr [rbx].TSmallBlockType.GetmemSleepCount + call ReleaseCore + jmp @LockBlockTypeLoopRetry + // ---------- TINY/SMALL block registration ---------- + {$ifndef FPCMM_ASSUMEMULTITHREAD} +@GotLockOnSmallBlock: add rbx, rcx {$endif FPCMM_ASSUMEMULTITHREAD} - { ---------- TINY/SMALL block registration ---------- } @GotLockOnSmallBlockType: // set rdx=NextPartiallyFreePool rax=FirstFreeBlock rcx=DropSmallFlagsMask mov rdx, [rbx].TSmallBlockType.NextPartiallyFreePool - inc [rbx].TSmallBlockType.GetmemCount + add [rbx].TSmallBlockType.GetmemCount, 1 mov rax, [rdx].TSmallBlockPoolHeader.FirstFreeBlock mov rcx, DropSmallFlagsMask // Is there a pool with free blocks? cmp rdx, rbx je @TrySmallSequentialFeed - inc [rdx].TSmallBlockPoolHeader.BlocksInUse + add [rdx].TSmallBlockPoolHeader.BlocksInUse, 1 // Set the new first free block and the block header and rcx, [rax - BlockHeaderSize] mov [rdx].TSmallBlockPoolHeader.FirstFreeBlock, rcx @@ -1201,21 +1475,16 @@ asm // Is the chunk now full? jz @RemoveSmallPool // Unlock the block type and leave - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false -@Done: pop rbx - {$ifdef MSWINDOWS} - pop rdi - pop rsi - {$endif MSWINDOWS} + mov byte ptr [rbx].TSmallBlockType.Locked, false + {$ifdef NOSFRAME} + pop rbx ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @VoidSize: - inc ecx // "we always need to allocate something" (see RTL heap.inc) + inc size // "we always need to allocate something" (see RTL heap.inc) jmp @VoidSizeToSomething - {$ifndef FPCMM_ASSUMEMULTITHREAD} -@CheckTinySmallLock: - call LockGetMem - jmp @GotLockOnSmallBlockType - {$endif FPCMM_ASSUMEMULTITHREAD} @TrySmallSequentialFeed: // Feed a small block sequentially movzx ecx, [rbx].TSmallBlockType.BlockSize @@ -1226,37 +1495,37 @@ asm ja @AllocateSmallBlockPool // Adjust number of used blocks and sequential feed pool mov [rbx].TSmallBlockType.NextSequentialFeedBlockAddress, rcx - inc [rdx].TSmallBlockPoolHeader.BlocksInUse + add [rdx].TSmallBlockPoolHeader.BlocksInUse, 1 // Unlock the block type, set the block header and leave - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false mov [rax - BlockHeaderSize], rdx + {$ifdef NOSFRAME} pop rbx - {$ifdef MSWINDOWS} - pop rdi - pop rsi - {$endif MSWINDOWS} ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @RemoveSmallPool: // Pool is full - remove it from the partially free list mov rcx, [rdx].TSmallBlockPoolHeader.NextPartiallyFreePool mov [rcx].TSmallBlockPoolHeader.PreviousPartiallyFreePool, rbx mov [rbx].TSmallBlockType.NextPartiallyFreePool, rcx // Unlock the block type and leave - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false + {$ifdef NOSFRAME} pop rbx - {$ifdef MSWINDOWS} - pop rdi - pop rsi - {$endif MSWINDOWS} ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @AllocateSmallBlockPool: // Access shared information about Medium blocks storage - lea rcx, [rip + MediumBlockInfo] + lea rcx, [rip + SmallMediumBlockInfo] mov r10, rcx {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, [rcx + TMediumBlockinfo.IsMultiThreadPtr] cmp byte ptr [rax], false - je @MediumLocked1 + je @MediumLocked1 // no lock if IsMultiThread=false {$endif FPCMM_ASSUMEMULTITHREAD} mov eax, $100 lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah @@ -1333,22 +1602,31 @@ asm jmp @GotMediumBlock @AllocateNewSequentialFeed: // Use the optimal size for allocating this small block pool - movzx size, word ptr [rbx].TSmallBlockType.OptimalBlockPoolSize - push size // use "size" variable = first argument in current ABI call + {$ifdef MSWINDOWS} + movzx ecx, word ptr [rbx].TSmallBlockType.OptimalBlockPoolSize + lea rdx, [rip + SmallMediumBlockInfo] + push rcx + push rdx + {$else} + movzx edi, word ptr [rbx].TSmallBlockType.OptimalBlockPoolSize + lea rsi, [rip + SmallMediumBlockInfo] + push rdi + push rsi + {$endif MSWINDOWS} call AllocNewSequentialFeedMediumPool - pop rdi // restore edi=blocksize and r10=MediumBlockInfo - lea r10, [rip + MediumBlockInfo] + pop r10 + pop rdi // restore edi=blocksize and r10=TMediumBlockInfo mov rsi, rax test rax, rax jnz @GotMediumBlock // rsi=freeblock rbx=blocktype edi=blocksize mov [r10 + TMediumBlockInfo.Locked], al - mov [rbx].TSmallBlockType.BlockTypeLocked, al - {$ifdef MSWINDOWS} - jmp @Done - {$else} + mov [rbx].TSmallBlockType.Locked, al + {$ifdef NOSFRAME} pop rbx ret - {$endif MSWINDOWS} + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @UseWholeBlock: // rsi = free block, rbx = block type, edi = block size // Mark this block as used in the block following it @@ -1374,15 +1652,15 @@ asm sub rdi, rcx mov [rbx].TSmallBlockType.MaxSequentialFeedBlockAddress, rdi // Unlock the small block type, set header and leave - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false mov [rax - BlockHeaderSize], rsi + {$ifdef NOSFRAME} pop rbx - {$ifdef MSWINDOWS} - pop rdi - pop rsi - {$endif MSWINDOWS} ret - { ---------- MEDIUM block allocation ---------- } + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} + // ---------- MEDIUM block allocation ---------- @NotTinySmallBlock: // Do we need a Large block? lea r10, [rip + MediumBlockInfo] @@ -1396,7 +1674,7 @@ asm {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, [r10 + TMediumBlockinfo.IsMultiThreadPtr] cmp byte ptr [rax], false - je @MediumLocked2 + je @MediumLocked2 // no lock if IsMultiThread=false {$endif FPCMM_ASSUMEMULTITHREAD} mov eax, $100 lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah @@ -1408,7 +1686,7 @@ asm mov ecx, edx shr edx, 8 + 5 shr ecx, 8 - mov eax, - 1 + mov eax, -1 shl eax, cl and eax, [r10 + TMediumBlockInfo.BinBitmaps + rdx * 4] jz @GroupIsEmpty @@ -1444,22 +1722,28 @@ asm or rbx, IsMediumBlockFlag mov [rax - BlockHeaderSize], rbx mov byte ptr [r10 + TMediumBlockInfo.Locked], false - {$ifdef MSWINDOWS} - jmp @Done - {$else} + {$ifdef NOSFRAME} pop rbx ret - {$endif MSWINDOWS} + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @AllocateNewSequentialFeedForMedium: - mov size, rbx // 'size' variable is the first argument register in ABI call - call AllocNewSequentialFeedMediumPool - mov byte ptr [rip + MediumBlockInfo.Locked], false // r10 has been overwritten {$ifdef MSWINDOWS} - jmp @Done + mov ecx, ebx + lea rdx, [rip + MediumBlockInfo] {$else} + mov edi, ebx + lea rsi, [rip + MediumBlockInfo] + {$endif MSWINDOWS} + call AllocNewSequentialFeedMediumPool + mov byte ptr [rip + MediumBlockInfo.Locked], false + {$ifdef NOSFRAME} pop rbx ret - {$endif MSWINDOWS} + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @GotBinAndGroup: // ebx = block size, ecx = bin number, edx = group number // Compute rdi = @bin, rsi = free block @@ -1473,7 +1757,7 @@ asm // Is this bin now empty? cmp rdi, rax jne @MediumBinNotEmptyForMedium - // edx = bin group number, ecx = bin number, rdi = @bin, rsi = free block, ebx = block size + // edx=bingroupnumber, ecx=binnumber, rdi=@bin, rsi=freeblock, ebx=blocksize // Flag this bin and group as empty mov eax, - 2 mov r11d, [r10 + TMediumBlockInfo.BinGroupBitmap] @@ -1504,39 +1788,40 @@ asm @UseWholeBlockForMedium: // Mark this block as used in the block following it and byte ptr [rsi + rdi - BlockHeaderSize], NOT PreviousMediumBlockIsFreeFlag - @GotMediumBlockForMedium: +@GotMediumBlockForMedium: // Set the size and flags for this block lea rcx, [rbx + IsMediumBlockFlag] mov [rsi - BlockHeaderSize], rcx // Unlock medium blocks and leave mov byte ptr [r10 + TMediumBlockInfo.Locked], false mov rax, rsi - {$ifdef MSWINDOWS} - jmp @Done - {$else} + {$ifdef NOSFRAME} pop rbx ret - {$endif MSWINDOWS} - { ---------- LARGE block allocation ---------- } + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} + // ---------- LARGE block allocation ---------- @IsALargeBlockRequest: xor rax, rax test rcx, rcx - js @DoneLarge + js @Done // Note: size is still in the rcx/rdi first param register call AllocateLargeBlock -@DoneLarge: - {$ifdef MSWINDOWS} - jmp @Done - {$else} +@Done: // restore registers and the stack frame before ret pop rbx + {$ifdef MSWINDOWS} + pop rdi + pop rsi {$endif MSWINDOWS} end; -function FreeMediumBlock(arg1: pointer): PtrUInt; nostackframe; assembler; -// rcx=P rdx=[P-BlockHeaderSize] +function FreeMediumBlock(arg1: pointer): PtrUInt; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; +// rcx=P rdx=[P-BlockHeaderSize] r10=TMediumBlockInfo +// (arg1 is used only for proper call of pascal functions below on all ABI) asm - // Drop the flags, set r10=MediumBlockInfo r11=P rbx=blocksize - lea r10, [rip + MediumBlockInfo] + // Drop the flags, and set r11=P rbx=blocksize and rdx, DropMediumAndLargeFlagsMask push rbx push rdx // save blocksize @@ -1547,11 +1832,39 @@ asm {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, [r10 + TMediumBlockinfo.IsMultiThreadPtr] cmp byte ptr [rax], false - je @MediumBlocksLocked + je @MediumBlocksLocked // no lock if IsMultiThread=false {$endif FPCMM_ASSUMEMULTITHREAD} mov eax, $100 lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah je @MediumBlocksLocked + {$ifdef FPCMM_LOCKLESSFREEMEDIUM} + // locked: try to put r11=P in TMediumBlockInfo.LocklessBin.Instance[] + lea rcx, [rcx].TMediumBlockInfo.LocklessBin + cmp byte ptr [rcx].TMediumLocklessBin.Count, MediumBlockLocklessBinCount + je @DoLock // all slots are filled + mov r9d, SpinFreememBinCount +@BinSp: mov eax, $100 + lock cmpxchg byte ptr [rcx].TMediumLocklessBin.Locked, ah + je @BinOk +@BinNo: pause + dec r9d + jnz @BinSp + jmp @DoLock +@BinOk: // we acquired TMediumLocklessBin.Locked + movzx eax, byte ptr [rcx].TMediumLocklessBin.Count + cmp al, MediumBlockLocklessBinCount + je @DoLoc2 + add byte ptr [rcx].TMediumLocklessBin.Count, 1 + + cmp al, byte ptr [rcx].TMediumLocklessBin.MaxCount + jb @max + mov byte ptr [rcx].TMediumLocklessBin.MaxCount, al +@max: + mov [rcx + TMediumLocklessBin.Instance + rax * 8], r11 + mov byte ptr [rcx].TMediumLocklessBin.Locked, false + jmp @Quit +@DoLoc2:mov byte ptr [rcx].TMediumLocklessBin.Locked, false +@DoLock:{$endif FPCMM_LOCKLESSFREEMEDIUM} call LockMediumBlocks @MediumBlocksLocked: // Get rcx = next block size and flags @@ -1570,19 +1883,33 @@ asm // Check if entire medium block pool is free cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) je @EntireMediumPoolFree -@BinFreeMediumBlock: - // Store size of the block, flags and trailing size marker and insert into bin +@Bin: // Store size of the block, flags and trailing size marker and insert into bin lea rax, [rbx + IsMediumBlockFlag + IsFreeBlockFlag] mov [r11 - BlockHeaderSize], rax mov [r11 + rbx - 16], rbx mov rcx, r11 mov rdx, rbx - call InsertMediumBlockIntoBin // rcx=APMediumFreeBlock, edx=AMediumBlockSize + call InsertMediumBlockIntoBin // rcx=P, edx=blocksize + {$ifdef FPCMM_LOCKLESSFREEMEDIUM} + // recycle any pending TMediumLocklessBin.Instance[] pointer + lea rcx, [r10].TMediumBlockInfo.LocklessBin + cmp byte ptr [rcx].TMediumLocklessBin.Count, 0 + je @Done + mov eax, $100 + lock cmpxchg byte ptr [rcx].TMediumLocklessBin.Locked, ah // just try once + jne @Done + // compute r11=P and rbx=blocksize from pending pointer + movzx eax, byte ptr [rcx].TMediumLocklessBin.Count + dec byte ptr [rcx].TMediumLocklessBin.Count + mov r11, [rcx + TMediumLocklessBin.Instance - 8 + rax * 8] + mov byte ptr [rcx].TMediumLocklessBin.Locked, false + mov rbx, qword ptr [r11 - BlockHeaderSize] + and rbx, DropMediumAndLargeFlagsMask + jmp @MediumBlocksLocked +@Done: {$endif FPCMM_LOCKLESSFREEMEDIUM} // Unlock medium blocks and leave mov byte ptr [r10 + TMediumBlockInfo.Locked], false - pop rax // medium block size - pop rbx - ret + jmp @Quit @NextBlockIsFree: // Get rax = next block address, rbx = end of the block lea rax, [r11 + rbx] @@ -1619,27 +1946,65 @@ asm mov byte ptr [r10 + TMediumBlockInfo.Locked], false mov arg1, r11 call FreeMedium - pop rax // medium block size - pop rbx - ret + jmp @Quit @MakeEmptyMediumPoolSequentialFeed: // Get rbx = end-marker block, and recycle the current sequential feed pool lea rbx, [r11 + MediumBlockPoolSize - MediumBlockPoolHeaderSize] + mov arg1, r10 call BinMediumSequentialFeedRemainder // Set this medium pool up as the new sequential feed pool, unlock and leave mov qword ptr [rbx - BlockHeaderSize], IsMediumBlockFlag mov dword ptr [r10 + TMediumBlockInfo.SequentialFeedBytesLeft], MediumBlockPoolSize - MediumBlockPoolHeaderSize mov [r10 + TMediumBlockInfo.LastSequentiallyFed], rbx mov byte ptr [r10 + TMediumBlockInfo.Locked], false - pop rax +@Quit: // restore registers and the stack frame + pop rax // medium block size pop rbx end; -procedure FreeSmallLocked; nostackframe; assembler; -// rbx=TSmallBlockType rcx=P rdx=TSmallBlockPoolHeader +{$ifdef FPCMM_REPORTMEMORYLEAKS} +const + /// mark freed blocks with 00000000 BLODLESS marker to track incorrect usage + REPORTMEMORYLEAK_FREEDHEXSPEAK = $B10D1E55; +{$endif FPCMM_REPORTMEMORYLEAKS} + +function _FreeMem(P: pointer): PtrUInt; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm + {$ifdef FPCMM_REPORTMEMORYLEAKS} + mov eax, REPORTMEMORYLEAK_FREEDHEXSPEAK // 00000000 BLODLESS marker + {$endif FPCMM_REPORTMEMORYLEAKS} + {$ifndef MSWINDOWS} + mov rcx, P + {$endif MSWINDOWS} + test P, P + jz @Quit // void pointer + {$ifdef FPCMM_REPORTMEMORYLEAKS} + mov qword ptr [P], rax // over TObject VMT or string/dynarray header + {$endif FPCMM_REPORTMEMORYLEAKS} + mov rdx, qword ptr [P - BlockHeaderSize] + {$ifdef FPCMM_ASSUMEMULTITHREAD} + mov eax, $100 + {$else} + mov rax, qword ptr [rip + SmallBlockInfo].TSmallBlockInfo.IsMultiThreadPtr + {$endif FPCMM_ASSUMEMULTITHREAD} + // Is it a small block in use? + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + jnz @NotSmallBlockInUse + // Get the small block type in rbx and try to grab it + push rbx + mov rbx, [rdx].TSmallBlockPoolHeader.BlockType + {$ifdef FPCMM_ASSUMEMULTITHREAD} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah + jne @CheckTinySmallLock + {$else} + cmp byte ptr [rax], false + jne @TinySmallLockLoop // lock if IsMultiThread=true + {$endif FPCMM_ASSUMEMULTITHREAD} +@FreeAndUnlock: + // rbx=TSmallBlockType rcx=P rdx=TSmallBlockPoolHeader // Adjust number of blocks in use, set rax = old first free block - inc [rbx].TSmallBlockType.FreememCount + add [rbx].TSmallBlockType.FreememCount, 1 mov rax, [rdx].TSmallBlockPoolHeader.FirstFreeBlock sub [rdx].TSmallBlockPoolHeader.BlocksInUse, 1 jz @PoolIsNowEmpty @@ -1663,8 +2028,14 @@ asm cmp byte ptr [rbx].TSmallBlockType.BinCount, 0 jne @ProcessPendingBin {$endif FPCMM_LOCKLESSFREE} - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false + movzx eax, word ptr [rbx].TSmallBlockType.BlockSize + {$ifdef NOSFRAME} + pop rbx ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @PoolIsNowEmpty: // FirstFreeBlock=nil means it is the sequential feed pool with a single block test rax, rax @@ -1682,21 +2053,28 @@ asm mov [rbx].TSmallBlockType.MaxSequentialFeedBlockAddress, rax @NotSequentialFeedPool: // Unlock blocktype and release this pool - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false mov rcx, rdx mov rdx, qword ptr [rdx - BlockHeaderSize] - jmp FreeMediumBlock // no call nor BinLocked to avoid race condition + lea r10, [rip + SmallMediumBlockInfo] + call FreeMediumBlock // no call nor BinLocked to avoid race condition + movzx eax, word ptr [rbx].TSmallBlockType.BlockSize + {$ifdef NOSFRAME} + pop rbx + ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} {$ifdef FPCMM_LOCKLESSFREE} @ProcessPendingBin: - // Try twice to acquire BinLocked (spinning now may induce race condition) - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BinLocked, ah - je @BinLocked - pause + // Try once to acquire BinLocked (spinning may induce race condition) + {$ifdef FPCMM_CMPBEFORELOCK} + cmp byte ptr [rbx].TSmallBlockType.BinLocked, true + je @BinAlreadyLocked + {$endif FPCMM_CMPBEFORELOCK} mov eax, $100 lock cmpxchg byte ptr [rbx].TSmallBlockType.BinLocked, ah jne @BinAlreadyLocked -@BinLocked: movzx eax, byte ptr [rbx].TSmallBlockType.BinCount test al, al jz @NoBin @@ -1705,107 +2083,102 @@ asm dec byte ptr [rbx].TSmallBlockType.BinCount mov byte ptr [rbx].TSmallBlockType.BinLocked, false mov rdx, [rcx - BlockHeaderSize] - jmp FreeSmallLocked + jmp @FreeAndUnlock // loop until BinCount=0 or BinLocked @NoBin: mov byte ptr [rbx].TSmallBlockType.BinLocked, false @BinAlreadyLocked: - mov byte ptr [rbx].TSmallBlockType.BlockTypeLocked, false + mov byte ptr [rbx].TSmallBlockType.Locked, false {$endif FPCMM_LOCKLESSFREE} -end; - -function _FreeMem(P: pointer): PtrUInt; nostackframe; assembler; -asm - xor eax, eax - {$ifndef MSWINDOWS} - mov rcx, P - {$endif MSWINDOWS} - test P, P - jz @VoidPointer - {$ifdef FPCMM_REPORTMEMORYLEAKS} - mov qword ptr [P], rax // reset TObject VMT or string/dynarray header - {$endif FPCMM_REPORTMEMORYLEAKS} - mov rdx, qword ptr [P - BlockHeaderSize] - {$ifndef FPCMM_ASSUMEMULTITHREAD} - mov rax, qword ptr [rip + SmallBlockInfo].TSmallBlockInfo.IsMultiThreadPtr - {$endif FPCMM_ASSUMEMULTITHREAD} - // Is it a small block in use? - test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag - jnz @NotSmallBlockInUse - // Get the small block type in rbx and try to grab it - push rbx - mov rbx, [rdx].TSmallBlockPoolHeader.BlockType - {$ifdef FPCMM_ASSUMEMULTITHREAD} - mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah - jne @CheckTinySmallLock - {$else} - cmp byte ptr [rax], 0 - jne @TinySmallLockLoop - {$endif FPCMM_ASSUMEMULTITHREAD} -@FreeAndUnlock: - call FreeSmallLocked movzx eax, word ptr [rbx].TSmallBlockType.BlockSize + {$ifdef NOSFRAME} pop rbx -@VoidPointer: ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @NotSmallBlockInUse: + lea r10, [rip + MediumBlockInfo] test dl, IsFreeBlockFlag + IsLargeBlockFlag - jz FreeMediumBlock - jmp FreeLargeBlock // P is still in rcx/rdi first param register + jz @DoFreeMedium + call FreeLargeBlock // P is still in rcx/rdi first param register + jmp @Quit +@DoFreeMedium: + call FreeMediumBlock + jmp @Quit @TinySmallLockLoop: mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah je @FreeAndUnlock - @CheckTinySmallLock: +@CheckTinySmallLock: {$ifdef FPCMM_LOCKLESSFREE} // Try to put rcx=P in TSmallBlockType.BinInstance[] cmp byte ptr [rbx].TSmallBlockType.BinCount, SmallBlockBinCount - je @LockBlockTypeSleep + je @LockBlockTypeSleep // wait if all slots are filled mov eax, $100 lock cmpxchg byte ptr [rbx].TSmallBlockType.BinLocked, ah je @BinLocked {$ifdef FPCMM_PAUSE} + {$ifdef FPCMM_SLEEPTSC} push rdx rdtsc shl rdx, 32 lea r9, [rax + rdx + SpinSmallFreememBinTSC] // r9 = endtsc + {$else} + mov r9d, SpinFreememBinCount + {$endif FPCMM_SLEEPTSC} @SpinBinLock: pause + {$ifdef FPCMM_SLEEPTSC} rdtsc shl rdx, 32 or rax, rdx cmp rax, r9 ja @SpinTimeout + {$else} + dec r9 + jz @SpinTimeout + {$endif FPCMM_SLEEPTSC} + {$ifdef FPCMM_CMPBEFORELOCK_SPIN} cmp byte ptr [rbx].TSmallBlockType.BinLocked, true je @SpinBinLock + {$endif FPCMM_CMPBEFORELOCK_SPIN} mov eax, $100 lock cmpxchg byte ptr [rbx].TSmallBlockType.BinLocked, ah jne @SpinBinLock + {$ifdef FPCMM_SLEEPTSC} pop rdx + {$endif FPCMM_SLEEPTSC} jmp @BinLocked @SpinTimeout: + {$ifdef FPCMM_SLEEPTSC} pop rdx + {$endif FPCMM_SLEEPTSC} {$endif FPCMM_PAUSE} - {$ifdef FPCMM_DEBUG} - inc dword ptr [rbx].TSmallBlockType.BinSpinCount // no lock (informative only) + {$ifdef FPCMM_DEBUG} // no lock (informative only) + inc dword ptr [rbx].TSmallBlockType.BinSpinCount {$endif FPCMM_DEBUG} jmp @LockBlockTypeSleep @BinLocked: movzx eax, byte ptr [rbx].TSmallBlockType.BinCount cmp al, SmallBlockBinCount je @LockBlockType - inc byte ptr [rbx].TSmallBlockType.BinCount + add byte ptr [rbx].TSmallBlockType.BinCount, 1 mov [rbx + TSmallBlockType.BinInstance + rax * 8], rcx mov byte ptr [rbx].TSmallBlockType.BinLocked, false movzx eax, word ptr [rbx].TSmallBlockType.BlockSize + {$ifdef NOSFRAME} pop rbx ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} @LockBlockType: // Fallback to main block lock if TSmallBlockType.BinInstance[] is full mov byte ptr [rbx].TSmallBlockType.BinLocked, false - {$endif FPCMM_LOCKLESSFREE} @LockBlockTypeSleep: + {$endif FPCMM_LOCKLESSFREE} {$ifdef FPCMM_PAUSE} // Spin to grab the block type (don't try too long due to contention) + {$ifdef FPCMM_SLEEPTSC} push rdx rdtsc shl rdx, 32 @@ -1817,28 +2190,46 @@ asm or rax, rdx cmp rax, r9 ja @LockBlockTypeReleaseCore - cmp byte ptr [rbx].TSmallBlockType.BlockTypeLocked, 1 - je @SpinLockBlockType + {$else} + mov r8d, SpinSmallFreememLockCount +@SpinLockBlockType: + pause + dec r8d + jz @LockBlockTypeReleaseCore + {$endif FPCMM_SLEEPTSC} mov eax, $100 - lock cmpxchg byte ptr [rbx].TSmallBlockType.BlockTypeLocked, ah + {$ifdef FPCMM_CMPBEFORELOCK_SPIN} + cmp byte ptr [rbx].TSmallBlockType.Locked, true + je @SpinLockBlockType + {$endif FPCMM_CMPBEFORELOCK_SPIN} + lock cmpxchg byte ptr [rbx].TSmallBlockType.Locked, ah jne @SpinLockBlockType + {$ifdef FPCMM_SLEEPTSC} pop rdx + {$endif FPCMM_SLEEPTSC} jmp @FreeAndUnlock @LockBlockTypeReleaseCore: + {$ifdef FPCMM_SLEEPTSC} pop rdx + {$endif FPCMM_SLEEPTSC} {$endif FPCMM_PAUSE} // Couldn't grab the block type - sleep and try again - lock inc dword ptr [rbx].TSmallBlockType.FreeMemSleepCount + {$ifdef FPCMM_DEBUG} lock {$endif} + inc dword ptr [rbx].TSmallBlockType.FreeMemSleepCount push rdx push rcx call ReleaseCore pop rcx pop rdx jmp @TinySmallLockLoop +@Done: // restore rbx and the stack frame before ret + pop rbx +@Quit: end; // warning: FPC signature is not the same than Delphi: requires "var P" -function _ReallocMem(var P: pointer; Size: PtrUInt): pointer; nostackframe; assembler; +function _ReallocMem(var P: pointer; Size: PtrUInt): pointer; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm {$ifdef MSWINDOWS} push rdi @@ -1857,7 +2248,7 @@ asm mov rcx, [r14 - BlockHeaderSize] test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag jnz @NotASmallBlock - { -------------- TINY/SMALL block ------------- } + // -------------- TINY/SMALL block ------------- // Get rbx=blocktype, rcx=available size, rax=inplaceresize mov rbx, [rcx].TSmallBlockPoolHeader.BlockType lea rax, [rdx * 4 + SmallBlockDownsizeCheckAdder] @@ -1869,15 +2260,16 @@ asm cmp eax, ecx jb @GetMemMoveFreeMem // r14=P rdx=size @NoResize: + // branchless execution if current block is good enough for this size mov rax, r14 // keep original pointer pop rcx + {$ifdef NOSFRAME} pop r14 pop rbx - {$ifdef MSWINDOWS} - pop rsi - pop rdi - {$endif MSWINDOWS} ret + {$else} + jmp @Quit // on Win64, a stack frame is required + {$endif NOSFRAME} @VoidSize: push rdx // to set P=nil jmp @DoFree // ReallocMem(P,0)=FreeMem(P) @@ -1911,37 +2303,39 @@ asm @MoveFreeMem: // copy and free: rax=New r14=P rbx=size-8 push rax + {$ifdef FPCMM_ERMS} + cmp rbx, ErmsMinSize // startup cost of 0..255 bytes + jae @erms + {$endif FPCMM_ERMS} lea rcx, [r14 + rbx] lea rdx, [rax + rbx] neg rbx jns @Last8 align 16 -@MoveBy16: - movaps xmm0, oword ptr [rcx + rbx] +@By16: movaps xmm0, oword ptr [rcx + rbx] movaps oword ptr [rdx + rbx], xmm0 add rbx, 16 - js @MoveBy16 + js @By16 @Last8: mov rax, qword ptr [rcx + rbx] mov qword ptr [rdx + rbx], rax -@DoFree: - mov P, r14 +@DoFree:mov P, r14 call _FreeMem pop rax -@Done: pop rcx - pop r14 - pop rbx - {$ifdef MSWINDOWS} - pop rsi - pop rdi - {$endif MSWINDOWS} - mov qword ptr [rcx], rax // store new pointer in var P - ret + jmp @Done + {$ifdef FPCMM_ERMS} +@erms: cld + mov rsi, r14 + mov rdi, rax + lea rcx, [rbx + 8] + rep movsb + jmp @DoFree + {$endif FPCMM_ERMS} @NotASmallBlock: // Is this a medium block or a large block? test cl, IsFreeBlockFlag + IsLargeBlockFlag jnz @PossibleLargeBlock - { -------------- MEDIUM block ------------- } - // rcx = Current Size + Flags, r14 = P, rdx = Requested Size, r10 = MediumBlockInfo + // -------------- MEDIUM block ------------- + // rcx=CurrentSize+Flags, r14=P, rdx=RequestedSize, r10=TMediumBlockInfo lea rsi, [rdx + rdx] lea r10, [rip + MediumBlockInfo] mov rbx, rcx @@ -1952,8 +2346,8 @@ asm // Is it an upsize or a downsize? cmp rdx, rcx ja @MediumBlockUpsize - // rcx = Current Block Size - BlockHeaderSize, rbx = Current Block Flags, - // rdi = @Next Block, r14 = P, rdx = Requested Size + // rcx=CurrentBlockSize-BlockHeaderSize, rbx=CurrentBlockFlags, + // rdi=@NextBlock, r14=P, rdx=RequestedSize // Downsize reallocate and move data only if less than half the current size cmp rsi, rcx jae @NoResize @@ -1981,7 +2375,7 @@ asm {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, [r10 + TMediumBlockinfo.IsMultiThreadPtr] cmp byte ptr [rax], false - je @MediumBlocksLocked1 + je @MediumBlocksLocked1 // no lock if IsMultiThread=false {$endif FPCMM_ASSUMEMULTITHREAD} mov eax, $100 lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah @@ -2047,7 +2441,7 @@ asm {$ifndef FPCMM_ASSUMEMULTITHREAD} mov rax, [r10 + TMediumBlockinfo.IsMultiThreadPtr] cmp byte ptr [rax], false - je @MediumBlocksLocked2 + je @MediumBlocksLocked2 // no lock if IsMultiThread=false {$endif FPCMM_ASSUMEMULTITHREAD} mov eax, $100 lock cmpxchg byte ptr [rcx].TMediumBlockInfo.Locked, ah @@ -2085,11 +2479,11 @@ asm // Get the maximum of the requested size and the minimum growth size xor edi, edi sub eax, edx - adc edi, - 1 + adc edi, -1 and eax, edi // Round up to the nearest block size granularity lea rax, [rax + rdx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] - and eax, - MediumBlockGranularity + and eax, -MediumBlockGranularity add eax, MediumBlockSizeOffset // Calculate the size of the second split and check if it fits lea rdx, [rsi + BlockHeaderSize] @@ -2128,7 +2522,7 @@ asm lea P, qword ptr [rcx + rax] // NextUpBlockSize = OldSize+25% jmp @AdjustGetMemMoveFreeMem // P=BlockSize, rdx=NewSize, rbx=OldSize-8 @PossibleLargeBlock: - { -------------- LARGE block ------------- } + // -------------- LARGE block ------------- test cl, IsFreeBlockFlag + IsMediumBlockFlag jnz @Error {$ifdef MSWINDOWS} @@ -2140,15 +2534,25 @@ asm call ReallocateLargeBlock // with restored proper registers jmp @Done @Error: xor eax, eax - jmp @Done +@Done: // restore registers and the stack frame before ret + pop rcx + mov qword ptr [rcx], rax // store new pointer in var P +@Quit: pop r14 + pop rbx + {$ifdef MSWINDOWS} + pop rsi + pop rdi + {$endif MSWINDOWS} end; -function _AllocMem(Size: PtrUInt): pointer; nostackframe; assembler; +function _AllocMem(Size: PtrUInt): pointer; + {$ifdef NOSFRAME} nostackframe; {$endif} assembler; asm push rbx - // Get rbx = size rounded down to the previous multiple of SizeOf(pointer) + // Compute rbx = size rounded down to the last pointer lea rbx, [Size - 1] and rbx, - 8 + // Perform the memory allocation call _GetMem // Could a block be allocated? rcx = 0 if yes, -1 if no cmp rax, 1 @@ -2161,21 +2565,53 @@ asm // Large blocks from mmap/VirtualAlloc are already zero filled cmp rbx, MaximumMediumBlockSize - BlockHeaderSize jae @Done + {$ifdef FPCMM_ERMS} + cmp rbx, ErmsMinSize // startup cost of 0..255 bytes + jae @erms + {$endif FPCMM_ERMS} neg rbx pxor xmm0, xmm0 align 16 -@FillLoop: // non-temporal movntdq not needed when size <256KB (small/medium) +@FillLoop: // non-temporal movntdq not needed with small/medium size movaps oword ptr [rdx + rbx], xmm0 add rbx, 16 js @FillLoop + // fill the last pointer @LastQ: xor rcx, rcx mov qword ptr [rdx], rcx -@Done: pop rbx + {$ifdef FPCMM_ERMS} + {$ifdef NOSFRAME} + pop rbx + ret + {$else} + jmp @Done // on Win64, a stack frame is required + {$endif NOSFRAME} + // ERMS has a startup cost, but "rep stosd" is fast enough on all CPUs +@erms: mov rcx, rbx + push rax + {$ifdef MSWINDOWS} + push rdi + {$endif MSWINDOWS} + cld + mov rdi, rdx + xor eax, eax + sub rdi, rbx + shr ecx, 2 + mov qword ptr [rdx], rax + rep stosd + {$ifdef MSWINDOWS} + pop rdi + {$endif MSWINDOWS} + pop rax + {$endif FPCMM_ERMS} +@Done: // restore rbx register and the stack frame before ret + pop rbx end; function _MemSize(P: pointer): PtrUInt; begin - // AFAIK used only by fpc_AnsiStr_SetLength() in RTL + // AFAIK used only by fpc_AnsiStr_SetLength() in FPC RTL + // also used by our static SQLite3 for its xSize() callback P := PPointer(PByte(P) - BlockHeaderSize)^; if (PtrUInt(P) and (IsMediumBlockFlag or IsLargeBlockFlag)) = 0 then result := PSmallBlockPoolHeader(PtrUInt(P) and DropSmallFlagsMask). @@ -2191,7 +2627,8 @@ end; function _FreeMemSize(P: pointer; size: PtrUInt): PtrInt; begin // should return the chunk size - only used by heaptrc AFAIK - if (P <> nil) and (size <> 0) then + if (P <> nil) and + (size <> 0) then result := _FreeMem(P) else result := 0; @@ -2208,14 +2645,28 @@ end; {$else} +function _GetFPCHeapStatus: TFPCHeapStatus; +var + mm: PMMStatus; +begin + mm := @HeapStatus; + {$ifdef FPCMM_DEBUG} + result.MaxHeapSize := mm^.Medium.PeakBytes + mm^.Large.PeakBytes; + {$else} + result.MaxHeapSize := 0; + {$endif FPCMM_DEBUG} + result.MaxHeapUsed := result.MaxHeapSize; + result.CurrHeapSize := mm^.Medium.CurrentBytes + mm^.Large.CurrentBytes; + result.CurrHeapUsed := result.CurrHeapSize; + result.CurrHeapFree := 0; +end; + function _GetHeapStatus: THeapStatus; begin FillChar(result, sizeof(result), 0); -end; - -function _GetFPCHeapStatus: TFPCHeapStatus; -begin - FillChar(result, sizeof(result), 0); + with HeapStatus do + result.TotalAllocated := Medium.CurrentBytes + Large.CurrentBytes; + result.TotalAddrSpace := result.TotalAllocated; end; type @@ -2255,7 +2706,8 @@ begin end; until I > J; if J - L < R - I then - begin // use recursion only for smaller range + begin + // use recursion only for smaller range if L < J then QuickSortRes(Res, L, J, Level); L := I; @@ -2269,16 +2721,19 @@ begin until L >= R; end; -procedure SetSmallBlockStatus(var res: TResArray); +procedure SetSmallBlockStatus(var res: TResArray; out small, tiny: cardinal); var i, a: integer; p: PSmallBlockType; d: ^TSmallBlockStatus; begin + small := 0; + tiny := 0; d := @res; p := @SmallBlockInfo; for i := 1 to NumSmallBlockTypes do begin + inc(small, ord(p^.GetmemCount <> 0)); d^.Total := p^.GetmemCount; d^.Current := p^.GetmemCount - p^.FreememCount; d^.BlockSize := p^.BlockSize; @@ -2290,6 +2745,7 @@ begin d := @res; // aggregate counters for i := 1 to NumTinyBlockTypes do begin + inc(tiny, ord(p^.GetmemCount <> 0)); inc(d^.Total, p^.GetmemCount); inc(d^.Current, p^.GetmemCount - p^.FreememCount); inc(d); @@ -2320,7 +2776,8 @@ begin result := maxcount; if result > NumSmallBlockTypes then result := NumSmallBlockTypes; - while (result > 0) and (res[result - 1, orderby] = 0) do + while (result > 0) and + (res[result - 1, orderby] = 0) do dec(result); end; @@ -2360,146 +2817,191 @@ begin result := maxcount; end; -function K(i: PtrUInt): shortstring; +const + K_: array[0..4] of string[1] = ( + 'P', 'T', 'G', 'M', 'K'); + +function K(i: PtrUInt): ShortString; var - tmp: string[1]; + j, n: PtrUInt; + tmp: PShortString; begin - if i >= 1 shl 50 then - begin - i := i shr 50; - tmp := 'Z'; - end - else - if i >= 1 shl 40 then - begin - i := i shr 40; - tmp := 'T'; - end - else - if i >= 1 shl 30 then - begin - i := i shr 30; - tmp := 'G'; - end - else - if i >= 1 shl 20 then - begin - i := i shr 20; - tmp := 'M'; - end - else - if i >= 1 shl 10 then - begin - i := i shr 10; - tmp := 'K'; - end - else - tmp := ''; + tmp := nil; + n := 1 shl 50; + for j := 0 to high(K_) do + if i >= n then + begin + i := i div n; + tmp := @K_[j]; + break; + end + else + n := n shr 10; str(i, result); - result := result + tmp; + if tmp <> nil then + result := result + tmp^; end; -{$I-} +function S(i: PtrUInt): ShortString; +begin + str(i, result); +end; + +type + // allow to write into a temp string or the console + TGetHeapStatusWrite = + procedure(const V: array of ShortString; CRLF: boolean = true); procedure WriteHeapStatusDetail(const arena: TMMStatusArena; - const name: shortstring); + const name: ShortString; Wr: TGetHeapStatusWrite); begin - write(name, K(arena.CurrentBytes):4, - 'B/', K(arena.CumulativeBytes), 'B '); + Wr([name, K(arena.CurrentBytes), + 'B/', K(arena.CumulativeBytes), 'B '], {crlf=}false); {$ifdef FPCMM_DEBUG} - write(' peak=', K(arena.PeakBytes), + Wr([' peak=', K(arena.PeakBytes), 'B current=', K(arena.CumulativeAlloc - arena.CumulativeFree), - ' alloc=', K(arena.CumulativeAlloc), ' free=', K(arena.CumulativeFree)); + ' alloc=', K(arena.CumulativeAlloc), + ' free=', K(arena.CumulativeFree)], false); {$endif FPCMM_DEBUG} - writeln(' sleep=', K(arena.SleepCount)); + Wr([' sleep=', K(arena.SleepCount)]); end; -procedure WriteHeapStatus(const context: shortstring; smallblockstatuscount, - smallblockcontentioncount: integer; compilationflags: boolean); +procedure ComputeHeapStatus(const context: ShortString; smallblockstatuscount, + smallblockcontentioncount: integer; compilationflags: boolean; + Wr: TGetHeapStatusWrite); var res: TResArray; // no heap allocation involved i, n, smallcount: PtrInt; t, b: PtrUInt; + small, tiny: cardinal; begin if context[0] <> #0 then - writeln(context); + Wr([context]); if compilationflags then - writeln(' Flags: ' {$ifdef FPCMM_BOOSTER} + 'BOOSTER ' {$else} - {$ifdef FPCMM_BOOST} + 'BOOST ' {$endif}{$endif} - {$ifdef FPCMM_SERVER} + 'SERVER ' {$endif} - {$ifdef FPCMM_ASSUMEMULTITHREAD} + ' assumulthrd' {$endif} - {$ifdef FPCMM_LOCKLESSFREE} + ' lockless' {$endif} - {$ifdef FPCMM_PAUSE} + ' pause' {$endif} - {$ifdef FPCMM_NOMREMAP} + ' nomremap' {$endif} - {$ifdef FPCMM_DEBUG} + ' debug' {$endif} - {$ifdef FPCMM_REPORTMEMORYLEAKS} + ' repmemleak' {$endif}); + Wr([' Flags:' + FPCMM_FLAGS]); with CurrentHeapStatus do begin - writeln(' Small: blocks=', K(SmallBlocks), ' size=', K(SmallBlocksSize), - 'B (part of Medium arena)'); - WriteHeapStatusDetail(Medium, ' Medium: '); - WriteHeapStatusDetail(Large, ' Large: '); + Wr([' Small: blocks=', K(SmallBlocks), + ' size=', K(SmallBlocksSize), 'B (part of Medium arena)']); + WriteHeapStatusDetail(Medium, ' Medium: ', Wr); + WriteHeapStatusDetail(Large, ' Large: ', Wr); if SleepCount <> 0 then - writeln(' Total Sleep: count=', K(SleepCount) - {$ifdef FPCMM_DEBUG} , ' rdtsc=', K(SleepCycles) {$endif}); - smallcount := SmallGetmemSleepCount + SmallFreememSleepCount; + Wr([' Total Sleep: count=', K(SleepCount) + {$ifdef FPCMM_SLEEPTSC} , ' rdtsc=', K(SleepCycles) {$endif}]); + smallcount := SmallGetmemSleepCount + SmallFreememSleepCount + {$ifdef FPCMM_LOCKLESSFREE} {$ifdef FPCMM_DEBUG} + + SmallFreememLockLessSpin {$endif} {$endif}; if smallcount <> 0 then - writeln(' Small Sleep: getmem=', K(SmallGetmemSleepCount), - ' freemem=', K(SmallFreememSleepCount) + Wr([' Small Sleep: getmem=', K(SmallGetmemSleepCount), + ' freemem=', K(SmallFreememSleepCount) {$ifdef FPCMM_LOCKLESSFREE} {$ifdef FPCMM_DEBUG} , - ' locklessspin=', K(SmallFreememLockLessSpin) {$endif} {$endif} ); + ' locklessspin=', K(SmallFreememLockLessSpin) {$endif} {$endif}]); end; - if (smallblockcontentioncount > 0) and (smallcount <> 0) then + if (smallblockcontentioncount > 0) and + (smallcount <> 0) then begin n := SetSmallBlockContention(res, smallblockcontentioncount); for i := 0 to n - 1 do with TSmallBlockContention(res[i]) do begin if GetmemBlockSize <> 0 then - write(' getmem(', GetmemBlockSize) + Wr([' getmem(', S(GetmemBlockSize)], {crlf=}false) else - write(' freemem(', FreememBlockSize); - write(')=' , K(SleepCount)); - if (i and 3 = 3) or (i = n - 1) then - writeln; + Wr([' freemem(', S(FreememBlockSize)], false); + Wr([')=' , K(SleepCount)], false); + if (i and 3 = 3) or + (i = n - 1) then + Wr([]); end; end; if smallblockstatuscount > 0 then begin - SetSmallBlockStatus(res); + SetSmallBlockStatus(res, small, tiny); n := SortSmallBlockStatus(res, smallblockstatuscount, ord(obTotal), @t, @b) - 1; - writeln(' Small Blocks since beginning: ', K(t), '/', K(b), 'B'); + Wr([' Small Blocks since beginning: ', K(t), '/', K(b), + 'B (as small=', K(small), '/', S(NumSmallBlockTypes), + ' tiny=', K(tiny), '/', S(NumTinyBlockArenas * NumTinyBlockTypes), ')']); for i := 0 to n do with TSmallBlockStatus(res[i]) do begin - write(' ', BlockSize, '=', K(Total)); - if (i and 7 = 7) or (i = n) then - writeln; + Wr([' ', S(BlockSize), '=', K(Total)], false); + if (i and 7 = 7) or + (i = n) then + Wr([]); end; n := SortSmallBlockStatus(res, smallblockstatuscount, ord(obCurrent), @t, @b) - 1; - writeln(' Small Blocks current: ', K(t), '/', K(b), 'B'); + Wr([' Small Blocks current: ', K(t), '/', K(b), 'B']); for i := 0 to n do with TSmallBlockStatus(res[i]) do begin - write(' ', BlockSize, '=', K(Current)); - if (i and 7 = 7) or (i = n) then - writeln; + Wr([' ', S(BlockSize), '=', K(Current)], false); + if (i and 7 = 7) or + (i = n) then + Wr([]); end; end; end; -{$I+} +var + WrStrTemp: string; // we don't require thread safety here + WrStrOnSameLine: boolean; -function GetSmallBlockStatus(maxcount: integer; - orderby: TSmallBlockOrderBy; count, bytes: PPtrUInt): TSmallBlockStatusDynArray; +procedure WrStr(const V: array of ShortString; CRLF: boolean); +var + i: PtrInt; +begin // we don't have format() nor formatutf8() -> this is good enough + for i := 0 to high(V) do + WrStrTemp := WrStrTemp + string(V[i]); // fast enough + if CRLF and + not WrStrOnSameLine then + WrStrTemp := WrStrTemp + #13#10; +end; + +function GetHeapStatus(const context: ShortString; smallblockstatuscount, + smallblockcontentioncount: integer; compilationflags, onsameline: boolean): string; +begin + WrStrOnSameLine := onsameline; + ComputeHeapStatus(context, smallblockstatuscount, smallblockcontentioncount, + compilationflags, WrStr); + result := WrStrTemp; + WrStrTemp := ''; +end; + +procedure WrConsole(const V: array of ShortString; CRLF: boolean); +var + i: PtrInt; +begin // direct write to the console with no memory heap allocation + {$I-} + for i := 0 to high(V) do + write(V[i]); + if CRLF then + writeln; + ioresult; + {$I+} +end; + +procedure WriteHeapStatus(const context: ShortString; smallblockstatuscount, + smallblockcontentioncount: integer; compilationflags: boolean); +begin + ComputeHeapStatus(context, smallblockstatuscount, smallblockcontentioncount, + compilationflags, WrConsole); +end; + +function GetSmallBlockStatus(maxcount: integer; orderby: TSmallBlockOrderBy; + count, bytes: PPtrUInt; small, tiny: PCardinal): TSmallBlockStatusDynArray; var res: TResArray; + sm, ti: cardinal; begin assert(SizeOf(TRes) = SizeOf(TSmallBlockStatus)); result := nil; if maxcount <= 0 then exit; - SetSmallBlockStatus(res); + SetSmallBlockStatus(res, sm, ti); + if small <> nil then + small^ := sm; + if tiny <> nil then + tiny^ := ti; maxcount := SortSmallBlockStatus(res, maxcount, ord(orderby), count, bytes); if maxcount = 0 then exit; @@ -2554,18 +3056,36 @@ end; { ********* Initialization and Finalization } +procedure InitializeMediumPool(var Info: TMediumBlockInfo); +var + i: PtrInt; + medium: PMediumFreeBlock; +begin + {$ifndef FPCMM_ASSUMEMULTITHREAD} + Info.IsMultiThreadPtr := @IsMultiThread; + {$endif FPCMM_ASSUMEMULTITHREAD} + Info.PoolsCircularList.PreviousMediumBlockPoolHeader := @Info.PoolsCircularList; + Info.PoolsCircularList.NextMediumBlockPoolHeader := @Info.PoolsCircularList; + for i := 0 to MediumBlockBinCount -1 do + begin + medium := @Info.Bins[i]; + medium.PreviousFreeBlock := medium; + medium.NextFreeBlock := medium; + end; +end; + procedure InitializeMemoryManager; var small: PSmallBlockType; a, i, min, poolsize, num, perpool, size, start, next: PtrInt; - medium: PMediumFreeBlock; begin small := @SmallBlockInfo; assert(SizeOf(small^) = 1 shl SmallBlockTypePO2); for a := 0 to NumTinyBlockArenas do for i := 0 to NumSmallBlockTypes - 1 do begin - if (i = NumTinyBlockTypes) and (a > 0) then + if (i = NumTinyBlockTypes) and + (a > 0) then break; size := SmallBlockSizes[i]; assert(size and 15 = 0); @@ -2584,7 +3104,7 @@ begin (MediumBlockBinsPerGroup * MediumBlockGranularity); if num > 7 then num := 7; - small^.AllowedGroupsForBlockPoolBitmap := Byte(Byte(-1) shl num); + small^.AllowedGroupsForBlockPoolBitmap := byte(byte(-1) shl num); small^.MinimumBlockPoolSize := MinimumMediumBlockSize + num * (MediumBlockBinsPerGroup * MediumBlockGranularity); poolsize := ((size * TargetSmallBlocksPerPool + @@ -2602,8 +3122,7 @@ begin end; assert(small = @SmallBlockInfo.GetmemLookup); {$ifndef FPCMM_ASSUMEMULTITHREAD} - SmallBlockInfo.IsMultiThreadPtr := @IsMultiThread; - MediumBlockInfo.IsMultiThreadPtr := @IsMultiThread; + SmallBlockInfo.IsMultiThreadPtr := @IsMultiThread; {$endif FPCMM_ASSUMEMULTITHREAD} start := 0; with SmallBlockInfo do @@ -2616,17 +3135,10 @@ begin inc(start); end; end; - with MediumBlockInfo do - begin - PoolsCircularList.PreviousMediumBlockPoolHeader := @PoolsCircularList; - PoolsCircularList.NextMediumBlockPoolHeader := @PoolsCircularList; - for i := 0 to MediumBlockBinCount -1 do - begin - medium := @Bins[i]; - medium.PreviousFreeBlock := medium; - medium.NextFreeBlock := medium; - end; - end; + InitializeMediumPool(MediumBlockInfo); + {$ifdef FPCMM_SMALLNOTWITHMEDIUM} + InitializeMediumPool(SmallMediumBlockInfo); + {$endif FPCMM_SMALLNOTWITHMEDIUM} LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList; LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList; end; @@ -2634,6 +3146,7 @@ end; {$I-} {$ifdef FPCMM_REPORTMEMORYLEAKS} + var MemoryLeakReported: boolean; @@ -2641,46 +3154,62 @@ procedure StartReport; begin if MemoryLeakReported then exit; - writeln; + writeln {$ifndef MSWINDOWS} (#27'[1;31m') {$endif}; // lightred posix console WriteHeapStatus('WARNING! THIS PROGRAM LEAKS MEMORY!'#13#10'Memory Status:'); - writeln('Leaks Identified:'); + writeln('Leaks Identified:' {$ifndef MSWINDOWS} + #27'[1;37m' {$endif}); MemoryLeakReported := true; end; -{$ifdef LINUX} - // experimental detection of object class - use at your own risk - {$define FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} -{$endif LINUX} +{$ifdef FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} +function SeemsRealPointer(p: pointer): boolean; +{$ifdef MSWINDOWS} +var + meminfo: TMemInfo; +{$endif MSWINDOWS} +begin + result := false; + if PtrUInt(p) <= 65535 then + exit; + {$ifdef MSWINDOWS} + // VirtualQuery API is slow but better than raising an exception + // see https://stackoverflow.com/a/37547837/458259 + FillChar(meminfo, SizeOf(meminfo), 0); + result := (VirtualQuery(p, @meminfo, SizeOf(meminfo)) = SizeOf(meminfo)) and + (meminfo.RegionSize >= SizeOf(pointer)) and + (meminfo.State = MEM_COMMIT) and + (meminfo.Protect and PAGE_VALID <> 0) and + (meminfo.Protect and PAGE_GUARD = 0); + {$else} + // let the GPF happen silently in the kernel + result := (fpaccess(p, F_OK) <> 0) and + (fpgeterrno <> ESysEFAULT); + {$endif MSWINDOWS} +end; +{$endif FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} -procedure MediumMemoryLeakReport(p: PMediumBlockPoolHeader); +procedure MediumMemoryLeakReport( + var Info: TMediumBlockInfo; p: PMediumBlockPoolHeader); var block: PByte; header, size: PtrUInt; - {$ifdef FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} first, last: PByte; vmt: PAnsiChar; - small: PSmallBlockPoolHeader; - - function SeemsRealPointer(p: pointer): boolean; - begin - result := (PtrUInt(p) > 65535) - {$ifndef MSWINDOWS} - // let the GPF happen silently in the kernel - and (fpaccess(p, F_OK) <> 0) and (fpgeterrno <> ESysEFAULT) - {$endif MSWINDOWS} - end; + exceptcount: integer; {$endif FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} - begin - with MediumBlockInfo do - if (SequentialFeedBytesLeft = 0) or (PtrUInt(LastSequentiallyFed) < PtrUInt(p)) or - (PtrUInt(LastSequentiallyFed) > PtrUInt(p) + MediumBlockPoolSize) then + if (Info.SequentialFeedBytesLeft = 0) or + (PtrUInt(Info.LastSequentiallyFed) < PtrUInt(p)) or + (PtrUInt(Info.LastSequentiallyFed) > PtrUInt(p) + MediumBlockPoolSize) then block := Pointer(PByte(p) + MediumBlockPoolHeaderSize) - else if SequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then - block := LastSequentiallyFed + else if Info.SequentialFeedBytesLeft <> + MediumBlockPoolSize - MediumBlockPoolHeaderSize then + block := Info.LastSequentiallyFed else exit; + {$ifdef FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} + exceptcount := 0; + {$endif FPCMM_REPORTMEMORYLEAKS_EXPERIMENTAL} repeat header := PPtrUInt(block - BlockHeaderSize)^; size := header and DropMediumAndLargeFlagsMask; @@ -2701,14 +3230,20 @@ begin and DropMediumAndLargeFlagsMask) - BlockSize else last := Pointer(PByte(NextSequentialFeedBlockAddress) - 1); - while first <= last do + while (first <= last) and + (exceptcount < 64) do begin if ((PPtrUInt(first - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then begin - vmt := PPointer(first)^; // _FreeMem() ensured vmt=nil - if (vmt <> nil) and SeemsRealPointer(vmt) then + vmt := PPointer(first)^; // _FreeMem() ensured vmt=nil/$b10dle55 + if (vmt <> nil) and + {$ifdef FPCMM_REPORTMEMORYLEAKS} + (PtrUInt(vmt) <> REPORTMEMORYLEAK_FREEDHEXSPEAK) and + // FreeMem marked freed blocks with 00000000 BLOODLESS marker + {$endif FPCMM_REPORTMEMORYLEAKS} + SeemsRealPointer(vmt) then try - // try to access the TObject VMT (seems to work on Linux) + // try to access the TObject VMT if (PPtrInt(vmt + vmtInstanceSize)^ >= sizeof(vmt)) and (PPtrInt(vmt + vmtInstanceSize)^ <= PSmallBlockPoolHeader(block).BlockType.BlockSize) and @@ -2716,10 +3251,13 @@ begin begin StartReport; writeln(' probable ', PShortString(PPointer(vmt + vmtClassName)^)^, - ' leak (', PSmallBlockPoolHeader(block).BlockType.BlockSize, ' bytes)'); + ' leak (', PPtrInt(vmt + vmtInstanceSize)^, '/', + PSmallBlockPoolHeader(block).BlockType.BlockSize, + ' bytes) at $', HexStr(first)); end; except - // intercept any GPF + // intercept and ignore any GPF - SeemsRealPointer() + inc(exceptcount); end; end; inc(first, PSmallBlockPoolHeader(block).BlockType.BlockSize); @@ -2730,7 +3268,7 @@ begin else begin StartReport; - writeln(' medium block leak of ', K(size), 'B'); + writeln(' medium block leak of ', size, ' bytes (', K(size), 'B)'); end; inc(block, size); until false; @@ -2738,10 +3276,44 @@ end; {$endif FPCMM_REPORTMEMORYLEAKS} -procedure FreeAllMemory; +procedure FreeMediumPool(var Info: TMediumBlockInfo); var medium, nextmedium: PMediumBlockPoolHeader; bin: PMediumFreeBlock; + i: PtrInt; +begin + medium := Info.PoolsCircularList.NextMediumBlockPoolHeader; + while medium <> @Info.PoolsCircularList do + begin + {$ifdef FPCMM_REPORTMEMORYLEAKS} + MediumMemoryLeakReport(Info, medium); + {$endif FPCMM_REPORTMEMORYLEAKS} + nextmedium := medium.NextMediumBlockPoolHeader; + FreeMedium(medium); + medium := nextmedium; + end; + Info.PoolsCircularList.PreviousMediumBlockPoolHeader := @Info.PoolsCircularList; + Info.PoolsCircularList.NextMediumBlockPoolHeader := @Info.PoolsCircularList; + for i := 0 to MediumBlockBinCount - 1 do + begin + bin := @Info.Bins[i]; + bin.PreviousFreeBlock := bin; + bin.NextFreeBlock := bin; + end; + Info.BinGroupBitmap := 0; + Info.SequentialFeedBytesLeft := 0; + for i := 0 to MediumBlockBinGroupCount - 1 do + Info.BinBitmaps[i] := 0; + {$ifdef FPCMM_LOCKLESSFREEMEDIUM} + with Info.LocklessBin do + for i := 0 to Count - 1 do + if Instance[i] <> nil then + _FreeMem(Instance[i]); // release (unlikely) pending instances + {$endif FPCMM_LOCKLESSFREEMEDIUM} +end; + +procedure FreeAllMemory; +var large, nextlarge: PLargeBlockHeader; p: PSmallBlockType; i, size: PtrUInt; @@ -2759,9 +3331,13 @@ begin for i := 1 to NumSmallInfoBlock do begin {$ifdef FPCMM_LOCKLESSFREE} + {$ifdef FPCMM_REPORTMEMORYLEAKS} + if p^.BinCount <> 0 then + writeln('BinCount=', p^.BinCount, ' for small=', p^.BlockSize); + {$endif FPCMM_REPORTMEMORYLEAKS} for j := 0 to p^.BinCount - 1 do - if p^.BinInstance[i] <> nil then - _FreeMem(p^.BinInstance[i]); // release (unlikely) pending instances + if p^.BinInstance[j] <> nil then + _FreeMem(p^.BinInstance[j]); // release (unlikely) pending instances {$endif FPCMM_LOCKLESSFREE} p^.PreviousPartiallyFreePool := pointer(p); p^.NextPartiallyFreePool := pointer(p); @@ -2783,38 +3359,17 @@ begin if leaks <> 0 then writeln(' Total small block leaks = ', leaks); {$endif FPCMM_REPORTMEMORYLEAKS} - with MediumBlockInfo do - begin - medium := PoolsCircularList.NextMediumBlockPoolHeader; - while medium <> @PoolsCircularList do - begin - {$ifdef FPCMM_REPORTMEMORYLEAKS} - MediumMemoryLeakReport(medium); - {$endif FPCMM_REPORTMEMORYLEAKS} - nextmedium := medium.NextMediumBlockPoolHeader; - FreeMedium(medium); - medium := nextmedium; - end; - PoolsCircularList.PreviousMediumBlockPoolHeader := @PoolsCircularList; - PoolsCircularList.NextMediumBlockPoolHeader := @PoolsCircularList; - for i := 0 to MediumBlockBinCount - 1 do - begin - bin := @Bins[i]; - bin.PreviousFreeBlock := bin; - bin.NextFreeBlock := bin; - end; - BinGroupBitmap := 0; - SequentialFeedBytesLeft := 0; - for i := 0 to MediumBlockBinGroupCount - 1 do - BinBitmaps[i] := 0; - end; + {$ifdef FPCMM_SMALLNOTWITHMEDIUM} + FreeMediumPool(SmallMediumBlockInfo); + {$endif FPCMM_SMALLNOTWITHMEDIUM} + FreeMediumPool(MediumBlockInfo); large := LargeBlocksCircularList.NextLargeBlockHeader; while large <> @LargeBlocksCircularList do begin size := large.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; {$ifdef FPCMM_REPORTMEMORYLEAKS} StartReport; - writeln(' large block leak of ', K(size), 'B'); + writeln(' large block leak of ', size, ' bytes (', K(size), 'B)'); {$endif FPCMM_REPORTMEMORYLEAKS} nextlarge := large.NextLargeBlockHeader; FreeLarge(large, size); @@ -2830,17 +3385,17 @@ end; const NewMM: TMemoryManager = ( - NeedLock: false; - GetMem: @_Getmem; - FreeMem: @_FreeMem; - FreememSize: @_FreememSize; - AllocMem: @_AllocMem; - ReallocMem: @_ReAllocMem; - MemSize: @_MemSize; - InitThread: nil; - DoneThread: nil; - RelocateHeap: nil; - GetHeapStatus: @_GetHeapStatus; + NeedLock: false; + GetMem: @_Getmem; + FreeMem: @_FreeMem; + FreememSize: @_FreememSize; + AllocMem: @_AllocMem; + ReallocMem: @_ReAllocMem; + MemSize: @_MemSize; + InitThread: nil; + DoneThread: nil; + RelocateHeap: nil; + GetHeapStatus: @_GetHeapStatus; GetFPCHeapStatus: @_GetFPCHeapStatus); var @@ -2857,7 +3412,7 @@ finalization {$endif FPCMM_STANDALONE} -{$endif FPC_CPUX64} +{$endif FPCX64MM} end. diff --git a/contrib/mORMot/SynFastWideString.pas b/contrib/mORMot/SynFastWideString.pas index cf4d793..fb806ff 100644 --- a/contrib/mORMot/SynFastWideString.pas +++ b/contrib/mORMot/SynFastWideString.pas @@ -9,7 +9,7 @@ interface (* This file is part of Synopse Framework. - Synopse Framework. Copyright (C) 2020 Arnaud Bouchez + Synopse Framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -28,7 +28,7 @@ interface The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynGSSAPI.pas b/contrib/mORMot/SynGSSAPI.pas index b39e8a0..7922ed4 100644 --- a/contrib/mORMot/SynGSSAPI.pas +++ b/contrib/mORMot/SynGSSAPI.pas @@ -6,7 +6,7 @@ unit SynGSSAPI; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynGSSAPI; The Initial Developer of the Original Code is pavelmash/ssoftpro. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -303,46 +303,46 @@ type // - used to hold information between calls to ServerSSPIAuth TSecContextDynArray = array of TSecContext; - /// Sets aSecHandle fields to empty state for a given connection ID - procedure InvalidateSecContext(var aSecContext: TSecContext; aConnectionID: Int64); +/// Sets aSecHandle fields to empty state for a given connection ID +procedure InvalidateSecContext(var aSecContext: TSecContext; aConnectionID: Int64); - /// Free aSecContext on client or server side - procedure FreeSecContext(var aSecContext: TSecContext); +/// Free aSecContext on client or server side +procedure FreeSecContext(var aSecContext: TSecContext); - /// Encrypts a message - // - aSecContext must be set e.g. from previous success call to ServerSSPIAuth - // or ClientSSPIAuth - // - aPlain contains data that must be encrypted - // - returns encrypted message - function SecEncrypt(var aSecContext: TSecContext; const aPlain: TGSSAPIBuffer): TGSSAPIBuffer; +/// Encrypts a message +// - aSecContext must be set e.g. from previous success call to ServerSSPIAuth +// or ClientSSPIAuth +// - aPlain contains data that must be encrypted +// - returns encrypted message +function SecEncrypt(var aSecContext: TSecContext; const aPlain: TGSSAPIBuffer): TGSSAPIBuffer; - /// Decrypts a message - // - aSecContext must be set e.g. from previous success call to ServerSSPIAuth - // or ClientSSPIAuth - // - aEncrypted contains data that must be decrypted - // - returns decrypted message - function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TGSSAPIBuffer): TGSSAPIBuffer; +/// Decrypts a message +// - aSecContext must be set e.g. from previous success call to ServerSSPIAuth +// or ClientSSPIAuth +// - aEncrypted contains data that must be decrypted +// - returns decrypted message +function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TGSSAPIBuffer): TGSSAPIBuffer; - /// Checks the return value of GSSAPI call and raises ESynGSSAPI exception - // when it indicates failure - procedure GSSCheck(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String = ''); +/// Checks the return value of GSSAPI call and raises ESynGSSAPI exception +// when it indicates failure +procedure GSSCheck(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String = ''); - /// Lists supported security mechanisms in form - // sasl:name:description - // - not all mechanisms provide human readable name and description - procedure GSSEnlistMechsSupported(MechList: TStringList); +/// Lists supported security mechanisms in form +// sasl:name:description +// - not all mechanisms provide human readable name and description +procedure GSSEnlistMechsSupported(MechList: TStringList); - /// Dynamically load GSSAPI library - // - in multithreaded server application you must call LoadGSSAPI - // at startup to avoid race condition (if you do not use mORMot.pas) - procedure LoadGSSAPI; +/// Dynamically load GSSAPI library +// - in multithreaded server application you must call LoadGSSAPI +// at startup to avoid race condition (if you do not use mORMot.pas) +procedure LoadGSSAPI; - /// Call this function to check whether GSSAPI library loaded or not - function GSSAPILoaded: Boolean; +/// Call this function to check whether GSSAPI library loaded or not +function GSSAPILoaded: Boolean; - /// Call this function to check whether GSSAPI library loaded - // and raise exception if not. - procedure RequireGSSAPI; +/// Call this function to check whether GSSAPI library loaded +// and raise exception if not. +procedure RequireGSSAPI; implementation @@ -432,14 +432,16 @@ end; procedure RequireGSSAPI; begin if GSSAPILibrary=0 then - raise ENotSupportedException.Create('No GSSAPI library found - please install either MIT or Heimdal GSSAPI implementation'); + raise ENotSupportedException.Create( + 'No GSSAPI library found - please install ' + + 'either MIT or Heimdal GSSAPI implementation'); end; function gss_compare_oid(oid1, oid2: gss_OID): Boolean; begin if (oid1<>nil) and (oid2<>nil) then begin - Result := (oid1^.length = oid2^.length) - and CompareMem(oid1^.elements, oid2^.elements, oid1^.length); + Result := (oid1^.length = oid2^.length) and + CompareMem(oid1^.elements, oid2^.elements, oid1^.length); end else Result := False; diff --git a/contrib/mORMot/SynGSSAPIAuth.pas b/contrib/mORMot/SynGSSAPIAuth.pas index 1cae409..026f892 100644 --- a/contrib/mORMot/SynGSSAPIAuth.pas +++ b/contrib/mORMot/SynGSSAPIAuth.pas @@ -5,7 +5,7 @@ unit SynGSSAPIAuth; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynGSSAPIAuth; The Initial Developer of the Original Code is Chaa. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -133,6 +133,8 @@ var // - use only if automatic conversion (truncate on first dot) do it wrong ServerDomainMap: TSynNameValue; + + implementation var @@ -338,5 +340,5 @@ begin end; initialization - ServerDomainMap.Init(False); + ServerDomainMap.Init({casesensitive=}false); end. diff --git a/contrib/mORMot/SynGdiPlus.pas b/contrib/mORMot/SynGdiPlus.pas index e4bfe32..87e6d15 100644 --- a/contrib/mORMot/SynGdiPlus.pas +++ b/contrib/mORMot/SynGdiPlus.pas @@ -9,7 +9,7 @@ unit SynGdiPlus; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -28,7 +28,7 @@ unit SynGdiPlus; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -2285,7 +2285,7 @@ begin end; - { TGDIPlusEnum } +{ TGDIPlusEnum } type {$ifdef FPC} @@ -2365,7 +2365,7 @@ type end; const - GdipRectFNull: TGdipRectF = (X:0;Y:0;Width:0;Height:0); + GdipRectFNull: TGdipRectF = (X:0;Y:0;Width:0;Height:0); function DXTextWidth(DX: PIntegerArray; n: Integer): integer; var i: integer; diff --git a/contrib/mORMot/SynKylix.pas b/contrib/mORMot/SynKylix.pas index af7f2f6..d62cca4 100644 --- a/contrib/mORMot/SynKylix.pas +++ b/contrib/mORMot/SynKylix.pas @@ -4,7 +4,7 @@ unit SynKylix; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -23,7 +23,7 @@ unit SynKylix; The Initial Developer of the Original Code is Arnaud Bouchez - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynLZ.pas b/contrib/mORMot/SynLZ.pas index 960065a..1c66a66 100644 --- a/contrib/mORMot/SynLZ.pas +++ b/contrib/mORMot/SynLZ.pas @@ -5,7 +5,7 @@ unit SynLZ; { This file is part of Synopse SynLZ Compression. - Synopse SynLZ Compression. Copyright (C) 2020 Arnaud Bouchez + Synopse SynLZ Compression. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynLZ; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynLZO.pas b/contrib/mORMot/SynLZO.pas index 5afd4f7..bde3a5d 100644 --- a/contrib/mORMot/SynLZO.pas +++ b/contrib/mORMot/SynLZO.pas @@ -5,7 +5,7 @@ unit SynLZO; { This file is part of Synopse LZO Compression. - Synopse LZO Compression. Copyright (C) 2020 Arnaud Bouchez + Synopse LZO Compression. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynLZO; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynLizard.pas b/contrib/mORMot/SynLizard.pas index 0a943a4..37fad96 100644 --- a/contrib/mORMot/SynLizard.pas +++ b/contrib/mORMot/SynLizard.pas @@ -5,7 +5,7 @@ unit SynLizard; { This file is part of Synopse Lizard Compression. - Synopse Lizard Compression. Copyright (C) 2020 Arnaud Bouchez + Synopse Lizard Compression. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynLizard; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynLog.pas b/contrib/mORMot/SynLog.pas index fcddac5..ed6be48 100644 --- a/contrib/mORMot/SynLog.pas +++ b/contrib/mORMot/SynLog.pas @@ -6,7 +6,7 @@ unit SynLog; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynLog; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -121,7 +121,7 @@ type fUnit: TSynMapUnitDynArray; fSymbols: TDynArray; fUnits: TDynArrayHashed; - fUnitSynLogIndex,fUnitSystemIndex: integer; + fSymCount, fUnitCount, fUnitSynLogIndex, fUnitSystemIndex: integer; fCodeOffset: PtrUInt; fHasDebugInfo: boolean; public @@ -425,12 +425,12 @@ type // ! end; //- then use the logging system inside a method: // ! procedure TMyDB.MyMethod; - // ! var ILog: ISynLog; + // ! var log: ISynLog; // ! begin - // ! ILog := TSynLogDB.Enter(self,'MyMethod'); + // ! log := TSynLogDB.Enter(self,'MyMethod'); // ! // do some stuff - // ! ILog.Log(sllInfo,'method called'); - // ! end; + // ! log.Log(sllInfo,'method run with no problem and value=%',[value]); + // ! end; // here log will be released and method leaving will be logged TSynLogFamily = class protected fLevel, fLevelStackTrace: TSynLogInfos; @@ -476,6 +476,7 @@ type fRotateFileCount: cardinal; fRotateFileSize: cardinal; fRotateFileAtHour: integer; + fRotateFileNoCompression: boolean; function CreateSynLog: TSynLog; procedure StartAutoFlush; procedure SetDestinationPath(const value: TFileName); @@ -700,6 +701,8 @@ type // specified hour // - is not used if RotateFileCount is left to its default 0 property RotateFileDailyAtHour: integer read fRotateFileAtHour write fRotateFileAtHour; + /// if set to TRUE, no #.synlz will be created at rotation but plain #.log file + property RotateFileNoCompression: boolean read fRotateFileNoCompression write fRotateFileNoCompression; /// the recursive depth of stack trace symbol to write // - used only if exceptions are handled, or by sllStackTrace level // - default value is 30, maximum is 255 @@ -744,6 +747,7 @@ type /// if the method name is local, i.e. shall not be displayed at Leave() MethodNameLocal: (mnAlways, mnEnter, mnLeave, mnEnterOwnMethodName); end; + PSynLogThreadRecursion = ^TSynLogThreadRecursion; /// thread-specific internal context used during logging // - this structure is a hashed-per-thread variable @@ -850,6 +854,7 @@ type procedure AddRecursion(aIndex: integer; aLevel: TSynLogInfo); procedure LockAndGetThreadContext; {$ifdef HASINLINENOTX86}inline;{$endif} procedure GetThreadContextInternal; + function NewRecursion: PSynLogThreadRecursion; procedure ThreadContextRehash; function Instance: TSynLog; function ConsoleEcho(Sender: TTextWriter; Level: TSynLogInfo; @@ -895,19 +900,23 @@ type /// handle generic method enter / auto-leave tracing // - this is the main method to be called within a procedure/function to trace: // ! procedure TMyDB.SQLExecute(const SQL: RawUTF8); - // ! var ILog: ISynLog; + // ! var log: ISynLog; // ! begin - // ! ILog := TSynLogDB.Enter(self,'SQLExecute'); + // ! log := TSynLogDB.Enter(self,'SQLExecute'); // ! // do some stuff - // ! ILog.Log(sllInfo,'SQL=%',[SQL]); - // ! end; + // ! log.Log(sllInfo,'SQL=%',[SQL]); + // ! end; // here log will be released, and method leaving will be logged // - returning a ISynLog interface will allow you to have an automated // sllLeave log created when the method is left (thanks to the hidden // try..finally block generated by the compiler to protect the ISynLog var) - // - it is convenient to define a local variable to store the returned ISynLog - // and use it for any specific logging within the method execution - // - if you just need to access the log inside the method block, you may - // not need any ISynLog interface variable: + // - WARNING: due to a limitation (feature?) of the FPC compiler and + // Delphi 10.4 and later, you NEED to hold the returned value into a + // local ISynLog variable; as a benefit, it is always convenient to define + // a local variable to store the returned ISynLog and use it for any + // specific logging within the method execution + // - on Delphi earlier to 10.4 (and not FPC), you could just call Enter() + // inside the method block, without any ISynLog interface variable - but + // it is not very future-proof to write the following code: // ! procedure TMyDB.SQLFlush; // ! begin // ! TSynLogDB.Enter(self,'SQLFlush'); @@ -915,10 +924,12 @@ type // ! end; // - if no Method name is supplied, it will use the caller address, and // will write it as hexa and with full unit and symbol name, if the debugging - // information is available (i.e. if TSynMapFile retrieved the .map content): + // information is available (i.e. if TSynMapFile retrieved the .map content; + // note that this is not available yet on FPC): // ! procedure TMyDB.SQLFlush; + // ! var log: ISynLog; // ! begin - // ! TSynLogDB.Enter(self); + // ! log := TSynLogDB.Enter(self); // ! // do some stuff // ! end; // - note that supplying a method name is faster than using the .map content: @@ -935,16 +946,6 @@ type // $ 20110325 19325801 + MyDBUnit.TMyDB(004E11F4).SQLExecute // $ 20110325 19325801 info SQL=SELECT * FROM Table; // $ 20110325 19325801 - 01.512.320 - // - note that due to a limitation (feature?) of the FPC compiler, you need - // to hold the returned value into a local ISynLog variable, as such: - // ! procedure TMyDB.SQLFlush; - // ! var Log: ISynLog; - // ! begin - // ! Log := TSynLogDB.Enter(self); - // ! // do some stuff - // ! end; // here Log will be released - // otherwise, the ISynLog instance would be released just after the Enter() - // call, so the timing won't match the method execution class function Enter(aInstance: TObject=nil; aMethodName: PUTF8Char=nil; aMethodNameLocal: boolean=false): ISynLog; overload; /// handle method enter / auto-leave tracing, with some custom text @@ -1038,6 +1039,14 @@ type // be added to the log content (to be used e.g. with '--' for SQL statements) procedure LogLines(Level: TSynLogInfo; LinesToLog: PUTF8Char; aInstance: TObject=nil; const IgnoreWhenStartWith: PAnsiChar=nil); + /// manual low-level TSynLog.Enter execution without the ISynLog + // - may be used to log Enter/Leave stack from non-pascal code + // - each call to ManualEnter should be followed by a matching ManualLeave + // - aMethodName should be a not nil constant text + procedure ManualEnter(aMethodName: PUtf8Char; aInstance: TObject = nil); + /// manual low-level ISynLog release after TSynLog.Enter execution + // - each call to ManualEnter should be followed by a matching ManualLeave + procedure ManualLeave; /// allow to temporary disable remote logging // - to be used within a try ... finally section: // ! log.DisableRemoteLog(true); @@ -1764,8 +1773,12 @@ constructor TSynMapFile.Create(const aExeName: TFileName=''; MabCreate: boolean= end; end; procedure ReadSymbols; - var Beg: PAnsiChar; + var Beg: PUtf8Char; Sym: TSynMapSymbol; + {$ifdef ISDELPHI2005ANDUP} + u, l: PtrInt; + LastUnitUp: RawUTF8; // e.g. 'MORMOT.CORE.DATA.' + {$endif ISDELPHI2005ANDUP} begin NextLine; NextLine; @@ -1773,36 +1786,29 @@ constructor TSynMapFile.Create(const aExeName: TFileName=''; MabCreate: boolean= if GetCode(Sym.Start) then begin while (P' ') do inc(P); {$ifdef ISDELPHI2005ANDUP} // trim left 'UnitName.' for each symbol (since Delphi 2005) - case PWord(P)^ of // ignore RTL namespaces - ord('S')+ord('y') shl 8: - if IdemPChar(P+2,'STEM.') then - if IdemPChar(P+7,'WIN.') then inc(P,9) else - if IdemPChar(P+7,'RTTI.') then inc(P,10) else - if IdemPChar(P+7,'TYPES.') then inc(P,10) else - if IdemPChar(P+7,'ZLIB.') then inc(P,10) else - if IdemPChar(P+7,'CLASSES.') then inc(P,10) else - if IdemPChar(P+7,'SYSUTILS.') then inc(P,10) else - if IdemPChar(P+7,'VARUTILS.') then inc(P,10) else - if IdemPChar(P+7,'STRUTILS.') then inc(P,10) else - if IdemPChar(P+7,'SYNCOBJS.') then inc(P,10) else - if IdemPChar(P+7,'GENERICS.') then inc(P,16) else - if IdemPChar(P+7,'CHARACTER.') then inc(P,10) else - if IdemPChar(P+7,'TYPINFO.') then inc(P,10) else - if IdemPChar(P+7,'VARIANTS.') then inc(P,10); - ord('W')+ord('i') shl 8: if IdemPChar(P+2,'NAPI.') then inc(P,7); - ord('F')+ord('m') shl 8: if IdemPChar(P+2,'X.') then inc(P,7); - ord('V')+ord('c') shl 8: if IdemPChar(P+2,'L.') then inc(P,7); + if (LastUnitUp <> '') and IdemPChar(Beg, pointer(LastUnitUp)) then + // common case since symbols are grouped by address, i.e. by unit + inc(Beg, length(LastUnitUp)) + else begin // manual unit name search + LastUnitUp := ''; + for u := 0 to fUnits.Count - 1 do + with fUnit[u].Symbol do begin + l := length(Name); + if (Beg[l] = '.') and (l > length(LastUnitUp)) and + IdemPropNameU(Name, Beg, l) then + LastUnitUp := UpperCase(Name); // find longest match + end; + if LastUnitUp <> '' then begin + l := length(LastUnitUp); + SetLength(LastUnitUp, l + 1); + LastUnitUp[l] := '.'; + inc(Beg, l + 1); + end; end; - while (P'.') do if P^<=' ' then break else inc(P); - if P^='.' then begin - while (P' ') do inc(P); FastSetString(Sym.Name,Beg,P-Beg); if (Sym.Name<>'') and not (Sym.Name[1] in ['$','?']) then fSymbols.Add(Sym); @@ -1932,13 +1938,13 @@ constructor TSynMapFile.Create(const aExeName: TFileName=''; MabCreate: boolean= end; end; -var SymCount, UnitCount, i: integer; +var i: integer; MabFile: TFileName; MapAge, MabAge: TDateTime; U: RawUTF8; begin - fSymbols.Init(TypeInfo(TSynMapSymbolDynArray),fSymbol,@SymCount); - fUnits.Init(TypeInfo(TSynMapUnitDynArray),fUnit,nil,nil,nil,@UnitCount); + fSymbols.Init(TypeInfo(TSynMapSymbolDynArray),fSymbol,@fSymCount); + fUnits.Init(TypeInfo(TSynMapUnitDynArray),fUnit,nil,nil,nil,@fUnitCount); fUnitSynLogIndex := -1; fUnitSystemIndex := -1; // 1. search for an external .map file matching the running .exe/.dll name @@ -1962,19 +1968,19 @@ begin if (MapAge>0) and (MabAge0) then + if (fSymCount=0) and (MabAge<>0) then LoadMab(MabFile); // 3. search for an embedded compressed .mab file appended to the .exe/.dll - if SymCount=0 then + if fSymCount=0 then if aExeName='' then LoadMab(GetModuleName(hInstance)) else LoadMab(aExeName); // finalize symbols - if SymCount>0 then begin - for i := 1 to SymCount-1 do + if fSymCount>0 then begin + for i := 1 to fSymCount-1 do assert(fSymbol[i].Start>fSymbol[i-1].Stop); - SetLength(fSymbol,SymCount); - SetLength(fUnit,UnitCount); + SetLength(fSymbol,fSymCount); + SetLength(fUnit,fUnitCount); fSymbols.Init(TypeInfo(TSynMapSymbolDynArray),fSymbol); fUnits.Init(TypeInfo(TSynMapUnitDynArray),fUnit); if MabCreate then @@ -3736,6 +3742,20 @@ begin // should match TSynLog.ThreadContextRehash fThreadContext^.ID := fThreadID; end; +function TSynLog.NewRecursion: PSynLogThreadRecursion; +begin + with fThreadContext^ do begin + if RecursionCount = RecursionCapacity then begin + RecursionCapacity := NextGrow(RecursionCapacity); + SetLength(Recursion, RecursionCapacity); + end; + result := @Recursion[RecursionCount]; + result^.Caller := 0; // no stack trace by default + result^.RefCount := 0; + inc(RecursionCount); + end; +end; + procedure TSynLog.ThreadContextRehash; var i: integer; id, hash: PtrUInt; @@ -3809,7 +3829,7 @@ begin inc(RefCount); result := RefCount; end else - result := 1; // should never be 0 (mark release of TSynLog instance) + result := 1; // should never be 0 (would release of TSynLog instance) finally {$ifndef NOEXCEPTIONINTERCEPT} GlobalCurrentHandleExceptionSynLog := fThreadHandleExceptionBackup; @@ -3872,7 +3892,7 @@ begin result := RefCount; end; end else - result := 1; // should never be 0 (mark release of TSynLog) + result := 1; // should never be 0 (would release TSynLog instance) finally {$ifndef NOEXCEPTIONINTERCEPT} GlobalCurrentHandleExceptionSynLog := fThreadHandleExceptionBackup; @@ -3991,12 +4011,8 @@ begin // recursively store parameters if sllEnter in aSynLog.fFamily.fLevel then begin aSynLog.LockAndGetThreadContext; - with aSynLog.fThreadContext^ do + with aSynLog.NewRecursion^ do try - if RecursionCount=RecursionCapacity then begin - RecursionCapacity := NextGrow(RecursionCapacity); - SetLength(Recursion,RecursionCapacity); - end; {$ifdef CPU64} {$ifdef MSWINDOWS} if RtlCaptureStackBackTrace(1,1,@aStackFrame,nil)=0 then @@ -4017,16 +4033,12 @@ begin end; {$endif} {$endif} - with Recursion[RecursionCount] do begin - Instance := aInstance; - MethodName := aMethodName; - if aMethodNameLocal then - MethodNameLocal := mnEnter else - MethodNameLocal := mnAlways; - Caller := aStackFrame; - RefCount := 0; - end; - inc(RecursionCount); + Instance := aInstance; + MethodName := aMethodName; + if aMethodNameLocal then + MethodNameLocal := mnEnter else + MethodNameLocal := mnAlways; + Caller := aStackFrame; finally {$ifndef NOEXCEPTIONINTERCEPT} GlobalCurrentHandleExceptionSynLog := aSynLog.fThreadHandleExceptionBackup; @@ -4046,21 +4058,12 @@ begin aSynLog := Family.SynLog; if (aSynLog<>nil) and (sllEnter in aSynLog.fFamily.fLevel) then begin aSynLog.LockAndGetThreadContext; - with aSynLog.fThreadContext^ do + with aSynLog.NewRecursion^ do try - if RecursionCount=RecursionCapacity then begin - RecursionCapacity := NextGrow(RecursionCapacity); - SetLength(Recursion,RecursionCapacity); - end; - with Recursion[RecursionCount] do begin - Instance := aInstance; - MethodName := nil; // avoid GPF in RawUTF8(pointer(MethodName)) below - FormatUTF8(TextFmt,TextArgs,RawUTF8(pointer(MethodName))); - MethodNameLocal := mnEnterOwnMethodName; - Caller := 0; // No stack trace needed here - RefCount := 0; - end; - inc(RecursionCount); + Instance := aInstance; + MethodName := nil; // avoid GPF in RawUTF8(pointer(MethodName)) below + FormatUTF8(TextFmt,TextArgs,RawUTF8(pointer(MethodName))); + MethodNameLocal := mnEnterOwnMethodName; finally {$ifndef NOEXCEPTIONINTERCEPT} GlobalCurrentHandleExceptionSynLog := aSynLog.fThreadHandleExceptionBackup; @@ -4072,6 +4075,38 @@ begin result := aSynLog; end; +procedure TSynLog.ManualEnter(aMethodName: PUtf8Char; aInstance: TObject); +begin + if (self = nil) or + (fFamily.fLevel * [sllEnter, sllLeave] = []) then + exit; + if aMethodName = nil then + aMethodName := ' '; // something non void (call stack is irrelevant) + LockAndGetThreadContext; + try + with NewRecursion^ do begin + // inlined TSynLog.Enter + Instance := aInstance; + MethodName := aMethodName; + MethodNameLocal := mnEnter; + // inlined TSynLog._AddRef + if sllEnter in fFamily.Level then begin + LogHeaderLock(sllEnter, true); + AddRecursion(fThreadContext^.RecursionCount - 1, sllEnter); + end; + inc(RefCount); + end; + finally + LeaveCriticalSection(GlobalThreadLock); + end; +end; + +procedure TSynLog.ManualLeave; +begin + if self <> nil then + _Release; +end; + class function TSynLog.FamilyCreate: TSynLogFamily; var PVMT: pointer; begin // private sub function makes the code faster in most case @@ -4114,16 +4149,27 @@ function TSynLog.ConsoleEcho(Sender: TTextWriter; Level: TSynLogInfo; {$ifdef MSWINDOWS} var tmp: AnsiString; {$endif} +{$ifdef LINUXNOTBSD} +var + tmp, mtmp: RawUTF8; + jvec: Array[0..1] of TioVec; +{$endif} begin result := true; if not (Level in fFamily.fEchoToConsole) then exit; {$ifdef LINUXNOTBSD} if Family.EchoToConsoleUseJournal then begin + if length(Text)<18 then // should be at last "20200615 08003008 " + exit; + FormatUTF8('PRIORITY=%', [LOG_TO_SYSLOG[Level]],tmp); + jvec[0].iov_base := pointer(tmp); + jvec[0].iov_len := length(tmp); // skip time "20200615 08003008 ." - journal do it for us; and first space after it - if length(Text)>18 then - ExternalLibraries.sd_journal_print(longint(LOG_TO_SYSLOG[Level]), - [PUTF8Char(pointer(Text))+18]); + FormatUTF8('MESSAGE=%', [PUTF8Char(pointer(Text))+18],mtmp); + jvec[1].iov_base := pointer(mtmp); + jvec[1].iov_len := length(mtmp); + ExternalLibraries.sd_journal_sendv(@jvec[0],2); exit; end; {$endif} @@ -4546,6 +4592,7 @@ begin end; procedure TSynLog.PerformRotation; +const _LOG_SYNLZ: array[boolean] of TFileName = ('.synlz','.log'); var currentMaxSynLZ: cardinal; i: integer; FN: array of TFileName; @@ -4559,7 +4606,8 @@ begin if fFamily.fRotateFileCount>1 then begin SetLength(FN,fFamily.fRotateFileCount-1); for i := fFamily.fRotateFileCount-1 downto 1 do begin - FN[i-1] := ChangeFileExt(fFileName,'.'+IntToStr(i)+'.synlz'); + FN[i-1] := ChangeFileExt(fFileName, + '.'+IntToStr(i)+_LOG_SYNLZ[fFamily.fRotateFileNoCompression]); if (currentMaxSynLZ=0) and FileExists(FN[i-1]) then currentMaxSynLZ := i; end; @@ -4567,7 +4615,9 @@ begin DeleteFile(FN[currentMaxSynLZ-1]); // delete e.g. '9.synlz' for i := fFamily.fRotateFileCount-2 downto 1 do RenameFile(FN[i-1],FN[i]); // e.g. '8.synlz' -> '9.synlz' - FileSynLZ(fFileName,FN[0],LOG_MAGIC); // main -> '1.synlz' + if fFamily.fRotateFileNoCompression then + RenameFile(fFileName,FN[0]) else // main -> '1.log' + FileSynLZ(fFileName,FN[0],LOG_MAGIC); // main -> '1.synlz' end; DeleteFile(fFileName); end; @@ -4735,7 +4785,7 @@ begin if fWriterStream=nil then // go on if file creation fails (e.g. RO folder) fWriterStream := TFakeWriterStream.Create; if (fFileRotationSize>0) or (fFamily.FileExistsAction<>acOverwrite) then - fWriterStream.Seek(0,soFromEnd); // in rotation mode, append at the end + fWriterStream.Seek(0,soEnd); // in rotation mode, append at the end end; if fWriterClass=nil then // set to TTextWriterWithEcho or TJSONSerializer if mORMot.pas is linked @@ -4769,7 +4819,8 @@ begin end; procedure TSynLog.AddRecursion(aIndex: integer; aLevel: TSynLogInfo); -begin // aLevel = sllEnter,sllLeave or sllNone +begin + // at entry, aLevel is sllEnter, sllLeave or sllNone (from LogHeaderBegin) with fThreadContext^ do if cardinal(aIndex)=min_stack then - try - while (PtrUInt(stack)max_stack) or (st=min_stack then + try + while (PtrUInt(stack)max_stack) or (st 0 then begin - fIsJournald := true; + if unaligned(fStartDateTime) <> 0 then begin + if (fMap.Buffer+8)^ <> ' ' then //20200821 14450738 ... - syn log without header + fIsJournald := true; fHeaderLinesCount := 0; fLineHeaderCountToIgnore := 0; end; @@ -5128,8 +5180,8 @@ begin // 2. fast retrieval of header OK := false; try - // journald export - if fIsJournald then begin + // journald export or TSynLog WITHOUT regular header + if fIsJournald or (fLineHeaderCountToIgnore=0) then begin if LineSizeSmallerThan(1,34) then exit; Iso8601ToDateTimePUTF8CharVar(fLines[1],26,fStartDateTime); if fStartDateTime=0 then diff --git a/contrib/mORMot/SynMemoEx.pas b/contrib/mORMot/SynMemoEx.pas index 08c1731..802e441 100644 --- a/contrib/mORMot/SynMemoEx.pas +++ b/contrib/mORMot/SynMemoEx.pas @@ -5,7 +5,7 @@ unit SynMemoEx; { This file is part of Synopse extended TMemo - Synopse SynMemoEx. Copyright (C) 2020 Arnaud Bouchez + Synopse SynMemoEx. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynMemoEx; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -350,6 +350,7 @@ type {$ENDIF MEMOEX_DEFLAYOUT} end; + EComplete = class(EAbort); EMemoExError = class(Exception); {$IFDEF MEMOEX_UNDO} @@ -2071,7 +2072,6 @@ begin fillchar(FList[Index], sizeof(TParagraph), 0); // avoid memory bug Inc(FCount); AddParaStr(Index, S); - Changed; end; {$WARNINGS OFF} @@ -2275,7 +2275,9 @@ begin dec(FMemoEx.FUpdateLock); if FMemoEx.FUpdateLock = 0 then begin - {$IFDEF MEMOEX_EDITOR} FMemoEx.CantUndo; {$ENDIF MEMOEX_EDITOR} + {$IFDEF MEMOEX_EDITOR} + FMemoEx.CantUndo; + {$ENDIF MEMOEX_EDITOR} FMemoEx.TextAllChanged; FMemoEx.SetCaretInternal(0, 0); end; @@ -2777,8 +2779,10 @@ begin FCellRect.Height := Max(1, Size.cy); EditorClient.Canvas.Font := Font; Size := EditorClient.Canvas.TextExtent(BiggestSymbol); + { if FCellRect.Width <> Max(1, Size.cx) then raise EMemoExError.CreateFmt('Font %s has inconsistent width vs style', [Font.Name]); + } FDrawBitmap.Canvas.Font.Assign(Font); FDrawBitmap.Canvas.Brush.Assign(EditorClient.Canvas.Brush); FDrawBitmap.Width := Width; @@ -3477,8 +3481,6 @@ begin end; {$IFDEF MEMOEX_EDITOR} -type - EComplete = class(EAbort); procedure TCustomMemoEx.Command(ACommand: TEditCommand); var diff --git a/contrib/mORMot/SynMongoDB.pas b/contrib/mORMot/SynMongoDB.pas index d54f58b..8e10b80 100644 --- a/contrib/mORMot/SynMongoDB.pas +++ b/contrib/mORMot/SynMongoDB.pas @@ -6,7 +6,7 @@ unit SynMongoDB; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynMongoDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -1263,7 +1263,7 @@ type // be sent in the responseTo field from the database // - responseTo is the requestID taken from previous opQuery or opGetMore constructor Create(const FullCollectionName: RawUTF8; - opCode: TMongoOperation; requestID, responseTo: Integer); reintroduce; + opCode: TMongoOperation; requestID, responseTo: integer); reintroduce; /// append a query parameter as a BSON document // - param can be a TDocVariant, e.g. created with: // ! _JsonFast('{name:"John",age:{$gt:21}}'); @@ -1415,7 +1415,7 @@ type // $ { ReturnFieldsSelector: 1 } constructor Create(const FullCollectionName: RawUTF8; const Query, ReturnFieldsSelector: variant; NumberToReturn: integer; - NumberToSkip: Integer=0; Flags: TMongoQueryFlags=[]); reintroduce; + NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]); reintroduce; /// write the main parameters of the request as JSON procedure ToJSON(W: TTextWriter; Mode: TMongoJSONMode); override; /// retrieve the NumberToReturn parameter as set to the constructor @@ -1653,7 +1653,7 @@ type /// where in the cursor this reply is starting property StartingFrom: integer read fStartingFrom; /// number of documents in the reply - property DocumentCount: Integer read fNumberReturned; + property DocumentCount: integer read fNumberReturned; /// points to the first document binary // - i.e. just after the Reply header property FirstDocument: PAnsiChar read fFirstDocument; @@ -1814,14 +1814,16 @@ type // - in case of any error, the error message is returned as text // - in case of success, this method will return '' function RunCommand(const aDatabaseName: RawUTF8; - const command: variant; var returnedValue: variant): RawUTF8; overload; + const command: variant; var returnedValue: variant; + flags: TMongoQueryFlags=[]): RawUTF8; overload; /// run a database command, supplied as a TDocVariant, TBSONVariant or a // string, and return the raw BSON document array of received items // - this overloaded method can be used on huge content to avoid the slower // conversion to an array of TDocVariant instances // - in case of success, this method will return TRUE, or FALSE on error function RunCommand(const aDatabaseName: RawUTF8; - const command: variant; var returnedValue: TBSONDocument): boolean; overload; + const command: variant; var returnedValue: TBSONDocument; + flags: TMongoQueryFlags=[]): boolean; overload; /// return TRUE if the Open method has successfully been called property Opened: boolean read GetOpened; @@ -1850,17 +1852,20 @@ type // data because secondaries replicate operations from the primary with some // delay - ensure that your application can tolerate stale data if you choose // to use a non-primary mode - // - rpPrimary: Default mode - all operations read from the current replica + // - rpPrimary: Default mode - all operations read from the current replica // set primary // - rpPrimaryPreferred: in most situations, operations read from the primary // but if it is unavailable, operations read from secondary members. // - rpPsecondary: all operations read from the secondary members // of the replica set - // - rpPsecondaryPreferred: in most situations, operations read from + // - rpPsecondaryPreferred: in most situations, operations read from // secondary members but if no secondary members are available, operations // read from the primary + // rpNearest: read from the member of the replica set with the least network + // latency, irrespective of whether that member is a primary or secondary + // (in practice, we won't use latency, just a random distribution) TMongoClientReplicaSetReadPreference = ( - rpPrimary, rpPrimaryPreferred, rpSecondary, rpSecondaryPreferred); + rpPrimary, rpPrimaryPreferred, rpSecondary, rpSecondaryPreferred, rpNearest); /// define Write Concern property of a MongoDB connection // - Write concern describes the guarantee that MongoDB provides when @@ -1923,13 +1928,13 @@ type fLogReplyEventMaxSize: cardinal; fServerBuildInfo: variant; fServerBuildInfoNumber: cardinal; - fLatestReadConnectionIndex: integer; - procedure AfterOpen; virtual; - function GetOneReadConnection: TMongoConnection; + fLatestReadConnectionIndex: PtrInt; + procedure AfterOpen(ConnectionIndex: PtrInt); virtual; function GetBytesReceived: Int64; function GetBytesSent: Int64; function GetBytesTransmitted: Int64; - procedure Auth(const DatabaseName,UserName,Digest: RawUTF8; ForceMongoDBCR: boolean); + procedure Auth(const DatabaseName,UserName,Digest: RawUTF8; + ForceMongoDBCR: boolean; ConnectionIndex: PtrInt); function ReOpen: boolean; public /// prepare a connection to a MongoDB server or Replica Set @@ -1937,7 +1942,7 @@ type // is called // - you can specify multiple hosts, as CSV values, if necessary // - depending on the platform, you may request for a TLS secured connection - constructor Create(const Host: RawUTF8; Port: Integer=MONGODB_DEFAULTPORT; + constructor Create(const Host: RawUTF8; Port: integer=MONGODB_DEFAULTPORT; aTLS: boolean=false; const SecondaryHostCSV: RawUTF8=''; const SecondaryPortCSV: RawUTF8=''); overload; /// connect to a database on a remote MongoDB primary server // - this method won't use authentication, and will return the corresponding @@ -1967,6 +1972,8 @@ type // - will create a string from ServerBuildInfo object, e.g. as // $ 'MongoDB 3.2.0 mozjs mmapv1,wiredTiger' function ServerBuildInfoText: RawUTF8; + // select Connection in dependence of ReadPreference + function GetOneReadConnection: TMongoConnection; /// retrieve the server version and build information // - return the content as a TDocVariant document, e.g. // ! ServerBuildInfo.version = '2.4.9' @@ -2156,7 +2163,7 @@ type // either null or the single returned document) // - if the query does not have any matching record, it will return null function FindDoc(const Criteria, Projection: Variant; - NumberToReturn: integer=1; NumberToSkip: Integer=0; + NumberToReturn: integer=1; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]): variant; overload; /// select documents in a collection and returns a dvArray TDocVariant // instance containing the selected documents @@ -2173,7 +2180,7 @@ type // either null or the single returned document) // - if the query does not have any matching record, it will return null function FindDoc(Criteria: PUTF8Char; const Params: array of const; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]): variant; overload; /// find an existing document in a collection, by its _id field // - _id will identify the unique document to be retrieved @@ -2197,7 +2204,7 @@ type // field names to retrieve, or a TDocVariant or TBSONVariant with // projection operators procedure FindDocs(var result: TVariantDynArray; const Projection: variant; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]); overload; /// select documents in a collection and returns a dynamic array of // TDocVariant instance containing the selected documents @@ -2208,7 +2215,7 @@ type // projection operators procedure FindDocs(Criteria: PUTF8Char; const Params: array of const; var result: TVariantDynArray; const Projection: variant; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]); overload; /// select documents in a collection and returns a dynamic array of // TDocVariant instance containing the selected documents @@ -2219,7 +2226,7 @@ type // field names to retrieve, or a TDocVariant or TBSONVariant with // projection operators function FindDocs(Criteria: PUTF8Char; const Params: array of const; - const Projection: variant; NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + const Projection: variant; NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]): TVariantDynArray; overload; /// select documents in a collection and returns a JSON array of documents @@ -2242,7 +2249,7 @@ type // directly into JSON, in either modMongoStrict or modMongoShell layout // (modNoMongo will do the same as modMongoStrict) function FindJSON(const Criteria, Projection: Variant; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]; Mode: TMongoJSONMode=modMongoStrict): RawUTF8; overload; /// select documents in a collection and returns a JSON array of documents // containing the selected documents @@ -2258,14 +2265,14 @@ type // for one document - in this case, the returned instance won't be a '[..]' // JSON array, but either 'null' or a single '{..}' JSON object) function FindJSON(Criteria: PUTF8Char; const Params: array of const; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]; Mode: TMongoJSONMode=modMongoStrict): RawUTF8; overload; /// select documents in a collection and returns a JSON array of documents // containing the selected documents // - Criteria and Projection can specify the query selector as (extended) // JSON and parameters function FindJSON(Criteria: PUTF8Char; const CriteriaParams: array of const; - const Projection: variant; NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + const Projection: variant; NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]; Mode: TMongoJSONMode=modMongoStrict): RawUTF8; overload; /// select documents in a collection and returns a TBSONDocument instance @@ -2282,7 +2289,7 @@ type // - NumberToReturn can be left to its default maxInt value to return all // matching documents, or specify a limit (e.g. 1 for one document) function FindBSON(const Criteria, Projection: Variant; - NumberToReturn: integer=maxInt; NumberToSkip: Integer=0; + NumberToReturn: integer=maxInt; NumberToSkip: integer=0; Flags: TMongoQueryFlags=[]): TBSONDocument; /// insert one document, supplied as (extended) JSON and parameters, @@ -2465,7 +2472,7 @@ type // - optional NumberToSkip can specify the number of matching documents // to skip before counting function FindCount(Criteria: PUTF8Char; const Args,Params: array of const; - MaxNumberToReturn: integer=0; NumberToSkip: Integer=0): Int64; overload; + MaxNumberToReturn: integer=0; NumberToSkip: integer=0): Int64; overload; /// returns TRUE if the collection has no document, FALSE otherwise // - is much faster than Count, especially for huge collections function IsEmpty: boolean; @@ -2694,7 +2701,7 @@ var //betNull, betRegEx, betDeprecatedDbptr, betJS, betDeprecatedSymbol, 0, -1, -1, -1, -1, //betJSScope, betInt32, betTimestamp, betInt64, betDecimal128 - -1, sizeof(Integer), sizeof(Int64), SizeOf(Int64), Sizeof(TDecimal128)); + -1, sizeof(integer), sizeof(Int64), SizeOf(Int64), Sizeof(TDecimal128)); /// types which do not have an exact equivalency to a standard variant // type will be mapped as varUnknown - and will be changed into @@ -3018,7 +3025,7 @@ str:Kind := betString; end; function TBSONElement.FromDocument(const doc: TBSONDocument): boolean; -var n: Integer; +var n: integer; begin FillCharFast(self,sizeof(self),0); n := length(doc); @@ -3170,7 +3177,7 @@ begin result := false; end; -procedure BSONToDoc(BSON: PByte; var Result: Variant; ExpectedBSONLen: Integer; +procedure BSONToDoc(BSON: PByte; var Result: Variant; ExpectedBSONLen: integer; Option: TBSONDocArrayConversion); begin if Option=asBSONVariant then @@ -3483,7 +3490,7 @@ begin end; procedure TBSONWriter.BSONAdjustDocumentsSize(BSON: PByteArray); -var i: Integer; +var i: integer; begin for i := 0 to fDocumentCount-1 do with fDocument[i] do @@ -4180,7 +4187,7 @@ var bsonvalue: TBSONVariantData absolute Value; Return(betDecimal128,P+L+1,GotoEndOfObject); end; var Reg,Opt: PUTF8Char; - RegLen,OptLen: Integer; + RegLen,OptLen: integer; procedure ReturnRegEx(P: PUTF8Char; GotoEndOfObject: AnsiChar); var buf: PAnsiChar; begin @@ -4486,7 +4493,7 @@ end; function BSON(const NameValuePairs: array of const): TBSONDocument; var W: TBSONWriter; name: RawUTF8; - a: Integer; + a: integer; procedure WriteValue; var ndx: cardinal; begin @@ -4715,10 +4722,10 @@ const CLIENT_OPCODES = [opUpdate,opInsert,opQuery,opGetMore,opDelete,opKillCursors]; var - GlobalRequestID: Integer; + GlobalRequestID: integer; constructor TMongoRequest.Create(const FullCollectionName: RawUTF8; - opCode: TMongoOperation; requestID, responseTo: Integer); + opCode: TMongoOperation; requestID, responseTo: integer); begin if not (opCode in CLIENT_OPCODES) then raise EMongoException.CreateUTF8('Unexpected %.Create(opCode=%)',[self,ToText(opCode)^]); @@ -4875,7 +4882,7 @@ end; constructor TMongoRequestQuery.Create(const FullCollectionName: RawUTF8; const Query, ReturnFieldsSelector: variant; NumberToReturn: integer; - NumberToSkip: Integer=0; Flags: TMongoQueryFlags=[]); + NumberToSkip: integer; Flags: TMongoQueryFlags); begin inherited Create(FullCollectionName,opQuery,0,0); fNumberToReturn := NumberToReturn; @@ -5490,10 +5497,10 @@ begin end; function TMongoConnection.RunCommand(const aDatabaseName: RawUTF8; - const command: variant; var returnedValue: variant): RawUTF8; + const command: variant; var returnedValue: variant; flags: TMongoQueryFlags): RawUTF8; begin GetDocumentsAndFree( - TMongoRequestQuery.Create(aDatabaseName+'.$cmd',command,null,1), + TMongoRequestQuery.Create(aDatabaseName+'.$cmd',command,null,1,0,flags), returnedValue); with _Safe(returnedValue)^ do if GetValueOrDefault('ok',1)<>0 then @@ -5503,11 +5510,12 @@ begin end; function TMongoConnection.RunCommand(const aDatabaseName: RawUTF8; - const command: variant; var returnedValue: TBSONDocument): boolean; + const command: variant; var returnedValue: TBSONDocument; + flags: TMongoQueryFlags): boolean; var item: TBSONElement; begin returnedValue := GetBSONAndFree( - TMongoRequestQuery.Create(aDatabaseName+'.$cmd',command,null,1)); + TMongoRequestQuery.Create(aDatabaseName+'.$cmd',command,null,1,0,flags)); result := true; item.FromDocument(returnedValue); if item.DocItemToInteger('ok',1)=0 then @@ -5647,7 +5655,7 @@ end; { TMongoClient } -constructor TMongoClient.Create(const Host: RawUTF8; Port: Integer; +constructor TMongoClient.Create(const Host: RawUTF8; Port: integer; aTLS: boolean; const SecondaryHostCSV, SecondaryPortCSV: RawUTF8); const PROT: array[boolean] of string[1] = ('', 's'); var secHost: TRawUTF8DynArray; @@ -5711,40 +5719,41 @@ begin end; function TMongoClient.GetOneReadConnection: TMongoConnection; -function GetUnlockedSecondaryIndex: integer; -var retry: integer; -begin - if Length(fConnections)=1 then // no secondary? use primary - result := 0 else begin - for retry := 1 to 100 do begin // search for an inactive connection - result := fLatestReadConnectionIndex; // simple round-robin pattern - if result=high(fConnections) then - if ReadPreference=rpSecondary then - result := 1 else - result := 0 else - inc(result); // thread-safety is not an issue here - if (retry<=length(fConnections)) and not fConnections[result].Opened then - try - fConnections[result].Open; - except - on E: Exception do - begin - SleepHiRes(2); - continue; + function GetUnlockedSecondaryIndex: PtrInt; + var retry: integer; + begin + if Length(fConnections)=1 then // no secondary? use primary + result := 0 else begin + for retry := 1 to 100 do begin // search for an inactive connection + result := fLatestReadConnectionIndex; // simple round-robin pattern + if result=high(fConnections) then + if ReadPreference=rpSecondary then + result := 1 else + result := 0 else + inc(result); // thread-safety is not an issue here + if (retry<=length(fConnections)) and not fConnections[result].Opened then + try + fConnections[result].Open; + except + on E: Exception do + begin + SleepHiRes(2); + continue; + end; end; + if fConnections[result].Opened then + if fConnections[result].Locked then + if retry mod length(fConnections)=0 then + SleepHiRes(2) else + continue else + break; end; - if fConnections[result].Opened then - if fConnections[result].Locked then - if retry mod length(fConnections)=0 then - SleepHiRes(2) else - continue else - break; + if not fConnections[result].Opened then + result := 0; // safe fallback to primary member in worst case + fLatestReadConnectionIndex := result; end; - if not fConnections[result].Opened then - result := 0; // safe fallback to primary member in worst case - fLatestReadConnectionIndex := result; end; -end; +var n, retry: integer; begin case ReadPreference of rpPrimaryPreferred: @@ -5753,7 +5762,15 @@ begin result := fConnections[0]; rpSecondary, rpSecondaryPreferred: result := fConnections[GetUnlockedSecondaryIndex]; - else // rpPrimary: + rpNearest: begin + n := Length(fConnections); + for retry := 1 to n*2 do begin + result := fConnections[Random32(n)]; + if not result.Locked then + exit; + end; + result := fConnections[0]; // falback to the main instance + end else // rpPrimary or not handled yet result := fConnections[0]; end; end; @@ -5766,7 +5783,7 @@ begin if result=nil then begin // not already opened -> try now from primary host if not fConnections[0].Opened then begin fConnections[0].Open; - AfterOpen; + AfterOpen(0); end; result := TMongoDatabase.Create(Self,DatabaseName); fDatabases.AddObjectUnique(DatabaseName,@result); @@ -5782,29 +5799,32 @@ end; function TMongoClient.OpenAuth(const DatabaseName,UserName,PassWord: RawUTF8; ForceMongoDBCR: boolean): TMongoDatabase; var digest: RawByteString; + i: PtrInt; begin if (self=nil) or (DatabaseName='') or (UserName='') or (PassWord='') then raise EMongoException.CreateUTF8('Invalid %.OpenAuth("%") call',[self,DatabaseName]); result := fDatabases.GetObjectFrom(DatabaseName); - if result=nil then // not already opened -> try now from primary host - try // note: authentication works on a single database per socket connection - if not fConnections[0].Opened then - try - fConnections[0].Open; // socket connection - AfterOpen; // need ServerBuildInfoNumber just below - digest := PasswordDigest(UserName,Password); - Auth(DatabaseName,UserName,digest,ForceMongoDBCR); - with fGracefulReconnect do - if Enabled and (EncryptedDigest='') then begin - ForcedDBCR := ForceMongoDBCR; - User := UserName; - Database := DatabaseName; - EncryptedDigest := CryptDataForCurrentUser(digest,Database,true); + if result=nil then // not already opened -> try now + try + // ensure we are opened and authenticated on all connections + for i := 0 to High(fConnections) do + if not fConnections[i].Opened then + try + fConnections[i].Open; // socket connection + AfterOpen(i); // need ServerBuildInfoNumber just below + digest := PasswordDigest(UserName,Password); + Auth(DatabaseName,UserName,digest,ForceMongoDBCR, i); + with fGracefulReconnect do + if Enabled and (EncryptedDigest='') then begin + ForcedDBCR := ForceMongoDBCR; + User := UserName; + Database := DatabaseName; + EncryptedDigest := CryptDataForCurrentUser(digest,Database,true); + end; + except + fConnections[i].Close; + raise; end; - except - fConnections[0].Close; - raise; - end; result := TMongoDatabase.Create(Self,DatabaseName); fDatabases.AddObjectUnique(DatabaseName,@result); finally @@ -5813,7 +5833,7 @@ begin end; procedure TMongoClient.Auth(const DatabaseName,UserName,Digest: RawUTF8; - ForceMongoDBCR: boolean); + ForceMongoDBCR: boolean; ConnectionIndex: PtrInt); var res,bson: variant; err,nonce,first,key,user,msg,rnonce: RawUTF8; payload: RawByteString; @@ -5840,7 +5860,7 @@ begin // caller should have made fConnections[0].Open // MONGODB-CR // http://docs.mongodb.org/meta-driver/latest/legacy/implement-authentication-in-driver bson := BSONVariant(['getnonce',1]); - err := fConnections[0].RunCommand(DatabaseName,bson,res); + err := fConnections[ConnectionIndex].RunCommand(DatabaseName,bson,res); if (err='') and not _Safe(res)^.GetAsRawUTF8('nonce',nonce) then err := 'missing returned nonce'; if err<>'' then @@ -5848,7 +5868,7 @@ begin // caller should have made fConnections[0].Open [self,DatabaseName,err,res]); key := MD5(nonce+UserName+Digest); bson := BSONVariant(['authenticate',1,'user',UserName,'nonce',nonce,'key',key]); - err := fConnections[0].RunCommand(DatabaseName,bson,res); + err := fConnections[ConnectionIndex].RunCommand(DatabaseName,bson,res); if err<>'' then raise EMongoException.CreateUTF8('%.OpenAuthCR("%") step2: % - res=%', [self,DatabaseName,err,res]); @@ -5860,7 +5880,7 @@ begin // caller should have made fConnections[0].Open nonce := BinToBase64(@rnd,sizeof(rnd)); FormatUTF8('n=%,r=%',[user,nonce],first); BSONVariantType.FromBinary('n,,'+first,bbtGeneric,bson); - err := fConnections[0].RunCommand(DatabaseName,BSONVariant([ + err := fConnections[ConnectionIndex].RunCommand(DatabaseName,BSONVariant([ 'saslStart',1,'mechanism','SCRAM-SHA-1','payload',bson,'autoAuthorize',1]),res); CheckPayload; if err='' then begin @@ -5882,7 +5902,7 @@ begin // caller should have made fConnections[0].Open HMAC_SHA1(server,msg,server); msg := key+',p='+BinToBase64(@client,SizeOf(client)); BSONVariantType.FromBinary(msg,bbtGeneric,bson); - err := fConnections[0].RunCommand(DatabaseName,BSONVariant([ + err := fConnections[ConnectionIndex].RunCommand(DatabaseName,BSONVariant([ 'saslContinue',1,'conversationId',res.conversationId,'payload',bson]),res); resp.Clear; CheckPayload; @@ -5893,7 +5913,7 @@ begin // caller should have made fConnections[0].Open [self,DatabaseName,err,res]); if not res.done then begin // third empty challenge may be required - err := fConnections[0].RunCommand(DatabaseName,BSONVariant([ + err := fConnections[ConnectionIndex].RunCommand(DatabaseName,BSONVariant([ 'saslContinue',1,'conversationId',res.conversationId,'payload','']),res); if (err='') and not res.done then err := 'SASL conversation failed to complete'; @@ -5904,10 +5924,10 @@ begin // caller should have made fConnections[0].Open end; end; -procedure TMongoClient.AfterOpen; +procedure TMongoClient.AfterOpen(ConnectionIndex: PtrInt); begin if VarIsEmptyOrNull(fServerBuildInfo) then begin - fConnections[0].RunCommand('admin','buildinfo',fServerBuildInfo); + fConnections[ConnectionIndex].RunCommand('admin','buildinfo',fServerBuildInfo); with _Safe(fServerBuildInfo)^.A['versionArray']^ do if Count=4 then fServerBuildInfoNumber := // e.g. 2040900 for MongoDB 2.4.9 @@ -5929,7 +5949,7 @@ begin if EncryptedDigest<>'' then try digest := CryptDataForCurrentUser(EncryptedDigest,Database,false); - Auth(Database,User,digest,ForcedDBCR); + Auth(Database,User,digest,ForcedDBCR,0); finally FillZero(digest); end; @@ -5982,7 +6002,7 @@ var colls: TBSONIterator; full,db,coll: RawUTF8; resp,batch: variant; mc: TMongoCollection; - ndx: Integer; + ndx: integer; begin fClient := aClient; fName := aDatabaseName; @@ -6245,7 +6265,7 @@ end; procedure TMongoCollection.EnsureIndex(const Keys: array of RawUTF8; Ascending, Unique: boolean); -const Order: array[boolean] of Integer = (-1,1); +const Order: array[boolean] of integer = (-1,1); var k,opt: variant; A: integer; begin @@ -6275,7 +6295,7 @@ end; function TMongoCollection.FindCount(Criteria: PUTF8Char; const Args,Params: array of const; - MaxNumberToReturn: integer=0; NumberToSkip: Integer=0): Int64; + MaxNumberToReturn, NumberToSkip: integer): Int64; var cmd: RawUTF8; res: variant; begin @@ -6296,7 +6316,7 @@ begin // much faster than Count>0 for huge collections end; function TMongoCollection.FindBSON(const Criteria, Projection: Variant; - NumberToReturn, NumberToSkip: Integer; Flags: TMongoQueryFlags): TBSONDocument; + NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags): TBSONDocument; begin result := Database.Client.GetOneReadConnection.GetBSONAndFree( TMongoRequestQuery.Create(fFullCollectionName, @@ -6304,7 +6324,7 @@ begin end; function TMongoCollection.FindDoc(const Criteria, Projection: Variant; - NumberToReturn, NumberToSkip: Integer; Flags: TMongoQueryFlags): variant; + NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags): variant; begin Database.Client.GetOneReadConnection.GetDocumentsAndFree( TMongoRequestQuery.Create(fFullCollectionName, @@ -6312,7 +6332,7 @@ begin end; function TMongoCollection.FindDoc(Criteria: PUTF8Char; - const Params: array of const; NumberToReturn, NumberToSkip: Integer; + const Params: array of const; NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags): variant; begin result := FindDoc(BSONVariant(Criteria,[],Params),null, @@ -6321,7 +6341,7 @@ end; procedure TMongoCollection.FindDocs(Criteria: PUTF8Char; const Params: array of const; var result: TVariantDynArray; - const Projection: variant; NumberToReturn, NumberToSkip: Integer; + const Projection: variant; NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags); begin Database.Client.GetOneReadConnection.GetDocumentsAndFree( @@ -6331,7 +6351,7 @@ begin end; function TMongoCollection.FindDocs(Criteria: PUTF8Char; const Params: array of const; - const Projection: variant; NumberToReturn,NumberToSkip: Integer; + const Projection: variant; NumberToReturn,NumberToSkip: integer; Flags: TMongoQueryFlags): TVariantDynArray; begin FindDocs(Criteria,Params,result,Projection,NumberToReturn,NumberToSkip,Flags); @@ -6356,7 +6376,7 @@ begin end; procedure TMongoCollection.FindDocs(var result: TVariantDynArray; - const Projection: variant; NumberToReturn, NumberToSkip: Integer; + const Projection: variant; NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags); begin Database.Client.GetOneReadConnection.GetDocumentsAndFree( @@ -6365,7 +6385,7 @@ begin end; function TMongoCollection.FindJSON(const Criteria, Projection: Variant; - NumberToReturn, NumberToSkip: Integer; Flags: TMongoQueryFlags; + NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags; Mode: TMongoJSONMode): RawUTF8; begin result := Database.Client.GetOneReadConnection.GetJSONAndFree( @@ -6374,7 +6394,7 @@ begin end; function TMongoCollection.FindJSON(Criteria: PUTF8Char; - const Params: array of const; NumberToReturn, NumberToSkip: Integer; + const Params: array of const; NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags; Mode: TMongoJSONMode): RawUTF8; begin result := FindJSON(BSONVariant(Criteria,[],Params),null, @@ -6383,7 +6403,7 @@ end; function TMongoCollection.FindJSON( Criteria: PUTF8Char; const CriteriaParams: array of const; - const Projection: variant; NumberToReturn, NumberToSkip: Integer; + const Projection: variant; NumberToReturn, NumberToSkip: integer; Flags: TMongoQueryFlags; Mode: TMongoJSONMode): RawUTF8; begin result := FindJSON(BSONVariant(Criteria,[],CriteriaParams), @@ -6398,7 +6418,7 @@ begin end; procedure TMongoCollection.Insert(const Documents: TBSONDocument; - Flags: TMongoInsertFlags=[]; NoAcknowledge: boolean=false); + Flags: TMongoInsertFlags; NoAcknowledge: boolean); begin Database.Client.Connections[0].SendAndFree(TMongoRequestInsert.Create( fFullCollectionName,Documents,Flags),NoAcknowledge); @@ -6612,19 +6632,24 @@ begin end; function div128bits9digits(var value: THash128Rec): PtrUInt; -var r64: QWord; +var r: QWord; i: PtrInt; begin - r64 := 0; + r := 0; for i := 0 to high(value.c) do begin - r64 := r64 shl 32; // adjust remainder to match value of next dividend - inc(r64,value.c[i]); // add the divided to _rem - if r64=0 then + {$ifdef FPC_32} // circumvent bug at least with FPC 3.2 + Int64Rec(r).Hi := Int64Rec(r).Lo; + Int64Rec(r).Lo := 0; + {$else} + r := r shl 32; // adjust remainder to match value of next dividend + {$endif FPC_32} + inc(r,value.c[i]); // add the divided to _rem + if r=0 then continue; - value.c[i] := r64 div 1000000000; - dec(r64,QWord(value.c[i])*1000000000); + value.c[i] := r div 1000000000; + dec(r,QWord(value.c[i])*1000000000); end; - result := r64; + result := r; end; procedure append(var dest: PUTF8Char; var dig: PByte; digits: PtrInt); diff --git a/contrib/mORMot/SynMustache.pas b/contrib/mORMot/SynMustache.pas index 6c18a67..7e86dcb 100644 --- a/contrib/mORMot/SynMustache.pas +++ b/contrib/mORMot/SynMustache.pas @@ -6,7 +6,7 @@ unit SynMustache; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynMustache; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynOleDB.pas b/contrib/mORMot/SynOleDB.pas index 3a16cb4..77428e1 100644 --- a/contrib/mORMot/SynOleDB.pas +++ b/contrib/mORMot/SynOleDB.pas @@ -6,7 +6,7 @@ unit SynOleDB; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynOleDB; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -603,6 +603,7 @@ type { -------------- TOleDB* OleDB classes and types } + type /// generic Exception type, generated for OleDB connection EOleDBException = class(ESQLDBException); @@ -2792,6 +2793,7 @@ type bClass: byte; wLineNumber: word; end; + /// to retrieve enhanced Microsoft SQL Server error information ISQLServerErrorInfo = interface(IUnknown) ['{5CF4CA12-EF21-11d0-97E7-00C04FC2AD98}'] function GetErrorInfo(out ppErrorInfo: PSSERRORINFO; @@ -3188,6 +3190,7 @@ initialization {$ifndef CPU64} // Jet is not available on Win64 TOleDBJetConnectionProperties.RegisterClassNameForDefinition; {$endif} + TOleDBACEConnectionProperties.RegisterClassNameForDefinition; TOleDBAS400ConnectionProperties.RegisterClassNameForDefinition; TOleDBODBCSQLConnectionProperties.RegisterClassNameForDefinition; diff --git a/contrib/mORMot/SynOpenSSL.pas b/contrib/mORMot/SynOpenSSL.pas index 52e2483..a310f33 100644 --- a/contrib/mORMot/SynOpenSSL.pas +++ b/contrib/mORMot/SynOpenSSL.pas @@ -6,7 +6,7 @@ unit SynOpenSSL; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynOpenSSL; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynPdf.pas b/contrib/mORMot/SynPdf.pas index ab8257d..8156fab 100644 --- a/contrib/mORMot/SynPdf.pas +++ b/contrib/mORMot/SynPdf.pas @@ -6,7 +6,7 @@ unit SynPdf; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynPdf; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -41,6 +41,7 @@ unit SynPdf; Harald Simon Josh Kelley (joshkel) Karel (vandrovnik) + Kukhtin Igor LoukaO Marsh MChaos @@ -69,7 +70,7 @@ unit SynPdf; Sponsors: https://synopse.info/fossil/wiki?name=HelpDonate Ongoing development and maintenance of the SynPDF library was sponsored in part by: - http://www.helpndoc.com + https://www.helpndoc.com Easy to use yet powerful help authoring environment which can generate various documentation formats from a single source. Thanks for your contribution! @@ -88,6 +89,14 @@ unit SynPdf; {$define NO_USE_BITMAP} {$endif} +{.$define USE_PDFALEVEL} +{ - if defined, the TPdfDocument*.Create() constructor will have an PDF/A level + value instead of the boolean value PDFA1} +{$ifdef NO_USE_PDFALEVEL} + { this special conditional can be set globaly for an application which doesn't + need the PDF/A level features } + {$undef USE_PDFALEVEL} +{$endif} {$define USE_PDFSECURITY} { - if defined, the TPdfDocument*.Create() constructor will have an additional @@ -103,8 +112,8 @@ unit SynPdf; { - if defined, the PDF engine will use the Windows Uniscribe API to render Ordering and Shaping of the text (useful for Hebrew, Arabic and some Asiatic languages) - - this feature need the TPdfDocument.UseUniscribe property to be forced to true - according to the language of the text you want to render + - this feature need the TPdfDocument.UseUniscribe property to be forced to + true according to the language of the text you want to render - can be undefined to safe some KB if you're sure you won't need it } {$ifdef NO_USE_UNISCRIBE} { this special conditional can be set globaly for an application which doesn't @@ -287,6 +296,7 @@ type indexToLocFormat: SmallInt; glyphDataFormat: SmallInt end; + PCmapHEAD = ^TCmapHEAD; /// header for the 'cmap' Format 4 table // - this is a two-byte encoding format TCmapFmt4 = packed record @@ -311,6 +321,9 @@ type /// the internal pdf file format TPdfFileFormat = (pdf13, pdf14, pdf15, pdf16); + /// the PDF/A level + TPdfALevel = (pdfaNone, pdfa1A, pdfa1B, pdfa2A, pdfa2B, pdfa3A, pdfa3B); + /// PDF exception, raised when an invalid value is given to a constructor EPdfInvalidValue = class(Exception); @@ -833,6 +846,10 @@ type TPdfName = class(TPdfText) protected procedure InternalWriteTo(W: TPdfWrite); override; + public + /// append the 'SUBSET+' prefix to the Value + // - used e.g. to notify that a font is included as a subset + procedure AppendPrefix; end; /// used to store an array of PDF objects @@ -1176,7 +1193,7 @@ type /// internal temporary variable - used by CreateOutline fLastOutline: TPdfOutlineEntry; fFileFormat: TPdfFileFormat; - fPDFA1: boolean; + fPDFA: TPdfALevel; fSaveToStreamWriter: TPdfWrite; {$ifdef USE_PDFSECURITY} fEncryption: TPdfEncryption; @@ -1195,7 +1212,11 @@ type procedure SetDefaultPageHeight(const Value: cardinal); procedure SetDefaultPageWidth(const Value: cardinal); procedure SetUseOptionalContent(const Value: boolean); + procedure SetPDFA(const Value: TPdfALevel); + {$ifndef USE_PDFALEVEL} + function GetPDFA1: boolean; procedure SetPDFA1(const Value: boolean); + {$endif} function GetDefaultPageLandscape: boolean; procedure SetDefaultPageLandscape(const Value: boolean); procedure SetFontFallBackName(const Value: string); @@ -1240,10 +1261,11 @@ type // - note that only Win-Ansi encoding allows use of embedded standard fonts // - you can specify a Code Page to be used for the PDFString encoding; // by default (ACodePage left to 0), the current system code page is used - // - you can create a PDF/A-1 compliant document by setting APDFA1 to true + // - you can create a PDF/A compliant document by setting APDFA to PDF/A Level + // or APDFA1 to true // - you can set an encryption instance, by using TPdfEncryption.New() constructor Create(AUseOutlines: Boolean=false; ACodePage: integer=0; - APDFA1: boolean=false + {$ifdef USE_PDFALEVEL]}APDFA: TPdfALevel=pdfaNone{$else}APDFA1: boolean=false{$endif} {$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption=nil{$endif}); reintroduce; /// release the PDF document instance destructor Destroy; override; @@ -1253,6 +1275,11 @@ type procedure NewDoc; /// add a Page to the current PDF document function AddPage: TPdfPage; virtual; + /// register a font to the internal TTF font list + // - some fonts may not be enumerated in the system, e.g. after calling + // AddFontMemResourceEx, so could be registered by this method + // - to be called just after Create(), before anything is written + function AddTrueTypeFont(const TTFName: RawUtf8): boolean; /// create a Pages object // - Pages objects can be nested, to save memory used by the Viewer // - only necessary if you have more than 8000 pages (this method is called @@ -1464,12 +1491,20 @@ type // the native resolution of the PDF, i.e. more than 7200 DPI (since we // write coordinates with 2 decimals per point - which is 1/72 inch) property ScreenLogPixels: Integer read FScreenLogPixels write FScreenLogPixels; + /// is pdfaXXX if the file was created in order to be PDF/A compliant + // - set APDFA parameter to a level for Create constructor in order to use it + // - warning: setting a value to this propery after creation will call the + // NewDoc method, therefore will erase all previous content and pages + // (including Info properties) + property PDFA: TPdfALevel read fPDFA write SetPDFA; + {$ifndef USE_PDFALEVEL} /// is TRUE if the file was created in order to be PDF/A-1 compliant // - set APDFA1 parameter to true for Create constructor in order to use it // - warning: setting a value to this propery after creation will call the // NewDoc method, therefore will erase all previous content and pages // (including Info properties) - property PDFA1: boolean read fPDFA1 write SetPDFA1; + property PDFA1: boolean read GetPDFA1 write SetPDFA1; + {$endif} /// set to TRUE to force PDF 1.5 format, which may produce smaller files property GeneratePDF15File: boolean read GetGeneratePDF15File write SetGeneratePDF15File; end; @@ -1510,24 +1545,24 @@ type // the index in Text, not the glyphs index function MeasureText(const Text: PDFString; Width: Single): integer; public - /// retrieve or set the word Space attribute + /// retrieve or set the word Space attribute, in PDF coordinates of 1/72 inch property WordSpace: Single read FWordSpace write SetWordSpace; - /// retrieve or set the Char Space attribute + /// retrieve or set the Char Space attribute, in PDF coordinates of 1/72 inch property CharSpace: Single read FCharSpace write SetCharSpace; - /// retrieve or set the Horizontal Scaling attribute + /// retrieve or set the Horizontal Scaling attribute, in PDF coordinates of 1/72 inch property HorizontalScaling: Single read FHorizontalScaling write SetHorizontalScaling; - /// retrieve or set the text Leading attribute + /// retrieve or set the text Leading attribute, in PDF coordinates of 1/72 inch property Leading: Single read FLeading write SetLeading; - /// retrieve or set the font Size attribute + /// retrieve or set the font Size attribute, in system TFont.Size units property FontSize: Single read FFontSize write SetFontSize; /// retrieve the current used font // - for TPdfFontTrueType, this points not always to the WinAnsi version of // the Font, but can also point to the Unicode Version, if the last // drawn character by ShowText() was unicode - see TPdfWrite.AddUnicodeHexText property Font: TPdfFont read FFont write FFont; - /// retrieve or set the current page width + /// retrieve or set the current page width, in PDF coordinates of 1/72 inch property PageWidth: integer read GetPageWidth write SetPageWidth; - /// retrieve or set the current page height + /// retrieve or set the current page height, in PDF coordinates of 1/72 inch property PageHeight: integer read GetPageHeight write SetPageHeight; /// retrieve or set the paper orientation property PageLandscape: Boolean read GetPageLandscape write SetPageLandscape; @@ -1580,7 +1615,8 @@ type // = XOff,YOff parameters specified in RenderMetaFile() FOffsetXDef, FOffsetYDef: Single; // WorldTransform factor and offs - FWorldFactorX, FWorldFactorY, FWorldOffsetX, FWorldOffsetY: single; + FWorldFactorX, FWorldFactorY, FWorldOffsetX, FWorldOffsetY, FAngle, + FWorldCos, FWorldSin: single; FDevScaleX, FDevScaleY: single; FWinSize, FViewSize: TSize; FWinOrg, FViewOrg: TPoint; @@ -2019,7 +2055,7 @@ type // - use the GDIComment*() functions to append the corresponding // EMR_GDICOMMENT message to a metafile content TPdfGDIComment = - (pgcOutline, pgcBookmark, pgcLink, pgcLinkNoBorder); + (pgcOutline, pgcBookmark, pgcLink, pgcLinkNoBorder, pgcJpegDirect); /// a dictionary wrapper class for the PDF document information fields // - all values use the generic VCL string type, and will be encoded @@ -2444,7 +2480,7 @@ type /// create the PDF document instance, with a VCL Canvas property // - see TPdfDocument.Create connstructor for the arguments expectations constructor Create(AUseOutlines: Boolean=false; ACodePage: integer=0; - APDFA1: boolean=false + {$ifdef USE_PDFALEVEL]}APDFA: TPdfALevel=pdfaNone{$else}APDFA1: boolean=false{$endif} {$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption=nil{$endif}); /// add a Page to the current PDF document function AddPage: TPdfPage; override; @@ -2659,6 +2695,8 @@ procedure GDICommentOutline(MetaHandle: HDC; const aTitle: RawUTF8; aLevel: Inte procedure GDICommentLink(MetaHandle: HDC; const aBookmarkName: RawUTF8; const aRect: TRect; NoBorder: boolean); +/// append a EMR_GDICOMMENT message for adding jpeg direct +procedure GDICommentJpegDirect(MetaHandle: HDC; const aFileName: RawUTF8; const aRect: TRect); {$ifdef USE_PDFSECURITY} const @@ -2942,6 +2980,13 @@ function ScriptApplyDigitSubstitution( implementation +const + // those constants are not defined in earlier Delphi revisions + cPI: single = 3.141592654; + cPIdiv180: single = 0.017453292; + c180divPI: single = 57.29577951; + c2PI: double = 6.283185307; + cPIdiv2: double = 1.570796326; function RGBA(r, g, b, a: cardinal): COLORREF; {$ifdef HASINLINE}inline;{$endif} begin @@ -3118,6 +3163,20 @@ begin // high(TPdfGDIComment)<$47 so it will never begin with GDICOMMENT_IDENTIF Windows.GdiComment(MetaHandle,L+(1+sizeof(TRect)),D); end; +procedure GDICommentJpegDirect(MetaHandle: HDC; const aFileName: RawUTF8; const aRect: TRect); +var Data: RawByteString; + D: PAnsiChar; + L: integer; +begin // high(TPdfGDIComment)<$47 so it will never begin with GDICOMMENT_IDENTIFIER + L := length(aFileName); + SetLength(Data,L+(1+sizeof(TRect))); + D := pointer(Data); + D^ := AnsiChar(pgcJpegDirect); + PRect(D+1)^ := aRect; + MoveFast(pointer(aFileName)^,D[1+sizeof(TRect)],L); + Windows.GdiComment(MetaHandle,L+(1+sizeof(TRect)),D); +end; + {$ifndef DELPHI5OROLDER} // used by TPdfFontTrueType.PrepareForSaving() function GetTTCIndex(const FontName: RawUTF8; var ttcIndex: Word; @@ -3234,7 +3293,6 @@ type TCoeff = array[0..3] of double; TCoeffArray = array[0..1, 0..3] of TCoeff; const - twoPi = 2 * PI; // coefficients for error estimation // while using cubic Bezier curves for approximation // 0 < b/a < 1/4 @@ -3292,11 +3350,11 @@ begin feta1 := ArcTan2(sin(lambda1) / fbRad, cos(lambda1) / faRad); feta2 := ArcTan2(sin(lambda2) / fbRad, cos(lambda2) / faRad); // make sure we have eta1 <= eta2 <= eta1 + 2 PI - feta2 := feta2 - (twoPi * floor((feta2 - feta1) / twoPi)); + feta2 := feta2 - (c2PI * floor((feta2 - feta1) / c2PI)); // the preceding correction fails if we have exactly et2 - eta1 = 2 PI // it reduces the interval to zero length if SameValue(feta1, feta2) then - feta2 := feta2 + twoPi; + feta2 := feta2 + c2PI; // start point fx1 := fcx + (faRad * cos(feta1)); fy1 := fcy + (fbRad * sin(feta1)); @@ -3360,7 +3418,7 @@ begin n := 1; while (not found) and (n < 1024) do begin dEta := (feta2 - feta1) / n; - if dEta <= 0.5 * PI then begin + if dEta <= cPIdiv2 then begin etaB := feta1; found := true; for i := 0 to n - 1 do begin @@ -3713,6 +3771,24 @@ begin W.Add('/').AddEscapeName(pointer(FValue)); end; +procedure TPdfName.AppendPrefix; +var prefix: RawUtf8; + c: cardinal; + i: PtrInt; +begin + if self=nil then + exit; + SetLength(prefix, 7); + c := Random32; // we will consume only 24-bit of randomness + for i := 1 to 6 do + begin + prefix[i] := AnsiChar((c and 15) + 65); + c := c shr 4; + end; + prefix[7] := '+'; + FValue := prefix+FValue; // we ensured a single subset per font +end; + { TPdfArray } @@ -4206,7 +4282,7 @@ function _PdfDateToDateTime(const AText: TPdfDate): TDateTime; var Y,M,D, H,MI,SS: cardinal; begin if Length(AText)<16 then - EConvertError.CreateRes(@SDateEncodeError); + raise EConvertError.CreateRes(@SDateEncodeError); Y := ord(AText[3])*1000+ord(AText[4])*100+ord(AText[5])*10+ord(AText[6]) -(48+480+4800+48000); M := ord(AText[7])*10+ord(AText[8])-(48+480); @@ -4218,7 +4294,7 @@ begin if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime() result := result + (H * (MinsPerHour * SecsPerMin * MSecsPerSec) + MI * (SecsPerMin * MSecsPerSec) + SS * MSecsPerSec) / MSecsPerDay else - EConvertError.CreateRes(@SDateEncodeError); + raise EConvertError.CreateRes(@SDateEncodeError); end; function _HasMultiByteString(Value: PAnsiChar): boolean; @@ -4876,8 +4952,8 @@ begin aChanged := fAddGlyphFont=fNone; Glyph := TTF.fUsedWide[TTF.FindOrAddUsedWideChar(Char)].Glyph; with Canvas.fDoc do - if fPDFA1 and (Glyph=0) and (fFontFallBackIndex<0) then - raise Exception.Create('PDFA/1 expects font fallback to be enabled, '+ + if (fPDFA <> pdfaNone) and (Glyph=0) and (fFontFallBackIndex<0) then + raise Exception.Create('PDFA expects font fallback to be enabled, '+ 'and the required font is not available on this system') else if (Glyph=0) and fUseFontFallBack and (fFontFallBackIndex>=0) then begin if fAddGlyphFont=fMain then @@ -5073,7 +5149,7 @@ constructor TPdfWrite.Create(Destination: TPdfDocument; DestStream: TStream); begin fDoc := Destination; fDestStream := DestStream; - fDestStreamPosition := fDestStream.Seek(0,soFromCurrent); + fDestStreamPosition := fDestStream.Seek(0,soCurrent); fCodePage := fDoc.CodePage; B := @Tmp; Bend := B+high(Tmp); @@ -5103,7 +5179,7 @@ begin Save; result := ''; SetLength(result,fDestStreamPosition); - fDestStream.Seek(0,soFromBeginning); + fDestStream.Seek(0,soBeginning); fDestStream.Read(pointer(result)^,fDestStreamPosition); end; end; @@ -5341,11 +5417,18 @@ begin end; constructor TPdfDocument.Create(AUseOutlines: Boolean; ACodePage: integer; - APDFA1: boolean{$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption{$endif}); + {$ifdef USE_PDFALEVEL]}APDFA: TPdfALevel{$else}APDFA1: boolean{$endif} + {$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption{$endif}); var LFont: TLogFontW; // TLogFontW to add to FTrueTypeFonts array as UTF-8 i: integer; begin - fPDFA1 := APDFA1; + {$ifdef USE_PDFALEVEL]} + fPDFA:=APDFA; + {$else} + if APDFA1 then + fPDFA := pdfa1B else + fPDFA := pdfaNone; + {$endif USE_PDFALEVEL} {$ifdef USE_PDFSECURITY} fEncryption := AEncryption; {$endif USE_PDFSECURITY} @@ -5671,18 +5754,18 @@ begin if fEncryption<>nil then NeedFileID := true; {$endif USE_PDFSECURITY} - if PDFA1 then begin + if PDFA<>pdfaNone then begin if fFileFormatnil then - raise EPdfInvalidOperation.Create('PDF/A-1 not allowed when encryption is enabled'); + raise EPdfInvalidOperation.Create('PDF/A not allowed when encryption is enabled'); {$endif USE_PDFSECURITY} fUseFontFallBack := true; FOutputIntents := TPdfArray.Create(FXref); Dico := TPdfDictionary.Create(FXRef); Dico.AddItem('Type','OutputIntent'); - Dico.AddItem('S','GTS_PDFA1'); + Dico.AddItem('S','GTS_PDFA1'); // there is no definition GTS_PDFA2 or GTS_PDFA3 Dico.AddItemText('OutputConditionIdentifier','sRGB'); Dico.AddItemText('RegistryName','http://www.color.org'); RGB := TPdfStream.Create(self); @@ -5764,6 +5847,15 @@ begin FCanvas.SetPage(result); end; +function TPdfDocument.AddTrueTypeFont(const TTFName: RawUtf8): boolean; +begin + result := GetTrueTypeFontIndex(TTFName) < 0; + if not result then + exit; + AddRawUTF8(FTrueTypeFonts,TTFName); + QuickSortRawUTF8(FTrueTypeFonts,length(FTrueTypeFonts),nil,@StrIComp); +end; + procedure TPdfDocument.FreeDoc; var i: integer; begin @@ -5815,6 +5907,8 @@ procedure TPdfDocument.SaveToStreamDirectBegin(AStream: TStream; const PDFHEADER: array[TPdfFileFormat] of PDFString = ( '%PDF-1.3'#10, '%PDF-1.4'#10'%'#228#229#230#240#10, '%PDF-1.5'#10'%'#241#242#243#244#10, '%PDF-1.6'#10'%'#245#246#247#248#10); +const PDFAPART: array[TPdfALevel] of PDFString = ('', '1', '1', '2', '2', '3', '3'); +const PDFACONFORMANCE: array[TPdfALevel] of PDFString = ('', 'A', 'B', 'A', 'B', 'A', 'B'); begin if fSaveToStreamWriter<>nil then raise EPdfInvalidOperation.Create('SaveToStreamDirectBegin called twice'); @@ -5824,7 +5918,7 @@ begin FInfo.ModDate := ForceModDate; FRoot.SaveOpenAction; // some PDF/A-1 requirements - if PDFA1 then begin + if PDFA<>pdfaNone then begin FMetaData.Writer.Add(RawByteString( ''+ ''+ @@ -5846,7 +5940,7 @@ begin '').Add(StringToUTF8(Info.Keywords)).Add(''+ ''+PDF_PRODUCER+''+ ''+ - '1A'+ + ''+PDFAPART[PDFA]+''+PDFACONFORMANCE[PDFA]+''+ ''); end; // write beginning of the content @@ -6053,11 +6147,13 @@ const TTFCFP_MS_PLATFORMID = 3; TTFCFP_SYMBOL_CHAR_SET = 0; TTFCFP_UNICODE_CHAR_SET = 1; + TTFCFP_DONT_CARE = 65535; TTFCFP_FLAGS_SUBSET = 1; TTFMFP_SUBSET = 0; TTFCFP_FLAGS_TTC = 4; - TTCF_TABLE = $66637474; + HEAD_TABLE = $64616568; // 'head' + TTCF_TABLE = $66637474; // 'ttcf' type /// a TTF name record used for the 'name' Format 4 table @@ -6322,12 +6418,26 @@ begin NewDoc; end; -procedure TPdfDocument.SetPDFA1(const Value: boolean); +procedure TPdfDocument.SetPDFA(const Value: TPdfALevel); begin - fPDFA1 := Value; + fPDFA := Value; NewDoc; end; +{$ifndef USE_PDFALEVEL} +function TPdfDocument.GetPDFA1: boolean; +begin + result := (fPDFA = pdfa1B); +end; + +procedure TPdfDocument.SetPDFA1(const Value: boolean); +begin + if Value then + SetPDFA(pdfa1B) else + SetPDFA(pdfaNone); +end; +{$endif USE_PDFALEVEL} + procedure TPdfDocument.SetFontFallBackName(const Value: string); begin fFontFallBackIndex := GetTrueTypeFontIndex(StringToUTF8(Value)); @@ -6664,7 +6774,7 @@ begin if ALogFont.lfWeight>=FW_SEMIBOLD then include(AStyle,pfsBold); result := SetFont(AName,ASize,AStyle,ALogFont.lfCharSet,-1, - (ALogFont.lfPitchAndFamily and 3) = FIXED_PITCH); + ALogFont.lfPitchAndFamily and TMPF_FIXED_PITCH=0); end; procedure TPdfCanvas.TextOut(X, Y: Single; const Text: PDFString); @@ -7199,7 +7309,7 @@ begin if FPage.FFont.FTrueTypeFontsIndex=0 then begin Ansi := CurrentAnsiConvert.UnicodeBufferToAnsi(PW,StrLenW(PW)); i := 1; - while i self then // WinAnsiFont.fUsedWide[] = glyphs for ShowText + begin + result := WinAnsiFont.FindOrAddUsedWideChar(aWideChar); + exit; + end; result := fUsedWideChar.Add(ord(aWideChar)); if result<0 then begin result := -(result+1); // this WideChar was already existing -> return index @@ -8004,14 +8118,15 @@ begin end; function TPdfFontTrueType.GetWideCharWidth(aWideChar: WideChar): Integer; +var ref: TPdfFontTrueType; begin - self := self.WinAnsiFont; // we need fUsedWide[] to be used glyphs + ref := WinAnsiFont; // WinAnsiFont.fUsedWide[] = glyphs used by ShowText result := WideCharToWinAnsi(ord(aWideChar)); if result>=0 then - if (fWinAnsiWidth<>nil) and (result>=32) then - result := fWinAnsiWidth[AnsiChar(result)] else - result := fDefaultWidth else - result := fUsedWide[FindOrAddUsedWideChar(aWideChar)].Width; + if (ref.fWinAnsiWidth<>nil) and (result>=32) then + result := ref.fWinAnsiWidth[AnsiChar(result)] else + result := ref.fDefaultWidth else + result := ref.fUsedWide[ref.FindOrAddUsedWideChar(aWideChar)].Width; end; { font subset embedding using Windows XP CreateFontPackage() FontSub.dll @@ -8033,6 +8148,95 @@ begin FreeMem(Buffer); end; +type + TTtfTableDirectory = packed record + sfntVersion: cardinal; // 0x00010000 for version 1.0 + numTables: word; // number of tables + searchRange: word; // HighBit(NumTables) x 16 + entrySelector: word; // Log2(HighBit(NumTables)) + rangeShift: word; // NumTables x 16 - SearchRange + end; + PTtfTableDirectory = ^TTtfTableDirectory; + + TTtfTableEntry = packed record + tag: cardinal; // table identifier + checksum: cardinal; // checksum for this table + offset: cardinal; // offset from start of font file + length: cardinal; // length of this table + end; + PTtfTableEntry = ^TTtfTableEntry; + +const + // see http://www.4real.gr/technical-documents-ttf-subset.html + // https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6.html + TTF_SUBSET: array[0..9] of array[0..3] of AnsiChar = ( + 'head', 'cvt ', 'fpgm', 'prep', 'hhea', 'maxp', 'hmtx', 'cmap', 'loca', 'glyf'); + +procedure ReduceTTF(out ttf: PDFString; SubSetData: pointer; SubSetSize: integer); +var dir: PTtfTableDirectory; + d, e: PTtfTableEntry; + head: PCmapHEAD; + n, i, len: PtrInt; + checksum: cardinal; +begin + SetLength(ttf, SubSetSize); // maximum size + d := pointer(ttf); + inc(PTtfTableDirectory(d)); + // identify the tables to be included + e := SubSetData; + inc(PTtfTableDirectory(e)); + n := 0; + if SubSetSize > SizeOf(dir^) then + for i := 1 to swap(PTtfTableDirectory(SubSetData)^.numTables) do begin + if IntegerScan(@TTF_SUBSET, length(TTF_SUBSET), e^.tag) <> nil then begin + d^ := e^; + inc(d); + inc(n); + end; + inc(e); + end; + // update the main directory + if n < 8 then begin // pdf expects 10, and our fixed dir^ below in 8..15 + MoveFast(SubSetData^, pointer(ttf)^, SubSetSize); // paranoid + exit; + end; + dir := pointer(ttf); + dir^.sfntVersion := PTtfTableDirectory(SubSetData)^.sfntVersion; + dir^.numTables := swap(word(n)); + //len := HighBit(n); // always 8 when n in 8..15 + //dir^.searchRange := swap(len * 16); + //dir^.entrySelector := swap(Floor(log2(len))); // requires the Math unit + //dir^.rangeShift := swap((integer(n) - len) * 16); + dir^.searchRange := 32768; // pre-computed values for n in 8..15 + dir^.entrySelector := 768; + dir^.rangeShift := 8192; + // include the associated data + checksum := 0; + head := nil; + e := pointer(ttf); + inc(PTtfTableDirectory(e)); + for i := 1 to n do begin + len := bswap32(e^.length); + MoveFast(PByteArray(SubSetData)[bswap32(e^.offset)], d^, len); + e^.offset := bswap32(PtrUInt(d) - PtrUInt(ttf)); + if e^.tag = HEAD_TABLE then // 'head' table + head := pointer(d); + while len and 3 <> 0 do begin // 32-bit padding + PByteArray(d)[len] := 0; + inc(len); + end; + inc(checksum, bswap32(e^.checksum)); // we didn't change the table itself + inc(PByte(d), len); + inc(e); + end; + // finalize the generated content + for i := 0 to ((SizeOf(dir^) + (integer(n) * SizeOf(e^))) shr 2) - 1 do + inc(checksum, PCardinalArray(ttf)[i]); + if head <> nil then + head^.checkSumAdjustment := bswap32($B1B0AFBA - checksum); + PStrLen(PtrUInt(ttf) - _STRLEN)^ := PtrUInt(d) - PtrUInt(ttf); // no realloc +end; + var FontSub: THandle = INVALID_HANDLE_VALUE; CreateFontPackage: function(puchSrcBuffer: pointer; ulSrcBufferSize: cardinal; @@ -8061,7 +8265,6 @@ var c: AnsiChar; tableTag: Longword; {$ifndef DELPHI5OROLDER} ttcNumFonts: Longword; - ttcBytes: array of byte; {$endif} begin DS := THeapMemoryStream.Create; @@ -8074,7 +8277,7 @@ begin Descendant.AddItem('Type','Font'); Descendant.AddItem('Subtype','CIDFontType2'); Descendant.AddItem('BaseFont',FName); - if fDoc.PDFA1 then + if fDoc.PDFA<>pdfaNone then Descendant.AddItem('CIDToGIDMap','Identity'); CIDSystemInfo := TPdfDictionary.Create(FDoc.FXref); CIDSystemInfo.AddItem('Supplement',0); @@ -8087,7 +8290,7 @@ begin fLastChar := WinAnsiFont.fUsedWide[n-1].Glyph; end; Descendant.AddItem('DW',WinAnsiFont.fDefaultWidth); - if fDoc.PDFA1 or not WinAnsiFont.fFixedWidth then begin + if (fDoc.PDFA<>pdfaNone) or not WinAnsiFont.fFixedWidth then begin WR.Add('['); // fixed width will use /DW value // WinAnsiFont.fUsedWide[] contains glyphs used by ShowText for i := 0 to n-1 do @@ -8155,7 +8358,7 @@ begin FData.AddItem('Widths',TPdfRawText.Create(WR.Add(']').ToPDFString)); end; // embedd True Type font into the PDF file (allow subset of used glyph) - if fDoc.PDFA1 or (fDoc.EmbeddedTTF and + if (fDoc.PDFA<>pdfaNone) or (fDoc.EmbeddedTTF and ((fDoc.fEmbeddedTTFIgnore=nil) or (fDoc.fEmbeddedTTFIgnore. IndexOf(fDoc.FTrueTypeFonts[fTrueTypeFontsIndex-1])<0))) then begin fDoc.GetDCWithFont(self); @@ -8165,9 +8368,8 @@ begin if ttfSize<>GDI_ERROR then begin // Yes, the font is in a .ttc collection // find out how many fonts are included in the collection - SetLength(ttcBytes,4); - if GetFontData(fDoc.FDC,TTCF_TABLE,8,pointer(ttcBytes),4) <> GDI_ERROR then - ttcNumFonts := ttcBytes[3] else // Higher bytes will be zero + if GetFontData(fDoc.FDC,TTCF_TABLE,8,@ttcNumFonts,4) <> GDI_ERROR then + ttcNumFonts := bswap32(ttcNumFonts) else ttcNumFonts := 1; // we need to find out the index of the font within the ttc collection // (this is not easy, so GetTTCIndex uses lookup on known ttc fonts) @@ -8206,12 +8408,15 @@ begin if CreateFontPackage(pointer(ttf),ttfSize, SubSetData,SubSetMem,SubSetSize, usFlags,ttcIndex,TTFMFP_SUBSET,0, - TTFCFP_MS_PLATFORMID,TTFCFP_UNICODE_CHAR_SET, + TTFCFP_MS_PLATFORMID,TTFCFP_DONT_CARE, pointer(Used.Values),Used.Count, @lpfnAllocate,@lpfnReAllocate,@lpfnFree,nil)=0 then begin // subset was created successfully -> save to PDF file - SetString(ttf,SubSetData,SubSetSize); + ReduceTTF(ttf,SubSetData,SubSetSize); FreeMem(SubSetData); + // see 5.5.3 Font Subsets: begins with a tag followed by a + + TPdfName(fFontDescriptor.ValueByName('FontName')).AppendPrefix; + TPdfName(fFontDescriptor.ValueByName('BaseFont')).AppendPrefix; end; end; end; @@ -8724,7 +8929,8 @@ begin end; constructor TPdfDocumentGDI.Create(AUseOutlines: Boolean; ACodePage: integer; - APDFA1: boolean{$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption{$endif}); + {$ifdef USE_PDFALEVEL]}APDFA: TPdfALevel{$else}APDFA1: boolean{$endif} + {$ifdef USE_PDFSECURITY}; AEncryption: TPdfEncryption{$endif}); begin inherited; fTPdfPageClass := TPdfPageGdi; @@ -9924,6 +10130,9 @@ end; procedure TPdfEnum.HandleComment(Kind: TPdfGDIComment; P: PAnsiChar; Len: integer); var Text: RawUTF8; W: integer; + Img: TPdfImage; + ImgName: PDFString; + ImgRect: TPdfRect; begin try case Kind of @@ -9945,6 +10154,18 @@ begin W := 0; Canvas.Doc.CreateLink(Canvas.RectI(PRect(P)^,true),Text,abSolid,W); end; + pgcJpegDirect: + if Len>Sizeof(TRect) then begin + SetString(Text,P+SizeOf(TRect),Len-SizeOf(TRect)); + ImgName := 'SynImgJpg'+PDFString(crc32cUTF8ToHex(Text)); + if Canvas.Doc.GetXObject(ImgName) = nil then + begin + Img := TPdfImage.CreateJpegDirect(Canvas.Doc,UTF8ToString(Text)); + Canvas.Doc.RegisterXObject(Img,ImgName); + end; + ImgRect := Canvas.RectI(PRect(P)^,true); + Canvas.DrawXObject(ImgRect.Left,ImgRect.Top,ImgRect.Right-ImgRect.Left,ImgRect.Bottom-ImgRect.Top,ImgName); + end; end; except on E: Exception do ; // ignore any error (continue EMF enumeration) @@ -10109,10 +10330,40 @@ begin end; // use transformation ScaleXForm := WorldTransform; - FWorldFactorX := WorldTransform.eM11; - FWorldFactorY := WorldTransform.eM22; - FWorldOffsetX := WorldTransform.eDx; - FWorldOffsetY := WorldTransform.eDy; + if (ScaleXForm.eM11 > 0) and + (ScaleXForm.eM22 > 0) and + (ScaleXForm.eM12 = 0) and + (ScaleXForm.eM21 = 0) then + begin // Scale + FWorldFactorX := ScaleXForm.eM11; + FWorldFactorY := ScaleXForm.eM22; + FWorldOffsetX := WorldTransform.eDx; + FWorldOffsetY := WorldTransform.eDy; + end + else + if (ScaleXForm.eM22 = ScaleXForm.eM11) and + (ScaleXForm.eM21 = -ScaleXForm.eM12) then + begin // Rotate + FAngle := ArcSin(ScaleXForm.eM12) * c180divPI; + FWorldCos := ScaleXForm.eM11; + FWorldSin := ScaleXForm.eM12; + end + else + if (ScaleXForm.eM11 = 0) and + (ScaleXForm.eM22 = 0) and + ((ScaleXForm.eM12 <> 0) or + (ScaleXForm.eM21 <> 0)) then + begin //Shear + + end + else + if ((ScaleXForm.eM11 < 0) or + (ScaleXForm.eM22 < 0)) and + (ScaleXForm.eM12 = 0) and + (ScaleXForm.eM21 = 0) then + begin //Reflection + + end; end; end; @@ -10425,7 +10676,7 @@ begin {$endif} Canvas.BeginText; if font.spec.angle<>0 then begin - a := font.spec.angle*(PI/180); + a := font.spec.angle*cPIdiv180; acos := cos(a); asin := sin(a); PosX := 0; @@ -10433,7 +10684,25 @@ begin Canvas.SetTextMatrix(acos, asin, -asin, acos, Canvas.I2X(Posi.X-Round(W*acos+H*asin)), Canvas.I2Y(Posi.Y-Round(H*acos-W*asin))); - end else begin + end else + if (WorldTransform.eM11 = WorldTransform.eM22) and + (WorldTransform.eM12 = -WorldTransform.eM21) and + not SameValue(ArcCos(WorldTransform.eM11), 0, 0.0001) then + begin + PosX := 0; + PosY := 0; + if SameValue(ArcCos(WorldTransform.eM11), 0, 0.0001) or //0deg + SameValue(ArcCos(WorldTransform.eM11), cPI, 0.0001) then //180deg + Canvas.SetTextMatrix(WorldTransform.eM11, WorldTransform.eM12, WorldTransform.eM21, WorldTransform.eM22, + Canvas.I2X(posi.X * WorldTransform.eM11 + posi.Y * WorldTransform.eM21 + WorldTransform.eDx), + Canvas.I2y(posi.X * WorldTransform.eM12 + posi.Y * WorldTransform.eM22 + WorldTransform.eDy)) + else + Canvas.SetTextMatrix(-WorldTransform.eM11, -WorldTransform.eM12, -WorldTransform.eM21, -WorldTransform.eM22, + Canvas.I2X(posi.X * WorldTransform.eM11 + posi.Y * WorldTransform.eM21 + WorldTransform.eDx), + Canvas.I2y(posi.X * WorldTransform.eM12 + posi.Y * WorldTransform.eM22 + WorldTransform.eDy)); + end + else + begin acos := 0; asin := 0; if Canvas.fViewSize.cx>0 then @@ -10600,7 +10869,7 @@ begin {$endif} SaveToStream(FWriter.fDestStream); // with CompressionQuality recompress end; - FWriter.fDestStreamPosition := FWriter.fDestStream.Seek(0,soFromCurrent); + FWriter.fDestStreamPosition := FWriter.fDestStream.Seek(0,soCurrent); end else begin if aImage.InheritsFrom(TBitmap) then B := TBitmap(aImage) else @@ -10684,7 +10953,7 @@ begin jpeg.Read(b,1); case b of $C0..$C3: begin - jpeg.Seek(3,soFromCurrent); + jpeg.Seek(3,soCurrent); jpeg.Read(w,2); height := swap(w); jpeg.Read(w,2); @@ -10697,12 +10966,12 @@ begin $FF: jpeg.Read(b,1); $D0..$D9, $01: begin - jpeg.Seek(1,soFromCurrent); + jpeg.Seek(1,soCurrent); jpeg.Read(b,1); end; else begin jpeg.Read(w,2); - jpeg.Seek(swap(w)-2, soFromCurrent); + jpeg.Seek(swap(w)-2, soCurrent); jpeg.Read(b,1); end; end; @@ -10722,7 +10991,7 @@ begin FFilter := 'DCTDecode'; FWriter.Save; // flush to allow direct access to fDestStream FWriter.Add(aJpegFile.Memory,Len); - FWriter.fDestStreamPosition := FWriter.fDestStream.Seek(0,soFromCurrent); + FWriter.fDestStreamPosition := FWriter.fDestStream.Seek(0,soCurrent); FAttributes.AddItem('Width',fPixelWidth); FAttributes.AddItem('Height',fPixelHeight); case BitDepth of @@ -10747,7 +11016,7 @@ begin FResources.AddItem('ProcSet',TPdfArray.CreateNames(nil,['PDF','Text','ImageC'])); FPage := TPdfPage.Create(nil); FCanvas := TPdfCanvas.Create(aDoc); - FCanvas.FPage:=FPage; + FCanvas.FPage := FPage; FCanvas.FPageFontList := FFontList; FCanvas.FContents := self; FCanvas.FFactor := 1; @@ -10927,12 +11196,14 @@ procedure TPdfEncryptionRC4MD5.EncodeBuffer(const BufIn; var BufOut; Count: card fLastObjectNumber := fDoc.fCurrentObjectNumber; fLastGenerationNumber := fDoc.fCurrentGenerationNumber; end; +var work: TRC4; // Encrypt() changes the RC4 state -> local copy for reuse begin if (fDoc.fCurrentObjectNumber<>fLastObjectNumber) or (fDoc.fCurrentGenerationNumber<>fLastGenerationNumber) then // a lot of string encodings have the same context ComputeNewRC4Key; - fLastRC4Key.Encrypt(BufIn,BufOut,Count); // RC4 allows in-place encryption :) + work := fLastRC4Key; + work.Encrypt(BufIn,BufOut,Count); // RC4 allows in-place encryption :) end; {$endif USE_PDFSECURITY} diff --git a/contrib/mORMot/SynProtoRTSPHTTP.pas b/contrib/mORMot/SynProtoRTSPHTTP.pas index d5513fe..42b40c6 100644 --- a/contrib/mORMot/SynProtoRTSPHTTP.pas +++ b/contrib/mORMot/SynProtoRTSPHTTP.pas @@ -6,7 +6,7 @@ unit SynProtoRTSPHTTP; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynProtoRTSPHTTP; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynProtoRelay.pas b/contrib/mORMot/SynProtoRelay.pas index fce9f6b..db25af6 100644 --- a/contrib/mORMot/SynProtoRelay.pas +++ b/contrib/mORMot/SynProtoRelay.pas @@ -6,7 +6,7 @@ unit SynProtoRelay; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynProtoRelay; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynSM.inc b/contrib/mORMot/SynSM.inc index ce1fd4e..1d01f28 100644 --- a/contrib/mORMot/SynSM.inc +++ b/contrib/mORMot/SynSM.inc @@ -1,10 +1,10 @@ { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info - Scripting support for mORMot Copyright (C) 2020 Pavel Mashlyakovsky + Scripting support for mORMot Copyright (C) 2022 Pavel Mashlyakovsky pavel.mash at gmail.com *** BEGIN LICENSE BLOCK ***** diff --git a/contrib/mORMot/SynSM.pas b/contrib/mORMot/SynSM.pas index b8743a1..1b973e4 100644 --- a/contrib/mORMot/SynSM.pas +++ b/contrib/mORMot/SynSM.pas @@ -5,10 +5,10 @@ unit SynSM; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info - Scripting support for mORMot Copyright (C) 2020 Pavel Mashlyakovsky + Scripting support for mORMot Copyright (C) 2022 Pavel Mashlyakovsky pavel.mash at gmail.com Some ideas taken from @@ -29,7 +29,7 @@ unit SynSM; The Initial Developer of the Original Code is Pavel Mashlyakovsky. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynSMAPI.pas b/contrib/mORMot/SynSMAPI.pas index a215a2b..0a6d83b 100644 --- a/contrib/mORMot/SynSMAPI.pas +++ b/contrib/mORMot/SynSMAPI.pas @@ -5,10 +5,10 @@ unit SynSMAPI; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info - Scripting support for mORMot Copyright (C) 2020 Pavel Mashlyakovsky + Scripting support for mORMot Copyright (C) 2022 Pavel Mashlyakovsky pavel.mash at gmail.com Some ideas taken from @@ -29,7 +29,7 @@ unit SynSMAPI; The Initial Developer of the Original Code is Pavel Mashlyakovsky. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynSQLite3.pas b/contrib/mORMot/SynSQLite3.pas index 5dff52e..57b7c39 100644 --- a/contrib/mORMot/SynSQLite3.pas +++ b/contrib/mORMot/SynSQLite3.pas @@ -6,7 +6,7 @@ unit SynSQLite3; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynSQLite3; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -48,7 +48,7 @@ unit SynSQLite3; ***** END LICENSE BLOCK ***** - SQLite3 3.32.3 database engine + SQLite3 3.38.2 database engine ******************************** Brand new SQLite3 library to be used with Delphi/FPC @@ -1187,7 +1187,7 @@ type close: function(DB: TSQLite3DB): integer; cdecl; /// Return the version of the SQLite database engine, in ascii format - // - currently returns '3.32.3', when used with our SynSQLite3Static unit + // - currently returns '3.38.2', when used with our SynSQLite3Static unit // - if an external SQLite3 library is used, version may vary // - you may use the VersionText property (or Version for full details) instead libversion: function: PUTF8Char; cdecl; @@ -2682,6 +2682,7 @@ type fBackupBackgroundInProcess: TSQLDatabaseBackupThread; fBackupBackgroundLastTime: RawUTF8; fBackupBackgroundLastFileName: TFileName; + fUseCacheSize: integer; {$ifdef WITHLOG} fLogResultMaximumSize: integer; fLog: TSynLogClass; @@ -2786,7 +2787,8 @@ type // - initialize a internal mutex to ensure that all access to the database is atomic // - raise an ESQLite3Exception on any error constructor Create(const aFileName: TFileName; const aPassword: RawUTF8=''; - aOpenV2Flags: integer=0; aDefaultCacheSize: integer=10000; aDefaultPageSize: integer=4096); reintroduce; + aOpenV2Flags: integer=0; aDefaultCacheSize: integer=10000; + aDefaultPageSize: integer=4096); reintroduce; /// close a database and free its memory and context //- if TransactionBegin was called but not commited, a RollBack is performed destructor Destroy; override; @@ -3035,6 +3037,9 @@ type // - cache is consistent only if ExecuteJSON() Expand parameter is constant // - cache is used by TSQLDataBase.ExecuteJSON() and TSQLTableDB.Create() property UseCache: boolean read GetUseCache write SetUseCache; + /// cache size in JSON bytes, to be set before UseCache is set to true + // - default is 16MB + property UseCacheSize: integer read fUseCacheSize write fUseCacheSize; /// return TRUE if a Transaction begun property TransactionActive: boolean read fTransactionActive; /// sets a busy handler that sleeps for a specified amount of time @@ -3905,6 +3910,7 @@ begin fIsMemory := true else fFileNameWithoutPath := ExtractFileName(fFileName); fPassword := aPassword; + fUseCacheSize := 16384*1024; fSQLFunctions := TSynObjectList.Create; result := DBOpen; if result<>SQLITE_OK then @@ -4228,7 +4234,7 @@ begin if self<>nil then if Value<>UseCache then if Value then - fCache := TSynCache.Create(16384*1024,true) else + fCache := TSynCache.Create(fUseCacheSize,true) else FreeAndNil(fCache); end; @@ -5258,8 +5264,11 @@ begin begin result := sqlite3.prepare_v2(RequestDB, pointer(SQL), length(SQL)+1, fRequest, fNextSQL); - while (result=SQLITE_OK) and (Request=0) do // comment or white-space + while (result=SQLITE_OK) and (Request=0) do begin // comment or white-space + if fNextSQL^ = #0 then // statement contains only comment + raise ESQLite3Exception.Create(DB,SQLITE_EMPTY,SQL); result := sqlite3.prepare_v2(RequestDB, fNextSQL, -1, fRequest, fNextSQL); + end; fFieldCount := sqlite3.column_count(fRequest); if not NoExcept then sqlite3_check(RequestDB,result,SQL); diff --git a/contrib/mORMot/SynSQLite3RegEx.pas b/contrib/mORMot/SynSQLite3RegEx.pas index ca1e86a..c4e832c 100644 --- a/contrib/mORMot/SynSQLite3RegEx.pas +++ b/contrib/mORMot/SynSQLite3RegEx.pas @@ -6,7 +6,7 @@ unit SynSQLite3RegEx; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynSQLite3RegEx; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynSQLite3Static.pas b/contrib/mORMot/SynSQLite3Static.pas index 776d10e..0d86c8a 100644 --- a/contrib/mORMot/SynSQLite3Static.pas +++ b/contrib/mORMot/SynSQLite3Static.pas @@ -1,4 +1,4 @@ -/// SQLite3 3.32.3 Database engine - statically linked for Windows/Linux +/// SQLite3 3.38.2 Database engine - statically linked for Windows/Linux // - this unit is a part of the freeware Synopse mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit SynSQLite3Static; @@ -6,7 +6,7 @@ unit SynSQLite3Static; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynSQLite3Static; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -47,7 +47,7 @@ unit SynSQLite3Static; ***** END LICENSE BLOCK ***** - Statically linked SQLite3 3.32.3 engine with optional AES encryption + Statically linked SQLite3 3.38.2 engine with optional AES encryption ********************************************************************** To be declared in your project uses clause: will fill SynSQlite3.sqlite3 @@ -210,13 +210,21 @@ implementation {$ifdef ANDROID} const _PREFIX = ''; {$ifdef CPUAARCH64} - {$L .\static\aarch64-android\libsqlite3.a} - {$L .\static\aarch64-android\libgcc.a} + {$L .\static\aarch64-android\sqlite3.o} + {$linklib .\static\aarch64-android\libgcc.a} {$endif CPUAARCH64} {$ifdef CPUARM} - {$L .\static\arm-android\libsqlite3.a} - {$L .\static\arm-android\libgcc.a} + {$L .\static\arm-android\sqlite3.o} + {$linklib .\static\arm-android\libgcc.a} {$endif CPUARM} + {$ifdef CPUX86} + {$L .\static\i386-android\sqlite3.o} + {$endif CPUX86} + {$ifdef CPUX64} + {$L .\static\x86_64-android\sqlite3.o} + // x86_64-linux-android-ld.bfd: final link failed + // (Nonrepresentable section on output) + {$endif CPUX64} {$endif ANDROID} {$ifdef FREEBSD} @@ -1142,7 +1150,8 @@ function sqlite3_trace_v2(DB: TSQLite3DB; Mask: integer; Callback: TSQLTraceCall const // error message if statically linked sqlite3.o(bj) does not match this - EXPECTED_SQLITE3_VERSION = {$ifdef ANDROID}''{$else}'3.32.3'{$endif}; + // - Android may be a little behind, so we don't check exact version + EXPECTED_SQLITE3_VERSION = {$ifdef ANDROID}''{$else}'3.38.2'{$endif}; constructor TSQLite3LibraryStatic.Create; var error: RawUTF8; @@ -1256,16 +1265,20 @@ begin if (EXPECTED_SQLITE3_VERSION='') or (fVersionText=EXPECTED_SQLITE3_VERSION) then exit; // you should never see it if you cloned https://github.com/synopse/mORMot - FormatUTF8('Static SQLite3 library as included within % is outdated!'#13+ - 'Linked version is % whereas the current/expected is '+EXPECTED_SQLITE3_VERSION+'.'#13#13+ - 'Please download supported latest SQLite3 '+EXPECTED_SQLITE3_VERSION+' revision'#13+ + FormatUTF8('Static SQLite3 library as included within % is outdated!'#13#10+ + 'Linked version is % whereas the current/expected is '+EXPECTED_SQLITE3_VERSION+'.'#13#10#13#10+ + 'Please download supported latest SQLite3 '+EXPECTED_SQLITE3_VERSION+' revision'#13#10+ 'from https://synopse.info/files/sqlite3'+{$ifdef FPC}'fpc'{$else}'obj'{$endif}+'.7z', [ExeVersion.ProgramName,fVersionText],error); LogToTextFile(error); // annoyning enough on all platforms // SynSQLite3Log.Add.Log() would do nothing: we are in .exe initialization - {$ifdef MSWINDOWS} // PITA popup - MessageBoxA(0,pointer(error),' WARNING: deprecated SQLite3 engine',MB_OK or MB_ICONWARNING); - {$endif} + {$ifdef MSWINDOWS} + AllocConsole; // PITA popup - better than a MessageBox() especially for services + {$endif MSWINDOWS} + {$I-} + writeln(error); + ioresult; + {$I+} end; destructor TSQLite3LibraryStatic.Destroy; diff --git a/contrib/mORMot/SynSSPI.pas b/contrib/mORMot/SynSSPI.pas index ba5c47f..da370ac 100644 --- a/contrib/mORMot/SynSSPI.pas +++ b/contrib/mORMot/SynSSPI.pas @@ -5,7 +5,7 @@ unit SynSSPI; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynSSPI; The Initial Developer of the Original Code is Chaa. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -318,8 +318,9 @@ function SecEncrypt(var aSecContext: TSecContext; const aPlain: TSSPIBuffer): TS // - aSecContext must be set e.g. from previous success call to ServerSSPIAuth // or ClientSSPIAuth // - aEncrypted contains data that must be decrypted +// - warning: aEncrypted is modified in-place during the process // - returns decrypted message -function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TSSPIBuffer): TSSPIBuffer; +function SecDecrypt(var aSecContext: TSecContext; var aEncrypted: TSSPIBuffer): TSSPIBuffer; type @@ -393,8 +394,6 @@ function CertCloseStore; external crypt32; function CertFindCertificateInStore; external crypt32; -(* ========================= High-Level SSPI / SChannel API wrappers === *) - { TSecBuffer } procedure TSecBuffer.Init(aType: cardinal; aData: pointer; @@ -405,6 +404,7 @@ begin cbBuffer := aSize; end; + { TSecBufferDesc } procedure TSecBufferDesc.Init(aVersion: cardinal; aBuffers: PSecBuffer; @@ -416,6 +416,9 @@ begin end; + +(* ========================= High-Level SSPI / SChannel API wrappers === *) + procedure InvalidateSecContext(var aSecContext: TSecContext; aConnectionID: Int64); begin aSecContext.ID := aConnectionID; @@ -506,7 +509,7 @@ begin Move(PByte(InBuf[2].pvBuffer)^, BufPtr^, InBuf[2].cbBuffer); end; -function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TSSPIBuffer): TSSPIBuffer; +function SecDecrypt(var aSecContext: TSecContext; var aEncrypted: TSSPIBuffer): TSSPIBuffer; var EncLen, SigLen: Cardinal; BufPtr: PByte; InBuf: array [0..1] of TSecBuffer; @@ -541,7 +544,6 @@ begin raise ESynSSPI.CreateLastOSError(aSecContext); SetString(Result, PAnsiChar(InBuf[1].pvBuffer), InBuf[1].cbBuffer); - FreeContextBuffer(InBuf[1].pvBuffer); end; diff --git a/contrib/mORMot/SynSSPIAuth.pas b/contrib/mORMot/SynSSPIAuth.pas index b26e542..c4c5245 100644 --- a/contrib/mORMot/SynSSPIAuth.pas +++ b/contrib/mORMot/SynSSPIAuth.pas @@ -5,7 +5,7 @@ unit SynSSPIAuth; { This file is part of Synopse mORMot framework. - Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez + Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -24,7 +24,7 @@ unit SynSSPIAuth; The Initial Developer of the Original Code is Chaa. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynScaleMM.pas b/contrib/mORMot/SynScaleMM.pas index 12d4da1..75fd1e6 100644 --- a/contrib/mORMot/SynScaleMM.pas +++ b/contrib/mORMot/SynScaleMM.pas @@ -49,12 +49,12 @@ unit SynScaleMM; The Initial Developer of the Original Code is André Mussche. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): - Arnaud Bouchez https://synopse.info - Portions created by each contributor are Copyright (C) 2020 + Portions created by each contributor are Copyright (C) 2022 each contributor. All Rights Reserved. Alternatively, the contents of this file may be used under the terms of diff --git a/contrib/mORMot/SynSelfTests.pas b/contrib/mORMot/SynSelfTests.pas index c1dbab1..9af8064 100644 --- a/contrib/mORMot/SynSelfTests.pas +++ b/contrib/mORMot/SynSelfTests.pas @@ -6,7 +6,7 @@ unit SynSelfTests; { This file is part of Synopse mORMot framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynSelfTests; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -371,6 +371,8 @@ type procedure UrlEncoding; /// some low-level JSON encoding/decoding procedure EncodeDecodeJSON; + /// some performance numbers about JSON parsing and generating + procedure JSONBenchmark; /// HTML generation from Wiki Or Markdown syntax procedure WikiMarkdownToHtml; {$ifndef NOVARIANTS} @@ -397,7 +399,7 @@ type {$ifndef DELPHI5OROLDER} -/// this test case will test some generic classes + /// this test case will test some generic classes // defined and implemented in the mORMot.pas unit TTestBasicClasses = class(TSynTestCase) published @@ -461,6 +463,8 @@ type procedure _SHA3; /// AES encryption/decryption functions procedure _AES256; + /// AES-GCM encryption/decryption with authentication + procedure _AES_GCM; /// RC4 encryption function procedure _RC4; /// Base-64 encoding/decoding functions @@ -824,15 +828,15 @@ type {$ifdef MSWINDOWS} /// test external DB using the JET engine procedure JETDatabase; - {$endif} - {$endif} - {$endif} + {$endif MSWINDOWS} + {$endif LVCL} + {$endif CPU64} {$ifdef MSWINDOWS} {$ifdef USEZEOS} /// test external Firebird embedded engine via Zeos/ZDBC (if available) procedure FirebirdEmbeddedViaZDBCOverHTTP; - {$endif} - {$endif} + {$endif USEZEOS} + {$endif MSWINDOWS} end; /// a test case for multi-threading abilities of the framework @@ -1357,8 +1361,8 @@ uses {$else} Graphics, {$endif} -{$endif} -{$endif} +{$endif FPC} +{$endif MSWINDOWS} SynCrypto, SynZip, SynLZO, @@ -3160,7 +3164,7 @@ begin str := UTF8ToString(UrlEncode(StringToUTF8('https://test3.diavgeia.gov.gr/doc/'))); check(str='https%3A%2F%2Ftest3.diavgeia.gov.gr%2Fdoc%2F'); Test('abcdef','abcdef'); - Test('abcdefyzABCDYZ01239_-.~ ','abcdefyzABCDYZ01239_-.~+'); + Test('abcdefyzABCDYZ01239_-.~ ','abcdefyzABCDYZ01239_-.%7E+'); Test('"Aardvarks lurk, OK?"','%22Aardvarks+lurk%2C+OK%3F%22'); Test('"Aardvarks lurk, OK%"','%22Aardvarks+lurk%2C+OK%25%22'); Test('where=name like :(''Arnaud%'')','where%3Dname+like+%3A%28%27Arnaud%25%27%29'); @@ -3909,6 +3913,7 @@ var crc: array[0..10000] of record crc: cardinal; end; totallen: Cardinal; + s2: RawByteString; procedure Test(hash: THasher; const name: string); var i: Integer; Timer: TPrecisionTimer; @@ -4034,6 +4039,11 @@ begin hmac32.Init(@c1,4); hmac32.Update(pointer(s),length(s)); check(hmac32.Done=c2); + s2 := s; + SymmetricEncrypt(i, s2); + check(s2 <> s); + SymmetricEncrypt(i, s2); + check(s2 = s); end; Test(crc32creference,'pas'); Test(crc32cfast,'fast'); @@ -5098,6 +5108,20 @@ begin Check(arr[0]='-1'); Check(arr[1]='25'); Check(arr[2]='0'); + Finalize(arr); + CSVToRawUTF8DynArray('AA,BB,CC,DD', ',', ',', arr); + check(Length(arr)=4); + Check(arr[0]='AA'); + Check(arr[1]='BB'); + Check(arr[2]='CC'); + Check(arr[3]='DD'); + Finalize(arr); + CSVToRawUTF8DynArray('A,B,C,D', ',', ',', arr); + check(Length(arr)=4); + Check(arr[0]='A'); + Check(arr[1]='B'); + Check(arr[2]='C'); + Check(arr[3]='D'); Check(AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree'); Check(CSVOfValue('?',3)='?,?,?'); {$ifndef DELPHI5OROLDER} @@ -5813,7 +5837,7 @@ var W: TFileBufferWriter; i: integer; V: double; u: SynUnicode; - a: WinAnsiString; + a: RawUTF8; {$endif NOVARIANTS} begin T := TSynTable.Create('Test'); @@ -5863,10 +5887,10 @@ begin for i := 1 to 100 do begin u := RandomUnicode(i*2); data.Field['text'] := u; - check(data.Field['text']=u); + check(SynUnicode(data.Field['text'])=u); a := RandomAnsi7(i*2); data.Field['ansi'] := a; - check(data.Field['ansi']=a); + check(SynUnicode(data.Field['ansi'])=SynUnicode(a)); // here, ansi is more efficent than text for storage size end; check(data.Field['bool']=true); @@ -5881,8 +5905,8 @@ begin CheckSame(data.Field['double'],V); end; check(data.Field['bool']=true); - check(data.Field['text']=u); - check(data.Field['ansi']=a); + check(SynUnicode(data.Field['text'])=u); + check(SynUnicode(data.Field['ansi'])=SynUnicode(a)); check(data.Field['ID']=1); // test TSynTableVariantType rec := T.Data; @@ -5904,10 +5928,11 @@ begin CheckSame(rec.double,3.141592654); for i := 1 to 100 do begin a := RandomAnsi7(i*2); + u := SynUnicode(a); rec.text := a; - check(rec.text=a,'rec.text'); + check(SynUnicode(rec.text)=u,'rec.text'); rec.ansi := a; - check(rec.ansi=a,'rec.ansi'); + check(SynUnicode(rec.ansi)=u,'rec.ansi'); end; check(rec.bool=true,'rec.bool'); check(rec.varint=100); @@ -5921,8 +5946,8 @@ begin CheckSame(rec.double,V); end; check(rec.bool=true); - check(rec.text=a); - check(rec.ansi=a); + check(SynUnicode(rec.text)=u); + check(SynUnicode(rec.ansi)=u); check(rec.ID=1); except on E: Exception do // variant error could raise exceptions @@ -7450,6 +7475,8 @@ begin Check(length(mus.tests)>5); for i := 0 to high(mus.tests) do with mus.Tests[i] do begin + if desc='Dotted names should be resolved against former resolutions.' then + continue; // we don't handle a":{"b":{}} context (yet) if PosEx(' {{>partial}}',template)>0 then continue; // we don't indent each line of the expanded partials (yet) mustache := TSynMustache.Parse(template); @@ -8797,6 +8824,14 @@ check(IsValidJSON(J)); check(IsValidJSON('['+J)); J := GetJSONObjectAsSQL(J,false,true); CheckEqual(J,U); + J := '{'#10'"httpServer": {'#10'"host": "*",'#10'"port": "8881",'#10 + + '"serverType": "Socket",'#10'/*"reverseProxy": {'#10'"kind": "nginx",'#10 + + '"sendFileLocationRoot": "snake-ukrpatent-local"'#10'}*/'#10'} //eol'#10'}'; + check(not IsValidJSON(J)); + RemoveCommentsFromJSON(UniqueRawUTF8(J)); + CheckUTF8(IsValidJSON(J),J); + J := JSONReformat(J,jsonCompact); + CheckEqual(J,'{"httpServer":{"host":"*","port":"8881","serverType":"Socket"}}'); J := '{"RowID": 210 ,"Name":"Alice","Role":"User","Last Login":null, // comment'#13#10+ '"First Login" : /* to be ignored */ null , "Department" : "{\"relPath\":\"317\\\\\",\"revision\":1}" } ]'; check(not IsValidJSON(J)); @@ -9402,6 +9437,105 @@ check(IsValidJSON(J)); {$endif} end; +procedure TTestLowLevelTypes.JSONBenchmark; +const + ITER = 20; + ONLYLOG = false; +var + people, notexpanded: RawUtf8; + P: PUtf8Char; + count, len, lennexp, i: integer; + dv: TDocVariantData; + table: TSQLTableJson; + timer: TPrecisionTimer; +begin + people := StringFromFile('People.json'); + if people = '' then + exit; // need to run at least once the ORM tests + len := length(people); + check(len > 800000, 'unexpected people.json'); + len := len * ITER; + timer.Start; + for i := 1 to ITER do + Check(IsValidUtf8(people)); + NotifyTestSpeed('IsValidUtf8()', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + Check(IsValidJson(people)); + NotifyTestSpeed('IsValidJson(RawUtf8)', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + Check(IsValidJson(PUTF8Char(pointer(people)))); + NotifyTestSpeed('IsValidJson(PUtf8Char)', 0, len, @timer, ONLYLOG); + P := @people[2]; // point just after initial '[' for JsonArrayCount + count := JsonArrayCount(P); + check(count > 8200); // = 8227 in current People.json ORM tests file + timer.Start; + for i := 1 to ITER do + Check(JsonArrayCount(P) = count); + NotifyTestSpeed('JsonArrayCount(P)', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + Check(JsonArrayCount(P, P + length(people) - 1) = count); + NotifyTestSpeed('JsonArrayCount(P,PMax)', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER * 5000 do + Check(JsonObjectPropCount(P + 3) = 6, 'first TOrmPeople object'); + NotifyTestSpeed('JsonObjectPropCount()', 0, ITER * 5000 * 119, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + begin + dv.InitJson(people, JSON_OPTIONS_FAST); + Check(dv.count = count); + dv.Clear; // to reuse dv + end; + NotifyTestSpeed('TDocVariant', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + begin + dv.InitJson(people, JSON_OPTIONS_FAST + [dvoInternNames]); + Check(dv.count = count); + dv.Clear; // to reuse dv + end; + NotifyTestSpeed('TDocVariant dvoInternNames', 0, len, @timer, ONLYLOG); + table := TSQLTableJson.Create('', people); + try + Check(table.RowCount = count); + timer.Start; + for i := 1 to ITER do + begin + notexpanded := table.GetJsonValues({expand=}false, 0, 65536); + lennexp := length(notexpanded); + Check(lennexp < length(people), 'notexpanded'); + end; + NotifyTestSpeed('TSQLTableJson GetJsonValues', 0, lennexp * ITER, @timer, ONLYLOG); + finally + table.Free; + end; + timer.Start; + for i := 1 to ITER do + begin + table := TSQLTableJson.Create('', people); + try + Check(table.RowCount = count); + finally + table.Free; + end; + end; + NotifyTestSpeed('TSQLTableJson expanded', 0, len, @timer, ONLYLOG); + timer.Start; + for i := 1 to ITER do + begin + table := TSQLTableJson.Create('', notexpanded); + try + Check(table.RowCount = count); + finally + table.Free; + end; + end; + NotifyTestSpeed('TSQLTableJson not expanded', 0, lennexp * ITER, @timer, ONLYLOG); +end; + procedure TTestLowLevelTypes.WikiMarkdownToHtml; begin // wiki @@ -9740,6 +9874,11 @@ begin check(json='{"double_params":[-12.12345678,-9.9E-15,-9.88E-15,-9E-15]}'); {$endif} CheckSame(double(TDocVariantData(o).A['double_params'].Value[1]),-9.9E-15); + // floats are stored as varCurrency by default in _Json() + o := _Json('{"value":99.99}'); + d := _Safe(o)^.D['value']; + CheckSame(d,99.99,DOUBLE_SAME,'99.99'); + CheckEqual(DoubleToStr(d),'99.99'); // see http://bsonspec.org/#/specification o := _JSON('{"hello": "world"}'); bsonDat := BSON(TDocVariantData(o)); @@ -10168,7 +10307,7 @@ var Doc,Doc2: TDocVariantData; s,j: RawUTF8; vd: double; vs: single; - lTable: TSQLTableJSON; + lTable: TSQLTableJson; lRefreshed: Boolean; begin Doc.Init; @@ -10436,7 +10575,7 @@ begin s := VariantSaveJSON(V); check(s='{"ID":1,"Notation":"ABC","Price":10.1,"CustomNotation":"XYZ"}'); // some tests to avoid regression about bugs reported by users on forum - lTable := TSQLTableJSON.Create(''); + lTable := TSQLTableJson.Create(''); try lTable.UpdateFrom(TEST_DATA_1,lRefreshed,nil); ndx := lTable.FieldIndex('RELATION_ID'); @@ -10911,7 +11050,7 @@ var Model: TSQLModel; Batch: TSQLRestBatch; IDs: TIDDynArray; i,j,n: integer; - dummy: RawUTF8; + dummy, s: RawUTF8; {$ifndef NOVARIANTS} procedure CheckVariantWith(const V: Variant; const i: Integer; const offset: integer=0); begin @@ -11051,7 +11190,7 @@ begin Client.RetrieveDocVariantArray(TSQLRecordTest,'items','Int,Test')); check(IdemPChar(pointer(dummy),'1=1'#$D#$A'2=2'#$D#$A'3=3'#$D#$A'4=4')); check(Hash32(dummy)=$BC89CA72); - {$endif} + {$endif NOVARIANTS} Check(Client.UpdateField(TSQLRecordTest,100,'ValWord',[100+10]), 'update one field of a given record'); R := TSQLRecordTest.Create(Client,100); @@ -11060,6 +11199,8 @@ begin finally R.Free; end; + s := Client.OneFieldValues(TSQLRecordTest,'Test','ValWord=:(110):'); + Check(s='100,110'); Check(Client.UpdateField(TSQLRecordTest,100,'ValWord',[100])); R := TSQLRecordTest.Create(Client,100); try @@ -11067,6 +11208,8 @@ begin finally R.Free; end; + s := Client.OneFieldValues(TSQLRecordTest,'Test',FormatUTF8('ValWord=?',[],[110])); + Check(s='110'); Check(Client.UpdateField(TSQLRecordTest,'Unicode',['110'],'ValWord',[120]), 'update one field of a given record'); R := TSQLRecordTest.Create(Client,110); @@ -11246,7 +11389,7 @@ begin {$ifndef LVCL} s := ObjectToJSON(T); Check(s='{"ID":0,"Int":0,"Test":"","Unicode":"","Ansi":"","ValFloat":0,'+ - '"ValWord":0,"ValDate":"","Next":0,"Data":"","ValVariant":null}'); + '"ValWord":0,"ValDate":"","Data":"","ValVariant":null}'); {$endif} T.ValDate := 39882.888612; // a fixed date and time T.Ansi := 'abcde6ef90'; @@ -11304,7 +11447,7 @@ begin s := ObjectToJSON(T); Check(s='{"ID":10,"Int":0,"Test":"'+T.Test+'","Unicode":"'+T.Test+ '","Ansi":"'+T.Test+'","ValFloat":3.141592653,"ValWord":1203,'+ - '"ValDate":"2009-03-10T21:19:36","Next":0,"Data":""'{$ifndef NOVARIANTS} + '"ValDate":"2009-03-10T21:19:36","Data":""'{$ifndef NOVARIANTS} +',"ValVariant":3.1416'{$endif}+'}'); T2.ClearProperties; Check(not T.SameValues(T2)); @@ -11357,7 +11500,8 @@ begin Check(s=StringReplaceAll(s2,', ',',')+',ValVariant=''{"name":"John","int":1234}'''); s := ObjectToJSON(T); delete(s1,3,3); // "RowID":10 -> "ID":10 - Check(s=s1+',"Data":"","ValVariant":{"name":"John","int":1234}}'); + s1 := StringReplaceAll(s1,',"Next":0',''); + CheckEqual(s,s1+',"Data":"","ValVariant":{"name":"John","int":1234}}'); bin := T.GetBinary; T2.ClearProperties; Check(T2.SetBinary(pointer(bin),PAnsiChar(pointer(bin))+length(bin))); @@ -11653,7 +11797,7 @@ begin Free; end; end; -{$ifdef MSWINDOWS} +{$ifdef MSWINDOWS} // PasZip.TZipRead uses memory mapped API procedure TestPasZipRead(const FN: TFileName; Count: integer); var pasZR: PasZip.TZipRead; begin @@ -11667,7 +11811,7 @@ begin end; end; var pasZW: PasZip.TZipWrite; -{$endif} +{$endif MSWINDOWS} var i: integer; begin ExeName := ExtractFileName(ExeVersion.ProgramFileName); @@ -11764,9 +11908,9 @@ var s,t,rle: RawByteString; i,j, complen2: integer; comp2,dec1: array of byte; {$ifdef CPUINTEL} - comp1,dec2: array of byte; + comp1, dec2: array of byte; complen1: integer; - {$endif} + {$endif CPUINTEL} begin for i := 1 to 200 do begin s := SynLZCompress(StringOfChar(AnsiChar(i),i)); @@ -12118,6 +12262,143 @@ begin {$endif CPUINTEL} end; +procedure TTestCryptographicRoutines._AES_GCM; +const + hex32: THash256 = ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f, + $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b,$1c,$1d,$1e,$1f); + buf32: THash256 = ($92,$4e,$17,$8a,$17,$fa,$1c,$a0,$e7,$48,$6f,$04,$04,$12,$3b,$91, + $db,$f7,$97,$bb,$9d,$bd,$e9,$b1,$d4,$8d,$5c,$7f,$53,$16,$59,$12); + tag32: array[0..15] of byte = ($10,$f9,$72,$b6,$f9,$e0,$a3,$c1,$cf,$9c,$cf,$56,$54,$3d,$ca,$79); + K01: THash256 = (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); + I01: array[0..11] of byte = (0,0,0,0,0,0,0,0,0,0,0,0); + P01: array[0..15] of byte = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + C01: array[0..15] of byte = ($ce,$a7,$40,$3d,$4d,$60,$6b,$6e,$07,$4e,$c5,$d3,$ba,$f3,$9d,$18); + T01: array[0..15] of byte = ($d0,$d1,$c8,$a7,$99,$99,$6b,$f0,$26,$5b,$98,$b5,$d4,$8a,$b9,$19); + K02: THash256 = (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); + I02: array[0..11] of byte = (0,0,0,0,0,0,0,0,0,0,0,0); + H02: array[0..15] of byte = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + T02: array[0..15] of byte = ($2d,$45,$55,$2d,$85,$75,$92,$2b,$3c,$a3,$cc,$53,$84,$42,$fa,$26); + K03: THash256 = (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); + I03: array[0..11] of byte = (0,0,0,0,0,0,0,0,0,0,0,0); + H03: array[0..15] of byte = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + P03: array[0..15] of byte = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0); + C03: array[0..15] of byte = ($ce,$a7,$40,$3d,$4d,$60,$6b,$6e,$07,$4e,$c5,$d3,$ba,$f3,$9d,$18); + T03: array[0..15] of byte = ($ae,$9b,$17,$71,$db,$a9,$cf,$62,$b3,$9b,$e0,$17,$94,$03,$30,$b4); + K04: THash256 = ($fb,$76,$15,$b2,$3d,$80,$89,$1d,$d4,$70,$98,$0b,$c7,$95,$84,$c8, + $b2,$fb,$64,$ce,$60,$97,$8f,$4d,$17,$fc,$e4,$5a,$49,$e8,$30,$b7); + I04: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4,$02,$da,$7d,$6f); + P04: array[0..15] of byte = ($a8,$45,$34,$8e,$c8,$c5,$b5,$f1,$26,$f5,$0e,$76,$fe,$fd,$1b,$1e); + C04: array[0..15] of byte = ($5d,$f5,$d1,$fa,$bc,$bb,$dd,$05,$15,$38,$25,$24,$44,$17,$87,$04); + T04: array[0..15] of byte = ($4c,$43,$cc,$e5,$a5,$74,$d8,$a8,$8b,$43,$d4,$35,$3b,$d6,$0f,$9f); + K05: THash256 = ($40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f); + I05: array[0..11] of byte = ($10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b); + H05: array[0..19] of byte = (0,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10,$11,$12,$13); + P05: array[0..23] of byte = ($20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f,$30,$31,$32,$33,$34,$35,$36,$37); + C05: array[0..23] of byte = ($59,$1b,$1f,$f2,$72,$b4,$32,$04,$86,$8f,$fc,$7b,$c7,$d5,$21,$99,$35,$26,$b6,$fa,$32,$24,$7c,$3c); + T05: array[0..15] of byte = ($7d,$e1,$2a,$56,$70,$e5,$70,$d8,$ca,$e6,$24,$a1,$6d,$f0,$9c,$08); + K07: THash256 = ($40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4a,$4b,$4c,$4d,$4e,$4f, + $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f); + I07: array[0..11] of byte = ($10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1a,$1b); + H07: THash256 = ($20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f); + P07: array[0..255] of byte =(0,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0a,$0b,$0c,$0d,$0e,$0f,$10,$11,$12,$13,$14,$15,$16,$17, + $18,$19,$1a,$1b,$1c,$1d,$1e,$1f,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2a,$2b,$2c,$2d,$2e,$2f, + $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3a,$3b,$3c,$3d,$3e,$3f,$40,$41,$42,$43,$44,$45,$46,$47, + $48,$49,$4a,$4b,$4c,$4d,$4e,$4f,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5a,$5b,$5c,$5d,$5e,$5f, + $60,$61,$62,$63,$64,$65,$66,$67,$68,$69,$6a,$6b,$6c,$6d,$6e,$6f,$70,$71,$72,$73,$74,$75,$76,$77, + $78,$79,$7a,$7b,$7c,$7d,$7e,$7f,$80,$81,$82,$83,$84,$85,$86,$87,$88,$89,$8a,$8b,$8c,$8d,$8e,$8f, + $90,$91,$92,$93,$94,$95,$96,$97,$98,$99,$9a,$9b,$9c,$9d,$9e,$9f,$a0,$a1,$a2,$a3,$a4,$a5,$a6,$a7, + $a8,$a9,$aa,$ab,$ac,$ad,$ae,$af,$b0,$b1,$b2,$b3,$b4,$b5,$b6,$b7,$b8,$b9,$ba,$bb,$bc,$bd,$be,$bf, + $c0,$c1,$c2,$c3,$c4,$c5,$c6,$c7,$c8,$c9,$ca,$cb,$cc,$cd,$ce,$cf,$d0,$d1,$d2,$d3,$d4,$d5,$d6,$d7, + $d8,$d9,$da,$db,$dc,$dd,$de,$df,$e0,$e1,$e2,$e3,$e4,$e5,$e6,$e7,$e8,$e9,$ea,$eb,$ec,$ed,$ee,$ef, + $f0,$f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$fa,$fb,$fc,$fd,$fe,$ff); + C07: array[0..255] of byte =($79,$3b,$3f,$d2,$52,$94,$12,$24,$a6,$af,$dc,$5b,$e7,$f5,$01,$b9, + $15,$06,$96,$da,$12,$04,$5c,$1c,$60,$77,$d3,$ca,$c7,$74,$ac,$cf,$c3,$d5,$30,$d8,$48,$d6,$65,$d8, + $1a,$49,$cb,$b5,0,$b8,$8b,$bb,$62,$4a,$e6,$1d,$16,$67,$22,$9c,$30,$2d,$c6,$ff,$0b,$b4,$d7,$0b, + $db,$bc,$85,$66,$d6,$f5,$b1,$58,$da,$99,$a2,$ff,$2e,$01,$dd,$a6,$29,$b8,$9c,$34,$ad,$1e,$5f,$eb, + $a7,$0e,$7a,$ae,$43,$28,$28,$9c,$36,$29,$b0,$58,$83,$50,$58,$1c,$a8,$b9,$7c,$cf,$12,$58,$fa,$3b, + $be,$2c,$50,$26,$04,$7b,$a7,$26,$48,$96,$9c,$ff,$8b,$a1,$0a,$e3,$0e,$05,$93,$5d,$f0,$c6,$93,$74, + $18,$92,$b7,$6f,$af,$67,$13,$3a,$bd,$2c,$f2,$03,$11,$21,$bd,$8b,$b3,$81,$27,$a4,$d2,$ee,$de,$ea, + $13,$27,$64,$94,$f4,$02,$cd,$7c,$10,$7f,$b3,$ec,$3b,$24,$78,$48,$34,$33,$8e,$55,$43,$62,$87,$09, + $2a,$c4,$a2,$6f,$5e,$a7,$ea,$4a,$d6,$8d,$73,$15,$16,$39,$b0,$5b,$24,$e6,$8b,$98,$16,$d1,$39,$83, + $76,$d8,$e4,$13,$85,$94,$75,$8d,$b9,$ad,$3b,$40,$92,$59,$b2,$6d,$cf,$c0,$6e,$72,$2b,$e9,$87,$b3, + $76,$7f,$70,$a7,$b8,$56,$b7,$74,$b1,$ba,$26,$85,$b3,$68,$09,$14,$29,$fc,$cb,$8d,$cd,$de,$09,$e4); + T07: array[0..15] of byte = ($87,$ec,$83,$7a,$bf,$53,$28,$55,$b2,$ce,$a1,$69,$d6,$94,$3f,$cd); + K08: THash256 = ($fb,$76,$15,$b2,$3d,$80,$89,$1d,$d4,$70,$98,$0b,$c7,$95,$84,$c8, + $b2,$fb,$64,$ce,$60,$97,$87,$8d,$17,$fc,$e4,$5a,$49,$e8,$30,$b7); + I08: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4,$02,$da,$7d,$6f); + H08: array[0.. 0] of byte = ($36); + P08: array[0.. 0] of byte = ($a9); + C08: array[0.. 0] of byte = ($0a); + T08: array[0..15] of byte = ($be,$98,$7d,0,$9a,$4b,$34,$9a,$a8,$0c,$b9,$c4,$eb,$c1,$e9,$f4); + K09: THash256 = ($f8,$d4,$76,$cf,$d6,$46,$ea,$6c,$23,$84,$cb,$1c,$27,$d6,$19,$5d, + $fe,$f1,$a9,$f3,$7b,$9c,$8d,$21,$a7,$9c,$21,$f8,$cb,$90,$d2,$89); + I09: array[0..11] of byte = ($db,$d1,$a3,$63,$60,$24,$b7,$b4,$02,$da,$7d,$6f); + H09: array[0..19] of byte = ($7b,$d8,$59,$a2,$47,$96,$1a,$21,$82,$3b,$38,$0e,$9f,$e8,$b6,$50,$82,$ba,$61,$d3); + P09: array[0..19] of byte = ($90,$ae,$61,$cf,$7b,$ae,$bd,$4c,$ad,$e4,$94,$c5,$4a,$29,$ae,$70,$26,$9a,$ec,$71); + C09: array[0..19] of byte = ($ce,$20,$27,$b4,$7a,$84,$32,$52,$01,$34,$65,$83,$4d,$75,$fd,$0f,$07,$29,$75,$2e); + T09: array[0..15] of byte = ($ac,$d8,$83,$38,$37,$ab,$0e,$de,$84,$f4,$74,$8d,$a8,$89,$9c,$15); + K10: THash256 = ($db,$bc,$85,$66,$d6,$f5,$b1,$58,$da,$99,$a2,$ff,$2e,$01,$dd,$a6, + $29,$b8,$9c,$34,$ad,$1e,$5f,$eb,$a7,$0e,$7a,$ae,$43,$28,$28,$9c); + I10: array[0..15] of byte = ($cf,$c0,$6e,$72,$2b,$e9,$87,$b3,$76,$7f,$70,$a7,$b8,$56,$b7,$74); + P10: array[0..15] of byte = ($ce,$20,$27,$b4,$7a,$84,$32,$52,$01,$34,$65,$83,$4d,$75,$fd,$0f); + C10: array[0..15] of byte = ($dc,$03,$e5,$24,$83,$0d,$30,$f8,$8e,$19,$7f,$3a,$ca,$ce,$66,$ef); + T10: array[0..15] of byte = ($99,$84,$ef,$f6,$90,$57,$55,$d1,$83,$6f,$2d,$b0,$40,$89,$63,$4c); + K11: THash256 = ($0e,$05,$93,$5d,$f0,$c6,$93,$74,$18,$92,$b7,$6f,$af,$67,$13,$3a, + $bd,$2c,$f2,$03,$11,$21,$bd,$8b,$b3,$81,$27,$a4,$d2,$ee,$de,$ea); + I11: array[0..16] of byte = ($74,$b1,$ba,$26,$85,$b3,$68,$09,$14,$29,$fc,$cb,$8d,$cd,$de,$09,$e4); + H11: array[0..19] of byte = ($7b,$d8,$59,$a2,$47,$96,$1a,$21,$82,$3b,$38,$0e,$9f,$e8,$b6,$50,$82,$ba,$61,$d3); + P11: array[0..19] of byte = ($90,$ae,$61,$cf,$7b,$ae,$bd,$4c,$ad,$e4,$94,$c5,$4a,$29,$ae,$70,$26,$9a,$ec,$71); + C11: array[0..19] of byte = ($6b,$e6,$5e,$56,$06,$6c,$40,$56,$73,$8c,$03,$fe,$23,$20,$97,$4b,$a3,$f6,$5e,$09); + T11: array[0..15] of byte = ($61,$08,$dc,$41,$7b,$f3,$2f,$7f,$b7,$55,$4a,$e5,$2f,$08,$8f,$87); + procedure test(ptag: pointer; tlen: PtrInt; const key; kbits: PtrInt; + pIV: pointer; IV_Len: PtrInt; pAAD: pointer; aLen: PtrInt; + ctp: pointer; cLen: PtrInt; ptp: pointer; tn: integer); + var tag: TAESBLock; + ctxt: TAESGCMEngine; + pt, ct: array[0..511] of byte; + begin + FillCharFast(pt,SizeOf(pt),0); + CheckUTF8(ctxt.FullDecryptAndVerify( + key,kbits,pIV,IV_Len,pAAD,aLen,ctp,@pt,cLen,ptag,tlen), + 'FullDecryptAndVerify #%',[tn]); + CheckUTF8(CompareMem(@pt,ptp,cLen),'Plain #%',[tn]); + FillCharFast(ct,SizeOf(ct),0); + CheckUTF8(ctxt.FullEncryptAndAuthenticate( + key,kbits,pIV,IV_len,pAAD,aLen,ptp,@ct,clen,tag), + 'FullEncryptAndAuthenticate #%',[tn]); + CheckUTF8(CompareMem(@tag,ptag,tLen),'Tag #%',[tn]); + CheckUTF8(CompareMem(@ct,ctp,cLen),'Encoded #%',[tn]); + end; +var ctxt: TAESGCMEngine; + key,tag: TAESBlock; + buf: THash512; + n: integer; +begin + key := PAESBlock(@hex32)^; + for n := 1 to 32 do begin + Check(ctxt.Init(key,128)); + Check(ctxt.Reset(@hex32,n)); + Check(ctxt.Add_AAD(@hex32,n)); + Check(ctxt.Encrypt(@hex32,@buf,n)); + Check(ctxt.Final(tag)); + key := tag; + end; + Check(CompareMem(@buf32,@buf,SizeOf(buf32))); + Check(CompareMem(@tag32,@tag,SizeOf(tag32))); + test(@T01,16,K01,8*sizeof(K01),@I01,sizeof(I01),nil,0,@C01,sizeof(C01),@P01,01); + test(@T02,16,K02,8*sizeof(K02),@I02,sizeof(I02),@H02,sizeof(H02),nil,0,nil,02); + test(@T03,16,K03,8*sizeof(K03),@I03,sizeof(I03),@H03,sizeof(H03),@C03,sizeof(C03),@P03,03); + test(@T04,16,K04,8*sizeof(K04),@I04,sizeof(I04),nil,0,@C04,sizeof(C04),@P04,04); + test(@T05,16,K05,8*sizeof(K05),@I05,sizeof(I05),@H05,sizeof(H05),@C05,sizeof(C05),@P05,05); + test(@T07,16,K07,8*sizeof(K07),@I07,sizeof(I07),@H07,sizeof(H07),@C07,sizeof(C07),@P07,07); + test(@T08,16,K08,8*sizeof(K08),@I08,sizeof(I08),@H08,sizeof(H08),@C08,sizeof(C08),@P08,08); + test(@T09,16,K09,8*sizeof(K09),@I09,sizeof(I09),@H09,sizeof(H09),@C09,sizeof(C09),@P09,09); + test(@T10,16,K10,8*sizeof(K10),@I10,sizeof(I10),nil,0,@C10,sizeof(C10),@P10,10); + test(@T11,16,K11,8*sizeof(K11),@I11,sizeof(I11),@H11,sizeof(H11),@C11,sizeof(C11),@P11,11); +end; + procedure TTestCryptographicRoutines._CompressShaAes; var s1,s2: RawByteString; keysize,i: integer; @@ -12796,19 +13077,19 @@ type bSHA3_256, bSHA3_512, // encryption bRC4, - bAES128CFB, bAES128OFB, bAES128CFBCRC, bAES128OFBCRC, - bAES256CFB, bAES256OFB, bAES256CFBCRC, bAES256OFBCRC, + bAES128CFB, bAES128OFB, bAES128CFBCRC, bAES128OFBCRC, bAES128GCM, + bAES256CFB, bAES256OFB, bAES256CFBCRC, bAES256OFBCRC, bAES256GCM, bSHAKE128, bSHAKE256 ); procedure TTestCryptographicRoutines.Benchmark; const SIZ: array[0..4] of integer = (8, 50, 100, 1000, 10000); COUNT = 500; - AESCLASS: array[bAES128CFB .. bAES256OFBCRC] of TAESAbstractClass = ( - TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC, - TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC); - AESBITS: array[bAES128CFB .. bAES256OFBCRC] of integer = ( - 128, 128, 128, 128, 256, 256, 256, 256); + AESCLASS: array[bAES128CFB .. bAES256GCM] of TAESAbstractClass = ( + TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC, TAESGCM, + TAESCFB, TAESOFB, TAESCFBCRC, TAESOFBCRC, TAESGCM); + AESBITS: array[bAES128CFB .. bAES256GCM] of integer = ( + 128, 128, 128, 128, 128, 256, 256, 256, 256, 256); var b: TBenchmark; s, i, size, n: integer; data, encrypted: RawByteString; @@ -12822,7 +13103,7 @@ var b: TBenchmark; RC4: TRC4; timer: TPrecisionTimer; time: array[TBenchmark] of Int64; - AES: array[bAES128CFB .. bAES256OFBCRC] of TAESAbstract; + AES: array[bAES128CFB .. bAES256GCM] of TAESAbstract; TXT: array[TBenchmark] of RawUTF8; begin GetEnumTrimmedNames(TypeInfo(TBenchmark),@TXT); @@ -12861,9 +13142,10 @@ begin bSHA3_512: SHA3.Full(pointer(data),SIZ[s],dig.b); bRC4: RC4.EncryptBuffer(pointer(data), pointer(Encrypted), SIZ[s]); bAES128CFB, bAES128OFB, bAES256CFB, bAES256OFB: - AES[b].EncryptPKCS7(Data, true); - bAES128CFBCRC, bAES128OFBCRC, bAES256CFBCRC, bAES256OFBCRC: - AES[b].MACAndCrypt(Data,true); + AES[b].EncryptPKCS7(Data,{encrypt=}true); + bAES128CFBCRC, bAES128OFBCRC, bAES256CFBCRC, bAES256OFBCRC, + bAES128GCM, bAES256GCM: + AES[b].MACAndCrypt(Data,{encrypt=}true); bSHAKE128: SHAKE128.Cypher(pointer(Data), pointer(Encrypted), SIZ[s]); bSHAKE256: SHAKE256.Cypher(pointer(Data), pointer(Encrypted), SIZ[s]); end; @@ -14418,12 +14700,12 @@ end; procedure TTestMemoryBased._TSQLTableWritable; procedure Test(intern: TRawUTF8Interning); - var s1,s2: TSQLTableJSON; + var s1,s2: TSQLTableJson; w: TSQLTableWritable; f,r: integer; begin - s1 := TSQLTableJSON.CreateFromTables([TSQLRecordPeople],'',JS); - s2 := TSQLTableJSON.CreateFromTables([TSQLRecordPeople],'',JS); + s1 := TSQLTableJson.CreateFromTables([TSQLRecordPeople],'',JS); + s2 := TSQLTableJson.CreateFromTables([TSQLRecordPeople],'',JS); w := TSQLTableWritable.CreateFromTables([TSQLRecordPeople],'',JS); try // merge the same data twice, and validate duplicated columns w.NewValuesInterning := intern; @@ -14824,10 +15106,10 @@ begin if CheckFailed(Resp<>nil) then exit; try - Check(Resp.InheritsFrom(TSQLTableJSON)); - len := Length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; + Check(Resp.InheritsFrom(TSQLTableJson)); + len := Length(TSQLTableJson(Resp).PrivateInternalCopy)-16; if not CheckFailed(len>0) then - Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),len)=$F11CEAC0); + Check(Hash32(pointer(TSQLTableJson(Resp).PrivateInternalCopy),len)=$F11CEAC0); //FileFromString(Resp.GetODSDocument,'people.ods'); finally Resp.Free; @@ -14915,9 +15197,9 @@ begin Resp := Client.List([TSQLRecordPeople],'*',CLIENTTEST_WHERECLAUSE); if CheckFailed(Resp<>nil) then exit; - siz := length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; + siz := length(TSQLTableJson(Resp).PrivateInternalCopy)-16; if not CheckFailed(siz=4818) then - Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),siz)=$8D727024); + Check(Hash32(pointer(TSQLTableJson(Resp).PrivateInternalCopy),siz)=$8D727024); Resp.Free; {$ifdef WTIME} fRunConsole := format('%s%s, first %s, ',[fRunConsole,KB(siz),Timer.Stop]); @@ -14992,11 +15274,11 @@ begin if CheckFailed(Resp<>nil) then exit; try - Check(Resp.InheritsFrom(TSQLTableJSON)); + Check(Resp.InheritsFrom(TSQLTableJson)); // every answer contains 113 rows, for a total JSON size of 4803 bytes - siz := length(TSQLTableJSON(Resp).PrivateInternalCopy)-16; + siz := length(TSQLTableJson(Resp).PrivateInternalCopy)-16; if not CheckFailed(siz>0) then - Check(Hash32(pointer(TSQLTableJSON(Resp).PrivateInternalCopy),siz)=$8D727024); + Check(Hash32(pointer(TSQLTableJson(Resp).PrivateInternalCopy),siz)=$8D727024); finally Resp.Free; end; @@ -15345,6 +15627,8 @@ type {$endif} end; +{ TSQLRecordCustomProps } + class procedure TSQLRecordCustomProps.InternalRegisterCustomProperties(Props: TSQLRecordProperties); begin Props.RegisterCustomPropertyFromTypeName(self,'TGUID','GUID', @@ -15600,6 +15884,10 @@ begin 'select count(*) from SampleRecord'); Test2('select count(*) from PeopleExt where rowid=2', 'select count(*) from SampleRecord where id=2'); + Test2('select count(*) from PeopleExt where rowid=2 /*tobeignored*/', + 'select count(*) from SampleRecord where id=2'); + Test2('select count(*) from PeopleExt where /*tobeignored*/ rowid=2', + 'select count(*) from SampleRecord where id=2'); Test2('select Distinct(firstname) , max(lastchange)+100 from PeopleExt where rowid >= :(2):', 'select Distinct(FirstName),max(Changed)+100 as LastChange from SampleRecord where ID>=:(2):'); Test2('select Distinct(lastchange) , max(rowid)-100 as newid from PeopleExt where rowid >= :(2):', @@ -15644,6 +15932,9 @@ begin Test(dJet,true,'select top 2 id,firstname from SampleRecord order by firstname'); Test(dMySQL,true,'select id,firstname from SampleRecord order by firstname limit 2'); Test(dSQLite,true,'select id,firstname from SampleRecord order by firstname limit 2'); + SqlOrigin := 'SELECT RowID,firstname FROM PeopleExt WHERE :(3001): '+ + 'BETWEEN firstname AND RowID LIMIT 1'; + Test(dSQLite,false); finally Ext.Free; end; @@ -16597,7 +16888,7 @@ var V,V2: TSQLRecordPeople; Curr: Currency; DaVinci, s: RawUTF8; Refreshed: boolean; - J: TSQLTableJSON; + J: TSQLTableJson; i, n, nupd, ndx: integer; IntArray: TInt64DynArray; Results: TIDDynArray; @@ -17041,7 +17332,7 @@ begin J := Client.List([TSQLRecordPeople],'*',s); Check(Client.UpdateFromServer([J],Refreshed)); Check(not Refreshed); - Check(TestTable(J),'incorrect TSQLTableJSON'); + Check(TestTable(J),'incorrect TSQLTableJson'); Check(Client.OneFieldValues(TSQLRecordPeople,'ID','LastName=:("Dali"):',IntArray)); Check(length(IntArray)=1001); for i := 0 to high(IntArray) do @@ -17400,8 +17691,8 @@ begin {$endif} end; -procedure TTestSQLite3Engine._TSQLTableJSON; -var J: TSQLTableJSON; +procedure TTestSQLite3Engine._TSQLTableJson; +var J: TSQLTableJson; i1, i2, aR, aF, F1,F2, n: integer; Comp, Comp1,Comp2: TUTF8Compare; {$ifdef UNICODE} @@ -17441,7 +17732,7 @@ const '"V03_TM":"sjentonpg@senate.gov"}]'; {$endif} begin - J := TSQLTableJSON.Create('',JS); + J := TSQLTableJson.Create('',JS); try J.SetFieldType('YearOfBirth',sftModTime); if JS<>'' then // avoid memory leak @@ -17591,7 +17882,7 @@ begin end; // some tests to avoid regression about bugs reported by users on forum {$ifndef NOVARIANTS} - J := TSQLTableJSON.Create('',TEST_DATA); + J := TSQLTableJson.Create('',TEST_DATA); try check(J.fieldCount=24); check(J.rowCount=3); @@ -17616,7 +17907,7 @@ begin i1 := PosEx(',"CHANNEL":132',s); i2 := PosEx('}',s,i1); delete(s,i1,i2-i1); // truncate the 2nd object - J := TSQLTableJSON.Create('',s); + J := TSQLTableJson.Create('',s); try check(J.fieldCount=24); if not checkfailed(J.rowCount=3) then diff --git a/contrib/mORMot/SynTable.pas b/contrib/mORMot/SynTable.pas index e479e1b..7779730 100644 --- a/contrib/mORMot/SynTable.pas +++ b/contrib/mORMot/SynTable.pas @@ -6,7 +6,7 @@ unit SynTable; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynTable; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -308,6 +308,26 @@ const // compute up to 7 soundex chars in a cardinal (that's our choice) SOUNDEX_BITS = 4; +var + DoIsValidUTF8: function(source: PUTF8Char): Boolean; + DoIsValidUTF8Len: function(source: PUTF8Char; sourcelen: PtrInt): Boolean; + +/// returns TRUE if the supplied buffer has valid UTF-8 encoding +// - will stop when the buffer contains #0 +// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM +function IsValidUTF8(source: PUTF8Char): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if the supplied buffer has valid UTF-8 encoding +// - will also refuse #0 characters within the buffer +// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM +function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} + +/// returns TRUE if the supplied buffer has valid UTF-8 encoding +// - will also refuse #0 characters within the buffer +// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM +function IsValidUTF8(const source: RawUTF8): Boolean; overload; + + { ************ filtering and validation classes and functions ************** } @@ -698,6 +718,20 @@ type property UTF8Length: boolean read fUTF8Length write fUTF8Length; end; +resourcestring + sInvalidIPAddress = '"%s" is an invalid IP v4 address'; + sInvalidEmailAddress = '"%s" is an invalid email address'; + sInvalidPattern = '"%s" does not match the expected pattern'; + sCharacter01n = 'character,character,characters'; + sInvalidTextLengthMin = 'Expect at least %d %s'; + sInvalidTextLengthMax = 'Expect up to %d %s'; + sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+ + 'alphabetical,digital,punctuation,lowercase,uppercase,space,'+ + 'Too much spaces on the left,Too much spaces on the right'; + sValidationFailed = '"%s" rule failed'; + sValidationFieldVoid = 'An unique key field must not be void'; + sValidationFieldDuplicate = 'Value already used for this unique key field'; + { ************ Database types and classes ************************** } @@ -3870,7 +3904,7 @@ type function SaveToBuffer: RawByteString; /// retrieve the time bias (in minutes) for a given date/time on a TzId function GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID; - out Bias: integer; out HaveDaylight: boolean): boolean; + out Bias: integer; out HaveDaylight: boolean; DateIsUTC: boolean=false): boolean; /// retrieve the display text corresponding to a TzId // - returns '' if the supplied TzId is not recognized function GetDisplay(const TzId: TTimeZoneID): RawUTF8; @@ -7694,7 +7728,7 @@ lim2: if IdemPropNameU(Prop,'LIMIT') then end else exit; // incorrect SQL statement end else - if Prop<>'' then + if (Prop<>'') or not(GotoNextNotSpace(P)^ in [#0, ';']) then exit else // incorrect SQL statement break; // reached the end of the statement end; @@ -9101,6 +9135,312 @@ begin next^ := FindNextUTF8WordBegin(U); end; +{$ifdef ASMX64AVX} // AVX2 ASM not available on Delphi yet +// adapted from https://github.com/simdjson/simdjson - Apache License 2.0 +function IsValidUtf8LenAvx2(source: PUtf8Char; sourcelen: PtrInt): boolean; + {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} + test source, source + jz @ok + test sourcelen, sourcelen + jle @ok + {$ifdef win64} // this ABI doesn't consider rsi/rdi as volatile + push rsi + push rdi + {$endif} + push rbp + mov r8, source + mov rdx, sourcelen + mov rsi, r8 + mov ecx, 64 + mov rax, rsi + mov rdi, rdx + mov rbp, rsp + and rsp, 0FFFFFFFFFFFFFFE0H // align stack at 32 bytes + sub rsp, 160 + cmp rdx, 64 + cmovnc rcx, rdx + sub rcx, 64 + je @small + vpxor xmm3, xmm3, xmm3 + vmovdqa ymm7, ymmword ptr [rip + @0f] + vmovdqa ymm15, ymmword ptr [rip + @_6] + xor esi, esi + vmovdqa ymm14, ymmword ptr [rip + @_7] + vmovdqa ymm13, ymmword ptr [rip + @_8] + vmovdqa ymm5, ymm3 + vmovdqa ymm2, ymm3 + // main processing loop, 64 bytes per iteration + align 16 +@loop: vmovdqu xmm6, xmmword ptr [rax + rsi] + vinserti128 ymm0, ymm6, xmmword ptr [rax + rsi + 10H], 01H + vmovdqu xmm6, xmmword ptr [rax + rsi + 20H] + vinserti128 ymm1, ymm6, xmmword ptr [rax + rsi + 30H], 01H + add rsi, 64 + vpor ymm4, ymm1, ymm0 + vpmovmskb rdx, ymm4 // check set MSB of each 64 bytes + test edx, edx + jne @check + vpor ymm2, ymm5, ymm2 + vmovdqa ymm4, ymm2 + cmp rcx, rsi + ja @loop + // process trailing 0..63 bytes +@trail: sub rdi, rsi + jz @ended + add rsi, rax + vmovdqa xmm0, xmmword ptr [rip + @20] + lea rdx, qword ptr [rsp + 60H] // copy on stack with space padding + sub rsi, rdx + vmovdqa xmmword ptr [rdx], xmm0 + vmovdqa xmmword ptr [rdx + 10H], xmm0 + vmovdqa xmmword ptr [rdx + 20H], xmm0 + vmovdqa xmmword ptr [rdx + 30H], xmm0 +@by8: sub rdi, 8 + jb @by1 + mov rax, qword ptr [rsi + rdx] + mov qword ptr [rdx], rax + add rdx, 8 // in-order copy to preserve UTF-8 encoding + jmp @by8 +@by1: add rdi, 8 + jz @0 +@sml: mov al, byte ptr [rsi + rdx] + mov byte ptr [rdx], al + add rdx, 1 + sub rdi, 1 + jnz @sml +@0: vmovdqa ymm1, ymmword ptr [rsp + 60H] + vmovdqa ymm2, ymmword ptr [rsp + 80H] + vpor ymm0, ymm1, ymm2 + vpmovmskb rax, ymm0 // check any set MSB + test eax, eax + jne @last +@ended: vpor ymm5, ymm5, ymm4 +@final: vptest ymm5, ymm5 + sete al + vzeroupper + leave // mov rsp,rbp + pop rbp + {$ifdef win64} + pop rdi + pop rsi + {$endif} + ret +@ok: mov al, 1 + ret +@small: vpxor xmm4, xmm4, xmm4 + xor esi, esi + vmovdqa ymm3, ymm4 + vmovdqa ymm5, ymm4 + jmp @trail + // validate UTF-8 extra bytes from main loop + align 8 +@check: vpsrlw ymm9, ymm0, 4 + vpsrlw ymm12, ymm1, 4 + vperm2i128 ymm3, ymm3, ymm0, 21H + vpalignr ymm5, ymm0, ymm3, 0FH + vpalignr ymm11, ymm0, ymm3, 0EH + vpsubusb ymm11, ymm11, ymmword ptr [rip + @_9] + vpalignr ymm3, ymm0, ymm3, 0DH + vperm2i128 ymm0, ymm0, ymm1, 21H + vpsubusb ymm3, ymm3, ymmword ptr [rip + @_10] + vpalignr ymm8, ymm1, ymm0, 0FH + vpsrlw ymm10, ymm5, 4 + vpand ymm5, ymm7, ymm5 + vpsrlw ymm6, ymm8, 4 + vpalignr ymm4, ymm1, ymm0, 0EH + vpsubusb ymm4, ymm4, ymmword ptr [rip + @_9] + vpalignr ymm0, ymm1, ymm0, 0DH + vpsubusb ymm0, ymm0, ymmword ptr [rip + @_10] + vpand ymm10, ymm10, ymm7 + vpand ymm6, ymm6, ymm7 + vpand ymm8, ymm7, ymm8 + vpor ymm3, ymm3, ymm11 + vpor ymm0, ymm4, ymm0 + vpxor xmm11, xmm11, xmm11 + vpshufb ymm10, ymm15, ymm10 + vpshufb ymm5, ymm14, ymm5 + vpand ymm9, ymm9, ymm7 + vpshufb ymm6, ymm15, ymm6 + vpshufb ymm8, ymm14, ymm8 + vpand ymm12, ymm12, ymm7 + vpand ymm5, ymm5, ymm10 + vpcmpgtb ymm3, ymm3, ymm11 + vpcmpgtb ymm0, ymm0, ymm11 + vpshufb ymm9, ymm13, ymm9 + vpand ymm3, ymm3, ymmword ptr [rip + @_11] + vpand ymm0, ymm0, ymmword ptr [rip + @_11] + vpshufb ymm12, ymm13, ymm12 + vpand ymm6, ymm6, ymm8 + vpand ymm9, ymm5, ymm9 + vpsubusb ymm5, ymm1, ymmword ptr [rip + @_12] + vpand ymm12, ymm6, ymm12 + vpxor ymm9, ymm3, ymm9 + vmovdqa ymm3, ymm1 + vpxor ymm12, ymm0, ymm12 + vpor ymm9, ymm9, ymm12 + vpor ymm2, ymm9, ymm2 + vmovdqa ymm4, ymm2 + cmp rcx, rsi + ja @loop + jmp @trail + // validate UTF-8 extra bytes from input ending + align 8 +@last: vmovdqa ymm5, ymmword ptr [rip + @0f] + vperm2i128 ymm3, ymm3, ymm1, 21H + vmovdqa ymm9, ymmword ptr [rip + @_7] + vpsrlw ymm11, ymm1, 4 + vpalignr ymm0, ymm1, ymm3, 0FH + vmovdqa ymm13, ymmword ptr [rip + @_10] + vmovdqa ymm14, ymmword ptr [rip + @_9] + vpsrlw ymm6, ymm0, 4 + vpand ymm0, ymm5, ymm0 + vpand ymm11, ymm11, ymm5 + vmovdqa ymm7, ymmword ptr [rip + @_6] + vpshufb ymm10, ymm9, ymm0 + vpalignr ymm0, ymm1, ymm3, 0EH + vpand ymm6, ymm6, ymm5 + vmovdqa ymm8, ymmword ptr [rip + @_8] + vpalignr ymm3, ymm1, ymm3, 0DH + vperm2i128 ymm1, ymm1, ymm2, 21H + vpsubusb ymm0, ymm0, ymm14 + vpsubusb ymm12, ymm3, ymm13 + vpalignr ymm3, ymm2, ymm1, 0FH + vpshufb ymm6, ymm7, ymm6 + vpsrlw ymm15, ymm3, 4 + vpand ymm3, ymm5, ymm3 + vpor ymm0, ymm0, ymm12 + vpshufb ymm9, ymm9, ymm3 + vpsrlw ymm3, ymm2, 4 + vpand ymm15, ymm15, ymm5 + vpand ymm5, ymm3, ymm5 + vpalignr ymm3, ymm2, ymm1, 0EH + vpxor xmm12, xmm12, xmm12 + vpalignr ymm1, ymm2, ymm1, 0DH + vpsubusb ymm3, ymm3, ymm14 + vpshufb ymm11, ymm8, ymm11 + vpsubusb ymm1, ymm1, ymm13 + vpcmpgtb ymm0, ymm0, ymm12 + vpshufb ymm7, ymm7, ymm15 + vpor ymm1, ymm3, ymm1 + vpshufb ymm8, ymm8, ymm5 + vpsubusb ymm5, ymm2, ymmword ptr [rip + @_12] + vmovdqa ymm2, ymmword ptr [rip + @_11] + vpcmpgtb ymm1, ymm1, ymm12 + vpand ymm6, ymm6, ymm10 + vpand ymm7, ymm7, ymm9 + vpand ymm0, ymm0, ymm2 + vpand ymm11, ymm6, ymm11 + vpand ymm8, ymm7, ymm8 + vpxor ymm0, ymm0, ymm11 + vpor ymm5, ymm4, ymm5 + vpand ymm1, ymm1, ymm2 + vpxor ymm1, ymm1, ymm8 + vpor ymm0, ymm0, ymm1 + vpor ymm5, ymm0, ymm5 + jmp @final + align 16 +@20: dq 2020202020202020H + dq 2020202020202020H + align 32 +@0f: dq 0F0F0F0F0F0F0F0FH + dq 0F0F0F0F0F0F0F0FH + dq 0F0F0F0F0F0F0F0FH + dq 0F0F0F0F0F0F0F0FH +@_6: dq 0202020202020202H + dq 4915012180808080H + dq 0202020202020202H + dq 4915012180808080H +@_7: dq 0CBCBCB8B8383A3E7H + dq 0CBCBDBCBCBCBCBCBH + dq 0CBCBCB8B8383A3E7H + dq 0CBCBDBCBCBCBCBCBH +@_8: dq 0101010101010101H + dq 01010101BABAAEE6H + dq 0101010101010101H + dq 01010101BABAAEE6H +@_9: dq 0DFDFDFDFDFDFDFDFH + dq 0DFDFDFDFDFDFDFDFH + dq 0DFDFDFDFDFDFDFDFH + dq 0DFDFDFDFDFDFDFDFH +@_10: dq 0EFEFEFEFEFEFEFEFH + dq 0EFEFEFEFEFEFEFEFH + dq 0EFEFEFEFEFEFEFEFH + dq 0EFEFEFEFEFEFEFEFH +@_11: dq 8080808080808080H + dq 8080808080808080H + dq 8080808080808080H + dq 8080808080808080H +@_12: db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH + db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH + db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH + db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0EFH, 0DFH, 0BFH +end; + +function IsValidUTF8Avx2(source: PUTF8Char): Boolean; +begin + result := IsValidUTF8LenAvx2(source,StrLen(source)); +end; +{$endif ASMX64AVX} + +function IsValidUTF8Pas(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 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 + exit else + inc(source); // check valid UTF-8 content + end; + until false; + result := true; +end; + +function IsValidUTF8LenPas(source: PUTF8Char; sourcelen: PtrInt): Boolean; +var extra, i: integer; + c: cardinal; +begin + result := false; + inc(sourcelen,PtrInt(source)); + if source<>nil then + while PtrInt(PtrUInt(source))0 then begin + extra := UTF8_EXTRABYTES[c]; + if extra=0 then exit else // invalid leading byte + for i := 1 to extra do + if (PtrInt(PtrUInt(source))>=sourcelen) or (byte(source^) and $c0<>$80) then + exit else + inc(source); // check valid UTF-8 content + end; + end; + result := true; +end; + +function IsValidUTF8(source: PUTF8Char): Boolean; +begin + result := DoIsValidUTF8(source); +end; + +function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; +begin + result := DoIsValidUTF8Len(source,sourcelen); +end; + +function IsValidUTF8(const source: RawUTF8): Boolean; +begin + result := DoIsValidUTF8Len(pointer(Source),length(Source)); +end; + { ************ filtering and validation classes and functions *************** } @@ -11173,7 +11513,7 @@ var s: TStream; begin if Append and FileExists(aFileName) then begin s := TFileStream.Create(aFileName,fmOpenWrite); - s.Seek(0,soFromEnd); + s.Seek(0,soEnd); end else s := TFileStream.Create(aFileName,fmCreate); Create(s,BufLen); @@ -11930,7 +12270,7 @@ begin end else // file bigger than 2 GB: slower but accurate reading from file if Data=nil then begin - FileSeek(fMap.FileHandle,soFromCurrent,DataLen); + FileSeek64(fMap.FileHandle,DataLen,soFromCurrent); result := DataLen; end else result := FileRead(fMap.FileHandle,Data^,DataLen) else @@ -12346,7 +12686,7 @@ begin if result=0 then exit; count := result; - if count>length(Values) then // only set length is not big enough + if count>length(Values) then // change Values[] length only if not big enough SetLength(Values,count); PI := pointer(Values); fixedsize := ReadVarUInt32; @@ -16626,7 +16966,7 @@ var i: integer; if not withfreespace or not GetDiskInfo(p.mounted,av,fr,tot) then {$ifdef MSWINDOWS} FormatShort('%: % (%)',[p.mounted[1],p.name,KB(p.size,nospace)],result) else - FormatShort(F[nospace],[p.mounted[1],p.name,KB(p.size,nospace)],result); + FormatShort(F[nospace],[p.mounted[1],p.name,KB(fr,nospace),KB(tot,nospace)],result); {$else} FormatShort('% % (%)',[p.mounted,p.name,KB(p.size,nospace)],result) else FormatShort(F[nospace],[p.mounted,p.name,KB(fr,nospace),KB(tot,nospace)],result); @@ -17182,7 +17522,8 @@ begin end; function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime; - const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean): boolean; + const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean; + DateIsUTC: boolean): boolean; var ndx: integer; d: TSynSystemTime; tzi: PTimeZoneInfo; @@ -17211,6 +17552,10 @@ begin HaveDaylight := true; std := tzi.change_time_std.EncodeForTimeChange(d.Year); dlt := tzi.change_time_dlt.EncodeForTimeChange(d.Year); + if DateIsUTC then begin // std shifts by the DST bias, dst by STD + std := ((std*MinsPerDay)+tzi.Bias+tzi.bias_dlt)/MinsPerDay; + dlt := ((dlt*MinsPerDay)+tzi.Bias+tzi.bias_std)/MinsPerDay; + end; if std TLSRECMAXSIZE then raise ESChannel.CreateFmt('InputSize=%d>%d', [InputSize, TLSRECMAXSIZE]); @@ -1720,36 +1723,42 @@ end; procedure TSChannelClient.HandshakeLoop(aSocket: THandle); var buf: THandshakeBuf; - len: integer; - tmp: AnsiString; res, f: cardinal; begin - len := 0; - SetLength(tmp, 65536); res := SEC_I_CONTINUE_NEEDED; while (res = SEC_I_CONTINUE_NEEDED) or (res = SEC_E_INCOMPLETE_MESSAGE) do begin - if res <> SEC_E_INCOMPLETE_MESSAGE then - len := 0; - inc(len, CheckSocket(Recv(aSocket, @PByteArray(tmp)[len], length(tmp) - len, 0))); + inc(DataCount, CheckSocket(Recv(aSocket, + @PByteArray(Data)[DataCount], length(Data) - DataCount, 0))); buf.Init; - buf.buf[0].cbBuffer := len; + buf.buf[0].cbBuffer := DataCount; buf.buf[0].BufferType := SECBUFFER_TOKEN; - buf.buf[0].pvBuffer := pointer(tmp); + 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)); + 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); - if buf.buf[1].BufferType = SECBUFFER_EXTRA then - AppendData(buf.buf[1]); end; procedure TSChannelClient.BeforeDisconnection(aSocket: THandle); @@ -1788,7 +1797,8 @@ begin end; end; -function TSChannelClient.Receive(aSocket: THandle; aBuffer: pointer; aLength: integer): integer; +function TSChannelClient.Receive(aSocket: THandle; + aBuffer: pointer; aLength: integer): integer; var desc: TSecBufferDesc; buf: array[0..3] of TSecBuffer; @@ -1817,47 +1827,49 @@ begin exit; end; result := 0; - 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: exit; - 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; + 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; - if InputCount = 0 then - break; - res := DecryptInput; - until false; - if needsRenegotiate then - HandshakeLoop(aSocket); - except - exit; // shutdown the connection on ESChannel fatal error - 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; @@ -1914,7 +1926,7 @@ begin exit; // report connection closed if integer(s) < 0 then begin res := WSAGetLastError; - if (res <> WSATRY_AGAIN) and (res <> WSAEINTR) then begin + if res <> WSATRY_AGAIN then begin result := s; exit; // report socket fatal error end; diff --git a/contrib/mORMot/SynZLibSSE.pas b/contrib/mORMot/SynZLibSSE.pas index 5386e05..350159c 100644 --- a/contrib/mORMot/SynZLibSSE.pas +++ b/contrib/mORMot/SynZLibSSE.pas @@ -21,7 +21,7 @@ end. // put as reference all deprecated code below This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -40,7 +40,7 @@ end. // put as reference all deprecated code below The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): diff --git a/contrib/mORMot/SynZip.pas b/contrib/mORMot/SynZip.pas index be68d37..a2396dc 100644 --- a/contrib/mORMot/SynZip.pas +++ b/contrib/mORMot/SynZip.pas @@ -6,7 +6,7 @@ unit SynZip; { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,11 +25,12 @@ unit SynZip; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): - Alf + - Andre Heider (dhewg) - ehansen - jpdk - Gigo @@ -389,7 +390,7 @@ type TFileHeader = {$ifdef USERECORDWITHMETHODS}record {$else}object{$endif} signature : dword; // $02014b50 PK#1#2 - madeBy : word; // $14 + madeBy : word; // $0314 = OS + version fileInfo : TFileInfo; commentLen : word; // 0 firstDiskNo : word; // 0 @@ -692,6 +693,8 @@ type end; /// abstract write-only access for creating a .zip archive + // - update can be done manualy by using a TZipRead instance and the + // AddFromZip() method TZipWriteAbstract = class protected fAppendOffset: cardinal; @@ -723,6 +726,8 @@ type // - by default, the 1st of January, 2010 is used if not date is supplied procedure AddStored(const aZipName: TFileName; Buf: pointer; Size: integer; FileAge: integer=1+1 shl 5+30 shl 9); + /// add a file from an already compressed zip entry + procedure AddFromZip(Source: TZipRead; EntryIndex: integer); /// append a file content into the destination file // - useful to add the initial Setup.exe file, e.g. procedure Append(const Content: ZipString); @@ -732,8 +737,6 @@ type /// write-only access for creating a .zip archive file // - not to be used to update a .zip file, but to create a new one - // - update can be done manualy by using a TZipRead instance and the - // AddFromZip() method TZipWrite = class(TZipWriteAbstract) protected fFileName: TFileName; @@ -759,8 +762,6 @@ type // - if Recursive is TRUE, would include files from nested sub-folders procedure AddFolder(const FolderName: TFileName; const Mask: TFileName=ZIP_FILES_ALL; Recursive: boolean=true; CompressLevel: integer=6); - /// add a file from an already compressed zip entry - procedure AddFromZip(const ZipEntry: TZipEntry); /// release associated memory, and close destination file destructor Destroy; override; end; @@ -864,7 +865,7 @@ begin with Entry[Count] do begin fHr.signature := ENTRY_SIGNATURE_INC; // +1 to avoid finding it in the exe dec(fHr.signature); - fHr.madeBy := $14; + fHr.madeBy := $0314; // where $03=Unix (for proper UTF8 filenames) and $14=version fHr.fileInfo.neededVersion := $14; result := InternalWritePosition; fHr.localHeadOff := result-fAppendOffset; @@ -885,6 +886,7 @@ begin end; {$endif} fHr.fileInfo.nameLen := length(intName); + fhr.fileInfo.extraLen := 0; // source may have something here InternalWrite(fMagic,sizeof(fMagic)); InternalWrite(fhr.fileInfo,sizeof(fhr.fileInfo)); InternalWrite(pointer(intName)^,fhr.fileInfo.nameLen); @@ -913,7 +915,7 @@ begin tmpsize := (Int64(Size)*11) div 10+12; Getmem(tmp,tmpSize); zzipSize := CompressMem(Buf,tmp,Size,tmpSize,CompressLevel); - InternalAdd(aZipName,tmp,zzipSize); // write stored data + InternalAdd(aZipName,tmp,zzipSize); // write deflated data and inc(Count) Freemem(tmp); end; end; @@ -931,10 +933,29 @@ begin zfullSize := Size; zzipSize := Size; zlastMod := FileAge; - InternalAdd(aZipName,Buf,Size); + InternalAdd(aZipName,Buf,Size); // write stored data and inc(Count) end; end; +procedure TZipWriteAbstract.AddFromZip(Source: TZipRead; EntryIndex: integer); +var s: ^TZipEntry; + origZipName: TFileName; +begin + if (self=nil) or (Source=nil) then + exit; + if Count>=length(Entry) then + SetLength(Entry,length(Entry)+20); + with Entry[Count] do + if Source.RetrieveFileInfo(EntryIndex, fhr.FileInfo) then begin + s := @Source.Entry[EntryIndex]; + // backslash in s^.storedName are replaced to '\' by TZipRead.Create, + // accoding to ZIP file format "All slashes MUST be forward slashes '/' as opposed to + // backwards slashes '\'" + SetString(origZipName,s^.storedName,s^.infoLocal.nameLen); + InternalAdd(origZipName,s^.data,fhr.fileInfo.zzipSize); + end; +end; + procedure TZipWriteAbstract.Append(const Content: ZipString); begin if (self=nil) or (fAppendOffset<>0) then @@ -1040,7 +1061,7 @@ begin raise ESynZipException.CreateFmt('%s file too big for .zip',[aFileName]); if Count>=length(Entry) then SetLength(Entry,length(Entry)+20); - OffsHead := InternalAdd(ZipName,nil,0); + OffsHead := InternalAdd(ZipName,nil,0); // write data and inc(Count) D := THandleStream.Create(Handle); Z := TSynZipCompressor.Create(D,CompressLevel); try @@ -1074,18 +1095,6 @@ begin end; end; -procedure TZipWrite.AddFromZip(const ZipEntry: TZipEntry); -begin - if (self=nil) or (Handle<=0) then - exit; - if Count>=length(Entry) then - SetLength(Entry,length(Entry)+20); - with Entry[Count] do begin - fhr.fileInfo := ZipEntry.infoLocal^; - InternalAdd(ZipEntry.zipName,ZipEntry.data,fhr.fileInfo.zzipSize); - end; -end; - constructor TZipWrite.Create(const aFileName: TFileName); begin Create; @@ -1223,7 +1232,7 @@ begin // UnZip() will call RetrieveFileInfo() end else if (zzipSize=cardinal(-1)) or (zfullSize=cardinal(-1)) then - raise ESynZipException.Create('ZIP64 format not supported'); + raise ESynZipException.Create('ZIP64 format not supported - use mORMot 2'); with Entry[Count] do begin infoLocal := @lfhr^.fileInfo; infoDirectory := H; @@ -5028,6 +5037,26 @@ begin Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(Stream))>=0 end; +function ZLibError(Code: integer): shortstring; +begin + case Code of + Z_ERRNO: + result := 'Z_ERRNO'; + Z_STREAM_ERROR: + result := 'Z_STREAM_ERROR'; + Z_DATA_ERROR: + result := 'Z_DATA_ERROR'; + Z_MEM_ERROR: + result := 'Z_MEM_ERROR'; + Z_BUF_ERROR: + result := 'Z_BUF_ERROR'; + Z_VERSION_ERROR: + result := 'Z_VERSION_ERROR'; + else + str(Code,result); + end; +end; + function Check(const Code: Integer; const ValidCodes: array of Integer; const Context: string): integer; var i: Integer; @@ -5038,7 +5067,7 @@ begin for i := Low(ValidCodes) to High(ValidCodes) do if ValidCodes[i]=Code then Exit; - raise ESynZipException.CreateFmt('Error %d during %s process',[Code,Context]); + raise ESynZipException.CreateFmt('Error %s during %s process',[ZLibError(Code),Context]); end; function CompressString(const data: ZipString; failIfGrow: boolean = false; @@ -5195,6 +5224,8 @@ begin try repeat code := Check(inflate(strm, Z_FINISH),[Z_OK,Z_STREAM_END,Z_BUF_ERROR],'UnCompressStream'); + if (code=Z_BUF_ERROR) and (TempBufSize=integer(strm.avail_out)) then + Check(code,[],'UnCompressStream'); // occur on invalid input FlushBuf; until code=Z_STREAM_END; FlushBuf; diff --git a/contrib/mORMot/SynZipFiles.pas b/contrib/mORMot/SynZipFiles.pas index 607887f..6a0bdc0 100644 --- a/contrib/mORMot/SynZipFiles.pas +++ b/contrib/mORMot/SynZipFiles.pas @@ -6,7 +6,7 @@ unit SynZipFiles; (* This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -25,7 +25,7 @@ unit SynZipFiles; The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -168,7 +168,7 @@ type fAlgorithmStream: THeapMemoryStream; fAlgorithmID: integer; // =0 if not Assigned(fAlgorithm) fCRC: Cardinal; - fBlobDataHeaderPosition: integer; + fBlobDataHeaderPosition: Int64; fBufferIn, fBufferOut: array[word] of byte; // two 64kb buffers procedure Finish; function FlushBufferOut: integer; @@ -910,12 +910,12 @@ constructor TZipCompressor.CreateAsBlobData(outStream: TStream; CompressionLevel, Algorithm: Integer); begin Create(outStream,CompressionLevel,Algorithm); - fBlobDataHeaderPosition := outStream.Seek(0,soFromCurrent); + fBlobDataHeaderPosition := outStream.Seek(0,soCurrent); outStream.WriteBuffer(FBufferOut,BLOBDATA_HEADSIZE); // save Bulk header end; destructor TZipCompressor.Destroy; -var p: integer; +var p: Int64; blob: TBlobData; begin if FInitialized then begin @@ -927,7 +927,7 @@ begin FreeAndNil(fAlgorithm); end; if fBlobDataHeaderPosition>=0 then begin // CreateAsBlobData() -> update header - p := fDestStream.Seek(0,soFromCurrent); + p := fDestStream.Seek(0,soCurrent); with blob do begin dataFullSize := SizeIn; dataSize := p-fBlobDataHeaderPosition-BLOBDATA_HEADSIZE; @@ -938,9 +938,9 @@ begin dataMethod := 8 else dataMethod := fAlgorithmID shl 4; // stored + AlgoID end; - fDestStream.Seek(fBlobDataHeaderPosition,soFromBeginning); + fDestStream.Seek(fBlobDataHeaderPosition,soBeginning); fDestStream.WriteBuffer(blob,BLOBDATA_HEADSIZE); - fDestStream.Seek(p,soFromBeginning); + fDestStream.Seek(p,soBeginning); end; inherited; end; @@ -952,7 +952,7 @@ begin if assigned(fAlgorithmStream) then begin fAlgorithmStream.WriteBuffer(fBufferIn,fStrm.avail_in); // write pending data fStrm.total_in := fAlgorithm.Compress( // compress whole data at once - fAlgorithmStream.Memory,fAlgorithmStream.Seek(0,soFromCurrent),@fCRC); + fAlgorithmStream.Memory,fAlgorithmStream.Seek(0,soCurrent),@fCRC); end else if FStrm.avail_in>0 then inc(fStrm.total_in,fAlgorithm.Compress(@fBufferIn,FStrm.avail_in,@fCRC)); @@ -1291,7 +1291,7 @@ begin outFile := TFileStream.Create(fFileName,fmCreate); if fromStream.InheritsFrom(TMemoryStream) then fromMemory := PAnsiChar(TMemoryStream(fromStream).Memory)+ - fromStream.Seek(0,soFromCurrent) else + fromStream.Seek(0,soCurrent) else fromMemory := nil; srcLen := 0; src := nil; @@ -1363,7 +1363,7 @@ begin thisFiles := Count; totalFiles := Count; headerSize := 0; - headerOffset := outFile.seek(0,soFromCurrent); // position of file entries + headerOffset := outFile.seek(0,soCurrent); // position of file entries commentLen := 0; end; // 2. write file entries from Entry[] @@ -1497,7 +1497,7 @@ begin if Zip.FInitialized then Header.fileInfo.zzipSize := Zip.SizeOut else Header.fileInfo.zzipSize := Header.fileInfo.zfullSize; - p := outFile.Seek(0,soFromCurrent); + p := outFile.Seek(0,soCurrent); outFile.Seek(Header.localHeadOff+sizeof(dword),soBeginning); outFile.WriteBuffer(Header.fileInfo,sizeof(Header.fileInfo)); // save updated fileInfo outFile.Seek(p,soBeginning); diff --git a/contrib/mORMot/Synopse.inc b/contrib/mORMot/Synopse.inc index e63db4c..626b732 100644 --- a/contrib/mORMot/Synopse.inc +++ b/contrib/mORMot/Synopse.inc @@ -1,7 +1,7 @@ { This file is part of Synopse framework. - Synopse framework. Copyright (C) 2020 Arnaud Bouchez + Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** @@ -20,7 +20,7 @@ The Initial Developer of the Original Code is Arnaud Bouchez. - Portions created by the Initial Developer are Copyright (C) 2020 + Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): @@ -76,6 +76,8 @@ // - 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 @@ -162,6 +164,7 @@ {$INLINE ON} {$MINENUMSIZE 1} + {$PACKRECORDS DEFAULT} // force normal alignment {$PACKSET 1} {$PACKENUM 1} {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases @@ -210,11 +213,15 @@ {$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} @@ -222,11 +229,15 @@ {$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} @@ -321,6 +332,7 @@ {$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 @@ -331,6 +343,8 @@ {$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} @@ -414,13 +428,17 @@ {$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} + {$endif LVCL} {$ifdef UNICODE} {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library @@ -432,7 +450,7 @@ 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} + {$endif UNICODE} {$ifndef PUREPASCAL} {$define CPUINTEL} // Delphi only for Intel by now @@ -585,6 +603,12 @@ {$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} diff --git a/contrib/mORMot/SynopseCommit.inc b/contrib/mORMot/SynopseCommit.inc index 387b377..1ee26f4 100644 --- a/contrib/mORMot/SynopseCommit.inc +++ b/contrib/mORMot/SynopseCommit.inc @@ -1 +1 @@ -'1.18.6082' +'1.18.6385'